{-# OPTIONS_GHC -fglasgow-exts -fth #-} ------------------------------------------------------------------------------- -- | -- Module : HLADSPA -- Copyright : (c) Alfonso Acosta 2006 -- License : LGPL -- -- Maintainer : alfonso.acosta@gmail.com -- Stability : really unstable -- Portability : portable -- -- LADSPA in Haskell, using lists as IO port buffers (more inefficient -- than Storable Arrays but more haskellish and allow making sanity -- checks which aid debugging) ------------------------------------------------------------------------------- module HLADSPA ( hLADSPAVersion, hLADSPAVersionMajor, hLADSPAVersionMinor, LadspaData, LadspaIndex, LadspaProperties, LadspaProp(..), PortDescriptor, PortProp(..), PortRangeHintDescriptor, PortRangeHintProp(..), PortRangeHint(..), PortData, Descriptor(..), Instance(..), exportDescriptors, -- needed by exportDescriptors descListFunction) where import Foreign import CForeign (CFloat, CULong, CInt, CString, newCString) import List (genericLength, sortBy) import Monad (zipWithM, when, unless) import Maybe (fromMaybe, fromJust, isJust) import Language.Haskell.TH.Syntax -- TODO: -- * Document it in Haddock -- * Plugin instance handles and implementation data, are static -- except for run (cannot be modified after instantiate() is called). -- * Analyze and comment real time compatibility (HardRTCapable) of haskell -- and this concrete implementation -- * Rethink names and cleanup marshaler functions -- * Optimize run -- * Make a port using Storable arrays (monadic but fast) -- * Implement run_adding() -- * Cleanup marshaler functions -- * It would be cool to precompute the sanity checks with Template Haskell -- * Instace of Lift Descriptor -- * Change representation of the port description so that it can't lead -- to inconsistencies such os [PortInput,PortOutput,PortAudio,PortControl]? -- * Package it using Cabal: -- I don't know how to use cabal yet but it can be tedious, -- because of the mixture with C. -- * Use scons instead of make. hLADSPAVersion = "0.1" hLADSPAVersionMajor = "0" hLADSPAVersionMinor = "1" type LadspaData = CFloat type LadspaIndex = CULong type LadspaProperties = [LadspaProp] -- With the list implementation InPlaceBroken shouldn't be used -- (the wrapper takes care of overlapped buffers ) and unfortunately -- HardRTCapable isn't possible because of the use of heap -- operations in run (I should investigate more on this) data LadspaProp = Realtime | InPlaceBroken | HardRTCapable deriving (Enum,Eq,Ord,Show) type PortDescriptor = [PortProp] data PortProp = PortInput | PortOutput | PortControl | PortAudio deriving (Enum,Eq,Ord,Show) type PortRangeHintDescriptor = [PortRangeHintProp] data PortRangeHintProp = BoundedBelow | BoundedAbove | Toggled | SampleRate | Logarithmic | Integer | DefaultMask | DefaultNone | DefaultMinimum | DefaultLow | DefaultMiddle | DefaultHigh | DefaultMaximum | Default0 | Default1 | Default100 | Default440 deriving (Enum,Eq,Ord,Show) data PortRangeHint = PortRangeHint {hintDescriptor :: PortRangeHintDescriptor, lowerBound :: LadspaData, upperBound :: LadspaData } -- Data for a port. Control port buffers are always one-element lists type PortData = [LadspaData] -- Existentially quantified records allow the plugin developer -- to chose hd and id types at will and, allowing to declare "heterogeneous" -- Descriptor lists. Drawback: it only works in ghc 6.6 and -- makes the design tricky. The problem comes from modelling (void*) in Haskell -- id is the implementation data data Descriptor = forall id. Descriptor {uniqueID :: LadspaIndex, label :: String, properties :: LadspaProperties, name, maker, copyright :: String, portCount :: LadspaIndex, portDescriptors :: [PortDescriptor], portNames :: [String], portRangeHints :: [PortRangeHint], _implementationData :: id, _instantiate :: Descriptor -> LadspaIndex -> Maybe Instance} -- hd is the handle data Instance = forall hd. Instance { _this :: hd, -- initial handle -- In this case we are using lists to represent the port I/O buffers, so the -- port connections (buffer pointers of ports) is handled by the marshaller -- connectPort :: (hd -> LadspaIndex -> Ptr LadspaData -> IO hd) _activate :: Maybe(hd -> IO ()), -- (LadspaIndex,PortData) indicates the portnumber and its data _run :: hd -> LadspaIndex -> [(LadspaIndex,PortData)] -> ([(LadspaIndex,PortData)], hd), -- Not yet implemented (is not mandatory for a plugin to provide them) -- _runAdding :: -- _setAddingGain :: _deactivate :: Maybe (hd -> IO ()), _cleanup :: hd -> IO () } -- IMPORTANT, every plugin source file must declare a variable of type -- [Descriptor] and export it with the exportDescriptors splice -- For example, for an empty plugin -- -- emptyDescriptors :: [Descriptors] -- emptyDescriptors = [] -- $(exportsDescriptors 'emptyDescriptors) exportDescriptors :: Name -> Q [Dec] exportDescriptors name = do t <- [t| CULong -> IO (StablePtr ExDescriptor) |] funN <- newName "descriptorFunction" let usedF = "descListFunction" funD = FunD funN [Clause [] (NormalB (v usedF `AppE` VarE name)) []] exportD = ForeignD (ExportF CCall "HLADSPA_descriptor_function" funN t) return [funD,exportD] where v = VarE . mkName -- FIXME: creating an instance of Lift Descriptor would simplify the function -- to this (note that as an advantage it takes [Descriptors] directly -- not Name and how readable it is) --exportDescriptors :: [Descriptor] -> Q Dec --exportDescriptors desc = -- [d| -- descriptorFunction :: CULong -> IO (StablePtr ExDescriptor) -- descriptorFunction = descListFunction desc -- foreign export ccall "HLADSPA_descriptor_function" -- descriptorFunction :: CULong -> IO (StablePtr ExDescriptor) -- |] ------------------------------------------------------------------------------- -- Private part of the package ------------------------------------------------------------------------------- ----------------------------------------------------------------------- -- Existentially quantified methods (Descriptor and Instance) functions ----------------------------------------------------------------------- instantiate :: Descriptor -> LadspaIndex -> Maybe Instance instantiate des@(Descriptor{_instantiate=i}) sampleR = i des sampleR activate, deactivate, cleanup :: Instance -> IO() activate Instance{_this=hd, _activate=maybeA} = (fromJust maybeA) hd deactivate Instance{_this=hd, _deactivate=maybeD} = (fromJust maybeD) hd cleanup Instance{_this=hd, _cleanup=c} = c hd -- FIXME: Record update for the non-Haskell-98 data type `Instance' ---is not (yet) supported (change once implemented in ghc) run :: Instance -> LadspaIndex -> [(LadspaIndex,PortData)] -> ([(LadspaIndex,PortData)], Instance) run {-ins@-}(Instance{_this=hd,_run=r,_activate=a,_deactivate=d,_cleanup=c}) sampleC input = (output, newIns) where (output,newHd) = r hd sampleC input -- newIns = ins{_this=newHd} newIns = Instance newHd a r d c --------------------- -- Interfacing with C --------------------- ----- --- Helper types and funcions ----- foreign export ccall "hs_free" free :: Ptr a -> IO () descListFunction :: [Descriptor] -> CULong -> IO (StablePtr ExDescriptor) descListFunction dtors n = if isJust maybeError then do putStrLn (fromJust maybeError) return nullStablePtr else do maybeNewStablePtr maybeExDes where maybeError = maybe Nothing checkDescriptor maybeDes maybeExDes = fmap descriptor2ExDescriptor maybeDes maybeDes = dtors !!! n (!!!) :: Integral b => [a] -> b -> Maybe a xs !!! n | n < 0 || null xs = Nothing (x:_) !!! 0 = Just x (_:xs) !!! n = xs !!! (n-1) -- Do sanity checks of a descriptor, returning a consistency error -- if found checkDescriptor :: Descriptor -> Maybe String -- FIXME, How to check that all fields in the descriptor were initialized? -- FIXME, finish the checking -- FIXME: improve errors checkDescriptor = applyCL checkList where checkList :: [Descriptor -> Maybe String] checkList = [checkPortDescriptors,checkPortNames,checkPortRangeHint] applyCL :: [Descriptor -> Maybe String] -> Descriptor -> Maybe String applyCL [] _ = Nothing applyCL (x:xs) des = fromMaybe (applyCL xs des) (Just (x des)) checkPortDescriptors :: Descriptor -> Maybe String -- FIXME: go through the list at once through fusion to check it faster checkPortDescriptors des | genericLength pd /= pc = Just ("the length of portDescritors does not match portCount") | not (all (\d -> (elem PortInput d) /= (elem PortOutput d)) pd) = Just ("All ports must be either input or output") | not (all (\d -> (elem PortControl d) /= (elem PortAudio d)) pd) = Just ("All ports must be either Control or Audio") | otherwise = Nothing where pd = portDescriptors des pc = portCount des checkPortNames :: Descriptor -> Maybe String checkPortNames des | genericLength pn /= pc = Just ("the length of portNames does not match portCount") | otherwise = Nothing where pn = portNames des pc = portCount des checkPortRangeHint :: Descriptor -> Maybe String checkPortRangeHint des | genericLength prh /= pc = Just ("the length of portRangeHint does not match portCount") | otherwise = Nothing where prh = portNames des pc = portCount des -- -- Port Classification for input or output ports -- How many ports Index Control/Audio type PortCtion = (LadspaIndex,[(LadspaIndex,PortProp)]) -- We extend the Descriptor and Instance types with classification -- of the input and output ports in order to help marshaling and -- make sanity checks on the output of run data ExDescriptor = ExDescriptor { ioCation :: (PortCtion,PortCtion), desc :: Descriptor} descriptor2ExDescriptor :: Descriptor -> ExDescriptor descriptor2ExDescriptor des = ExDescriptor (classifyPorts(portDescriptors des)) des data ExInstance = ExInstance { ioCtion :: (PortCtion,PortCtion), ins :: Instance} classifyPorts :: [PortDescriptor] -> (PortCtion,PortCtion) -- Classify the ports acording to input/output keeping their index from -- the original list and saying if they are Control or Audio -- It assumes that the descriptors were sanity-checked -- FIXME: there must be a more elegant and yet efficient -- way of doing this, this function is a monster classifyPorts xs = fst (foldr acumDesc (((0,[]),(0,[])),l-1) xs) where l = genericLength xs acumDesc :: PortDescriptor -> ((PortCtion,PortCtion), LadspaIndex) -> ((PortCtion,PortCtion), LadspaIndex) acumDesc desc ((clasI,clasO),n) = let (iO, cA) = classifyDesc desc in if iO == PortInput then ((addToClas n cA clasI, clasO),n-1) else ((clasI,addToClas n cA clasO),n-1) addToClas index controlAudio clas@(countIO,iox) = (countIO+1,(index,controlAudio):iox) classifyDesc :: [PortProp] -> (PortProp, PortProp) -- Provides is a port is (Input or Output) and (Control or Audio) classifyDesc = foldr classifyProp (PortControl, PortInput) classifyProp prop (acumIO, acumCA) = (inputOutput prop acumCA, controlAudio prop acumCA) where controlAudio _ PortControl = PortControl controlAudio _ PortAudio = PortAudio controlAudio a _ = a inputOutput _ PortInput = PortInput inputOutput _ PortOutput = PortOutput inputOutput a _ = a props2flags :: Enum prop => [prop] -> CInt props2flags = foldr ((.|.).(2^).fromEnum) 0 nullStablePtr :: StablePtr a nullStablePtr = castPtrToStablePtr nullPtr maybeNewStablePtr :: Maybe a -> IO (StablePtr a) maybeNewStablePtr = maybe (return nullStablePtr) newStablePtr -- marshalCA: marshal a constructor argument from an algebraic type -- useful to externally marshal each field argument into a C struct marshalCA :: (a -> b) -> (b -> IO c) -> StablePtr a -> IO c -- ptr, is a pointer to an extended descriptor and -- select is supposed to obtain the constructor argument -- or whatever which should be marshaled marshalCA select marshal ptr = do a <- deRefStablePtr ptr marshal (select a) -- marshalDF: marshal a field from Descriptor given a pointer to ExDescriptor marshalDF :: (Descriptor -> b) -> (b -> IO c) -> StablePtr ExDescriptor -> IO c marshalDF select marshal = marshalCA (select.desc) marshal -- marshalF: marshal a function to a function pointer -- marshalF :: StablePtr a -> ( ) -> IO newArrayMap :: Storable b => (a -> IO b) -> [a] -> IO (Ptr b) -- Marhal a list, marshalling its elements first newArrayMap marshalE xs = do ds <- mapM marshalE xs newArray ds --- --- Marshaler functions --- marshalUniqueID :: StablePtr ExDescriptor -> IO CULong marshalUniqueID = marshalDF uniqueID return foreign export ccall "marshal_uniqueID" marshalUniqueID :: StablePtr ExDescriptor -> IO CULong marshalLabel :: StablePtr ExDescriptor -> IO CString marshalLabel = marshalDF label newCString foreign export ccall "marshal_label" marshalLabel :: StablePtr ExDescriptor -> IO CString marshalProperties :: StablePtr ExDescriptor -> IO CInt marshalProperties = marshalDF properties (return.props2flags) foreign export ccall "marshal_properties" marshalProperties :: StablePtr ExDescriptor -> IO CInt marshalName, marshalMaker, marshalCR :: StablePtr ExDescriptor -> IO CString marshalName = marshalDF name newCString marshalMaker = marshalDF maker newCString marshalCR = marshalDF copyright newCString foreign export ccall "marshal_name" marshalName :: StablePtr ExDescriptor -> IO CString foreign export ccall "marshal_maker" marshalMaker :: StablePtr ExDescriptor -> IO CString foreign export ccall "marshal_cr" marshalCR :: StablePtr ExDescriptor -> IO CString marshalPortCount :: StablePtr ExDescriptor -> IO CULong marshalPortCount = marshalDF portCount return foreign export ccall "marshal_port_count" marshalPortCount :: StablePtr ExDescriptor -> IO CULong marshalPortDescriptors :: StablePtr ExDescriptor -> IO (Ptr CInt) marshalPortDescriptors = marshalDF portDescriptors (newArrayMap marshalE) where marshalE = return.props2flags foreign export ccall "marshal_port_descriptors" marshalPortDescriptors :: StablePtr ExDescriptor -> IO (Ptr CInt) marshalPortRangeHints :: StablePtr ExDescriptor -> IO (Ptr (StablePtr PortRangeHint)) marshalPortRangeHints =marshalDF portRangeHints (newArrayMap newStablePtr) foreign export ccall "marshal_port_range_hints" marshalPortRangeHints :: StablePtr ExDescriptor -> IO (Ptr (StablePtr PortRangeHint)) marshalHintDescriptor :: StablePtr PortRangeHint -> IO CInt marshalHintDescriptor = marshalCA hintDescriptor (return.props2flags) foreign export ccall "marshal_hint_descriptor" marshalHintDescriptor :: StablePtr PortRangeHint -> IO CInt marshalLowerBound :: StablePtr PortRangeHint -> IO CFloat marshalLowerBound = marshalCA lowerBound return foreign export ccall "marshal_lower_bound" marshalLowerBound :: StablePtr PortRangeHint -> IO CFloat marshalUpperBound :: StablePtr PortRangeHint -> IO CFloat marshalUpperBound = marshalCA upperBound return foreign export ccall "marshal_upper_bound" marshalUpperBound :: StablePtr PortRangeHint -> IO CFloat -- There is no need for exporting the implementation data to the external -- C wrapper -- marshalID :: StablePtr ExDescriptor -> IO (StablePtr id) -- marshalID = marshalCA implementationData newStablePtr -- foreign export ccall "marshal_implementation_data" -- marshalID :: StablePtr ExDescriptor -> IO (StablePtr id) marshalPortNames :: StablePtr ExDescriptor -> IO (Ptr CString) marshalPortNames = marshalDF portNames (newArrayMap newCString) foreign export ccall "marshal_port_names" marshalPortNames :: StablePtr ExDescriptor -> IO (Ptr CString) type CInstantiate = StablePtr ExDescriptor -> CULong -> IO (StablePtr ExInstance) cInstantiate :: CInstantiate cInstantiate ptr ul = do d <- deRefStablePtr ptr let maybeIns = instantiate (desc d) (fromIntegral ul) maybeExIns = fmap (ExInstance (ioCation d)) maybeIns maybeNewStablePtr maybeExIns foreign export ccall "HLADSPA_instantiate" cInstantiate :: CInstantiate -- Gets the arrays of input and output port pointers, the sample rate, -- calls run, writes the result in the Output Port pointers and -- returns the new handle type CRun = StablePtr ExInstance -> CULong -> Ptr (Ptr CFloat) -> Ptr (Ptr CFloat) -> IO (StablePtr ExInstance) cRun :: CRun -- By the time of calling this func, the length of PortDescriptors should have -- been already checked against PortCount -- FIXME: Another monster function, clean the code -- FIXME: Give an option to avoid sanity checks and make run() faster -- once the plugin was developed cRun exInsPtr sampleC ibPtr obPtr = do exIns <- deRefStablePtr exInsPtr b <- marshalIBuffers ((fst.ioCtion) exIns) ibPtr sampleC let (oBuff, newIns) = run (ins exIns) sampleC b marshalOBuffers ((snd.ioCtion) exIns) obPtr sampleC oBuff newStablePtr (ExInstance (ioCtion exIns) newIns) where marshalIBuffers :: PortCtion -> Ptr (Ptr CFloat) -> CULong -> IO [(LadspaIndex,[LadspaData])] -- Marshal input buffers from C marshalIBuffers (nInput,iClas) iBuffPtr sampleC = do bPtrList <- peekArray (fromIntegral nInput) iBuffPtr zipWithM (marshalIBuffer sampleC) iClas bPtrList marshalIBuffer :: CULong -> (LadspaIndex, PortProp) -> Ptr CFloat -> IO (LadspaIndex, [LadspaData]) marshalIBuffer sampleC (n, audioControl) ptr = do b <- peekArray (fromIntegral bLength) ptr return (n,b) where bLength = if audioControl == PortAudio then sampleC else 1 marshalOBuffers :: PortCtion -> Ptr (Ptr CFloat) -> CULong -> [(LadspaIndex, PortData)] -> IO () -- Marshal Output buffers to C, (write the return of run in the -- C output buffers) marshalOBuffers (nOutput,oClas) oBuffPtr sampleC runOutput = do bPtrList <- peekArray (fromIntegral nOutput) oBuffPtr -- sanity checks for runOutput -- when (genericLength runOutput /= nOutput) (error ("Output for at least a port is missing in "++ show nOutput)) let sortedRO = sortBy (\x y -> compare (fst x) (fst y)) runOutput -- -- zipWithM (marshalOBuffer sampleC) oClas (zip bPtrList sortedRO) return () marshalOBuffer :: CULong -> (LadspaIndex, PortProp) -> (Ptr CFloat, (LadspaIndex, PortData)) -> IO () marshalOBuffer sampleC (pnC, audioControl) (ptr,(pn,xd)) = -- FIXME: give better errors do -- sanity check -- when (pnC /= pn) (error ("Check the output indexes" ++ "of run, they don't match!")) -- -- (toWrite, leftOver) <- return (splitAt (fromIntegral bLength) xd) -- sanity check -- when (leftOver /= [] || genericLength toWrite < bLength) (error ("Check the length of the output buffers" ++ " of run,they don't match!")) -- -- pokeArray ptr toWrite where bLength = if audioControl == PortAudio then sampleC else 1 foreign export ccall "HLADSPA_run" cRun :: CRun -- Translate a function over Instance to C exportable function -- over an Extended Instance -- FIXME: integrate this function with cRun as well if possible fIns2CFExInst :: (Instance -> IO a) -> StablePtr ExInstance -> IO a fIns2CFExInst insAction exInsPtr = do exIns <- deRefStablePtr exInsPtr insAction (ins exIns) -- Ask for a property about an Extended Instance type CExInsProp = StablePtr ExInstance -> IO Bool cHasActivate, cHasDeactivate :: CExInsProp cHasActivate = fIns2CFExInst (return.insHasActivate) where insHasActivate Instance{_activate =maybeA} = isJust maybeA cHasDeactivate = fIns2CFExInst (return.insHasDeactivate) where insHasDeactivate Instance{_deactivate=maybeD} = isJust maybeD foreign export ccall "HLADSPA_has_activate" cHasActivate :: CExInsProp foreign export ccall "HLADSPA_has_deactivate" cHasDeactivate :: CExInsProp -- An action over a extended instance expressed in C syntax type CExInsAction = StablePtr ExInstance -> IO() cActivate, cDeactivate, cCleanup :: CExInsAction cActivate = fIns2CFExInst activate cDeactivate = fIns2CFExInst deactivate cCleanup = fIns2CFExInst cleanup foreign export ccall "HLADSPA_activate" cActivate :: CExInsAction foreign export ccall "HLADSPA_deactivate" cDeactivate :: CExInsAction foreign export ccall "HLADSPA_cleanup" cCleanup :: CExInsAction