diff --git a/free/Sound/JACK/FFIFree.hs b/free/Sound/JACK/FFIFree.hs new file mode 100644 --- /dev/null +++ b/free/Sound/JACK/FFIFree.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +module Sound.JACK.FFIFree where + +import Foreign.Ptr (Ptr) +import Foreign.C.String (CString) + +-- | Free an array of NULL terminated port names returned by 'get_ports' and 'port_get_all_connections'. +foreign import ccall "static stdlib.h free" + freePortNameArray :: Ptr CString -> IO () diff --git a/jack.cabal b/jack.cabal --- a/jack.cabal +++ b/jack.cabal @@ -1,20 +1,27 @@ Name: jack -Version: 0.6.1.1 +Version: 0.6.2 License: GPL License-File: LICENSE -Author: Soenke Hahn, Henning Thielemann +Author: Soenke Hahn, Stefan Kersten, Henning Thielemann Maintainer: Henning Thielemann Synopsis: Bindings for the JACK Audio Connection Kit -Description: Very basic bindings for the JACK Audio Connection Kit +Description: + Very basic bindings for the JACK Audio Connection Kit. + It has support both for PCM audio and MIDI handling. + . + In order to adapt to your system, + you may have to disable pkgConfig or jackFree cabal flags. Homepage: http://www.haskell.org/haskellwiki/JACK Category: Sound Build-Type: Simple -Cabal-Version: >=1.6 +Cabal-Version: >=1.14 Tested-With: GHC==6.8.2, GHC==6.10.4, GHC==6.12.3 Tested-With: GHC==7.0.2, GHC==7.2.1, GHC==7.4.1 Extra-Source-Files: README INSTALL + free/Sound/JACK/FFIFree.hs + jackfree/Sound/JACK/FFIFree.hs Source-Repository head type: darcs @@ -23,8 +30,16 @@ Source-Repository this type: darcs location: http://code.haskell.org/jack/ - tag: 0.6.1.1 + tag: 0.6.2 +Flag pkgConfig + description: Use pkg-config tool for check version and presence of jack + default: True + +Flag jackFree + description: Use jack_free instead of free + default: True + Flag buildExamples description: Build example executables default: False @@ -32,7 +47,7 @@ Library Build-Depends: midi >=0.1.5.2 && <0.3, - bytestring >=0.9.1.4 && <0.10, + bytestring >=0.9.1.4 && <0.11, explicit-exception >=0.1.5 && <0.2, transformers >=0.2 && <0.4, enumset >=0.0 && <0.1, @@ -47,8 +62,10 @@ Other-Modules: Sound.JACK.Private Sound.JACK.FFI + Sound.JACK.FFIFree Sound.JACK.FFI.MIDI - Build-Tools: c2hs>=0.15.1 + Default-Language: Haskell98 + Build-Tools: hsc2hs >=0.66 && <1.0 Hs-Source-Dirs: src GHC-Options: -Wall -fwarn-tabs -fwarn-incomplete-record-updates If impl(ghc >= 6.12) @@ -56,44 +73,59 @@ If os(darwin) CC-Options: -U__BLOCKS__ - Extensions: ForeignFunctionInterface - -- use extra-libraries, if pkg-config fails - -- http://hackage.haskell.org/trac/hackage/ticket/170 - -- Extra-Libraries: jack - -- - -- There seem to be two lines of JACK: - -- JACK1 as used by Kubuntu, e.g. jack-0.118.0 - -- JACK2 as used by Suse, e.g. jack-1.9.0 - -- Thus I just omit the jack version here - PkgConfig-depends: jack + Other-Extensions: ForeignFunctionInterface Includes: jack/jack.h, jack/midiport.h + If flag(jackFree) + Hs-Source-Dirs: jackfree + Else + Hs-Source-Dirs: free + + If flag(pkgConfig) + -- There seem to be two lines of JACK: + -- JACK1 as used by Ubuntu, e.g. jack-0.118.0 + -- JACK2 as used by Suse, e.g. jack-1.9.0 + If flag(jackFree) + PkgConfig-depends: jack (>=0.118 && <1) || (>=1.9.8 && <2) + Else + PkgConfig-depends: jack (>=0.0 && <0.118) || (>=1.9.0 && <1.9.8) + Else + -- use extra-libraries, if pkg-config fails + -- http://hackage.haskell.org/trac/hackage/ticket/170 + Extra-Libraries: jack + Executable amplify If !flag(buildExamples) Buildable: False + Default-Language: Haskell98 GHC-Options: -Wall -fwarn-tabs -fwarn-incomplete-record-updates - Extensions: ForeignFunctionInterface - Extra-Libraries: jack - Other-Modules: Sound.JACK.FFI.MIDI - Hs-Source-Dirs: src, . + Hs-Source-Dirs: . + Build-Depends: + jack, + base >=3.0 && <5 Main-Is: examples/Amplify.hs Executable impulse-train If !flag(buildExamples) Buildable: False + Default-Language: Haskell98 GHC-Options: -Wall -fwarn-tabs -fwarn-incomplete-record-updates - Extensions: ForeignFunctionInterface - Extra-Libraries: jack - Other-Modules: Sound.JACK.FFI.MIDI - Hs-Source-Dirs: src, . + Hs-Source-Dirs: . + Build-Depends: + jack, + transformers >=0.2 && <0.4, + array >=0.2 && <0.5, + base >=3.0 && <5 Main-Is: examples/ImpulseTrain.hs Executable midimon If !flag(buildExamples) Buildable: False + Default-Language: Haskell98 GHC-Options: -Wall -fwarn-tabs -fwarn-incomplete-record-updates - Extensions: ForeignFunctionInterface - Extra-Libraries: jack - Other-Modules: Sound.JACK.FFI.MIDI - Hs-Source-Dirs: src, . + Hs-Source-Dirs: . + Build-Depends: + jack, + midi >=0.1.5.2 && <0.3, + base >=3.0 && <5 Main-Is: examples/Midimon.hs diff --git a/jackfree/Sound/JACK/FFIFree.hs b/jackfree/Sound/JACK/FFIFree.hs new file mode 100644 --- /dev/null +++ b/jackfree/Sound/JACK/FFIFree.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +module Sound.JACK.FFIFree where + +import Foreign.Ptr (Ptr) +import Foreign.C.String (CString) + +-- | Free an array of NULL terminated port names returned by 'get_ports' and 'port_get_all_connections'. +foreign import ccall "static jack/jack.h jack_free" + freePortNameArray :: Ptr CString -> IO () diff --git a/src/Sound/JACK.hs b/src/Sound/JACK.hs --- a/src/Sound/JACK.hs +++ b/src/Sound/JACK.hs @@ -34,7 +34,6 @@ withClient, withClientDefault, clientClose, - getPorts, activate, deactivate, @@ -42,6 +41,7 @@ PortType, Direction, Input, Output, + JackFFI.UnknownType, UnknownDirection, Port, newPort, @@ -60,6 +60,30 @@ getSampleRate, + mkClientRegistration, + setClientRegistration, + + JackFFI.PortId, + mkPortRegistration, + setPortRegistration, + mkPortConnect, + setPortConnect, + + portById, + portByName, + + portName, + portShortName, + + getPorts, + portGetAllConnections, + + narrowPort, + narrowPortType, + narrowPortDirection, + switchUnknownTypePort, + switchUnknownDirectionPort, + JackFFI.NFrames(JackFFI.NFrames), nframesIndices, nframesBounds, quit, waitForBreakAndClose, @@ -74,17 +98,20 @@ import qualified Sound.JACK.Exception as JackExc import qualified Sound.JACK.FFI as JackFFI +import qualified Sound.JACK.FFIFree as JackFFIFree +import Sound.JACK.FFI.MIDI (EventBuffer, ) import Sound.JACK.FFI (Process, nframesIndices, nframesBounds, ) import qualified Control.Monad.Exception.Synchronous as Sync import qualified Control.Monad.Trans.Class as Trans +import Control.Exception (finally, ) import qualified Foreign.Marshal.Array as Array import qualified Foreign.C.String as CString import qualified Foreign.C.Types as C import Foreign.Storable (Storable, peek, ) import Foreign.Ptr (Ptr, FunPtr, nullPtr, castPtr, ) -import Foreign.C.String (peekCString, ) +import Foreign.C.String (CString, peekCString, ) import Foreign.C.Error (Errno(Errno), ) import qualified Data.EnumSet as ES @@ -99,20 +126,30 @@ class Direction dir where dirToFlags :: dir -> JackFFI.PortFlagSet --- | Handles of Jack input ports +-- | Type argument for Jack input ports data Input = Input instance Direction Input where dirToFlags ~Input = JackFFI.portIsInput --- | Handles of Jack output ports +-- | Type argument for Jack output ports data Output = Output instance Direction Output where dirToFlags ~Output = JackFFI.portIsOutput +{- | +Type argument for Jack ports +where we do not know +whether it is an input or an output port. +-} +data UnknownDirection = UnknownDirection +_dummyUnknownDirection :: UnknownDirection +_dummyUnknownDirection = UnknownDirection + + -- | Constructs a new Jack client. newClient :: (JackExc.ThrowsStatus e) => @@ -185,13 +222,13 @@ JackExc.ThrowsPortRegister e) => JackFFI.PortFlagSet -> Client -> String -> Sync.ExceptionalT e IO (Port typ dir) -newPortByType flags (Client client) portName = +newPortByType flags (Client client) name = let aux :: (PortType typ, Direction dir, JackExc.ThrowsPortRegister e) => typ -> dir -> Sync.ExceptionalT e IO (Port typ dir) aux portType dir = - withPortName portName $ \cPortName -> + withPortName name $ \cPortName -> withCString (portTypeToCString portType) $ \pType -> do -- putStrLn ("register..." ++ show (client, cstring, pType, inout, 0)) port <- Trans.lift $ @@ -260,8 +297,8 @@ Client -> Sync.ExceptionalT e IO () -> Sync.ExceptionalT e IO () -withActivation client act = - bracket (activate client) (\() -> deactivate client) (\() -> act) +withActivation client = + bracket_ (activate client) (deactivate client) -- | closes the given Jack client without causing any trouble (hopefully) clientClose :: @@ -295,14 +332,21 @@ withPortName name f = withCString name $ f . JackFFI.PortName --- | returns the names of all existing ports of the given Jack client +peekPortNameArray :: Ptr CString -> IO [String] +peekPortNameArray a = + if a == nullPtr + then return [] + else finally + (mapM peekCString =<< Array.peekArray0 nullPtr a) + (JackFFIFree.freePortNameArray a) + +-- | Returns the names of all existing ports. getPorts :: Client -- ^ the Jack client -> IO [String] -- ^ the names as a list of strings getPorts client = CString.withCString "" $ \empty -> do - mapM peekCString - =<< Array.peekArray0 nullPtr - =<< JackFFI.get_ports (getClient client) empty empty 0 + JackFFI.get_ports (getClient client) empty empty 0 + >>= peekPortNameArray connect :: @@ -391,3 +435,168 @@ getSampleRate :: Client -> IO Int getSampleRate (Client ptr) = fmap fromIntegral $ JackFFI.get_sample_rate ptr + + +-- | Create a client registration callback 'FunPtr'. +foreign import ccall "wrapper" mkClientRegistration :: JackFFI.ClientRegistration -> IO (FunPtr JackFFI.ClientRegistration) + +-- | Set the client registration callback. +setClientRegistration :: + (JackExc.ThrowsErrno e) => + Client -> + FunPtr JackFFI.ClientRegistration -> + Sync.ExceptionalT e IO () +setClientRegistration client procPtr = + liftErrno $ JackFFI.set_client_registration_callback (getClient client) procPtr nullPtr + + +-- | Create a port registration callback 'FunPtr'. +foreign import ccall "wrapper" mkPortRegistration :: JackFFI.PortRegistration -> IO (FunPtr JackFFI.PortRegistration) + +-- | Set the port registration callback. +setPortRegistration :: + (JackExc.ThrowsErrno e) => + Client -> + FunPtr JackFFI.PortRegistration -> + Sync.ExceptionalT e IO () +setPortRegistration client procPtr = + liftErrno $ JackFFI.set_port_registration_callback (getClient client) procPtr nullPtr + + +-- | Create a port connect callback 'FunPtr'. +foreign import ccall "wrapper" mkPortConnect :: JackFFI.PortConnect -> IO (FunPtr JackFFI.PortConnect) + +-- | Set the port connect callback. +setPortConnect :: + (JackExc.ThrowsErrno e) => + Client -> + FunPtr JackFFI.PortConnect -> + Sync.ExceptionalT e IO () +setPortConnect client procPtr = + liftErrno $ JackFFI.set_port_connect_callback (getClient client) procPtr nullPtr + + +portById :: + Client -> JackFFI.PortId -> + IO (Port JackFFI.UnknownType UnknownDirection) +portById client portId = + fmap Port $ + JackFFI.port_by_id (getClient client) portId + +portByName :: + Client -> String -> + IO (Port JackFFI.UnknownType UnknownDirection) +portByName client name = + fmap Port $ + CString.withCString name $ JackFFI.port_by_name (getClient client) . JackFFI.PortName + +-- | Return the full port name, including the @client_name:@ prefix. +portName :: Port typ dir -> IO String +portName (Port port) = JackFFI.port_name port >>= peekCString + +-- | Return the short port name, not including the @client_name:@ prefix. +portShortName :: Port typ dir -> IO String +portShortName (Port port) = JackFFI.port_short_name port >>= peekCString + +-- | Return all the port names a given port is connected to. +-- +-- This function must not be called from a JACK event callback. +portGetAllConnections :: + Client -> Port typ dir -> IO [String] +portGetAllConnections client (Port port) = + JackFFI.port_get_all_connections (getClient client) port + >>= peekPortNameArray + +narrowPort :: + (PortType typ, Direction dir, JackExc.ThrowsPortMismatch e) => + Port JackFFI.UnknownType UnknownDirection -> + Sync.ExceptionalT e IO (Port typ dir) +narrowPort port = + narrowPortType =<< narrowPortDirection port + +narrowPortType :: + (PortType typ, JackExc.ThrowsPortMismatch e) => + Port JackFFI.UnknownType dir -> + Sync.ExceptionalT e IO (Port typ dir) +narrowPortType = + let aux :: + (PortType typ, + JackExc.ThrowsPortMismatch e) => + typ -> Port JackFFI.UnknownType dir -> + Sync.ExceptionalT e IO (Port typ dir) + aux portType (Port port) = do + typ <- + Trans.lift $ + peekCString . JackFFI.deconsPortName =<< JackFFI.port_type port + Sync.assertT (JackExc.portMismatch JackExc.TypeMismatch) $ + portTypeToCString portType == typ + return $ Port $ castPtr port + in aux undefined + +narrowPortDirection :: + (Direction dir, JackExc.ThrowsPortMismatch e) => + Port typ UnknownDirection -> + Sync.ExceptionalT e IO (Port typ dir) +narrowPortDirection = + let aux :: + (Direction dir, + JackExc.ThrowsPortMismatch e) => + dir -> Port typ UnknownDirection -> + Sync.ExceptionalT e IO (Port typ dir) + aux dir (Port port) = do + flags <- Trans.lift $ JackFFI.port_flags port + Sync.assertT (JackExc.portMismatch JackExc.DirectionMismatch) $ + not $ ES.disjoint flags $ dirToFlags dir + return $ Port port + in aux undefined + +switchUnknownTypePort :: + (JackExc.ThrowsPortMismatch e) => + Port JackFFI.UnknownType dir -> + (Port C.CFloat dir -> Sync.ExceptionalT e IO a) -> + (Port EventBuffer dir -> Sync.ExceptionalT e IO a) -> + Sync.ExceptionalT e IO a +switchUnknownTypePort (Port port) audio midi = do + typ <- + Trans.lift $ + peekCString . JackFFI.deconsPortName + =<< JackFFI.port_type port + let ifMatch :: + (PortType typ, Monad m) => + typ -> (Port typ dir -> m a) -> + Port typ dir -> m a -> m a + ifMatch portType trueAct p falseAct = + if portTypeToCString portType == typ + then trueAct p + else falseAct + case Port $ castPtr port of + audioPort -> + ifMatch undefined audio audioPort $ + case Port $ castPtr port of + midiPort -> + ifMatch undefined midi midiPort $ + Sync.throwT $ JackExc.portMismatch JackExc.TypeMismatch + +switchUnknownDirectionPort :: + (JackExc.ThrowsPortMismatch e) => + Port typ UnknownDirection -> + (Port typ Input -> Sync.ExceptionalT e IO a) -> + (Port typ Output -> Sync.ExceptionalT e IO a) -> + Sync.ExceptionalT e IO a +switchUnknownDirectionPort (Port port) input output = do + flags <- Trans.lift $ JackFFI.port_flags port + let ifMatch :: + (Direction dir, Monad m) => + dir -> (Port typ dir -> m a) -> + Port typ dir -> m a -> m a + ifMatch dir trueAct p falseAct = + if not $ ES.disjoint flags $ dirToFlags dir + then trueAct p + else falseAct + case Port port of + inPort -> + ifMatch undefined input inPort $ + case Port port of + outPort -> + ifMatch undefined output outPort $ + Sync.throwT $ JackExc.portMismatch JackExc.DirectionMismatch diff --git a/src/Sound/JACK/Exception.hs b/src/Sound/JACK/Exception.hs --- a/src/Sound/JACK/Exception.hs +++ b/src/Sound/JACK/Exception.hs @@ -3,6 +3,7 @@ All, ThrowsStatus (status), Status(..), ThrowsPortRegister (portRegister), PortRegister(..), + ThrowsPortMismatch (portMismatch), PortMismatch(..), PortMismatchKind(..), ThrowsErrno (errno), Errno(..), ) where @@ -14,7 +15,7 @@ -type All = Status (PortRegister (FE.Errno)) +type All = Status (PortRegister (PortMismatch FE.Errno)) toStringWithHead :: All -> String @@ -48,6 +49,9 @@ instance ThrowsPortRegister e => ThrowsPortRegister (Status e) where portRegister = NoStatus portRegister +instance ThrowsPortMismatch e => ThrowsPortMismatch (Status e) where + portMismatch = NoStatus . portMismatch + instance ThrowsErrno e => ThrowsErrno (Status e) where errno = NoStatus . errno @@ -76,11 +80,44 @@ instance ThrowsPortRegister (PortRegister e) where portRegister = PortRegister +instance ThrowsPortMismatch e => ThrowsPortMismatch (PortRegister e) where + portMismatch = NoPortRegister . portMismatch + instance ThrowsErrno e => ThrowsErrno (PortRegister e) where errno = NoPortRegister . errno +class ThrowsPortMismatch e where + portMismatch :: PortMismatchKind -> e + +data PortMismatch e = + PortMismatch PortMismatchKind + | NoPortMismatch e + +data PortMismatchKind = TypeMismatch | DirectionMismatch + +instance ToString e => ToString (PortMismatch e) where + toString e0 = + case e0 of + PortMismatch TypeMismatch -> "port not of excpected type" + PortMismatch DirectionMismatch -> "port does not support excpected direction" + NoPortMismatch e1 -> toString e1 + +instance ThrowsStatus e => ThrowsStatus (PortMismatch e) where + status = NoPortMismatch . status + +instance ThrowsPortRegister e => ThrowsPortRegister (PortMismatch e) where + portRegister = NoPortMismatch portRegister + +instance ThrowsPortMismatch (PortMismatch e) where + portMismatch = PortMismatch + +instance ThrowsErrno e => ThrowsErrno (PortMismatch e) where + errno = NoPortMismatch . errno + + + class ThrowsErrno e where errno :: FE.Errno -> e @@ -102,6 +139,9 @@ instance ThrowsPortRegister e => ThrowsPortRegister (Errno e) where portRegister = NoErrno portRegister + +instance ThrowsPortMismatch e => ThrowsPortMismatch (Errno e) where + portMismatch = NoErrno . portMismatch instance ThrowsErrno (Errno e) where errno = Errno diff --git a/src/Sound/JACK/FFI.hs b/src/Sound/JACK/FFI.hs deleted file mode 100644 --- a/src/Sound/JACK/FFI.hs +++ /dev/null @@ -1,193 +0,0 @@ --- -*-haskell-*- -{-# LANGUAGE ForeignFunctionInterface #-} - -{- - JACK bindings for Haskell - Copyright (C) 2011 Henning Thielemann - Copyright (C) 2007 Soenke Hahn - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License along - with this program; if not, write to the Free Software Foundation, Inc., - 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. --} - -module Sound.JACK.FFI where - -import Foreign.Ptr (Ptr, FunPtr) -import Foreign.C.String (CString) -import qualified Foreign.C.Error as E -import qualified Foreign.C.Types as C - -import qualified Data.EnumSet as ES -import Data.Word (Word, ) -import Data.Ix (Ix(range, inRange, rangeSize, index)) -import Data.Monoid (Monoid, mempty, mappend, ) - - -data Client = Client -data Port typ = Port - -foreign import ccall "static jack/jack.h jack_client_open" - client_open :: CString -> OpenOptionSet -> Ptr StatusSet -> CString -> IO (Ptr Client) - -{-# DEPRECATED client_new "use client_open instead" #-} -foreign import ccall "static jack/jack.h jack_client_new" - client_new :: CString -> IO (Ptr Client) - -foreign import ccall "static jack/jack.h jack_get_sample_rate" - get_sample_rate :: Ptr Client -> IO C.CInt - - -type OpenOptionSet = ES.T C.CULong OpenOptions - -data OpenOptions = - NoStartServer - | UseExactName - | ServerName - deriving (Enum, Eq, Ord, Show, Ix) - -wordNullOption, wordNoStartServer, wordUseExactName, wordServerName :: OpenOptionSet -wordNullOption = ES.empty -wordNoStartServer = ES.fromEnum NoStartServer -wordUseExactName = ES.fromEnum UseExactName -wordServerName = ES.fromEnum ServerName - - -type StatusSet = ES.T C.CULong Status - -data Status = - Failure - | InvalidOption - | NameNotUnique - | ServerStarted - | ServerFailed - | ServerError - | NoSuchClient - | LoadFailure - | InitFailure - | ShmFailure - | VersionError - deriving (Enum, Eq, Ord, Show, Ix) - -wordFailure, wordInvalidOption, wordNameNotUnique, wordServerStarted, - wordServerFailed, wordServerError, wordNoSuchClient, wordLoadFailure, - wordInitFailure, wordShmFailure, wordVersionError :: StatusSet -wordFailure = ES.fromEnum Failure -wordInvalidOption = ES.fromEnum InvalidOption -wordNameNotUnique = ES.fromEnum NameNotUnique -wordServerStarted = ES.fromEnum ServerStarted -wordServerFailed = ES.fromEnum ServerFailed -wordServerError = ES.fromEnum ServerError -wordNoSuchClient = ES.fromEnum NoSuchClient -wordLoadFailure = ES.fromEnum LoadFailure -wordInitFailure = ES.fromEnum InitFailure -wordShmFailure = ES.fromEnum ShmFailure -wordVersionError = ES.fromEnum VersionError - - -type PortFlagSet = ES.T C.CULong PortFlag - -data PortFlag = - PortIsInput - | PortIsOutput - | PortIsPhysical - | PortCanMonitor - | PortIsTerminal - deriving (Enum, Eq, Ord, Show, Ix) - - -newtype PortName = PortName {deconsPortName :: CString} - -portIsInput, portIsOutput :: PortFlagSet -portIsInput = ES.fromEnum PortIsInput -portIsOutput = ES.fromEnum PortIsOutput - - -foreign import ccall "static jack/jack.h jack_port_register" - port_register :: Ptr Client -> PortName -> CString -> - PortFlagSet -> C.CULong -> IO (Ptr (Port a)) - - --- | represents absolute frame time -newtype NFrames = NFrames C.CUInt - deriving (Show, Eq, Ord) - -nframesToWord :: NFrames -> Word -nframesToWord (NFrames n) = fromIntegral n - -instance Ix NFrames where - range (a,b) = - map (NFrames . fromIntegral) $ - range (nframesToWord a, nframesToWord b) - index (a,b) i = - index (nframesToWord a, nframesToWord b) (nframesToWord i) - inRange (a,b) i = - inRange (nframesToWord a, nframesToWord b) (nframesToWord i) - rangeSize (a,b) = - rangeSize (nframesToWord a, nframesToWord b) - -instance Monoid NFrames where - mempty = NFrames 0 - mappend (NFrames x) (NFrames y) = NFrames (x+y) - - -nframesIndices :: NFrames -> [NFrames] -nframesIndices (NFrames n) = - take (fromIntegral n) $ map NFrames $ iterate (1+) 0 - -nframesBounds :: NFrames -> (NFrames,NFrames) -nframesBounds (NFrames n) = - (NFrames 0, NFrames $ n - 1) - - -data CallbackArg = CallbackArg - - -type Process = NFrames -> Ptr CallbackArg -> IO E.Errno - -foreign import ccall "static jack/jack.h jack_set_process_callback" - set_process_callback :: - Ptr Client -> FunPtr Process -> Ptr CallbackArg -> IO E.Errno - -foreign import ccall "static jack/jack.h jack_last_frame_time" - last_frame_time :: Ptr Client -> IO NFrames - - -foreign import ccall "static jack/jack.h jack_port_get_buffer" - port_get_buffer :: Ptr (Port a) -> NFrames -> IO (Ptr a) - -foreign import ccall "static jack/jack.h jack_get_buffer_size" - get_buffer_size :: Ptr Client -> IO (C.CUInt) - -foreign import ccall "static jack/jack.h jack_activate" - activate :: Ptr Client -> IO E.Errno - -foreign import ccall "static jack/jack.h jack_client_close" - client_close :: Ptr Client -> IO E.Errno - -foreign import ccall "static jack/jack.h jack_get_ports" - get_ports :: Ptr Client -> CString -> CString -> C.CULong -> IO (Ptr CString) --- get_ports :: Ptr Client -> CString -> CString -> C.CULong -> IO (Ptr PortName) - --- may return eEXIST -foreign import ccall "static jack/jack.h jack_connect" - connect :: Ptr Client -> PortName -> PortName -> IO E.Errno - -foreign import ccall "static jack/jack.h jack_disconnect" - disconnect :: Ptr Client -> PortName -> PortName -> IO E.Errno - -foreign import ccall "static jack/jack.h jack_port_unregister" - port_unregister :: Ptr Client -> Ptr (Port a) -> IO E.Errno - -foreign import ccall "static jack/jack.h jack_deactivate" - deactivate :: Ptr Client -> IO E.Errno diff --git a/src/Sound/JACK/FFI.hsc b/src/Sound/JACK/FFI.hsc new file mode 100644 --- /dev/null +++ b/src/Sound/JACK/FFI.hsc @@ -0,0 +1,251 @@ +-- -*-haskell-*- +{-# LANGUAGE ForeignFunctionInterface #-} + +{- + JACK bindings for Haskell + Copyright (C) 2011 Henning Thielemann + Copyright (C) 2007 Soenke Hahn + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License along + with this program; if not, write to the Free Software Foundation, Inc., + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. +-} + +module Sound.JACK.FFI where + +import Foreign.Ptr (Ptr, FunPtr) +import Foreign.C.String (CString) +import qualified Foreign.C.Error as E +import qualified Foreign.C.Types as C + +import qualified Data.EnumSet as ES +import Data.Word (Word, Word32, ) +import Data.Ix (Ix(range, inRange, rangeSize, index)) +import Data.Monoid (Monoid, mempty, mappend, ) + +#include "jack/jack.h" + +data Client = Client +data Port typ = Port + +foreign import ccall "static jack/jack.h jack_client_open" + client_open :: CString -> OpenOptionSet -> Ptr StatusSet -> CString -> IO (Ptr Client) + +{-# DEPRECATED client_new "use client_open instead" #-} +foreign import ccall "static jack/jack.h jack_client_new" + client_new :: CString -> IO (Ptr Client) + +foreign import ccall "static jack/jack.h jack_get_sample_rate" + get_sample_rate :: Ptr Client -> IO C.CInt + + +type OpenOptionSet = ES.T C.CULong OpenOptions + +data OpenOptions = + NoStartServer + | UseExactName + | ServerName + deriving (Enum, Eq, Ord, Show, Ix) + +wordNullOption, wordNoStartServer, wordUseExactName, wordServerName :: OpenOptionSet +wordNullOption = ES.empty +wordNoStartServer = ES.fromEnum NoStartServer +wordUseExactName = ES.fromEnum UseExactName +wordServerName = ES.fromEnum ServerName + + +type StatusSet = ES.T C.CULong Status + +data Status = + Failure + | InvalidOption + | NameNotUnique + | ServerStarted + | ServerFailed + | ServerError + | NoSuchClient + | LoadFailure + | InitFailure + | ShmFailure + | VersionError + deriving (Enum, Eq, Ord, Show, Ix) + +wordFailure, wordInvalidOption, wordNameNotUnique, wordServerStarted, + wordServerFailed, wordServerError, wordNoSuchClient, wordLoadFailure, + wordInitFailure, wordShmFailure, wordVersionError :: StatusSet +wordFailure = ES.fromEnum Failure +wordInvalidOption = ES.fromEnum InvalidOption +wordNameNotUnique = ES.fromEnum NameNotUnique +wordServerStarted = ES.fromEnum ServerStarted +wordServerFailed = ES.fromEnum ServerFailed +wordServerError = ES.fromEnum ServerError +wordNoSuchClient = ES.fromEnum NoSuchClient +wordLoadFailure = ES.fromEnum LoadFailure +wordInitFailure = ES.fromEnum InitFailure +wordShmFailure = ES.fromEnum ShmFailure +wordVersionError = ES.fromEnum VersionError + + +type PortFlagSet = ES.T C.CULong PortFlag + +data PortFlag = + PortIsInput + | PortIsOutput + | PortIsPhysical + | PortCanMonitor + | PortIsTerminal + deriving (Enum, Eq, Ord, Show, Ix) + + +newtype PortName = PortName {deconsPortName :: CString} + +portIsInput, portIsOutput :: PortFlagSet +portIsInput = ES.fromEnum PortIsInput +portIsOutput = ES.fromEnum PortIsOutput + + +foreign import ccall "static jack/jack.h jack_port_register" + port_register :: Ptr Client -> PortName -> CString -> + PortFlagSet -> C.CULong -> IO (Ptr (Port a)) + + +-- | represents absolute frame time +newtype NFrames = NFrames C.CUInt + deriving (Show, Eq, Ord) + +nframesToWord :: NFrames -> Word +nframesToWord (NFrames n) = fromIntegral n + +instance Ix NFrames where + range (a,b) = + map (NFrames . fromIntegral) $ + range (nframesToWord a, nframesToWord b) + index (a,b) i = + index (nframesToWord a, nframesToWord b) (nframesToWord i) + inRange (a,b) i = + inRange (nframesToWord a, nframesToWord b) (nframesToWord i) + rangeSize (a,b) = + rangeSize (nframesToWord a, nframesToWord b) + +instance Monoid NFrames where + mempty = NFrames 0 + mappend (NFrames x) (NFrames y) = NFrames (x+y) + + +nframesIndices :: NFrames -> [NFrames] +nframesIndices (NFrames n) = + take (fromIntegral n) $ map NFrames $ iterate (1+) 0 + +nframesBounds :: NFrames -> (NFrames,NFrames) +nframesBounds (NFrames n) = + (NFrames 0, NFrames $ n - 1) + + +data CallbackArg = CallbackArg + + +type Process = NFrames -> Ptr CallbackArg -> IO E.Errno + +foreign import ccall "static jack/jack.h jack_set_process_callback" + set_process_callback :: + Ptr Client -> FunPtr Process -> Ptr CallbackArg -> IO E.Errno + +type ClientRegistration = CString -> C.CInt -> Ptr CallbackArg -> IO () + +foreign import ccall "static jack/jack.h jack_set_client_registration_callback" + set_client_registration_callback :: + Ptr Client -> FunPtr ClientRegistration -> Ptr CallbackArg -> IO E.Errno + +newtype PortId = PortId #{type jack_port_id_t} deriving (Eq, Ord, Show) + +{- | +Type argument for Jack ports where the type of samples transported by the port +is unknown. +-} +data UnknownType = UnknownType + +type PortRegistration = PortId -> C.CInt -> Ptr CallbackArg -> IO () + +foreign import ccall "static jack/jack.h jack_set_port_registration_callback" + set_port_registration_callback :: + Ptr Client -> FunPtr PortRegistration -> Ptr CallbackArg -> IO E.Errno + +type PortConnect = PortId -> PortId -> C.CInt -> Ptr CallbackArg -> IO () + +foreign import ccall "static jack/jack.h jack_set_port_connect_callback" + set_port_connect_callback :: + Ptr Client -> FunPtr PortConnect -> Ptr CallbackArg -> IO E.Errno + + +foreign import ccall "static jack/jack.h jack_port_by_id" + port_by_id :: + Ptr Client -> PortId -> IO (Ptr (Port UnknownType)) + +foreign import ccall "static jack/jack.h jack_port_by_name" + port_by_name :: + Ptr Client -> PortName -> IO (Ptr (Port UnknownType)) + +foreign import ccall "static jack/jack.h jack_port_name" + port_name :: + Ptr (Port typ) -> IO CString + +foreign import ccall "static jack/jack.h jack_port_short_name" + port_short_name :: + Ptr (Port typ) -> IO CString + +foreign import ccall "static jack/jack.h jack_port_flags" + port_flags :: + Ptr (Port typ) -> IO PortFlagSet + +foreign import ccall "static jack/jack.h jack_port_type" + port_type :: + Ptr (Port UnknownType) -> IO PortName + +foreign import ccall "static jack/jack.h jack_get_ports" + get_ports :: Ptr Client -> CString -> CString -> C.CULong -> IO (Ptr CString) +-- get_ports :: Ptr Client -> CString -> CString -> C.CULong -> IO (Ptr PortName) + +foreign import ccall "static jack/jack.h jack_port_get_all_connections" + port_get_all_connections :: + Ptr Client -> Ptr (Port typ) -> IO (Ptr CString) + + +foreign import ccall "static jack/jack.h jack_last_frame_time" + last_frame_time :: Ptr Client -> IO NFrames + +foreign import ccall "static jack/jack.h jack_port_get_buffer" + port_get_buffer :: Ptr (Port a) -> NFrames -> IO (Ptr a) + +foreign import ccall "static jack/jack.h jack_get_buffer_size" + get_buffer_size :: Ptr Client -> IO (C.CUInt) + +foreign import ccall "static jack/jack.h jack_activate" + activate :: Ptr Client -> IO E.Errno + +foreign import ccall "static jack/jack.h jack_client_close" + client_close :: Ptr Client -> IO E.Errno + +-- may return eEXIST +foreign import ccall "static jack/jack.h jack_connect" + connect :: Ptr Client -> PortName -> PortName -> IO E.Errno + +foreign import ccall "static jack/jack.h jack_disconnect" + disconnect :: Ptr Client -> PortName -> PortName -> IO E.Errno + +foreign import ccall "static jack/jack.h jack_port_unregister" + port_unregister :: Ptr Client -> Ptr (Port a) -> IO E.Errno + +foreign import ccall "static jack/jack.h jack_deactivate" + deactivate :: Ptr Client -> IO E.Errno + + diff --git a/src/Sound/JACK/FFI/MIDI.chs b/src/Sound/JACK/FFI/MIDI.chs deleted file mode 100644 --- a/src/Sound/JACK/FFI/MIDI.chs +++ /dev/null @@ -1,148 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface #-} - -#include "jack/midiport.h" - -module Sound.JACK.FFI.MIDI - ( - EventBuffer(EventBuffer), - - RawEvent(RawEvent), - time, - buffer, - - toRawEventFunction, - - get_event_count, - event_get, - clear_buffer, - event_reserve, - event_write, - - -- internal - withByteStringPtr, - ) - -where - -import Sound.JACK.FFI (NFrames(NFrames), ) - -import Foreign.Marshal.Array (copyArray, advancePtr, ) -import Foreign.ForeignPtr (withForeignPtr, ) -import Foreign.Ptr (Ptr, castPtr, ) -import Foreign.Storable (Storable, peekByteOff, pokeByteOff, sizeOf, alignment, peek, poke) -import qualified Foreign.C.Error as E -import qualified Foreign.C.Types as C -import Foreign.C.Types (CUInt, CUChar, ) -import Data.Word (Word8, ) - -import qualified Data.ByteString as B -import qualified Data.ByteString.Internal as BI -import qualified Data.ByteString.Lazy as BL -import qualified Sound.MIDI.Message as Msg -import qualified Sound.MIDI.Parser.Report as Report - -import System.IO (hPutStrLn, stderr, ) - - --- could also be an empty data declaration -data EventBuffer = EventBuffer - --- | Represents a raw JACK MIDI event -data RawEvent = RawEvent { - time :: NFrames -- ^ Sample index at which event is valid (relative to cycle start) - , buffer :: B.ByteString -- ^ Raw MIDI data -} deriving (Eq, Ord) - --- | Converts high level MIDI Event transformation functions into raw MIDI Event transformation functions -toRawEventFunction :: - (NFrames -> (NFrames, Msg.T) -> IO (NFrames, Msg.T)) - -- ^ transforms Sound.MIDI.File.Event - -> - (NFrames -> RawEvent -> IO RawEvent) - -- ^ transforms Sound.JACK.MIDI.RawEvent -toRawEventFunction fun cycleStart rawEvent = - case Msg.maybeFromByteString $ BL.fromChunks [buffer rawEvent] of - Report.Cons warnings result -> do - mapM_ (hPutStrLn stderr) warnings - case result of - Left _ -> do - putStrLn $ "Warning: Did not understand Event: " ++ show rawEvent - return rawEvent - Right e -> do - (time_, event_) <- fun cycleStart (time rawEvent, e) - return $ RawEvent time_ $ B.concat $ - BL.toChunks $ Msg.toByteString event_ - -instance Storable RawEvent where - sizeOf _ = {# sizeof jack_midi_event_t #} - - alignment _ = alignment (undefined :: C.CUInt) - - peek pointer = do - time_ <- {# get jack_midi_event_t-> time #} pointer - size_ <- {# get jack_midi_event_t-> size #} pointer - - bufferPtr <- {# get jack_midi_event_t-> buffer #} pointer - let sizeInt = fromIntegral size_ - buffer_ <- - BI.create sizeInt $ \dest -> - copyArray dest (castPtr bufferPtr) sizeInt - - return $ RawEvent (NFrames time_) buffer_ - - {- | - This implementation expects that port buffer pointer is already initialized. - This is dangerous, but currently we do not know, how to do it better. - -} - poke pointer (RawEvent (NFrames time_) buffer_) = do - {# set jack_midi_event_t-> time #} pointer time_ - {# set jack_midi_event_t-> size #} pointer (fromIntegral $ B.length buffer_) - - bufferPtr <- {# get jack_midi_event_t-> buffer #} pointer - withByteStringPtr buffer_ $ \ptr len -> - copyArray (castPtr bufferPtr) ptr len - - {# set jack_midi_event_t-> buffer #} pointer bufferPtr - -withByteStringPtr :: B.ByteString -> (Ptr Word8 -> Int -> IO a) -> IO a -withByteStringPtr bstr act = - case BI.toForeignPtr bstr of - (fptr, start, len) -> - withForeignPtr fptr $ \ptr -> - act (advancePtr ptr start) len - - -instance Show RawEvent where - show rawEvent = - "MIDIEvent @ " ++ show (time rawEvent) ++ - "\t: " ++ showEvent (buffer rawEvent) - -showEvent :: B.ByteString -> String -showEvent buffer_ = - case Msg.maybeFromByteString $ BL.fromChunks [buffer_] of - Report.Cons warnings result -> - unlines warnings ++ - case result of - Left errMsg -> "Warning: " ++ errMsg - Right e -> - case e of - Msg.Channel b -> "MidiMsg.Channel " ++ show b - Msg.System _ -> "MidiMsg.System ..." - - - -foreign import ccall "static jack/midiport.h jack_midi_get_event_count" - get_event_count :: Ptr EventBuffer -> IO NFrames - -foreign import ccall "static jack/midiport.h jack_midi_event_get" - event_get :: Ptr RawEvent -> Ptr EventBuffer -> NFrames -> IO E.Errno - -foreign import ccall "static jack/midiport.h jack_midi_clear_buffer" - clear_buffer :: Ptr EventBuffer -> IO () - --- nullPtr may be mapped to eNOBUFS exception as in event_write -foreign import ccall "static jack/midiport.h jack_midi_event_reserve" - event_reserve :: Ptr EventBuffer -> NFrames -> C.CSize -> IO (Ptr Word8) - -foreign import ccall "static jack/midiport.h jack_midi_event_write" - event_write :: Ptr EventBuffer -> NFrames -> Ptr Word8 -> C.CULong -> IO E.Errno diff --git a/src/Sound/JACK/FFI/MIDI.hsc b/src/Sound/JACK/FFI/MIDI.hsc new file mode 100644 --- /dev/null +++ b/src/Sound/JACK/FFI/MIDI.hsc @@ -0,0 +1,150 @@ +{-# LANGUAGE ForeignFunctionInterface #-} + +#include "jack/midiport.h" + +module Sound.JACK.FFI.MIDI + ( + EventBuffer(EventBuffer), + + RawEvent(RawEvent), + time, + buffer, + + toRawEventFunction, + + get_event_count, + event_get, + clear_buffer, + event_reserve, + event_write, + + -- internal + withByteStringPtr, + ) + +where + +import Sound.JACK.FFI (NFrames(NFrames), ) + +import Foreign.Marshal.Array (copyArray, advancePtr, ) +import Foreign.ForeignPtr (withForeignPtr, ) +import Foreign.Ptr (Ptr, castPtr, ) +import Foreign.Storable (Storable, peekByteOff, pokeByteOff, sizeOf, alignment, peek, poke) +import qualified Foreign.C.Error as E +import qualified Foreign.C.Types as C +import Data.Word (Word8, ) + +import qualified Data.ByteString as B +import qualified Data.ByteString.Internal as BI +import qualified Data.ByteString.Lazy as BL +import qualified Sound.MIDI.Message as Msg +import qualified Sound.MIDI.Parser.Report as Report + +import System.IO (hPutStrLn, stderr, ) + +-- cf. FFI cookbook +#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__) + +-- could also be an empty data declaration +data EventBuffer = EventBuffer + +-- | Represents a raw JACK MIDI event +data RawEvent = RawEvent { + time :: NFrames -- ^ Sample index at which event is valid (relative to cycle start) + , buffer :: B.ByteString -- ^ Raw MIDI data +} deriving (Eq, Ord) + +-- | Converts high level MIDI Event transformation functions into raw MIDI Event transformation functions +toRawEventFunction :: + (NFrames -> (NFrames, Msg.T) -> IO (NFrames, Msg.T)) + -- ^ transforms Sound.MIDI.File.Event + -> + (NFrames -> RawEvent -> IO RawEvent) + -- ^ transforms Sound.JACK.MIDI.RawEvent +toRawEventFunction fun cycleStart rawEvent = + case Msg.maybeFromByteString $ BL.fromChunks [buffer rawEvent] of + Report.Cons warnings result -> do + mapM_ (hPutStrLn stderr) warnings + case result of + Left _ -> do + putStrLn $ "Warning: Did not understand Event: " ++ show rawEvent + return rawEvent + Right e -> do + (time_, event_) <- fun cycleStart (time rawEvent, e) + return $ RawEvent time_ $ B.concat $ + BL.toChunks $ Msg.toByteString event_ + +instance Storable RawEvent where + sizeOf _ = #{size jack_midi_event_t} + + alignment _ = #{alignment jack_midi_event_t} + + peek pointer = do + time_ <- #{peek jack_midi_event_t, time} pointer + size_ <- #{peek jack_midi_event_t, size} pointer + + bufferPtr <- #{peek jack_midi_event_t, buffer} pointer + let sizeInt = fromIntegral (size_ :: C.CSize) + buffer_ <- + BI.create sizeInt $ \dest -> + copyArray dest (castPtr bufferPtr) sizeInt + + return $ RawEvent (NFrames time_) buffer_ + + {- | + This implementation expects that port buffer pointer is already initialized. + This is dangerous, but currently we do not know, how to do it better. + -} + poke pointer (RawEvent (NFrames time_) buffer_) = do + #{poke jack_midi_event_t, time} pointer time_ + #{poke jack_midi_event_t, size} pointer + (fromIntegral $ B.length buffer_ :: C.CSize) + + bufferPtr <- #{peek jack_midi_event_t, buffer} pointer + withByteStringPtr buffer_ $ \ptr len -> + copyArray (castPtr bufferPtr) ptr len + + #{poke jack_midi_event_t, buffer} pointer bufferPtr + +withByteStringPtr :: B.ByteString -> (Ptr Word8 -> Int -> IO a) -> IO a +withByteStringPtr bstr act = + case BI.toForeignPtr bstr of + (fptr, start, len) -> + withForeignPtr fptr $ \ptr -> + act (advancePtr ptr start) len + + +instance Show RawEvent where + show rawEvent = + "MIDIEvent @ " ++ show (time rawEvent) ++ + "\t: " ++ showEvent (buffer rawEvent) + +showEvent :: B.ByteString -> String +showEvent buffer_ = + case Msg.maybeFromByteString $ BL.fromChunks [buffer_] of + Report.Cons warnings result -> + unlines warnings ++ + case result of + Left errMsg -> "Warning: " ++ errMsg + Right e -> + case e of + Msg.Channel b -> "MidiMsg.Channel " ++ show b + Msg.System _ -> "MidiMsg.System ..." + + + +foreign import ccall "static jack/midiport.h jack_midi_get_event_count" + get_event_count :: Ptr EventBuffer -> IO NFrames + +foreign import ccall "static jack/midiport.h jack_midi_event_get" + event_get :: Ptr RawEvent -> Ptr EventBuffer -> NFrames -> IO E.Errno + +foreign import ccall "static jack/midiport.h jack_midi_clear_buffer" + clear_buffer :: Ptr EventBuffer -> IO () + +-- nullPtr may be mapped to eNOBUFS exception as in event_write +foreign import ccall "static jack/midiport.h jack_midi_event_reserve" + event_reserve :: Ptr EventBuffer -> NFrames -> C.CSize -> IO (Ptr Word8) + +foreign import ccall "static jack/midiport.h jack_midi_event_write" + event_write :: Ptr EventBuffer -> NFrames -> Ptr Word8 -> C.CULong -> IO E.Errno diff --git a/src/Sound/JACK/Private.hs b/src/Sound/JACK/Private.hs --- a/src/Sound/JACK/Private.hs +++ b/src/Sound/JACK/Private.hs @@ -63,10 +63,10 @@ like explicit-exception:SIO. -} bracket :: - Sync.ExceptionalT e IO a -> - (a -> Sync.ExceptionalT e IO ()) -> - (a -> Sync.ExceptionalT e IO b) -> - Sync.ExceptionalT e IO b + Sync.ExceptionalT e IO handle -> + (handle -> Sync.ExceptionalT e IO ()) -> + (handle -> Sync.ExceptionalT e IO a) -> + Sync.ExceptionalT e IO a bracket open close act = Sync.ExceptionalT $ Exc.bracket @@ -85,6 +85,14 @@ case r of Sync.Success a -> Sync.runExceptionalT $ act a Sync.Exception e -> return $ Sync.Exception e) + +bracket_ :: + Sync.ExceptionalT e IO () -> + Sync.ExceptionalT e IO () -> + Sync.ExceptionalT e IO a -> + Sync.ExceptionalT e IO a +bracket_ open close act = + bracket open (\() -> close) (\() -> act) liftErrno ::