diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,27 +0,0 @@ - -import Distribution.Simple -import Distribution.Simple.Utils -import Directory -import Monad -import System - -neededHeaders = ["jack/jack.h", "st.h"] - -main = do - args <- getArgs - when ((head args) == "configure") (checkHeaders neededHeaders) - defaultMainWithHooks defaultUserHooks - - -checkHeaders ll = do - mapM checkHeader ll - return () - -includeDirs = ["/usr/local/include", "/usr/include"] - -checkHeader name = do - putStr ("Searching for " ++ name ++ "...") - bools <- mapM (\ p -> doesFileExist (p ++ "/" ++ name)) includeDirs - when (not $ or bools) (fail ("ERROR: " ++ name ++ " not found")) - putStrLn "found" - diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#! /usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/examples/Amplify.hs b/examples/Amplify.hs --- a/examples/Amplify.hs +++ b/examples/Amplify.hs @@ -1,11 +1,13 @@ -{-# options -O2 #-} module Main where import Foreign.C.Types (CFloat) -import qualified Sound.JACK as Jack +import qualified Sound.JACK.Audio as Audio main :: IO () -main = Jack.mainStereo foo +main = Audio.mainStereo foo foo :: (CFloat, CFloat) -> IO (CFloat, CFloat) -foo (a, b) = return (a, b) +foo (a, b) = return (a * fac, b * fac) + +fac :: CFloat +fac = 2 diff --git a/examples/ImpulseTrain.hs b/examples/ImpulseTrain.hs new file mode 100644 --- /dev/null +++ b/examples/ImpulseTrain.hs @@ -0,0 +1,35 @@ +module Main where + +import qualified Sound.JACK.Audio as Audio +import qualified Sound.JACK as JACK + +import qualified Control.Monad.Trans.Class as Trans +import qualified Foreign.C.Error as E + +import System.Environment (getProgName) + +import Data.Array.Storable (writeArray, ) + + +main :: IO () +main = do + name <- getProgName + JACK.handleExceptions $ + JACK.withClientDefault name $ \client -> + JACK.withPort client "output" $ \output -> do + JACK.setProcess client =<< + (Trans.lift $ JACK.mkProcess $ process output) + JACK.withActivation client $ Trans.lift $ do + putStrLn $ "started " ++ name ++ "..." + JACK.waitForBreak + +process :: + Audio.Port JACK.Output -> JACK.Process +process output nframes _buffer = do + outArr <- Audio.getBufferArray output nframes + case JACK.nframesIndices nframes of + [] -> return () + zero:rest -> do + writeArray outArr zero 1 + mapM_ (\i -> writeArray outArr i 0) rest + return E.eOK diff --git a/examples/Midimon.hs b/examples/Midimon.hs new file mode 100644 --- /dev/null +++ b/examples/Midimon.hs @@ -0,0 +1,19 @@ +module Main where + +import qualified Sound.JACK.MIDI as MIDI +import Sound.JACK (NFrames(NFrames), ) + +import qualified Sound.MIDI.Message as Msg + + +main :: IO () +main = MIDI.main foo + +foo :: NFrames -> (NFrames, Msg.T) -> IO (NFrames, Msg.T) +foo (NFrames cycleStart) (tf@(NFrames t), e) = do + putStrLn $ "Time: " ++ show (cycleStart + t) ++ " " ++ + case e of + Msg.Channel b -> "MidiMsg.Channel " ++ show b + Msg.System _ -> "MidiMsg.System ..." + return (tf, e) + diff --git a/jack.cabal b/jack.cabal --- a/jack.cabal +++ b/jack.cabal @@ -1,33 +1,98 @@ Name: jack -Version: 0.5 +Version: 0.6 License: GPL License-File: LICENSE -Author: Soenke Hahn +Author: Soenke Hahn, Henning Thielemann Maintainer: Henning Thielemann -Homepage: http://open-projects.net/~shahn/index.php?seite=code -Repository: http://darcs.haskell.org/jack/ -Category: Sound --- base package version needed for unsafeForeignPtrToStorableArray, --- base-2.1.1 is shipped with GHC-6.6 --- in base-1.0 (GHC-6.4) this function is missing -Build-Type: Custom -Build-Depends: base>=2.1 Synopsis: Bindings for the JACK Audio Connection Kit Description: Very basic bindings for the JACK Audio Connection Kit -Hs-Source-Dirs: src -Exposed-Modules: Sound.JACK -Other-Modules: Sound.JACK.FFI -Tested-With: GHC==6.6 -ghc-options: -Wall -threaded -Extensions: ForeignFunctionInterface -Extra-Libraries: jack -Includes: jack/jack.h -Include-Dirs: /usr/local/include, /usr/include -Extra-Source-Files: README, INSTALL +Homepage: http://www.haskell.org/haskellwiki/JACK +Category: Sound +Build-Type: Simple +Cabal-Version: >=1.6 +Tested-With: GHC == 6.8.2, GHC == 6.10.4, GHC == 6.12.3, GHC == 7.0.2, GHC == 7.2.1 +Extra-Source-Files: + README + INSTALL -Executable: amplify -GHC-Options: -Wall -threaded -Extensions: ForeignFunctionInterface -Extra-Libraries: jack -Hs-Source-Dirs: src, . -Main-Is: examples/Amplify.hs +Source-Repository head + type: darcs + location: http://code.haskell.org/jack/ + +Source-Repository this + type: darcs + location: http://code.haskell.org/jack/ + tag: 0.6 + +Flag buildExamples + description: Build example executables + default: False + +Library + Build-Depends: + midi >=0.1.5.2 && <0.2, + bytestring >=0.9.1.4 && <0.10, + explicit-exception >=0.1.5 && <0.2, + transformers >=0.2 && <0.3, + enumset >=0.0 && <0.1, + array >=0.2 && <0.4, + unix >=2.3 && <2.6, + base >=4.0 && <5.0 + Exposed-Modules: + Sound.JACK + Sound.JACK.Audio + Sound.JACK.MIDI + Sound.JACK.Exception + Other-Modules: + Sound.JACK.Private + Sound.JACK.FFI + Sound.JACK.FFI.MIDI + Build-Tools: c2hs>=0.15.1 + Hs-Source-Dirs: src + GHC-Options: -threaded -Wall -fwarn-tabs -fwarn-incomplete-record-updates + If impl(ghc >= 6.12) + GHC-Options: -fwarn-unused-do-bind + 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 + Includes: jack/jack.h, jack/midiport.h + +Executable amplify + If !flag(buildExamples) + Buildable: False + GHC-Options: -threaded -Wall -fwarn-tabs -fwarn-incomplete-record-updates + Extensions: ForeignFunctionInterface + Extra-Libraries: jack + Other-Modules: Sound.JACK.FFI.MIDI + Hs-Source-Dirs: src, . + Main-Is: examples/Amplify.hs + +Executable impulse-train + If !flag(buildExamples) + Buildable: False + GHC-Options: -threaded -Wall -fwarn-tabs -fwarn-incomplete-record-updates + Extensions: ForeignFunctionInterface + Extra-Libraries: jack + Other-Modules: Sound.JACK.FFI.MIDI + Hs-Source-Dirs: src, . + Main-Is: examples/ImpulseTrain.hs + +Executable midimon + If !flag(buildExamples) + Buildable: False + GHC-Options: -threaded -Wall -fwarn-tabs -fwarn-incomplete-record-updates + Extensions: ForeignFunctionInterface + Extra-Libraries: jack + Other-Modules: Sound.JACK.FFI.MIDI + Hs-Source-Dirs: src, . + Main-Is: examples/Midimon.hs diff --git a/src/Sound/JACK.hs b/src/Sound/JACK.hs --- a/src/Sound/JACK.hs +++ b/src/Sound/JACK.hs @@ -1,5 +1,7 @@ +{-# 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 @@ -24,314 +26,360 @@ -} module Sound.JACK - ( - CFloat, - CUInt, - + ( -- * general stuff Client, - Input, - Output, newClient, - newClientSimple, - newInput, - newOutput, - activate, + newClientDefault, + disposeClient, + withClient, + withClientDefault, clientClose, getPorts, + + activate, + deactivate, + withActivation, + + PortType, + Direction, Input, Output, + + Port, + newPort, + disposePort, + withPort, + + PortSet, + setOfPort, + setOfPorts, + + Process, connect, - setProcessMono, - setProcessStereo, + mkProcess, + setProcess, + JackFFI.CallbackArg, - mainMono, - mainStereo, - ) + getSampleRate, + + JackFFI.NFrames(JackFFI.NFrames), + nframesIndices, nframesBounds, + quit, waitForBreakAndClose, + waitForBreak, + + -- * Exceptions + handleExceptions, +) where +import Sound.JACK.Private + +import qualified Sound.JACK.Exception as JackExc import qualified Sound.JACK.FFI as JackFFI -import Sound.JACK.FFI (flagsToWord, wordToFlags) +import Sound.JACK.FFI (Process, nframesIndices, nframesBounds, ) -import Foreign (newForeignPtr_, malloc, peek, peekArray0) -import Foreign.Ptr (Ptr, FunPtr, nullPtr) -import Foreign.C.String (newCString, peekCString) -import Foreign.C.Types (CUInt, CInt, CChar, CFloat, CULong) +import qualified Control.Monad.Exception.Synchronous as Sync +import qualified Control.Monad.Trans.Class as Trans + +import qualified Foreign.Marshal.Array as Array +import qualified Foreign.C.String as CString +import Foreign.Storable (Storable, peek, ) +import Foreign.Ptr (Ptr, FunPtr, nullPtr, castPtr, ) +import Foreign.C.String (peekCString, ) +import Foreign.C.Error (Errno(Errno), ) +import qualified Data.EnumSet as ES + import Control.Concurrent (MVar, putMVar, newEmptyMVar, takeMVar, threadDelay) +import qualified System.IO as IO import System.Posix.Signals (installHandler, keyboardSignal, Handler(Catch)) -import System.Environment (getProgName) -import Control.Monad (when) -import System.Random hiding (split) -import Data.Array.Storable - (StorableArray, Ix(range, index, inRange), readArray, writeArray, - unsafeForeignPtrToStorableArray) +import Data.Monoid (Monoid, mempty, mappend, ) --- | Handles of Jack clients -newtype Client = Client (Ptr ()) + +class Direction dir where + dirToFlags :: dir -> JackFFI.PortFlagSet + -- | Handles of Jack input ports -newtype Input = Input (Ptr ()) +data Input = Input + +instance Direction Input where + dirToFlags ~Input = JackFFI.portIsInput + -- | Handles of Jack output ports -newtype Output = Output (Ptr ()) +data Output = Output +instance Direction Output where + dirToFlags ~Output = JackFFI.portIsOutput + + + -- | Constructs a new Jack client. -newClient :: String -- ^ name of the JACK server +newClient :: + (JackExc.ThrowsStatus e) => + String -- ^ name of the JACK server -> String -- ^ name of the client - -> IO Client -newClient server name = do - cserverS <- newCString server - cclientS <- newCString name - status <- malloc - let opt = flagsToWord [JackFFI.ServerName, JackFFI.NoStartServer] - client <- JackFFI.client_open cclientS opt status cserverS - checkStatus client status - return (Client client) + -> Sync.ExceptionalT e IO Client +newClient server name = + withCString server $ \cserverS -> + withCString name $ \cclientS -> + alloca $ \status -> do + let opt = ES.fromEnums [JackFFI.ServerName, JackFFI.NoStartServer] + client <- Trans.lift $ JackFFI.client_open cclientS opt status cserverS + _ <- checkStatus client status + return (Client client) -- | Creates a new JACK client with the "default" server -newClientSimple :: String -- ^ name of the client - -> IO Client -newClientSimple name = newClient "default" name +newClientDefault :: + (JackExc.ThrowsStatus e) => + String -- ^ name of the client + -> Sync.ExceptionalT e IO Client +newClientDefault name = newClient defaultServer name -checkStatus :: Ptr a -> Ptr CULong -> IO () -checkStatus c s = do - errCode <- peek s - when (c == nullPtr) (failStatus errCode) - when (errCode /= 0) - (putStrLn $ "warning: " ++ show (wordToFlags errCode :: [JackFFI.Status])) +defaultServer :: String +defaultServer = "default" -failStatus :: CULong -> IO () -failStatus errCode = - fail ("jack_client_open returned a nullPointer. Returned errorcodes: " - ++ show (wordToFlags errCode :: [JackFFI.Status])) +disposeClient :: + (JackExc.ThrowsErrno e) => + Client -> Sync.ExceptionalT e IO () +disposeClient client = + liftErrno $ JackFFI.client_close (getClient client) --- | creates a new input port for the given client -newInput :: Client -- ^ Jack client - -> String -- ^ name of the input port - -> IO Input -newInput (Client client) portName = do - cstring <- newCString portName - audio_type <- newCString "32 bit float mono audio" --- putStrLn ("register..." ++ show (client, cstring, audio_type, 1, 0)) - ret <- JackFFI.port_register client cstring audio_type 1 0 --- putStrLn "register..." - return $ Input ret +{- | +Run a block of code with a newly allocated client. +Do not use the client outside the block. +-} +withClient :: + (JackExc.ThrowsStatus e) => + String -- ^ name of the JACK server + -> String -- ^ name of the client + -> (Client -> Sync.ExceptionalT e IO a) + -> Sync.ExceptionalT e IO a +withClient server name = + bracket + (newClient server name) + (Trans.lift . fmap (const ()) . + JackFFI.client_close . getClient) --- | creates a new output port -newOutput :: Client -- ^ Jack client - -> String -- ^ name of the output port - -> IO Output -newOutput (Client client) portName = do - cstring <- newCString portName - audio_type <- newCString "32 bit float mono audio" - ret <- JackFFI.port_register client cstring audio_type 2 0 - return $ Output ret +withClientDefault :: + (JackExc.ThrowsStatus e) => + String -- ^ name of the client + -> (Client -> Sync.ExceptionalT e IO a) + -> Sync.ExceptionalT e IO a +withClientDefault = + withClient defaultServer --- | activates the given Jack client -activate :: Client -> IO () -activate client = do - JackFFI.activate $ getClient client - return () +checkStatus :: + (JackExc.ThrowsStatus e) => + Ptr a + -> Ptr JackFFI.StatusSet + -> Sync.ExceptionalT e IO JackFFI.StatusSet +checkStatus c s = do + errCode <- Trans.lift $ peek s + Sync.assertT (JackExc.status errCode) (c /= nullPtr) + return errCode --- | closes the given Jack client without causing any trouble (hopefully) -clientClose :: Client -> [Input] -> [Output] -> IO () -clientClose client inports outports = do - mapM (JackFFI.port_unregister (getClient client)) (map getInput inports) - mapM (JackFFI.port_unregister (getClient client)) (map getOutput outports) - JackFFI.deactivate (getClient client) - JackFFI.client_close (getClient client) - return () -type Process = CUInt -> Ptr (CChar) -> IO (CInt) -foreign import ccall "wrapper" mkProcess :: Process -> IO (FunPtr Process) +newPortByType :: + (PortType typ, Direction dir, + JackExc.ThrowsPortRegister e) => + JackFFI.PortFlagSet -> Client -> String -> + Sync.ExceptionalT e IO (Port typ dir) +newPortByType flags (Client client) portName = + let aux :: + (PortType typ, Direction dir, + JackExc.ThrowsPortRegister e) => + typ -> dir -> Sync.ExceptionalT e IO (Port typ dir) + aux portType dir = + withPortName portName $ \cPortName -> + withCString (portTypeToCString portType) $ \pType -> do + -- putStrLn ("register..." ++ show (client, cstring, pType, inout, 0)) + port <- Trans.lift $ + JackFFI.port_register client cPortName pType (dirToFlags dir ES..|. flags) 0 + Sync.assertT JackExc.portRegister (port/=nullPtr) + return $ Port port + in aux undefined undefined +{- | +Better use 'withPort' that also handles freeing the port. +-} +newPort :: + (PortType typ, Direction dir, + JackExc.ThrowsPortRegister e) => + Client -- ^ Jack client + -> String -- ^ name of the input port + -> Sync.ExceptionalT e IO (Port typ dir) +newPort client name = + newPortByType ES.empty client name -getClient :: Client -> Ptr () -getClient (Client x) = x -getInput :: Input -> Ptr () -getInput (Input x) = x +disposePort :: + (PortType typ, Direction dir, + JackExc.ThrowsErrno e) => + Client -> Port typ dir -> Sync.ExceptionalT e IO () +disposePort client = + liftErrno . JackFFI.port_unregister (getClient client) . getPort -getOutput :: Output -> Ptr () -getOutput (Output x) = x +{- | +Creates a new port for the given client and delete it after usage. +The port manages audio or MIDI data in input or output direction +depending on the Port type. +Usually the required port type can be inferred from following actions +that use that port. --- | returns the names of all existing ports of the given Jack client -getPorts :: Client -- ^ the Jack client - -> IO [String] -- ^ the names as a list of strings -getPorts client = do - empty <- newCString "" - strArray <- JackFFI.get_ports (getClient client) empty empty 0 - peekArray0 nullPtr strArray >>= mapM peekCString +Do not use the port outside the enclosed block. +-} +withPort :: + (PortType typ, Direction dir, + JackExc.ThrowsPortRegister e, + JackExc.ThrowsErrno e) => + Client -- ^ Jack client + -> String -- ^ name of the input port + -> (Port typ dir -> Sync.ExceptionalT e IO a) + -> Sync.ExceptionalT e IO a +withPort client name = + bracket (newPort client name) (disposePort client) -connect :: Client -> String -> String -> IO() -connect client outport inport = do - outCString <- newCString outport - inCString <- newCString inport - JackFFI.connect (getClient client) outCString inCString - return () +-- | activates the given Jack client +activate :: + (JackExc.ThrowsErrno e) => + Client -> Sync.ExceptionalT e IO () +activate client = + liftErrno $ JackFFI.activate $ getClient client -quit :: MVar () -> Client -> [Input] -> [Output] -> IO () -quit mvar client ins outs = do - putStrLn "quitting..." - clientClose client ins outs - threadDelay 1000000 - putMVar mvar () +deactivate :: + (JackExc.ThrowsErrno e) => + Client -> Sync.ExceptionalT e IO () +deactivate client = + liftErrno $ JackFFI.deactivate $ getClient client +withActivation :: + (JackExc.ThrowsErrno e) => + Client -> + Sync.ExceptionalT e IO () -> + Sync.ExceptionalT e IO () +withActivation client act = + bracket (activate client) (\() -> deactivate client) (\() -> act) +-- | closes the given Jack client without causing any trouble (hopefully) +clientClose :: + (JackExc.ThrowsErrno e) => + Client -> PortSet -> + Sync.ExceptionalT e IO () +clientClose client (PortSet ports) = do + mapM_ (liftErrno . JackFFI.port_unregister (getClient client)) ports + deactivate client + disposeClient client -mainMono :: (CFloat -> IO CFloat) -> IO () -mainMono fun = do - name <- getProgName - client <- newClientSimple name +foreign import ccall "wrapper" mkProcess :: Process -> IO (FunPtr Process) - input <- newInput client "input" - output <- newOutput client "output" +getClient :: Client -> Ptr JackFFI.Client +getClient (Client x) = x - setProcessMono client input fun output +getPort :: Port typ dir -> Ptr (JackFFI.Port typ) +getPort (Port x) = x - activate client - putStrLn $ "started " ++ name ++ "..." +withPortName :: + String -> (JackFFI.PortName -> Sync.ExceptionalT e IO a) -> + Sync.ExceptionalT e IO a +withPortName name f = + withCString name $ f . JackFFI.PortName - mvar <- newEmptyMVar - installHandler keyboardSignal (Catch (quit mvar client [input] [output])) Nothing - takeMVar mvar +-- | returns the names of all existing ports of the given Jack client +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 -setProcessMono :: - Client -> Input -> (CFloat -> IO CFloat) -> Output -> IO CInt -setProcessMono client input fun output = do - procPtr <- mkProcess $ wrapMonoFun input fun output - JackFFI.set_process_callback (getClient client) procPtr nullPtr -wrapMonoFun :: Input -> (CFloat -> IO CFloat) -> Output - -> (CUInt -> Ptr CChar -> IO CInt) -- what JACK expects -wrapMonoFun input fun output nframes _args = do - inArr <- getBufferArray (getInput input) nframes - outArr <- getBufferArray (getOutput output) nframes - mapM (applyToArraysMono inArr fun outArr) [0..(nframes - 1)] - return 0 -- ??? +connect :: + (JackExc.ThrowsErrno e) => + Client -> String -> String -> + Sync.ExceptionalT e IO () +connect client outport inport = + withPortName outport $ \ outCString -> + withPortName inport $ \ inCString -> + liftErrno $ JackFFI.connect (getClient client) outCString inCString -applyToArraysMono :: StorableArray CUInt CFloat -> (CFloat -> IO CFloat) - -> StorableArray CUInt CFloat - -> CUInt -> IO () -applyToArraysMono inArr fun outArr i = - readArray inArr i >>= fun >>= writeArray outArr i -getBufferArray :: Ptr () -> CUInt -> IO (StorableArray CUInt CFloat) -getBufferArray bptr nframes = do - ptr <- JackFFI.port_get_buffer bptr nframes - fptr <- newForeignPtr_ ptr - unsafeForeignPtrToStorableArray fptr (0, (nframes - 1)) +{- | +A collection of mixed types of ports. +It is mainly needed for freeing all allocated ports. +-} +newtype PortSet = PortSet [Ptr (JackFFI.Port ())] --- Stereo -mainStereo :: ((CFloat, CFloat) -> IO (CFloat, CFloat)) -> IO () -mainStereo fun = do - name <- getProgName - client <- newClientSimple name +instance Monoid PortSet where + mempty = PortSet mempty + mappend (PortSet a) (PortSet b) = PortSet (mappend a b) - inputLeft <- newInput client "inputLeft" - inputRight <- newInput client "inputRight" - outputLeft <- newOutput client "outputLeft" - outputRight <- newOutput client "outputRight" +setOfPort :: + (PortType typ, Direction dir) => + Port typ dir -> PortSet +setOfPort = + PortSet . (:[]) . castPtr . getPort - seq (map fun (replicate 100 (0, 0))) (return ()) +setOfPorts :: + (PortType typ, Direction dir) => + [Port typ dir] -> PortSet +setOfPorts = + PortSet . map (castPtr . getPort) - setProcessStereo client inputLeft inputRight fun outputLeft outputRight - activate client - putStrLn $ "started " ++ name ++ "..." +quit :: + MVar () -> Client -> PortSet -> IO () +quit mvar client ports = do + putStrLn "quitting..." + Sync.resolveT + (\(Errno e) -> + IO.hPutStrLn IO.stderr $ + "exception when closing with errno: " ++ show e) + (clientClose client ports) + threadDelay 1000000 + putMVar mvar () + +waitForBreakAndClose :: + Client -> PortSet -> IO () +waitForBreakAndClose client ports = do mvar <- newEmptyMVar - installHandler - keyboardSignal - (Catch (quit mvar client [inputLeft, inputRight] [outputLeft, outputRight])) + _ <- installHandler keyboardSignal + (Catch $ quit mvar client ports) Nothing takeMVar mvar - -setProcessStereo :: - Client -> Input -> Input -> - ((CFloat, CFloat) -> IO (CFloat, CFloat)) -> - Output -> Output -> IO CInt -setProcessStereo client inputLeft inputRight fun outputLeft outputRight = do - procPtr <- mkProcess $ wrapStereoFun inputLeft inputRight fun outputLeft outputRight - JackFFI.set_process_callback (getClient client) procPtr nullPtr +waitForBreak :: IO () +waitForBreak = do + mvar <- newEmptyMVar + _ <- installHandler keyboardSignal + (Catch $ do + putStrLn "quitting..." + threadDelay 1000000 + putMVar mvar ()) + Nothing + takeMVar mvar -wrapStereoFun :: Input -> Input - -> ((CFloat, CFloat) -> IO (CFloat, CFloat)) - -> Output -> Output - -> (CUInt -> Ptr CChar -> IO CInt) -- what JACK expects -wrapStereoFun iL iR fun oL oR nframes _args = do - inLArr <- getBufferArray (getInput iL) nframes - inRArr <- getBufferArray (getInput iR) nframes - outLArr <- getBufferArray (getOutput oL) nframes - outRArr <- getBufferArray (getOutput oR) nframes - mapM (applyToArraysStereo inLArr inRArr fun outLArr outRArr) [0..(nframes - 1)] - return 0 -- ??? - -applyToArraysStereo :: StorableArray CUInt CFloat - -> StorableArray CUInt CFloat - -> ((CFloat, CFloat) -> IO (CFloat, CFloat)) - -> StorableArray CUInt CFloat - -> StorableArray CUInt CFloat - -> CUInt -> IO () -applyToArraysStereo iL iR fun oL oR i = do - l <- readArray iL i - r <- readArray iR i - (l', r') <- fun (l, r) - writeArray oL i l' - writeArray oR i r' - +handleExceptions :: + Sync.ExceptionalT JackExc.All IO () -> + IO () +handleExceptions = + Sync.resolveT $ IO.hPutStrLn IO.stderr . JackExc.toStringWithHead --- Useful instances -instance Ix CUInt where - range (a, b) = [a..b] - index (start, _end) i = fromEnum (i - start) - inRange (start, end) i = start <= i && i <= end +setProcess :: + (JackExc.ThrowsErrno e) => + Client -> + FunPtr Process -> + Sync.ExceptionalT e IO () +setProcess client procPtr = + liftErrno $ JackFFI.set_process_callback (getClient client) procPtr nullPtr -instance Random CFloat where - random g = randomIvalDouble (0::Double,1) realToFrac g - randomR (a,b) g = randomIvalDouble (realToFrac a, realToFrac b) realToFrac g - -randomIvalInteger :: (RandomGen g, Num a) => (Integer, Integer) -> g -> (a, g) -randomIvalInteger (l,h) rng = - if l > h - then randomIvalInteger (h,l) rng - else case (f n 1 rng) of (v, rng') -> (fromInteger (l + v `mod` k), rng') - where - k = h - l + 1 - b = 2147483561 - n = iLogBase b k - - f 0 acc g = (acc, g) - f nn acc g = - let - (x,g') = next g - in - f (nn-1) (fromIntegral x + acc * b) g' - -randomIvalDouble :: (RandomGen g, Fractional a) => - (Double, Double) -> (Double -> a) -> g -> (a, g) -randomIvalDouble (l,h) fromDouble rng = - if l > h - then randomIvalDouble (h,l) fromDouble rng - else - case (randomIvalInteger (toInteger (minBound::Int), toInteger (maxBound::Int)) rng) of - (x, rng') -> - let - scaled_x = - fromDouble ((l+h)/2) + - fromDouble ((h-l) / realToFrac intRange) * - fromIntegral (x::Int) - in - (scaled_x, rng') - -intRange :: Integer -intRange = toInteger (maxBound::Int) - toInteger (minBound::Int) - -iLogBase :: Integer -> Integer -> Integer -iLogBase b i = if i < b then 1 else 1 + iLogBase b (i `div` b) - +getSampleRate :: Client -> IO Int +getSampleRate (Client ptr) = + fmap fromIntegral $ JackFFI.get_sample_rate ptr diff --git a/src/Sound/JACK/Audio.hs b/src/Sound/JACK/Audio.hs new file mode 100644 --- /dev/null +++ b/src/Sound/JACK/Audio.hs @@ -0,0 +1,152 @@ +module Sound.JACK.Audio ( + Sample, Port, withPort, + + setProcessMono, + setProcessStereo, + + getBufferArray, + + mainMono, + mainStereo, + ) where + +import qualified Sound.JACK.Private as Priv +import qualified Sound.JACK as Jack +import Sound.JACK.Private (Client, ) +import Sound.JACK (Direction, Input, Output, ) + +import qualified Sound.JACK.Exception as JackExc +import Sound.JACK.FFI (NFrames, nframesIndices, nframesBounds, Process, ) + +import qualified Control.Monad.Exception.Synchronous as Sync +import qualified Control.Monad.Trans.Class as Trans + +import Foreign.ForeignPtr (newForeignPtr_, ) +import Foreign.C.Error (eOK, ) +import Foreign.C.Types (CFloat, ) + +import System.Environment (getProgName) + +import Data.Array.Storable + (StorableArray, readArray, writeArray, + unsafeForeignPtrToStorableArray) + + +type Sample = CFloat + +type Port = Priv.Port Sample + + +withPort :: + (Direction dir, + JackExc.ThrowsPortRegister e, + JackExc.ThrowsErrno e) => + Client -- ^ Jack client + -> String -- ^ name of the input port + -> (Port dir -> Sync.ExceptionalT e IO a) + -> Sync.ExceptionalT e IO a +withPort = Jack.withPort + + +getBufferArray :: + (Direction dir) => + Port dir -> NFrames -> IO (StorableArray NFrames Sample) +getBufferArray port nframes = do + flip unsafeForeignPtrToStorableArray (nframesBounds nframes) + =<< newForeignPtr_ + =<< Priv.portGetBuffer port nframes + + +mainMono :: (Sample -> IO Sample) -> IO () +mainMono fun = do + name <- getProgName + Jack.handleExceptions $ + Jack.withClientDefault name $ \client -> + Jack.withPort client "input" $ \input -> + Jack.withPort client "output" $ \output -> do + setProcessMono client input fun output + Jack.withActivation client $ Trans.lift $ do + putStrLn $ "started " ++ name ++ "..." + Jack.waitForBreak + +setProcessMono :: + (JackExc.ThrowsErrno e) => + Client -> + Port Input -> (Sample -> IO Sample) -> + Port Output -> + Sync.ExceptionalT e IO () +setProcessMono client input fun output = + Jack.setProcess client =<< + (Trans.lift $ Jack.mkProcess $ wrapMonoFun input fun output) + +wrapMonoFun :: + Port Input -> (Sample -> IO Sample) -> + Port Output -> Process +wrapMonoFun input fun output nframes _args = do + inArr <- getBufferArray input nframes + outArr <- getBufferArray output nframes + mapM_ (applyToArraysMono inArr fun outArr) (nframesIndices nframes) + return eOK + +applyToArraysMono :: + StorableArray NFrames Sample -> (Sample -> IO Sample) + -> StorableArray NFrames Sample + -> NFrames -> IO () +applyToArraysMono inArr fun outArr i = + readArray inArr i >>= fun >>= writeArray outArr i + +mainStereo :: ((Sample, Sample) -> IO (Sample, Sample)) -> IO () +mainStereo fun = do + name <- getProgName + Jack.handleExceptions $ + Jack.withClientDefault name $ \client -> + Jack.withPort client "inputLeft" $ \inputLeft -> + Jack.withPort client "inputRight" $ \inputRight -> + Jack.withPort client "outputLeft" $ \outputLeft -> + Jack.withPort client "outputRight" $ \outputRight -> do + setProcessStereo client + inputLeft inputRight fun + outputLeft outputRight + Jack.withActivation client $ Trans.lift $ do + putStrLn $ "started " ++ name ++ "..." + Jack.waitForBreak + + +setProcessStereo :: + (JackExc.ThrowsErrno e) => + Client -> + Port Input -> Port Input -> + ((Sample, Sample) -> IO (Sample, Sample)) -> + Port Output -> Port Output -> + Sync.ExceptionalT e IO () +setProcessStereo client inputLeft inputRight fun outputLeft outputRight = + Jack.setProcess client =<< + (Trans.lift $ Jack.mkProcess $ + wrapStereoFun inputLeft inputRight fun outputLeft outputRight) + + +wrapStereoFun :: + Port Input -> Port Input + -> ((Sample, Sample) -> IO (Sample, Sample)) + -> Port Output -> Port Output + -> Process +wrapStereoFun iL iR fun oL oR nframes _args = do + inLArr <- getBufferArray iL nframes + inRArr <- getBufferArray iR nframes + outLArr <- getBufferArray oL nframes + outRArr <- getBufferArray oR nframes + mapM_ (applyToArraysStereo inLArr inRArr fun outLArr outRArr) (nframesIndices nframes) + return eOK + +applyToArraysStereo :: StorableArray NFrames Sample + -> StorableArray NFrames Sample + -> ((Sample, Sample) -> IO (Sample, Sample)) + -> StorableArray NFrames Sample + -> StorableArray NFrames Sample + -> NFrames -> IO () +applyToArraysStereo iL iR fun oL oR i = do + l <- readArray iL i + r <- readArray iR i + (l', r') <- fun (l, r) + writeArray oL i l' + writeArray oR i r' diff --git a/src/Sound/JACK/Exception.hs b/src/Sound/JACK/Exception.hs new file mode 100644 --- /dev/null +++ b/src/Sound/JACK/Exception.hs @@ -0,0 +1,110 @@ +module Sound.JACK.Exception ( + ToString(toString), toStringWithHead, + All, + ThrowsStatus (status), Status(..), + ThrowsPortRegister (portRegister), PortRegister(..), + ThrowsErrno (errno), Errno(..), + ) where + +import qualified Sound.JACK.FFI as JackFFI + +import qualified Foreign.C.Error as FE +import qualified Data.EnumSet as ES +import Data.Bits (Bits, ) + + + +type All = Status (PortRegister (FE.Errno)) + +toStringWithHead :: + All -> String +toStringWithHead e = + "JACK exception: " ++ toString e + +class ToString e where + toString :: e -> String + +instance (Bits w, Enum a, Show a) => ToString (ES.T w a) where + toString = show . ES.toEnums + + +class ThrowsStatus e where + status :: JackFFI.StatusSet -> e + +data Status e = + Status JackFFI.StatusSet + | NoStatus e + +instance ToString e => ToString (Status e) where + toString e0 = + case e0 of + Status st -> toString st + NoStatus e1 -> toString e1 + + +instance ThrowsStatus (Status e) where + status = Status + +instance ThrowsPortRegister e => ThrowsPortRegister (Status e) where + portRegister = NoStatus portRegister + +instance ThrowsErrno e => ThrowsErrno (Status e) where + errno = NoStatus . errno + +{- +instance ThrowsStatus (ES.T w a) where + status = id +-} + + +class ThrowsPortRegister e where + portRegister :: e + +data PortRegister e = + PortRegister + | NoPortRegister e + +instance ToString e => ToString (PortRegister e) where + toString e0 = + case e0 of + PortRegister -> "could not register port" + NoPortRegister e1 -> toString e1 + +instance ThrowsStatus e => ThrowsStatus (PortRegister e) where + status = NoPortRegister . status + +instance ThrowsPortRegister (PortRegister e) where + portRegister = PortRegister + +instance ThrowsErrno e => ThrowsErrno (PortRegister e) where + errno = NoPortRegister . errno + + + +class ThrowsErrno e where + errno :: FE.Errno -> e + +data Errno e = + Errno FE.Errno + | NoErrno e + +instance ToString e => ToString (Errno e) where + toString e0 = + case e0 of + Errno en -> toString en + NoErrno e1 -> toString e1 + +instance ToString FE.Errno where + toString (FE.Errno en) = "error code " ++ show en + +instance ThrowsStatus e => ThrowsStatus (Errno e) where + status = NoErrno . status + +instance ThrowsPortRegister e => ThrowsPortRegister (Errno e) where + portRegister = NoErrno portRegister + +instance ThrowsErrno (Errno e) where + errno = Errno + +instance ThrowsErrno FE.Errno where + errno = id diff --git a/src/Sound/JACK/FFI.hs b/src/Sound/JACK/FFI.hs --- a/src/Sound/JACK/FFI.hs +++ b/src/Sound/JACK/FFI.hs @@ -1,7 +1,9 @@ -{-# OPTIONS -fffi #-} +-- -*-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 @@ -23,34 +25,45 @@ import Foreign.Ptr (Ptr, FunPtr) import Foreign.C.String (CString) -import Foreign.C.Types (CUInt, CInt, CChar, CFloat, CULong) - -import Data.Bits (setBit, bit) +import Foreign.C.Error (Errno, ) +import Foreign.C.Types (CUInt, CInt, CULong, ) -import Data.Array(Ix) +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 -> CULong -> Ptr CULong -> CString -> IO (Ptr ()) + 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_new :: CString -> IO (Ptr Client) +foreign import ccall "static jack/jack.h jack_get_sample_rate" + get_sample_rate :: Ptr Client -> IO CInt + +type OpenOptionSet = ES.T CULong OpenOptions + data OpenOptions = NoStartServer | UseExactName | ServerName deriving (Enum, Eq, Ord, Show, Ix) -wordNullOption, wordNoStartServer, wordUseExactName, wordServerName :: CULong -wordNullOption = 0 -wordNoStartServer = flagToWord NoStartServer -wordUseExactName = flagToWord UseExactName -wordServerName = flagToWord ServerName +wordNullOption, wordNoStartServer, wordUseExactName, wordServerName :: OpenOptionSet +wordNullOption = ES.empty +wordNoStartServer = ES.fromEnum NoStartServer +wordUseExactName = ES.fromEnum UseExactName +wordServerName = ES.fromEnum ServerName +type StatusSet = ES.T CULong Status data Status = Failure @@ -68,64 +81,113 @@ wordFailure, wordInvalidOption, wordNameNotUnique, wordServerStarted, wordServerFailed, wordServerError, wordNoSuchClient, wordLoadFailure, - wordInitFailure, wordShmFailure, wordVersionError :: CULong -wordFailure = flagToWord Failure -wordInvalidOption = flagToWord InvalidOption -wordNameNotUnique = flagToWord NameNotUnique -wordServerStarted = flagToWord ServerStarted -wordServerFailed = flagToWord ServerFailed -wordServerError = flagToWord ServerError -wordNoSuchClient = flagToWord NoSuchClient -wordLoadFailure = flagToWord LoadFailure -wordInitFailure = flagToWord InitFailure -wordShmFailure = flagToWord ShmFailure -wordVersionError = flagToWord VersionError + 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 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 () -> Ptr (CChar) -> Ptr (CChar) -> - CULong -> CULong -> IO (Ptr ()) + port_register :: Ptr Client -> PortName -> CString -> + PortFlagSet -> CULong -> IO (Ptr (Port a)) + +-- | represents absolute frame time +newtype NFrames = NFrames 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 Errno + foreign import ccall "static jack/jack.h jack_set_process_callback" - set_process_callback :: - Ptr () -> FunPtr (CUInt -> Ptr (CChar) -> IO (CInt)) -> Ptr (CChar) -> IO (CInt) + set_process_callback :: + Ptr Client -> FunPtr Process -> Ptr CallbackArg -> IO 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 () -> CUInt -> IO (Ptr CFloat) + 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 () -> IO (CUInt) + get_buffer_size :: Ptr Client -> IO (CUInt) foreign import ccall "static jack/jack.h jack_activate" - activate :: Ptr () -> IO (CInt) + activate :: Ptr Client -> IO Errno foreign import ccall "static jack/jack.h jack_client_close" - client_close :: Ptr () -> IO (CInt) + client_close :: Ptr Client -> IO Errno foreign import ccall "static jack/jack.h jack_get_ports" - get_ports :: Ptr () -> Ptr (CChar) -> Ptr (CChar) -> CULong -> IO (Ptr (Ptr (CChar))) + get_ports :: Ptr Client -> CString -> CString -> CULong -> IO (Ptr CString) +-- get_ports :: Ptr Client -> CString -> CString -> CULong -> IO (Ptr PortName) +-- may return eEXIST foreign import ccall "static jack/jack.h jack_connect" - connect :: Ptr () -> Ptr (CChar) -> Ptr (CChar) -> IO (CInt) + connect :: Ptr Client -> PortName -> PortName -> IO Errno +foreign import ccall "static jack/jack.h jack_disconnect" + disconnect :: Ptr Client -> PortName -> PortName -> IO Errno + foreign import ccall "static jack/jack.h jack_port_unregister" - port_unregister :: Ptr () -> Ptr () -> IO (CInt) + port_unregister :: Ptr Client -> Ptr (Port a) -> IO Errno foreign import ccall "static jack/jack.h jack_deactivate" - deactivate :: Ptr () -> IO (CInt) - - - --- * Utility functions - -flagToWord :: (Enum a) => a -> CULong -flagToWord = bit . fromEnum - -flagsToWord :: (Enum a) => [a] -> CULong -flagsToWord = foldl setBit 0 . map fromEnum - -wordToFlags :: (Enum a) => CULong -> [a] -wordToFlags = - map fst . filter (odd . snd) . - zip [toEnum 0 ..] . iterate (flip div 2) + deactivate :: Ptr Client -> IO Errno diff --git a/src/Sound/JACK/FFI/MIDI.chs b/src/Sound/JACK/FFI/MIDI.chs new file mode 100644 --- /dev/null +++ b/src/Sound/JACK/FFI/MIDI.chs @@ -0,0 +1,147 @@ +{-# 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 Foreign.C.Types (CULong, CUInt, CUChar, CSize) +import Foreign.C.Error (Errno, ) +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 :: 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 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 -> CSize -> IO (Ptr Word8) + +foreign import ccall "static jack/midiport.h jack_midi_event_write" + event_write :: Ptr EventBuffer -> NFrames -> Ptr Word8 -> CULong -> IO Errno diff --git a/src/Sound/JACK/MIDI.hs b/src/Sound/JACK/MIDI.hs new file mode 100644 --- /dev/null +++ b/src/Sound/JACK/MIDI.hs @@ -0,0 +1,156 @@ +module Sound.JACK.MIDI ( + RawEvent, + rawEvent, + rawEventTime, + rawEventBuffer, + toRawEventFunction, + + Port, withPort, + + setProcess, + + readRawEvents, + writeRawEvent, + + main, + mainRaw, + ) where + +import qualified Sound.JACK.Private as Priv +import qualified Sound.JACK as Jack +import Sound.JACK.Private (Client(Client), liftErrno, alloca, ) +import Sound.JACK (Direction, Input, Output, ) + +import qualified Sound.JACK.Exception as JackExc +import qualified Sound.JACK.FFI as JackFFI +import qualified Sound.JACK.FFI.MIDI as JackMIDI +import Sound.JACK.FFI (NFrames, nframesIndices, Process, ) +import Sound.JACK.FFI.MIDI (RawEvent, EventBuffer, time, buffer, toRawEventFunction, ) + +import qualified Data.ByteString as B + +import qualified Sound.MIDI.Message as Msg + +import qualified Control.Monad.Exception.Synchronous as Sync +import qualified Control.Monad.Trans.Class as Trans + +import Foreign.Storable (Storable, peek, ) +import Foreign.Ptr (Ptr, ) +import Foreign.C.Error (eOK, ) + +import System.Environment (getProgName) +import Control.Monad (when, forM, ) + + +type Port = Priv.Port EventBuffer + +withPort :: + (Direction dir, + JackExc.ThrowsPortRegister e, + JackExc.ThrowsErrno e) => + Client -- ^ Jack client + -> String -- ^ name of the input port + -> (Port dir -> Sync.ExceptionalT e IO a) + -> Sync.ExceptionalT e IO a +withPort = Jack.withPort + + +{- | +Smart constructor for a raw MIDI event. +-} +rawEvent :: + NFrames -- ^ Sample index at which event is valid (relative to cycle start) + -> B.ByteString -- ^ Raw MIDI data + -> RawEvent +rawEvent = JackMIDI.RawEvent + +rawEventTime :: RawEvent -> NFrames +rawEventTime = time + +rawEventBuffer :: RawEvent -> B.ByteString +rawEventBuffer = buffer + + +-- | Creates an input and an output, and transforms all raw input events into raw output +-- events using the given function +mainRaw :: (NFrames -> RawEvent -> IO RawEvent) -- ^ transforms raw input to output events + -> IO () +mainRaw fun = do + name <- getProgName + Jack.handleExceptions $ + Jack.withClientDefault name $ \client -> + Jack.withPort client "input" $ \input -> + Jack.withPort client "output" $ \output -> do + setProcess client input fun output + Jack.withActivation client $ Trans.lift $ do + putStrLn $ "started " ++ name ++ "..." + Jack.waitForBreak + +-- | Creates an input and an output, and transforms all input events into output +-- events using the given function +main :: (NFrames -> (NFrames, Msg.T) -> IO (NFrames, Msg.T)) -- ^ transforms input to output events + -> IO () +main fun = mainRaw (toRawEventFunction fun) + + +-- | sets the process loop of the JACK Client +setProcess :: + (JackExc.ThrowsErrno e) => + Client -- ^ the JACK Client, whose process loop will be set + -> Port Input -- ^ where to get events from + -> (NFrames -> RawEvent -> IO RawEvent) + -- ^ transforms input to output events + -> Port Output -- ^ where to put events + -> Sync.ExceptionalT e IO () + -- ^ exception causing JACK to remove that client from the process() graph. +setProcess client input fun output = + Jack.setProcess client =<< + (Trans.lift $ Jack.mkProcess $ wrapFun client input fun output) + +-- | reads all available MIDI Events on the given PortBuffer +readRawEvents :: + (JackExc.ThrowsErrno e) => + Ptr EventBuffer -- ^ the PortBuffer to read from + -> Sync.ExceptionalT e IO [RawEvent] + -- ^ pointers to newly allocated events, must be freed later! +readRawEvents buffer_ = do + nEvents <- Trans.lift $ JackMIDI.get_event_count buffer_ + forM (nframesIndices nEvents) $ \n -> + alloca $ \eventPtr -> do + liftErrno $ JackMIDI.event_get eventPtr buffer_ n + Trans.lift $ peek eventPtr + -- putStrLn $ "Got MIDI Event number " ++ (show n) ++ " with result " ++ (show result) ++ " at time " ++ (show $ time event) ++ " size: " ++ (show $ size event) ++ " buffer: " ++ (show $ buffer event) + + +-- | writes a MIDI event to the PortBuffer of a MIDI output or throws eNOBUFS if buffer is full +writeRawEvent :: + (JackExc.ThrowsErrno e) => + Ptr EventBuffer -- ^ the PortBuffer of the MIDI output to write to + -> RawEvent -- ^ the RawEvent to write + -> Sync.ExceptionalT e IO () +writeRawEvent portBuffer event = + liftErrno $ do + JackMIDI.clear_buffer portBuffer + JackMIDI.withByteStringPtr (buffer event) $ \ptr len -> + JackMIDI.event_write portBuffer (time event) + ptr (fromIntegral len) + -- putStrLn $ "Writing MIDI Event: buffer: " ++ (show $ buffer event) + +wrapFun :: + Client -> + Port Input -> (NFrames -> RawEvent -> IO RawEvent) -> + Port Output -> Process +wrapFun (Client client) input fun output nframes _args = do + inputPortBuffer <- Priv.portGetBuffer input nframes + outputPortBuffer <- Priv.portGetBuffer output nframes + lastCycle <- JackFFI.last_frame_time client + Sync.resolveT return $ do + inEvents <- readRawEvents inputPortBuffer + -- when (not (null inEvents)) $ putStrLn $ "wrapFun: Got " ++ (show $ length inEvents) ++ " input events" + outEvents <- mapM (Trans.lift . fun lastCycle) inEvents + -- when (not (null outEvents)) $ putStrLn $ "wrapFun: Got " ++ (show $ length outEvents) ++ " output events" + mapM_ (writeRawEvent outputPortBuffer) outEvents + Trans.lift $ when (null outEvents) $ + JackMIDI.clear_buffer outputPortBuffer + return eOK + diff --git a/src/Sound/JACK/Private.hs b/src/Sound/JACK/Private.hs new file mode 100644 --- /dev/null +++ b/src/Sound/JACK/Private.hs @@ -0,0 +1,96 @@ +module Sound.JACK.Private where + +import qualified Sound.JACK.Exception as JackExc +import qualified Sound.JACK.FFI as JackFFI +import Sound.JACK.FFI.MIDI (EventBuffer, ) +import Sound.JACK.FFI (NFrames, ) + +import qualified Control.Monad.Exception.Synchronous as Sync +import qualified Control.Exception as Exc + +import qualified Foreign.Marshal.Alloc as Alloc +import qualified Foreign.C.String as CString +import Foreign.Storable (Storable, ) +import Foreign.Ptr (Ptr, ) +import Foreign.C.Types (CFloat, ) +import Foreign.C.Error (Errno, eOK, ) + + +-- | Handles of Jack clients +newtype Client = Client (Ptr JackFFI.Client) + + +-- | Jack Port Type +class PortType typ where + portTypeToCString :: typ -> String + +instance PortType CFloat where + portTypeToCString _ = "32 bit float mono audio" + +instance PortType EventBuffer where + portTypeToCString _ = "8 bit raw midi" + + +newtype Port typ dir = Port (Ptr (JackFFI.Port typ)) + + +portGetBuffer :: + (PortType typ) => + Port typ dir -> NFrames -> IO (Ptr typ) +portGetBuffer (Port port) nframes = + JackFFI.port_get_buffer port nframes + +withCString :: + String -> + (CString.CString -> Sync.ExceptionalT e IO b) -> + Sync.ExceptionalT e IO b +withCString str f = + Sync.ExceptionalT $ + CString.withCString str (Sync.runExceptionalT . f) + +alloca :: + (Storable a) => + (Ptr a -> Sync.ExceptionalT e IO b) -> + Sync.ExceptionalT e IO b +alloca f = + Sync.ExceptionalT $ + Alloc.alloca (Sync.runExceptionalT . f) + +{- +Mixing of explicit exceptions +with "unchecked" exceptions embedded in IO monad is really not nice. +We should switch to an exception-free IO monad +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 +bracket open close act = + Sync.ExceptionalT $ + Exc.bracket + (Sync.runExceptionalT open) + {- + Exception of 'close' cannot be maintained, + since we can only propagate an exception + or generate a new one. + Generally exceptions in closing functions are a bad idea. + -} + (\r -> + case r of + Sync.Success a -> Sync.runExceptionalT $ close a + Sync.Exception e -> return $ Sync.Exception e) + (\r -> + case r of + Sync.Success a -> Sync.runExceptionalT $ act a + Sync.Exception e -> return $ Sync.Exception e) + + +liftErrno :: + (JackExc.ThrowsErrno e) => + IO Errno -> Sync.ExceptionalT e IO () +liftErrno = + Sync.ExceptionalT . + fmap (\err -> + Sync.assert (JackExc.errno err) $ err == eOK)