jack 0.6.2 → 0.7
raw patch · 11 files changed
+727/−168 lines, 11 filesdep +containersdep +event-listdep +non-negativedep ~basedep ~bytestringdep ~explicit-exceptionnew-component:exe:capturenew-component:exe:synth
Dependencies added: containers, event-list, non-negative, storablevector
Dependency ranges changed: base, bytestring, explicit-exception, unix
Files
- examples/Capture.hs +87/−0
- examples/ImpulseTrain.hs +5/−6
- examples/Synthesizer.hs +75/−0
- examples/Synthesizer/Render.hs +164/−0
- jack.cabal +71/−28
- src/Sound/JACK.hs +119/−34
- src/Sound/JACK/Audio.hs +39/−31
- src/Sound/JACK/FFI.hsc +25/−14
- src/Sound/JACK/FFI/MIDI.hsc +13/−6
- src/Sound/JACK/MIDI.hs +129/−42
- src/Sound/JACK/Private.hs +0/−7
+ examples/Capture.hs view
@@ -0,0 +1,87 @@+{- |+This program creates a number of input ports+according to a list of given port names.+It captures the audio data from these ports+and writes the raw audio data in an interleaved way+to the file @captured.f32@.+You may convert it to an audio format with header information using @sox@.++Example:+> $ capture left right+> $ sox -c 2 -r 44100 captured.f32 captured.wav+-}+module Main where++import qualified Sound.JACK as Jack+import qualified Sound.JACK.Audio as JA++import qualified Sound.JACK.Exception as JackExc+import Sound.JACK (Process, Client, Port)++import qualified Control.Monad.Exception.Synchronous as Sync+import qualified Control.Monad.Trans.Cont as MC+import qualified Control.Monad.Trans.Class as Trans+import Data.Foldable (forM_, )++import Foreign.Storable (sizeOf, peek, )+import Foreign.Ptr (nullPtr, )+import Foreign.C.Error (eOK, )++import qualified System.Environment as Env+import qualified System.Console.GetOpt as GetOpt++import qualified System.IO as IO+import Data.Array.Base (getNumElements, )+import Data.Array.Storable+ (newArray_, readArray, writeArray, withStorableArray, )+++main :: IO ()+main = do+ name <- Env.getProgName+ args <- Env.getArgs+ case args of+ [] ->+ putStrLn $+ GetOpt.usageInfo ("Usage: " ++ name ++ " JACK-PORT-NAME...") []+ _ -> capture name args++capture :: String -> [String] -> IO ()+capture name portNames =+ IO.withBinaryFile "captured.f32" IO.WriteMode $ \st ->+ Jack.handleExceptions $ flip MC.runContT return $ do+ client <- MC.ContT $ Jack.withClientDefault name+ inputs <- mapM (MC.ContT . Jack.withPort client) portNames+ Trans.lift $ setProcess st client inputs+ Trans.lift $ Jack.withActivation client $ Trans.lift $ do+ putStrLn $ "started " ++ name ++ "..."+ Jack.waitForBreak++setProcess ::+ (JackExc.ThrowsErrno e) =>+ IO.Handle ->+ Client ->+ [Port JA.Sample Jack.Input] ->+ Sync.ExceptionalT e IO ()+setProcess st client input =+ flip (Jack.setProcess client) nullPtr =<<+ (Trans.lift $ Jack.makeProcess $+ wrapFun st input)++wrapFun ::+ IO.Handle ->+ [Port JA.Sample Jack.Input] ->+ Process a+wrapFun st inputs nframes _args = do+ inArrs <- mapM (flip JA.getBufferArray nframes) inputs+ let (a,b) = Jack.nframesBounds nframes+ numChannels = length inputs+ output <- newArray_ ((a,0), (b, numChannels - 1))+ forM_ (Jack.nframesIndices nframes) $ \i ->+ forM_ (zip inArrs [0..]) $ \(inArr,c) ->+ writeArray output (i,c) =<< readArray inArr i+ withStorableArray output $ \p -> do+ n <- getNumElements output+ dummy <- peek p+ IO.hPutBuf st p $ sizeOf dummy * n+ return eOK
examples/ImpulseTrain.hs view
@@ -3,6 +3,7 @@ import qualified Sound.JACK.Audio as Audio import qualified Sound.JACK as JACK +import qualified Control.Monad.Exception.Synchronous as Sync import qualified Control.Monad.Trans.Class as Trans import qualified Foreign.C.Error as E @@ -16,20 +17,18 @@ name <- getProgName JACK.handleExceptions $ JACK.withClientDefault name $ \client ->- JACK.withPort client "output" $ \output -> do- JACK.setProcess client =<<- (Trans.lift $ JACK.mkProcess $ process output)+ JACK.withPort client "output" $ \output ->+ JACK.withProcess client (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+ Audio.Port JACK.Output -> JACK.NFrames -> Sync.ExceptionalT E.Errno IO ()+process output nframes = Trans.lift $ 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/Synthesizer.hs view
@@ -0,0 +1,75 @@+module Main where++import qualified Synthesizer.Render as Render++import qualified Sound.MIDI.Message as Msg+import qualified Sound.MIDI.Message.Channel as ChannelMsg+import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg++import qualified Sound.JACK.MIDI as MIDI+import qualified Sound.JACK.Audio as Audio+import qualified Sound.JACK as JACK++import qualified Data.EventList.Absolute.TimeBody as EventList++import qualified Control.Monad.Exception.Synchronous as Sync+import qualified Control.Monad.Trans.State.Strict as MS+import qualified Control.Monad.Trans.Class as Trans+import qualified Foreign.C.Error as E+import Foreign.Marshal.Array (copyArray, )++import System.Environment (getProgName, )++import qualified Data.StorableVector.Base as SVB++import Data.IORef (IORef, newIORef, readIORef, writeIORef, )+++main :: IO ()+main = do+ name <- getProgName+ stateRef <- newIORef Render.initialState+ JACK.handleExceptions $+ JACK.withClientDefault name $ \client ->+ JACK.withPort client "input" $ \input ->+ JACK.withPort client "output" $ \output ->+ JACK.withProcess client (process client stateRef input output) $+ JACK.withActivation client $ Trans.lift $ do+ putStrLn $ "started " ++ name ++ "..."+ JACK.waitForBreak++checkVoiceMsg :: Msg.T -> Maybe VoiceMsg.T+checkVoiceMsg ev =+ case ev of+ Msg.Channel (ChannelMsg.Cons _chan (ChannelMsg.Voice dat)) ->+ Just dat+ _ -> Nothing++intFromNFrames :: Integral i => JACK.NFrames -> i+intFromNFrames (JACK.NFrames n) = fromIntegral n++runStateOnIORef :: IORef s -> MS.State s a -> IO a+runStateOnIORef ref m = do+ (a, state) <- fmap (MS.runState m) $ readIORef ref+ writeIORef ref state+ return a++process ::+ JACK.Client ->+ IORef (Render.State Audio.Sample) ->+ MIDI.Port JACK.Input ->+ Audio.Port JACK.Output ->+ JACK.NFrames ->+ Sync.ExceptionalT E.Errno IO ()+process client stateRef input output nframes = do+ evs <- MIDI.readEventsFromPort input nframes+ Trans.lift $ do+ rate <- JACK.getSampleRate client+ outArr <- Audio.getBufferPtr output nframes+ block <-+ runStateOnIORef stateRef $+ Render.run (intFromNFrames nframes) rate $+ EventList.toPairList $+ EventList.mapMaybe checkVoiceMsg $+ EventList.mapTime intFromNFrames evs+ SVB.withStartPtr block $ \src len -> copyArray outArr src len
+ examples/Synthesizer/Render.hs view
@@ -0,0 +1,164 @@+module Synthesizer.Render where++import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg+import Sound.MIDI.Message.Channel.Voice (Pitch, )++import qualified Data.StorableVector.ST.Strict as SVST+import qualified Data.StorableVector as SV++import Foreign.Storable (Storable, )+import Control.Monad.ST.Strict as ST++import qualified Control.Monad.Trans.State.Strict as MS++import qualified Data.Map as Map++import Control.Monad (liftM, )++import Debug.Trace (trace, )+++type Time = Integer+type Size = Int+type SampleRate = Int+++check :: Monad m => Bool -> String -> m () -> m ()+check b msg act =+ if not b+ then trace msg $ return ()+ else act++unsafeAddChunkToBuffer :: (Storable a, Num a) =>+ SVST.Vector s a -> Int -> SV.Vector a -> ST s ()+unsafeAddChunkToBuffer v start xs =+ let go i j =+ if j >= SV.length xs+ then return ()+ else+ SVST.unsafeModify v i (SV.index xs j +) >>+ go (i + 1) (j + 1)+ in check (start>=0)+ ("start negative: " ++ show (start, SV.length xs)) $+ check (start <= SVST.length v)+ ("start too late: " ++ show (start, SV.length xs)) $+ check (start+SV.length xs <= SVST.length v)+ ("end too late: " ++ show (start, SV.length xs)) $+ go start 0++arrange ::+ (Storable a, Num a) =>+ Size ->+ [(Int, SV.Vector a)] ->+ SV.Vector a+arrange size evs =+ SVST.runSTVector (do+ v <- SVST.new (fromIntegral size) 0+ mapM_ (uncurry $ unsafeAddChunkToBuffer v) evs+ return v)+++data OscillatorState a = OscillatorState a a Int++type State a = Map.Map Pitch (OscillatorState a)+++initialState :: State a+initialState = Map.empty+++stopTone ::+ Int ->+ (Maybe (Int, OscillatorState a),+ [(Int, Int, OscillatorState a)]) ->+ [(Int, Int, OscillatorState a)]+stopTone stopTime (mplaying, finished) =+ case mplaying of+ Just (startTime, osci) ->+ (startTime, stopTime-startTime, osci) : finished+ Nothing -> finished++renderTone ::+ (Storable a, Floating a) =>+ Int -> OscillatorState a ->+ (SV.Vector a, OscillatorState a)+renderTone dur state@(OscillatorState amp freq phase) =+ if dur<0+ then+ trace ("renderTone: negative duration " ++ show dur) $+ (SV.empty, state)+ else+ let gain = 0.9999+ in (SV.zipWith (\y k -> y * sin (2*pi*fromIntegral k * freq))+ (SV.iterateN dur (gain*) amp)+ (SV.iterateN dur (1+) phase),+ OscillatorState (amp*gain^dur) freq (phase+dur))++processEvents ::+ (Storable a, Floating a, Monad m) =>+ Size ->+ SampleRate ->+ [(Time, VoiceMsg.T)] ->+ MS.StateT (State a) m [(Int, SV.Vector a)]+processEvents size rate input = do+ oscis0 <- MS.get+ let pendingOscis =+ fmap+ (\(mplaying, finished) ->+ let mplayingNew =+ fmap+ (\(start,s0) ->+ case renderTone (fromIntegral size - start) s0 of+ (chunk, s1) -> ((start,chunk), s1))+ mplaying+ in (fmap snd mplayingNew,+ maybe id (\p -> (fst p :)) mplayingNew $+ map+ (\(start, dur, s) -> (start, fst $ renderTone dur s))+ finished)) $+ foldl+ (\oscis (time,ev) ->+ case VoiceMsg.explicitNoteOff ev of+ VoiceMsg.NoteOn pitch velocity ->+ Map.insertWith+ (\(newOsci, []) s ->+ {-+ A key may be pressed that was already pressed.+ This should not happen, but we must be prepared for it.+ Thus we call stopTone.+ -}+ (newOsci, stopTone time s))+ pitch+ (Just (time,+ OscillatorState+ (0.2 * 2 ** VoiceMsg.realFromVelocity velocity)+ (VoiceMsg.frequencyFromPitch pitch /+ fromIntegral rate)+ 0),+ [])+ oscis+ VoiceMsg.NoteOff pitch _velocity ->+ Map.adjust+ (\s ->+ {-+ A key may be released that was not pressed.+ This should not happen, but we must be prepared for it.+ Thus stopTone also handles that case.+ -}+ (Nothing, stopTone time s))+ pitch+ oscis+ _ -> oscis)+ (fmap (\s -> (Just (0, s), [])) oscis0)+ (map (\(time,ev) -> (fromInteger time, ev)) input)+ MS.put (Map.mapMaybe fst pendingOscis)+ return (concatMap snd $ Map.elems pendingOscis)++run ::+ (Storable a, Floating a, Monad m) =>+ Size ->+ SampleRate ->+ [(Time, VoiceMsg.T)] ->+ MS.StateT (State a) m (SV.Vector a)+run size rate input =+ liftM (arrange size) $ processEvents size rate input
jack.cabal view
@@ -1,12 +1,12 @@ Name: jack-Version: 0.6.2+Version: 0.7 License: GPL License-File: LICENSE Author: Soenke Hahn, Stefan Kersten, Henning Thielemann Maintainer: Henning Thielemann <haskell@henning-thielemann.de> Synopsis: Bindings for the JACK Audio Connection Kit Description:- Very basic bindings for the JACK Audio Connection Kit.+ Bindings for the JACK Audio Connection Kit. It has support both for PCM audio and MIDI handling. . In order to adapt to your system,@@ -16,7 +16,7 @@ Build-Type: Simple Cabal-Version: >=1.14 Tested-With: GHC==6.8.2, GHC==6.10.4, GHC==6.12.3-Tested-With: GHC==7.0.2, GHC==7.2.1, GHC==7.4.1+Tested-With: GHC==7.0.2, GHC==7.2.1, GHC==7.4.1, GHC==7.6.1 Extra-Source-Files: README INSTALL@@ -30,7 +30,7 @@ Source-Repository this type: darcs location: http://code.haskell.org/jack/- tag: 0.6.2+ tag: 0.7 Flag pkgConfig description: Use pkg-config tool for check version and presence of jack@@ -47,12 +47,14 @@ Library Build-Depends: midi >=0.1.5.2 && <0.3,+ event-list >=0.1 && <0.2,+ non-negative >=0.1 && <0.2, bytestring >=0.9.1.4 && <0.11,- explicit-exception >=0.1.5 && <0.2,+ explicit-exception >=0.1.7 && <0.2, transformers >=0.2 && <0.4, enumset >=0.0 && <0.1, array >=0.2 && <0.5,- unix >=2.3 && <2.6,+ unix >=2.3 && <2.7, base >=4.0 && <5.0 Exposed-Modules: Sound.JACK@@ -95,37 +97,78 @@ Extra-Libraries: jack Executable amplify- If !flag(buildExamples)+ If flag(buildExamples)+ Build-Depends:+ jack,+ base >=3.0 && <5+ Else Buildable: False Default-Language: Haskell98+ GHC-Options: -Wall -fwarn-tabs -fwarn-incomplete-record-updates -rtsopts+ Hs-Source-Dirs: examples+ Main-Is: Amplify.hs++Executable capture+ If flag(buildExamples)+ Build-Depends:+ jack,+ explicit-exception >=0.1.7 && <0.2,+ transformers >=0.2 && <0.4,+ array >=0.2 && <0.5,+ base >=3.0 && <5+ Else+ Buildable: False+ Default-Language: Haskell98 GHC-Options: -Wall -fwarn-tabs -fwarn-incomplete-record-updates- Hs-Source-Dirs: .- Build-Depends:- jack,- base >=3.0 && <5- Main-Is: examples/Amplify.hs+ Hs-Source-Dirs: examples+ Main-Is: Capture.hs Executable impulse-train- If !flag(buildExamples)+ If flag(buildExamples)+ Build-Depends:+ jack,+ explicit-exception >=0.1.7 && <0.2,+ transformers >=0.2 && <0.4,+ array >=0.2 && <0.5,+ base >=3.0 && <5+ Else Buildable: False Default-Language: Haskell98- GHC-Options: -Wall -fwarn-tabs -fwarn-incomplete-record-updates- Hs-Source-Dirs: .- Build-Depends:- jack,- transformers >=0.2 && <0.4,- array >=0.2 && <0.5,- base >=3.0 && <5- Main-Is: examples/ImpulseTrain.hs+ GHC-Options: -Wall -fwarn-tabs -fwarn-incomplete-record-updates -rtsopts+ Hs-Source-Dirs: examples+ Main-Is: ImpulseTrain.hs Executable midimon- If !flag(buildExamples)+ If flag(buildExamples)+ Build-Depends:+ jack,+ midi >=0.1.5.2 && <0.3,+ base >=3.0 && <5+ Else Buildable: False Default-Language: Haskell98+ GHC-Options: -Wall -fwarn-tabs -fwarn-incomplete-record-updates -rtsopts+ Hs-Source-Dirs: examples+ Main-Is: Midimon.hs++Executable synth+ If flag(buildExamples)+ Build-Depends:+ jack,+ midi >=0.1.5.2 && <0.3,+ event-list >=0.1 && <0.2,+ explicit-exception >=0.1.7 && <0.2,+ transformers >=0.2 && <0.4,+ containers >=0.2 && <0.5,+ bytestring >=0.9.1 && <0.11,+ storablevector >=0.2.7 && <0.3,+ array >=0.2 && <0.5,+ base >=3.0 && <5+ Else+ Buildable: False+ Default-Language: Haskell98 GHC-Options: -Wall -fwarn-tabs -fwarn-incomplete-record-updates- Hs-Source-Dirs: .- Build-Depends:- jack,- midi >=0.1.5.2 && <0.3,- base >=3.0 && <5- Main-Is: examples/Midimon.hs+ Hs-Source-Dirs: examples+ Main-Is: Synthesizer.hs+ Other-Modules:+ Synthesizer.Render
src/Sound/JACK.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE ForeignFunctionInterface #-} {- JACK bindings for Haskell- Copyright (C) 2011 Henning Thielemann+ Copyright (C) 2011-2013 Henning Thielemann Copyright (C) 2007 Soenke Hahn This program is free software; you can redistribute it and/or modify@@ -54,20 +54,24 @@ Process, connect,- mkProcess,+ makeProcess, setProcess,- JackFFI.CallbackArg,+ withProcess, getSampleRate,+ lastFrameTime, - mkClientRegistration,+ makeClientRegistration, setClientRegistration,+ withClientRegistration, JackFFI.PortId,- mkPortRegistration,+ makePortRegistration, setPortRegistration,- mkPortConnect,+ withPortRegistration,+ makePortConnect, setPortConnect,+ withPortConnect, portById, portByName,@@ -100,19 +104,20 @@ import qualified Sound.JACK.FFI as JackFFI import qualified Sound.JACK.FFIFree as JackFFIFree import Sound.JACK.FFI.MIDI (EventBuffer, )-import Sound.JACK.FFI (Process, nframesIndices, nframesBounds, )+import Sound.JACK.FFI+ (Process, Input(Input), Output(Output), nframesIndices, nframesBounds, ) import qualified Control.Monad.Exception.Synchronous as Sync import qualified Control.Monad.Trans.Class as Trans-import Control.Exception (finally, )+import qualified Control.Exception as Exc import qualified Foreign.Marshal.Array as Array import qualified Foreign.C.String as CString import qualified Foreign.C.Types as C import Foreign.Storable (Storable, peek, )-import Foreign.Ptr (Ptr, FunPtr, nullPtr, castPtr, )+import Foreign.Ptr (Ptr, FunPtr, nullPtr, castPtr, freeHaskellFunPtr, nullFunPtr, ) import Foreign.C.String (CString, peekCString, )-import Foreign.C.Error (Errno(Errno), )+import Foreign.C.Error (Errno(Errno), eOK) import qualified Data.EnumSet as ES import Control.Concurrent (MVar, putMVar, newEmptyMVar, takeMVar, threadDelay)@@ -126,15 +131,9 @@ class Direction dir where dirToFlags :: dir -> JackFFI.PortFlagSet --- | Type argument for Jack input ports-data Input = Input- instance Direction Input where dirToFlags ~Input = JackFFI.portIsInput --- | Type argument for Jack output ports-data Output = Output- instance Direction Output where dirToFlags ~Output = JackFFI.portIsOutput @@ -165,7 +164,7 @@ _ <- checkStatus client status return (Client client) --- | Creates a new JACK client with the "default" server+-- | Creates a new JACK client with the @default@ server newClientDefault :: (JackExc.ThrowsStatus e) => String -- ^ name of the client@@ -317,7 +316,7 @@ _dummy :: C.CInt _dummy = undefined -foreign import ccall "wrapper" mkProcess :: Process -> IO (FunPtr Process)+foreign import ccall "wrapper" makeProcess :: Process arg -> IO (FunPtr (Process arg)) getClient :: Client -> Ptr JackFFI.Client@@ -336,7 +335,7 @@ peekPortNameArray a = if a == nullPtr then return []- else finally+ else Exc.finally (mapM peekCString =<< Array.peekArray0 nullPtr a) (JackFFIFree.freePortNameArray a) @@ -423,57 +422,143 @@ Sync.resolveT $ IO.hPutStrLn IO.stderr . JackExc.toStringWithHead +{-# INLINE withCallback #-}+withCallback ::+ (JackExc.ThrowsErrno e) =>+ (callback -> IO (FunPtr callbackExt)) ->+ (Client -> FunPtr callbackExt -> Ptr () -> Sync.ExceptionalT e IO ()) ->+ Client -> callback ->+ Sync.ExceptionalT e IO a ->+ Sync.ExceptionalT e IO a+withCallback makeCallback setCallback client proc act =+ bracket+ (do+ procPtr <- Trans.lift $ makeCallback proc+ setCallback client procPtr nullPtr+ return procPtr)+ (\procPtr -> do+ setCallback client nullFunPtr nullPtr+ Trans.lift $ freeHaskellFunPtr procPtr)+ (const act)++ setProcess :: (JackExc.ThrowsErrno e) => Client ->- FunPtr Process ->+ FunPtr (Process arg) ->+ Ptr arg -> Sync.ExceptionalT e IO ()-setProcess client procPtr =- liftErrno $ JackFFI.set_process_callback (getClient client) procPtr nullPtr+setProcess client procPtr arg =+ liftErrno $ JackFFI.set_process_callback (getClient client) procPtr arg +withProcess ::+ (JackExc.ThrowsErrno e) =>+ Client ->+ (JackFFI.NFrames -> Sync.ExceptionalT Errno IO ()) ->+ Sync.ExceptionalT e IO a ->+ Sync.ExceptionalT e IO a+withProcess =+ withCallback+ (\proc ->+ makeProcess $ \ nframes _arg ->+ Sync.switchT return (\() -> return eOK) $ proc nframes)+ setProcess ++ getSampleRate :: Client -> IO Int getSampleRate (Client ptr) = fmap fromIntegral $ JackFFI.get_sample_rate ptr +{-+Call this function from within a callback+in order to obtain the start time of the current block.+-}+lastFrameTime :: Client -> IO JackFFI.NFrames+lastFrameTime (Client client) =+ JackFFI.last_frame_time client -- | Create a client registration callback 'FunPtr'.-foreign import ccall "wrapper" mkClientRegistration :: JackFFI.ClientRegistration -> IO (FunPtr JackFFI.ClientRegistration)+foreign import ccall "wrapper" makeClientRegistration :: JackFFI.ClientRegistration arg -> IO (FunPtr (JackFFI.ClientRegistration arg)) -- | Set the client registration callback. setClientRegistration :: (JackExc.ThrowsErrno e) => Client ->- FunPtr JackFFI.ClientRegistration ->+ FunPtr (JackFFI.ClientRegistration arg) ->+ Ptr arg -> Sync.ExceptionalT e IO ()-setClientRegistration client procPtr =- liftErrno $ JackFFI.set_client_registration_callback (getClient client) procPtr nullPtr+setClientRegistration client procPtr arg =+ liftErrno $ JackFFI.set_client_registration_callback (getClient client) procPtr arg +withClientRegistration ::+ (JackExc.ThrowsErrno e) =>+ Client ->+ (String -> Bool -> IO ()) ->+ Sync.ExceptionalT e IO a ->+ Sync.ExceptionalT e IO a+withClientRegistration =+ withCallback+ (\proc -> makeClientRegistration $+ \ namePtr registered _arg -> do+ name <- peekCString namePtr+ proc name (registered/=0))+ setClientRegistration ++ -- | Create a port registration callback 'FunPtr'.-foreign import ccall "wrapper" mkPortRegistration :: JackFFI.PortRegistration -> IO (FunPtr JackFFI.PortRegistration)+foreign import ccall "wrapper" makePortRegistration :: JackFFI.PortRegistration arg -> IO (FunPtr (JackFFI.PortRegistration arg)) -- | Set the port registration callback. setPortRegistration :: (JackExc.ThrowsErrno e) => Client ->- FunPtr JackFFI.PortRegistration ->+ FunPtr (JackFFI.PortRegistration arg) ->+ Ptr arg -> Sync.ExceptionalT e IO ()-setPortRegistration client procPtr =- liftErrno $ JackFFI.set_port_registration_callback (getClient client) procPtr nullPtr+setPortRegistration client procPtr arg =+ liftErrno $ JackFFI.set_port_registration_callback (getClient client) procPtr arg +withPortRegistration ::+ (JackExc.ThrowsErrno e) =>+ Client ->+ (JackFFI.PortId -> Bool -> IO ()) ->+ Sync.ExceptionalT e IO a ->+ Sync.ExceptionalT e IO a+withPortRegistration =+ withCallback+ (\proc -> makePortRegistration $+ \ portA registered _arg ->+ proc portA (registered/=0))+ setPortRegistration + -- | Create a port connect callback 'FunPtr'.-foreign import ccall "wrapper" mkPortConnect :: JackFFI.PortConnect -> IO (FunPtr JackFFI.PortConnect)+foreign import ccall "wrapper" makePortConnect :: JackFFI.PortConnect arg -> IO (FunPtr (JackFFI.PortConnect arg)) -- | Set the port connect callback. setPortConnect :: (JackExc.ThrowsErrno e) => Client ->- FunPtr JackFFI.PortConnect ->+ FunPtr (JackFFI.PortConnect arg) ->+ Ptr arg -> Sync.ExceptionalT e IO ()-setPortConnect client procPtr =- liftErrno $ JackFFI.set_port_connect_callback (getClient client) procPtr nullPtr+setPortConnect client procPtr arg =+ liftErrno $ JackFFI.set_port_connect_callback (getClient client) procPtr arg++withPortConnect ::+ (JackExc.ThrowsErrno e) =>+ Client ->+ (JackFFI.PortId -> JackFFI.PortId -> Bool -> IO ()) ->+ Sync.ExceptionalT e IO a ->+ Sync.ExceptionalT e IO a+withPortConnect =+ withCallback+ (\proc -> makePortConnect $+ \ portA portB connected _arg ->+ proc portA portB (connected/=0))+ setPortConnect portById ::
src/Sound/JACK/Audio.hs view
@@ -1,9 +1,10 @@ module Sound.JACK.Audio ( Sample, Port, withPort, - setProcessMono,- setProcessStereo,+ withProcessMono,+ withProcessStereo, + getBufferPtr, getBufferArray, mainMono,@@ -16,13 +17,15 @@ import Sound.JACK (Direction, Input, Output, ) import qualified Sound.JACK.Exception as JackExc-import Sound.JACK.FFI (NFrames, nframesIndices, nframesBounds, Process, )+import qualified Sound.JACK.FFI as JackFFI+import Sound.JACK.FFI (NFrames, nframesIndices, nframesBounds, ) 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.Ptr (Ptr, )+import Foreign.C.Error (Errno, ) import qualified Foreign.C.Types as C import System.Environment (getProgName)@@ -48,13 +51,19 @@ withPort = Jack.withPort +getBufferPtr ::+ (Direction dir) =>+ Port dir -> NFrames -> IO (Ptr Sample)+getBufferPtr (Priv.Port port) nframes =+ JackFFI.port_get_buffer port nframes+ getBufferArray :: (Direction dir) => Port dir -> NFrames -> IO (StorableArray NFrames Sample)-getBufferArray port nframes = do+getBufferArray port nframes = flip unsafeForeignPtrToStorableArray (nframesBounds nframes) =<< newForeignPtr_- =<< Priv.portGetBuffer port nframes+ =<< getBufferPtr port nframes mainMono :: (Sample -> IO Sample) -> IO ()@@ -63,30 +72,30 @@ Jack.handleExceptions $ Jack.withClientDefault name $ \client -> Jack.withPort client "input" $ \input ->- Jack.withPort client "output" $ \output -> do- setProcessMono client input fun output+ Jack.withPort client "output" $ \output ->+ withProcessMono client input fun output $ Jack.withActivation client $ Trans.lift $ do putStrLn $ "started " ++ name ++ "..." Jack.waitForBreak -setProcessMono ::+withProcessMono :: (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)+ Sync.ExceptionalT e IO a ->+ Sync.ExceptionalT e IO a+withProcessMono client input fun output =+ Jack.withProcess client $ wrapMonoFun input fun output wrapMonoFun :: Port Input -> (Sample -> IO Sample) ->- Port Output -> Process-wrapMonoFun input fun output nframes _args = do+ Port Output ->+ NFrames -> Sync.ExceptionalT Errno IO ()+wrapMonoFun input fun output nframes = Trans.lift $ 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)@@ -103,40 +112,39 @@ Jack.withPort client "inputLeft" $ \inputLeft -> Jack.withPort client "inputRight" $ \inputRight -> Jack.withPort client "outputLeft" $ \outputLeft ->- Jack.withPort client "outputRight" $ \outputRight -> do- setProcessStereo client+ Jack.withPort client "outputRight" $ \outputRight ->+ withProcessStereo client inputLeft inputRight fun- outputLeft outputRight+ outputLeft outputRight $ Jack.withActivation client $ Trans.lift $ do putStrLn $ "started " ++ name ++ "..." Jack.waitForBreak -setProcessStereo ::+withProcessStereo :: (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)+ Sync.ExceptionalT e IO a ->+ Sync.ExceptionalT e IO a+withProcessStereo client inputLeft inputRight fun outputLeft outputRight =+ Jack.withProcess client $+ 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+ Port Input -> Port Input ->+ ((Sample, Sample) -> IO (Sample, Sample)) ->+ Port Output -> Port Output ->+ NFrames -> Sync.ExceptionalT Errno IO ()+wrapStereoFun iL iR fun oL oR nframes = Trans.lift $ 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
src/Sound/JACK/FFI.hsc view
@@ -29,15 +29,24 @@ import qualified Foreign.C.Types as C import qualified Data.EnumSet as ES-import Data.Word (Word, Word32, )+import Data.Word (Word, Word32, Word64, ) import Data.Ix (Ix(range, inRange, rangeSize, index)) import Data.Monoid (Monoid, mempty, mappend, ) -#include "jack/jack.h"+import Numeric.NonNegative.Class as NonNeg +#include "jack/types.h"+ data Client = Client data Port typ = Port +-- | Type argument for Jack input ports+data Input = Input++-- | Type argument for Jack output ports+data Output = Output++ foreign import ccall "static jack/jack.h jack_client_open" client_open :: CString -> OpenOptionSet -> Ptr StatusSet -> CString -> IO (Ptr Client) @@ -120,7 +129,7 @@ -- | represents absolute frame time-newtype NFrames = NFrames C.CUInt+newtype NFrames = NFrames #{type jack_nframes_t} deriving (Show, Eq, Ord) nframesToWord :: NFrames -> Word@@ -141,7 +150,10 @@ mempty = NFrames 0 mappend (NFrames x) (NFrames y) = NFrames (x+y) +instance NonNeg.C NFrames where+ split = NonNeg.splitDefault (\(NFrames n) -> n) NFrames + nframesIndices :: NFrames -> [NFrames] nframesIndices (NFrames n) = take (fromIntegral n) $ map NFrames $ iterate (1+) 0@@ -151,20 +163,17 @@ (NFrames 0, NFrames $ n - 1) -data CallbackArg = CallbackArg---type Process = NFrames -> Ptr CallbackArg -> IO E.Errno+type Process arg = NFrames -> Ptr arg -> IO E.Errno foreign import ccall "static jack/jack.h jack_set_process_callback" set_process_callback ::- Ptr Client -> FunPtr Process -> Ptr CallbackArg -> IO E.Errno+ Ptr Client -> FunPtr (Process arg) -> Ptr arg -> IO E.Errno -type ClientRegistration = CString -> C.CInt -> Ptr CallbackArg -> IO ()+type ClientRegistration arg = CString -> C.CInt -> Ptr arg -> IO () foreign import ccall "static jack/jack.h jack_set_client_registration_callback" set_client_registration_callback ::- Ptr Client -> FunPtr ClientRegistration -> Ptr CallbackArg -> IO E.Errno+ Ptr Client -> FunPtr (ClientRegistration arg) -> Ptr arg -> IO E.Errno newtype PortId = PortId #{type jack_port_id_t} deriving (Eq, Ord, Show) @@ -174,17 +183,17 @@ -} data UnknownType = UnknownType -type PortRegistration = PortId -> C.CInt -> Ptr CallbackArg -> IO ()+type PortRegistration arg = PortId -> C.CInt -> Ptr arg -> IO () foreign import ccall "static jack/jack.h jack_set_port_registration_callback" set_port_registration_callback ::- Ptr Client -> FunPtr PortRegistration -> Ptr CallbackArg -> IO E.Errno+ Ptr Client -> FunPtr (PortRegistration arg) -> Ptr arg -> IO E.Errno -type PortConnect = PortId -> PortId -> C.CInt -> Ptr CallbackArg -> IO ()+type PortConnect arg = PortId -> PortId -> C.CInt -> Ptr arg -> IO () foreign import ccall "static jack/jack.h jack_set_port_connect_callback" set_port_connect_callback ::- Ptr Client -> FunPtr PortConnect -> Ptr CallbackArg -> IO E.Errno+ Ptr Client -> FunPtr (PortConnect arg) -> Ptr arg -> IO E.Errno foreign import ccall "static jack/jack.h jack_port_by_id"@@ -249,3 +258,5 @@ deactivate :: Ptr Client -> IO E.Errno +_dummy :: (Word32, Word64)+_dummy = undefined
src/Sound/JACK/FFI/MIDI.hsc view
@@ -5,6 +5,7 @@ module Sound.JACK.FFI.MIDI ( EventBuffer(EventBuffer),+ Buffer(Buffer), RawEvent(RawEvent), time,@@ -24,7 +25,7 @@ where -import Sound.JACK.FFI (NFrames(NFrames), )+import Sound.JACK.FFI (NFrames(NFrames), Input, Output, ) import Foreign.Marshal.Array (copyArray, advancePtr, ) import Foreign.ForeignPtr (withForeignPtr, )@@ -48,6 +49,12 @@ -- could also be an empty data declaration data EventBuffer = EventBuffer +newtype Buffer dir = Buffer (Ptr EventBuffer)++_dummy :: Buffer dir+_dummy = Buffer undefined++ -- | Represents a raw JACK MIDI event data RawEvent = RawEvent { time :: NFrames -- ^ Sample index at which event is valid (relative to cycle start)@@ -134,17 +141,17 @@ foreign import ccall "static jack/midiport.h jack_midi_get_event_count"- get_event_count :: Ptr EventBuffer -> IO NFrames+ get_event_count :: Buffer Input -> IO NFrames foreign import ccall "static jack/midiport.h jack_midi_event_get"- event_get :: Ptr RawEvent -> Ptr EventBuffer -> NFrames -> IO E.Errno+ event_get :: Ptr RawEvent -> Buffer Input -> NFrames -> IO E.Errno foreign import ccall "static jack/midiport.h jack_midi_clear_buffer"- clear_buffer :: Ptr EventBuffer -> IO ()+ clear_buffer :: Buffer Output -> IO () -- nullPtr may be mapped to eNOBUFS exception as in event_write foreign import ccall "static jack/midiport.h jack_midi_event_reserve"- event_reserve :: Ptr EventBuffer -> NFrames -> C.CSize -> IO (Ptr Word8)+ event_reserve :: Buffer Output -> NFrames -> C.CSize -> IO (Ptr Word8) foreign import ccall "static jack/midiport.h jack_midi_event_write"- event_write :: Ptr EventBuffer -> NFrames -> Ptr Word8 -> C.CULong -> IO E.Errno+ event_write :: Buffer Output -> NFrames -> Ptr Word8 -> C.CULong -> IO E.Errno
src/Sound/JACK/MIDI.hs view
@@ -7,41 +7,57 @@ Port, withPort, - setProcess,+ withProcess, + Buffer,+ getBuffer,+ clearBuffer,+ readRawEvents, writeRawEvent,+ readRawEventsFromPort,+ writeRawEventsToPort, + writeEvent,+ readEventsFromPort,+ writeEventsToPort,+ 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.Private (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 Sound.JACK.FFI as JackFFI+import Sound.JACK.FFI (NFrames, nframesIndices, )+import Sound.JACK.FFI.MIDI+ (RawEvent, EventBuffer, Buffer(Buffer), toRawEventFunction, ) import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL +import qualified Data.EventList.Absolute.TimeBody as EventList+ import qualified Sound.MIDI.Message as Msg+import qualified Sound.MIDI.Parser.Report as Report 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 Foreign.C.Error (Errno, ) import System.Environment (getProgName)-import Control.Monad (when, forM, )+import Control.Monad (forM, ) +import Data.Maybe (mapMaybe, ) + type Port = Priv.Port EventBuffer withPort ::@@ -65,10 +81,10 @@ rawEvent = JackMIDI.RawEvent rawEventTime :: RawEvent -> NFrames-rawEventTime = time+rawEventTime = JackMIDI.time rawEventBuffer :: RawEvent -> B.ByteString-rawEventBuffer = buffer+rawEventBuffer = JackMIDI.buffer -- | Creates an input and an output, and transforms all raw input events into raw output@@ -80,8 +96,8 @@ Jack.handleExceptions $ Jack.withClientDefault name $ \client -> Jack.withPort client "input" $ \input ->- Jack.withPort client "output" $ \output -> do- setProcess client input fun output+ Jack.withPort client "output" $ \output ->+ withProcess client input fun output $ Jack.withActivation client $ Trans.lift $ do putStrLn $ "started " ++ name ++ "..." Jack.waitForBreak@@ -94,63 +110,134 @@ -- | sets the process loop of the JACK Client-setProcess ::+withProcess :: (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 ()+ -> Sync.ExceptionalT e IO a+ -> Sync.ExceptionalT e IO a -- ^ 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)+withProcess client input fun output =+ Jack.withProcess client $ 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+ Buffer Input -- ^ 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)+ -- putStrLn $ "Got MIDI Event number " ++ (show n) ++ " with result " ++ (show result) ++ " at JackMIDI.time " ++ (show $ JackMIDI.time event) ++ " size: " ++ (show $ size event) ++ " JackMIDI.buffer: " ++ (show $ JackMIDI.buffer event) --- | writes a MIDI event to the PortBuffer of a MIDI output or throws eNOBUFS if buffer is full+getBuffer ::+ Direction dir =>+ Port dir -> NFrames -> IO (Buffer dir)+getBuffer (Priv.Port port) n =+ fmap Buffer $ JackFFI.port_get_buffer port n++clearBuffer :: Buffer Output -> IO ()+clearBuffer portBuffer =+ JackMIDI.clear_buffer portBuffer++-- | writes a MIDI event to the PortBuffer of a MIDI output or throws eNOBUFS if JackMIDI.buffer is full writeRawEvent :: (JackExc.ThrowsErrno e) =>- Ptr EventBuffer -- ^ the PortBuffer of the MIDI output to write to+ Buffer Output -- ^ 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)+ liftErrno $+ JackMIDI.withByteStringPtr (JackMIDI.buffer event) $ \ptr len ->+ JackMIDI.event_write portBuffer (JackMIDI.time event) ptr (fromIntegral len)- -- putStrLn $ "Writing MIDI Event: buffer: " ++ (show $ buffer event)+ -- putStrLn $ "Writing MIDI Event: JackMIDI.buffer: " ++ (show $ JackMIDI.buffer event) +readRawEventsFromPort ::+ (JackExc.ThrowsErrno e) =>+ Port Input -> NFrames ->+ Sync.ExceptionalT e IO [RawEvent]+readRawEventsFromPort port nframes =+ readRawEvents =<< (Trans.lift $ getBuffer port nframes)++{- |+Clears an output buffer and writes a sequence of events to it.+That is, you must only call this function once per callback.+-}+writeRawEventsToPort ::+ (JackExc.ThrowsErrno e) =>+ Port Output -> NFrames ->+ [RawEvent] ->+ Sync.ExceptionalT e IO ()+writeRawEventsToPort port nframes es = do+ buffer <- Trans.lift $ getBuffer port nframes+ Trans.lift $ clearBuffer buffer+ mapM_ (writeRawEvent buffer) es+++parseEvent :: JackMIDI.RawEvent -> Maybe (NFrames, Msg.T)+parseEvent ev =+ case Msg.maybeFromByteString $ BL.fromChunks [rawEventBuffer ev] of+ Report.Cons _warnings result ->+ case result of+ Right dat -> Just (rawEventTime ev, dat)+ _ -> Nothing++{- |+Reads midi events from an input buffer+and converts them to a high-level representation.+Messages are simply ignored if they cannot be parsed.+-}+readEventsFromPort ::+ (JackExc.ThrowsErrno e) =>+ Port Input -> NFrames ->+ Sync.ExceptionalT e IO (EventList.T NFrames Msg.T)+readEventsFromPort port nframes =+ fmap (EventList.fromPairList . mapMaybe parseEvent) $+ readRawEventsFromPort port nframes+++writeEvent ::+ (JackExc.ThrowsErrno e) =>+ Buffer Output -> NFrames -> Msg.T ->+ Sync.ExceptionalT e IO ()+writeEvent buffer pos =+ writeRawEvent buffer .+ JackMIDI.RawEvent pos .+ B.concat . BL.toChunks . Msg.toByteString++{- |+Clears an output buffer and writes a sequence of events to it.+That is, you must only call this function once per callback.+-}+writeEventsToPort ::+ (JackExc.ThrowsErrno e) =>+ Port Output -> NFrames ->+ EventList.T NFrames Msg.T ->+ Sync.ExceptionalT e IO ()+writeEventsToPort port nframes =+ writeRawEventsToPort port nframes .+ map (uncurry JackMIDI.RawEvent) .+ EventList.toPairList .+ fmap (B.concat . BL.toChunks . Msg.toByteString)++ 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-+ Port Output ->+ NFrames -> Sync.ExceptionalT Errno IO ()+wrapFun client input fun output nframes = do+ inEvents <- readRawEventsFromPort input nframes+ -- when (not (null inEvents)) $ putStrLn $ "wrapFun: Got " ++ (show $ length inEvents) ++ " input events"+ lastCycle <- Trans.lift $ Jack.lastFrameTime client+ outEvents <- mapM (Trans.lift . fun lastCycle) inEvents+ -- when (not (null outEvents)) $ putStrLn $ "wrapFun: Got " ++ (show $ length outEvents) ++ " output events"+ writeRawEventsToPort output nframes outEvents
src/Sound/JACK/Private.hs view
@@ -3,7 +3,6 @@ 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@@ -33,12 +32,6 @@ 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 ->