{-# 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(..), PortCA(..), PortRangeHintDescriptor, PortRangeHintProp(..), PortRangeHint(..), PortBounds(..), PortData, Descriptor(..), GDescriptor, des2GDes, Handle(..), 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. -- * A way to check if all fields of a record were initialized? -- * Use a state monad for handles? -- * Differentiate between audiodata and controldata? (see toggle) -- * Use a type which supports control of length instead of lists? -- * I'm not really happy with the type used for run -- * Check UniqueIDs of the examples dir -- * Fix .hi dependencies in the makefiles -- * Split plugins in HLADSPA.so and PluginItself.so to allow reusing -- the HLADSPA.so code hLADSPAVersion = "0.2" hLADSPAVersionMajor = "0" hLADSPAVersionMinor = "2" 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) data PortCA = PortControl | PortAudio deriving (Enum,Eq,Ord,Show) data PortDescriptor = PortInput PortCA | PortOutput PortCA deriving (Eq,Show) type PortRangeHintDescriptor = [PortRangeHintProp] data PortRangeHintProp = Toggled | SampleRate | Logarithmic | Integer | DefaultMinimum | DefaultLow | DefaultMiddle | DefaultHigh | DefaultMaximum | Default0 | Default1 | Default100 | Default440 deriving (Enum,Eq,Ord,Show) data PortBounds = Unbounded | BoundedBelow LadspaData | BoundedAbove LadspaData | BoundedBetween LadspaData LadspaData deriving (Eq,Show) data PortRangeHint = PortRangeHint {hintDescriptor :: PortRangeHintDescriptor, bounds :: PortBounds } deriving (Eq,Show) -- Data for a port. Control port buffers are always one-element lists type PortData = [LadspaData] data Handle hd => Descriptor id hd = Descriptor {uniqueID :: LadspaIndex, label :: String, properties :: LadspaProperties, name, maker, copyright :: String, portCount :: LadspaIndex, portDescriptors :: [PortDescriptor], portNames :: [String], portRangeHints :: [PortRangeHint], implementationData :: id, instantiate :: Descriptor id hd -> LadspaIndex -> Maybe hd, usesActivate :: Bool, usesDeactivate :: Bool} class Handle hd where -- 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 ()) activate = Nothing -- (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 ()) -- default value deactivate = Nothing cleanup :: hd -> IO () cleanup _ = return () des2GDes :: Handle hd => Descriptor id hd -> GDescriptor des2GDes = GDes data GDescriptor = forall id hd.Handle hd => GDes (Descriptor id hd) -- IMPORTANT, every plugin source file must declare a variable of type -- [GDescriptor] and export it with the exportDescriptors splice -- For example, for an empty plugin -- -- emptyDescriptors :: [Descriptors] -- emptyDescriptors = [] -- $(exportDescriptors 'emptyDescriptors) exportDescriptors :: Name -> Q [Dec] exportDescriptors name = do --i <- reify name --runIO (print i) --runIO (print name) 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: using the following type would allow static checks -- exportDescriptors :: [GDescriptor] -> Q Dec -- * Note that as an advantage it takes -- [GDescriptors] directly, not the variable Name and how readable it is -- * It is impossible to implement right now anyway due to a -- GHC restriction: "you can't define a function in a module, and call -- it from within a splice in the same module.", and in that is what -- exportDescriptors would require , cuase it would be applied to a -- descriptor list defined in the same module ------------------------------------------------------------------------------- -- Private part of the package ------------------------------------------------------------------------------- --------------------- -- Interfacing with C --------------------- ------------------------------------------------ -- Types to help and speed up interfacing with C ------------------------------------------------ -- -- Port Classification for input or output ports -- Used to make sanity checks of the output of run -- and to speed up marshalling -- How many ports Index Control/Audio type PortCtion = (LadspaIndex,[(LadspaIndex,PortCA)]) -- We extend the Descriptor and Handle to include the port -- classification in order to pass it to run. Note that they are existetially -- quantified because the FFI doesn't support type signatures data ExDescriptor = ExDescriptor (PortCtion,PortCtion) GDescriptor gDes2ExDes :: GDescriptor -> ExDescriptor gDes2ExDes gdes@(GDes Descriptor{portDescriptors=p}) = ExDescriptor (classifyPorts p) gdes data ExHandle = forall hd.Handle hd => ExHandle (PortCtion,PortCtion) hd -- FFI-exportable types for the extended Descriptor and Handle type CHandle = StablePtr (ExHandle) type CDescriptor = StablePtr (ExDescriptor) ----- --- Helper types and funcions ----- foreign export ccall "hs_free" free :: Ptr a -> IO () descListFunction :: [GDescriptor] -> CULong -> IO CDescriptor descListFunction dtors n = if isJust maybeError then do putStrLn (fromJust maybeError) return nullStablePtr else do maybeNewStablePtr maybeExDes where maybeError = maybe Nothing checkGDes maybeGDes checkGDes (GDes d) = checkDescriptor d maybeExDes = fmap gDes2ExDes maybeGDes maybeGDes = 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 :: Handle hd => Descriptor id hd -> Maybe String -- FIXME, How to check that all fields in the descriptor were initialized? -- FIXME: improve errors checkDescriptor = applyCL checkList where checkList = [checkPortDescriptors,checkPortNames,checkPortRangeHints] --applyCL :: Handle hd => [Descriptor id hd -> Maybe String] -> -- Descriptor id hd -> Maybe String applyCL [] _ = Nothing applyCL (x:xs) des = case x des of Nothing -> applyCL xs des j@(Just _) -> j checkPortDescriptors :: Handle hd => Descriptor id hd -> Maybe String checkPortDescriptors des | genericLength pd /= pc = Just ("the length of portDescritors does not match portCount") | otherwise = Nothing where pd = portDescriptors des pc = portCount des checkPortNames :: Handle hd => Descriptor id hd-> 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 checkPortRangeHints :: Handle hd => Descriptor id hd -> Maybe String checkPortRangeHints des | genericLength prh /= pc = Just ("the length of portRangeHint does not match portCount") | otherwise = Nothing where prh = portRangeHints des pc = portCount des 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 classifyPorts xs = fst (foldr acumDesc (((0,[]),(0,[])),l-1) xs) where l = genericLength xs acumDesc :: PortDescriptor -> ((PortCtion,PortCtion), LadspaIndex) -> ((PortCtion,PortCtion), LadspaIndex) acumDesc (PortInput cA) ((clasI,clasO),n) = ((addToClas n cA clasI, clasO),n-1) acumDesc (PortOutput cA) ((clasI,clasO),n) = ((clasI,addToClas n cA clasO),n-1) addToClas index controlAudio clas@(countIO,iox) = (countIO+1,(index,controlAudio):iox) enums2flag :: Enum e => [e] -> CInt enums2flag = 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 :: (GDescriptor -> b) -> (b -> IO c) -> CDescriptor -> IO c marshalDF select marshal = marshalCA (\(ExDescriptor _ des) -> select des ) marshal 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 :: CDescriptor -> IO CULong marshalUniqueID = marshalDF (\(GDes d) -> uniqueID d) return foreign export ccall "marshal_uniqueID" marshalUniqueID :: StablePtr ExDescriptor -> IO CULong marshalLabel :: StablePtr ExDescriptor -> IO CString marshalLabel = marshalDF (\(GDes d) -> label d) newCString foreign export ccall "marshal_label" marshalLabel :: StablePtr ExDescriptor -> IO CString marshalProperties :: StablePtr ExDescriptor -> IO CInt marshalProperties = marshalDF (\(GDes d) -> properties d) (return.enums2flag) foreign export ccall "marshal_properties" marshalProperties :: StablePtr ExDescriptor -> IO CInt marshalName, marshalMaker, marshalCR :: CDescriptor -> IO CString marshalName = marshalDF (\(GDes d) -> name d) newCString marshalMaker = marshalDF (\(GDes d) -> maker d) newCString marshalCR = marshalDF (\(GDes d) -> copyright d) newCString foreign export ccall "marshal_name" marshalName :: CDescriptor -> IO CString foreign export ccall "marshal_maker" marshalMaker :: CDescriptor -> IO CString foreign export ccall "marshal_cr" marshalCR :: CDescriptor -> IO CString marshalPortCount :: CDescriptor -> IO CULong marshalPortCount = marshalDF (\(GDes d) -> portCount d) return foreign export ccall "marshal_port_count" marshalPortCount :: CDescriptor -> IO CULong marshalPortDescriptors :: CDescriptor -> IO (Ptr CInt) marshalPortDescriptors = marshalDF (\(GDes d) -> portDescriptors d) (newArrayMap marshalE) where marshalE = return.portDescriptor2flag portDescriptor2flag :: PortDescriptor -> CInt portDescriptor2flag (PortInput ca) = 0x1 .|. (portCA2flag ca) portDescriptor2flag (PortOutput ca) = 0x2 .|. (portCA2flag ca) portCA2flag :: PortCA -> CInt portCA2flag PortControl = 0x4 portCA2flag PortAudio = 0x8 foreign export ccall "marshal_port_descriptors" marshalPortDescriptors :: CDescriptor -> IO (Ptr CInt) marshalPortRangeHints :: StablePtr ExDescriptor -> IO (Ptr (StablePtr PortRangeHint)) marshalPortRangeHints = marshalDF (\(GDes d) -> portRangeHints d) (newArrayMap newStablePtr) foreign export ccall "marshal_port_range_hints" marshalPortRangeHints :: StablePtr ExDescriptor -> IO (Ptr (StablePtr PortRangeHint)) marshalHintDescriptor :: StablePtr PortRangeHint -> IO CInt marshalHintDescriptor = marshalCA id (return.getHint) where getHint :: PortRangeHint -> CInt getHint (PortRangeHint des bounds) = bounds2flag bounds .|. des2flag des -- #define LADSPA_HINT_TOGGLED 0x4 des2flag = foldr ((.|.).prop2flag) 0 prop2flag Toggled = 0x4 prop2flag SampleRate = 0x8 prop2flag Logarithmic = 0x10 prop2flag Integer = 0x20 prop2flag DefaultMinimum = 0x40 prop2flag DefaultLow = 0x80 prop2flag DefaultMiddle = 0xC0 prop2flag DefaultHigh = 0x100 prop2flag DefaultMaximum = 0x140 prop2flag Default0 = 0x200 prop2flag Default1 = 0x240 prop2flag Default100 = 0x280 prop2flag Default440 = 0x2C0 bounds2flag Unbounded = 0x0 bounds2flag (BoundedBelow _) = 0x1 bounds2flag (BoundedAbove _) = 0x2 bounds2flag (BoundedBetween _ _) = 0x1 .|. 0x2 foreign export ccall "marshal_hint_descriptor" marshalHintDescriptor :: StablePtr PortRangeHint -> IO CInt marshalLowerBound :: StablePtr PortRangeHint -> IO CFloat marshalLowerBound = marshalCA (getLowerBound.bounds) return where getLowerBound (BoundedBetween lower _) = lower getLowerBound (BoundedBelow lower) = lower getLowerBound _ = 0 foreign export ccall "marshal_lower_bound" marshalLowerBound :: StablePtr PortRangeHint -> IO CFloat marshalUpperBound :: StablePtr PortRangeHint -> IO CFloat marshalUpperBound = marshalCA (getUpperBound.bounds) return where getUpperBound (BoundedBetween _ upper) = upper getUpperBound (BoundedAbove upper) = upper getUpperBound _ = 0 foreign export ccall "marshal_upper_bound" marshalUpperBound :: StablePtr PortRangeHint -> IO CFloat marshalPortNames :: CDescriptor -> IO (Ptr CString) marshalPortNames = marshalDF (\(GDes d) -> portNames d)(newArrayMap newCString) foreign export ccall "marshal_port_names" marshalPortNames :: CDescriptor -> IO (Ptr CString) marshalUsesActivate, marshalUsesDeactivate :: CDescriptor -> IO Bool marshalUsesActivate = marshalDF (\(GDes d) -> usesActivate d) return marshalUsesDeactivate = marshalDF (\(GDes d) -> usesDeactivate d) return foreign export ccall "HLADSPA_has_activate" marshalUsesActivate :: CDescriptor -> IO Bool foreign export ccall "HLADSPA_has_deactivate" marshalUsesDeactivate :: CDescriptor -> IO Bool type CInstantiate = CDescriptor -> CULong -> IO (CHandle) cInstantiate :: CInstantiate cInstantiate ptr ul = do ExDescriptor c (GDes d@Descriptor{instantiate=i}) <- deRefStablePtr ptr let maybeHandle = i d (fromIntegral ul) maybeExHandle = fmap (ExHandle c) maybeHandle maybeNewStablePtr maybeExHandle 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 = CHandle -> CULong -> Ptr (Ptr CFloat) -> Ptr (Ptr CFloat) -> IO (CHandle) cRun :: CRun -- By the time of calling this func, the length of PortDescriptors should have -- been already checked against PortCount -- FIXME: A monster function, clean the code -- FIXME: Give an option to avoid sanity checks and make run() faster -- once the plugin was developed cRun exHdPtr sampleC ibPtr obPtr = do ExHandle cation hd <- deRefStablePtr exHdPtr b <- marshalIBuffers (fst cation) ibPtr sampleC let (oBuff, newHd) = run hd sampleC b marshalOBuffers (snd cation) obPtr sampleC oBuff newStablePtr (ExHandle cation newHd) 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, PortCA) -> 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 ("HLADSPA: 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, PortCA) -> (Ptr CFloat, (LadspaIndex, PortData)) -> IO () marshalOBuffer sampleC (pnC, audioControl) (ptr,(pn,xd)) = -- FIXME: give better errors do -- sanity check -- when (pnC /= pn) (error ("HLADSPA: 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 ("HLADSPA: 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 -- An action over a handle expressed in C syntax type CHandleAction = CHandle -> IO() cActivate, cDeactivate, cCleanup :: CHandleAction cActivate ptr = do ExHandle _ hd <- deRefStablePtr ptr case activate of Nothing -> error "HLADSPA: error: usesActivate=True but activate=Nothing" Just f -> f hd cDeactivate ptr = do ExHandle _ hd <- deRefStablePtr ptr case deactivate of Nothing -> error "HLADSPA: error: usesDeactivate=True but deactivate=Nothing" Just f -> f hd cCleanup ptr = do ExHandle _ hd <- deRefStablePtr ptr cleanup hd foreign export ccall "HLADSPA_activate" cActivate :: CHandleAction foreign export ccall "HLADSPA_deactivate" cDeactivate :: CHandleAction foreign export ccall "HLADSPA_cleanup" cCleanup :: CHandleAction