packages feed

jack 0.5 → 0.6

raw patch · 13 files changed

+1220/−352 lines, 13 filesdep +arraydep +bytestringdep +enumsetdep ~basesetup-changednew-component:exe:impulse-trainnew-component:exe:midimon

Dependencies added: array, bytestring, enumset, explicit-exception, midi, transformers, unix

Dependency ranges changed: base

Files

− Setup.hs 
@@ -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"-
+ Setup.lhs view
@@ -0,0 +1,3 @@+#! /usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
examples/Amplify.hs view
@@ -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
+ examples/ImpulseTrain.hs view
@@ -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
+ examples/Midimon.hs view
@@ -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)+
jack.cabal view
@@ -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 <haskell@henning-thielemann.de>-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
src/Sound/JACK.hs view
@@ -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
+ src/Sound/JACK/Audio.hs view
@@ -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'
+ src/Sound/JACK/Exception.hs view
@@ -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
src/Sound/JACK/FFI.hs view
@@ -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
+ src/Sound/JACK/FFI/MIDI.chs view
@@ -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
+ src/Sound/JACK/MIDI.hs view
@@ -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+
+ src/Sound/JACK/Private.hs view
@@ -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)