diff --git a/examples/Capture.hs b/examples/Capture.hs new file mode 100644 --- /dev/null +++ b/examples/Capture.hs @@ -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 diff --git a/examples/ImpulseTrain.hs b/examples/ImpulseTrain.hs --- a/examples/ImpulseTrain.hs +++ b/examples/ImpulseTrain.hs @@ -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 diff --git a/examples/Synthesizer.hs b/examples/Synthesizer.hs new file mode 100644 --- /dev/null +++ b/examples/Synthesizer.hs @@ -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 diff --git a/examples/Synthesizer/Render.hs b/examples/Synthesizer/Render.hs new file mode 100644 --- /dev/null +++ b/examples/Synthesizer/Render.hs @@ -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 diff --git a/jack.cabal b/jack.cabal --- a/jack.cabal +++ b/jack.cabal @@ -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 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 diff --git a/src/Sound/JACK.hs b/src/Sound/JACK.hs --- a/src/Sound/JACK.hs +++ b/src/Sound/JACK.hs @@ -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 :: diff --git a/src/Sound/JACK/Audio.hs b/src/Sound/JACK/Audio.hs --- a/src/Sound/JACK/Audio.hs +++ b/src/Sound/JACK/Audio.hs @@ -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 diff --git a/src/Sound/JACK/FFI.hsc b/src/Sound/JACK/FFI.hsc --- a/src/Sound/JACK/FFI.hsc +++ b/src/Sound/JACK/FFI.hsc @@ -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 diff --git a/src/Sound/JACK/FFI/MIDI.hsc b/src/Sound/JACK/FFI/MIDI.hsc --- a/src/Sound/JACK/FFI/MIDI.hsc +++ b/src/Sound/JACK/FFI/MIDI.hsc @@ -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 diff --git a/src/Sound/JACK/MIDI.hs b/src/Sound/JACK/MIDI.hs --- a/src/Sound/JACK/MIDI.hs +++ b/src/Sound/JACK/MIDI.hs @@ -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 diff --git a/src/Sound/JACK/Private.hs b/src/Sound/JACK/Private.hs --- a/src/Sound/JACK/Private.hs +++ b/src/Sound/JACK/Private.hs @@ -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 ->