diff --git a/alsa-seq.cabal b/alsa-seq.cabal --- a/alsa-seq.cabal +++ b/alsa-seq.cabal @@ -1,12 +1,12 @@ Name: alsa-seq -Version: 0.5.1.1 -Copyright: Bjorn Bringert, Iavor S. Diatchki, Henning Thielemann -Maintainer: Henning Thielemann +Version: 0.6 Author: Henning Thielemann , Dylan Simon , Bjorn Bringert , Iavor S. Diatchki +Maintainer: Henning Thielemann +Copyright: Bjorn Bringert, Iavor S. Diatchki, Dylan Simon, Henning Thielemann Category: Sound, Music License: BSD3 License-file: LICENSE @@ -23,15 +23,12 @@ Extra-Source-Files: filter/modify/Sound/ALSA/Sequencer/Client/Info/EventFilter.hs filter/setget/Sound/ALSA/Sequencer/Client/Info/EventFilter.hs + src/Sound/ALSA/Sequencer/Marshal/Template.h + src/Sound/ALSA/Sequencer/Area.h Source-Repository head type: darcs - location: http://code.haskell.org/~thielema/alsa-seq/ - -Source-Repository this - type: darcs - location: http://code.haskell.org/~thielema/alsa-seq/ - tag: 0.5.1.1 + location: http://code.haskell.org/alsa/seq/ Flag buildExamples description: Build example executables @@ -44,12 +41,15 @@ Library Build-depends: alsa-core >=0.5 && <0.6, - enumset >= 0.0.2 && <0.1, - array >= 0.1 && <0.5, - data-accessor >=0.2.1 && <0.3, - utility-ht >= 0.0.7 && <0.1, + enumset >=0.0.3 && <0.1, + transformers >=0.2 && <0.4, + array >=0.1 && <0.5, + bytestring >=0.9 && <0.10, + data-accessor >=0.2.2 && <0.3, + utility-ht >=0.0.7 && <0.1, + poll >=0.0 && <0.1, extensible-exceptions >=0.1.1 && <0.2, - base >= 3 && <5 + base >=3 && <5 GHC-Options: -Wall Extensions: @@ -58,6 +58,7 @@ EmptyDataDecls Hs-Source-Dirs: src + Include-Dirs: src If flag(modifyFilter) PkgConfig-Depends: alsa >= 1.0.17 Hs-Source-Dirs: filter/modify @@ -70,29 +71,40 @@ Sound.ALSA.Sequencer.Address Sound.ALSA.Sequencer.Client Sound.ALSA.Sequencer.Client.Info + Sound.ALSA.Sequencer.Client.InfoMonad + Sound.ALSA.Sequencer.Connect Sound.ALSA.Sequencer.Port Sound.ALSA.Sequencer.Port.Info + Sound.ALSA.Sequencer.Port.InfoMonad Sound.ALSA.Sequencer.Event Sound.ALSA.Sequencer.Event.Accessor - Sound.ALSA.Sequencer.RealTime + Sound.ALSA.Sequencer.Event.RemoveMonad + Sound.ALSA.Sequencer.Query Sound.ALSA.Sequencer.Queue Sound.ALSA.Sequencer.Queue.Info Sound.ALSA.Sequencer.Queue.Status Sound.ALSA.Sequencer.Queue.Tempo Sound.ALSA.Sequencer.Queue.Timer + Sound.ALSA.Sequencer.RealTime + Sound.ALSA.Sequencer.Time + Sound.ALSA.Sequencer.Concurrent Sound.ALSA.Sequencer.Subscribe Sound.ALSA.Sequencer.Subscribe.Query + Sound.ALSA.Sequencer.Poll Other-modules: + Sound.ALSA.Sequencer.Event.Remove Sound.ALSA.Sequencer.Marshal.Sequencer Sound.ALSA.Sequencer.Marshal.Address Sound.ALSA.Sequencer.Marshal.Client + Sound.ALSA.Sequencer.Marshal.ClientInfo + Sound.ALSA.Sequencer.Marshal.Connect Sound.ALSA.Sequencer.Marshal.Port + Sound.ALSA.Sequencer.Marshal.PortInfo Sound.ALSA.Sequencer.Marshal.Queue - Sound.ALSA.Sequencer.Marshal.QueueTimer Sound.ALSA.Sequencer.Marshal.Event Sound.ALSA.Sequencer.Marshal.RealTime - Sound.ALSA.Sequencer.Marshal.QuerySubscribe + Sound.ALSA.Sequencer.Marshal.Time Sound.ALSA.Sequencer.Client.Info.EventFilter Sound.ALSA.Sequencer.Area Sound.ALSA.Sequencer.Sequencer @@ -105,11 +117,12 @@ If !flag(buildExamples) Buildable: False Hs-Source-Dirs: src, examples + Include-Dirs: src If flag(modifyFilter) Hs-Source-Dirs: filter/modify Else Hs-Source-Dirs: filter/setget - GHC-Options: -Wall -threaded + GHC-Options: -Wall Extensions: ForeignFunctionInterface GeneralizedNewtypeDeriving @@ -118,19 +131,24 @@ Sound.ALSA.Sequencer.Marshal.Sequencer Sound.ALSA.Sequencer.Marshal.Address Sound.ALSA.Sequencer.Marshal.Client + Sound.ALSA.Sequencer.Marshal.ClientInfo + Sound.ALSA.Sequencer.Marshal.Connect Sound.ALSA.Sequencer.Marshal.Port + Sound.ALSA.Sequencer.Marshal.PortInfo Sound.ALSA.Sequencer.Marshal.Queue - Sound.ALSA.Sequencer.Marshal.QueueTimer Sound.ALSA.Sequencer.Marshal.Event Sound.ALSA.Sequencer.Marshal.RealTime - Sound.ALSA.Sequencer.Marshal.QuerySubscribe + Sound.ALSA.Sequencer.Marshal.Time Sound.ALSA.Sequencer.Area Sound.ALSA.Sequencer.Sequencer Build-Depends: alsa-core >=0.5 && <0.6, - enumset >= 0.0.2 && <0.1, - array >= 0.1 && <0.5, - utility-ht >= 0.0.7 && <0.1, + enumset >=0.0.3 && <0.1, + transformers >=0.2 && <0.4, + array >=0.1 && <0.5, + bytestring >=0.9 && <0.10, + data-accessor >=0.2.2 && <0.3, + utility-ht >=0.0.7 && <0.1, base >=3 && <5 Executable alsa-seq-send-note @@ -138,11 +156,12 @@ If !flag(buildExamples) Buildable: False Hs-Source-Dirs: src, examples + Include-Dirs: src If flag(modifyFilter) Hs-Source-Dirs: filter/modify Else Hs-Source-Dirs: filter/setget - GHC-Options: -Wall -threaded + GHC-Options: -Wall Extensions: ForeignFunctionInterface GeneralizedNewtypeDeriving @@ -151,19 +170,25 @@ Sound.ALSA.Sequencer.Marshal.Sequencer Sound.ALSA.Sequencer.Marshal.Address Sound.ALSA.Sequencer.Marshal.Client + Sound.ALSA.Sequencer.Marshal.ClientInfo + Sound.ALSA.Sequencer.Marshal.Connect Sound.ALSA.Sequencer.Marshal.Port + Sound.ALSA.Sequencer.Marshal.PortInfo Sound.ALSA.Sequencer.Marshal.Queue - Sound.ALSA.Sequencer.Marshal.QueueTimer Sound.ALSA.Sequencer.Marshal.Event Sound.ALSA.Sequencer.Marshal.RealTime - Sound.ALSA.Sequencer.Marshal.QuerySubscribe + Sound.ALSA.Sequencer.Marshal.Time Sound.ALSA.Sequencer.Area Sound.ALSA.Sequencer.Sequencer + Common Build-Depends: alsa-core >=0.5 && <0.6, - enumset >= 0.0.2 && <0.1, - array >= 0.1 && <0.5, - utility-ht >= 0.0.7 && <0.1, + enumset >=0.0.3 && <0.1, + transformers >=0.2 && <0.4, + array >=0.1 && <0.5, + bytestring >=0.9 && <0.10, + data-accessor >=0.2.2 && <0.3, + utility-ht >=0.0.7 && <0.1, base >=3 && <5 Executable alsa-seq-broadcast @@ -171,11 +196,12 @@ If !flag(buildExamples) Buildable: False Hs-Source-Dirs: src, examples + Include-Dirs: src If flag(modifyFilter) Hs-Source-Dirs: filter/modify Else Hs-Source-Dirs: filter/setget - GHC-Options: -Wall -threaded + GHC-Options: -Wall Extensions: ForeignFunctionInterface GeneralizedNewtypeDeriving @@ -184,31 +210,37 @@ Sound.ALSA.Sequencer.Marshal.Sequencer Sound.ALSA.Sequencer.Marshal.Address Sound.ALSA.Sequencer.Marshal.Client + Sound.ALSA.Sequencer.Marshal.ClientInfo + Sound.ALSA.Sequencer.Marshal.Connect Sound.ALSA.Sequencer.Marshal.Port + Sound.ALSA.Sequencer.Marshal.PortInfo Sound.ALSA.Sequencer.Marshal.Queue - Sound.ALSA.Sequencer.Marshal.QueueTimer Sound.ALSA.Sequencer.Marshal.Event Sound.ALSA.Sequencer.Marshal.RealTime - Sound.ALSA.Sequencer.Marshal.QuerySubscribe + Sound.ALSA.Sequencer.Marshal.Time Sound.ALSA.Sequencer.Area Sound.ALSA.Sequencer.Sequencer Build-Depends: alsa-core >=0.5 && <0.6, - enumset >= 0.0.2 && <0.1, - array >= 0.1 && <0.5, - utility-ht >= 0.0.7 && <0.1, + enumset >=0.0.3 && <0.1, + transformers >=0.2 && <0.4, + array >=0.1 && <0.5, + bytestring >=0.9 && <0.10, + data-accessor >=0.2.2 && <0.3, + utility-ht >=0.0.7 && <0.1, base >=3 && <5 -Executable alsa-seq-list-clients - Main-Is: list-clients.hs +Executable alsa-seq-list-ports + Main-Is: list-ports.hs If !flag(buildExamples) Buildable: False Hs-Source-Dirs: src, examples + Include-Dirs: src If flag(modifyFilter) Hs-Source-Dirs: filter/modify Else Hs-Source-Dirs: filter/setget - GHC-Options: -Wall -threaded + GHC-Options: -Wall Extensions: ForeignFunctionInterface GeneralizedNewtypeDeriving @@ -217,19 +249,24 @@ Sound.ALSA.Sequencer.Marshal.Sequencer Sound.ALSA.Sequencer.Marshal.Address Sound.ALSA.Sequencer.Marshal.Client + Sound.ALSA.Sequencer.Marshal.ClientInfo + Sound.ALSA.Sequencer.Marshal.Connect Sound.ALSA.Sequencer.Marshal.Port + Sound.ALSA.Sequencer.Marshal.PortInfo Sound.ALSA.Sequencer.Marshal.Queue - Sound.ALSA.Sequencer.Marshal.QueueTimer Sound.ALSA.Sequencer.Marshal.Event Sound.ALSA.Sequencer.Marshal.RealTime - Sound.ALSA.Sequencer.Marshal.QuerySubscribe + Sound.ALSA.Sequencer.Marshal.Time Sound.ALSA.Sequencer.Area Sound.ALSA.Sequencer.Sequencer Build-Depends: alsa-core >=0.5 && <0.6, - enumset >= 0.0.2 && <0.1, - array >= 0.1 && <0.5, - utility-ht >= 0.0.7 && <0.1, + enumset >=0.0.3 && <0.1, + transformers >=0.2 && <0.4, + array >=0.1 && <0.5, + bytestring >=0.9 && <0.10, + data-accessor >=0.2.2 && <0.3, + utility-ht >=0.0.7 && <0.1, base >=3 && <5 Executable alsa-seq-melody @@ -237,11 +274,12 @@ If !flag(buildExamples) Buildable: False Hs-Source-Dirs: src, examples + Include-Dirs: src If flag(modifyFilter) Hs-Source-Dirs: filter/modify Else Hs-Source-Dirs: filter/setget - GHC-Options: -Wall -threaded + GHC-Options: -Wall Extensions: ForeignFunctionInterface GeneralizedNewtypeDeriving @@ -250,19 +288,25 @@ Sound.ALSA.Sequencer.Marshal.Sequencer Sound.ALSA.Sequencer.Marshal.Address Sound.ALSA.Sequencer.Marshal.Client + Sound.ALSA.Sequencer.Marshal.ClientInfo + Sound.ALSA.Sequencer.Marshal.Connect Sound.ALSA.Sequencer.Marshal.Port + Sound.ALSA.Sequencer.Marshal.PortInfo Sound.ALSA.Sequencer.Marshal.Queue - Sound.ALSA.Sequencer.Marshal.QueueTimer Sound.ALSA.Sequencer.Marshal.Event Sound.ALSA.Sequencer.Marshal.RealTime - Sound.ALSA.Sequencer.Marshal.QuerySubscribe + Sound.ALSA.Sequencer.Marshal.Time Sound.ALSA.Sequencer.Area Sound.ALSA.Sequencer.Sequencer + Common Build-Depends: alsa-core >=0.5 && <0.6, - enumset >= 0.0.2 && <0.1, - array >= 0.1 && <0.5, - utility-ht >= 0.0.7 && <0.1, + enumset >=0.0.3 && <0.1, + transformers >=0.2 && <0.4, + array >=0.1 && <0.5, + bytestring >=0.9 && <0.10, + data-accessor >=0.2.2 && <0.3, + utility-ht >=0.0.7 && <0.1, base >=3 && <5 Executable alsa-seq-list-subscribers @@ -270,11 +314,12 @@ If !flag(buildExamples) Buildable: False Hs-Source-Dirs: src, examples + Include-Dirs: src If flag(modifyFilter) Hs-Source-Dirs: filter/modify Else Hs-Source-Dirs: filter/setget - GHC-Options: -Wall -threaded + GHC-Options: -Wall Extensions: ForeignFunctionInterface GeneralizedNewtypeDeriving @@ -283,17 +328,105 @@ Sound.ALSA.Sequencer.Marshal.Sequencer Sound.ALSA.Sequencer.Marshal.Address Sound.ALSA.Sequencer.Marshal.Client + Sound.ALSA.Sequencer.Marshal.ClientInfo + Sound.ALSA.Sequencer.Marshal.Connect Sound.ALSA.Sequencer.Marshal.Port + Sound.ALSA.Sequencer.Marshal.PortInfo Sound.ALSA.Sequencer.Marshal.Queue - Sound.ALSA.Sequencer.Marshal.QueueTimer Sound.ALSA.Sequencer.Marshal.Event Sound.ALSA.Sequencer.Marshal.RealTime - Sound.ALSA.Sequencer.Marshal.QuerySubscribe + Sound.ALSA.Sequencer.Marshal.Time Sound.ALSA.Sequencer.Area Sound.ALSA.Sequencer.Sequencer + Sound.ALSA.Sequencer.Subscribe.Query Build-Depends: alsa-core >=0.5 && <0.6, - enumset >= 0.0.2 && <0.1, - array >= 0.1 && <0.5, - utility-ht >= 0.0.7 && <0.1, + enumset >=0.0.3 && <0.1, + transformers >=0.2 && <0.4, + array >=0.1 && <0.5, + bytestring >=0.9 && <0.10, + data-accessor >=0.2.2 && <0.3, + utility-ht >=0.0.7 && <0.1, + base >=3 && <5 + +Executable alsa-seq-beat + Main-Is: beat.hs + If !flag(buildExamples) + Buildable: False + Hs-Source-Dirs: src, examples + Include-Dirs: src + If flag(modifyFilter) + Hs-Source-Dirs: filter/modify + Else + Hs-Source-Dirs: filter/setget + GHC-Options: -Wall + Extensions: + ForeignFunctionInterface + GeneralizedNewtypeDeriving + EmptyDataDecls + Other-modules: + Sound.ALSA.Sequencer.Marshal.Sequencer + Sound.ALSA.Sequencer.Marshal.Address + Sound.ALSA.Sequencer.Marshal.Client + Sound.ALSA.Sequencer.Marshal.ClientInfo + Sound.ALSA.Sequencer.Marshal.Connect + Sound.ALSA.Sequencer.Marshal.Port + Sound.ALSA.Sequencer.Marshal.PortInfo + Sound.ALSA.Sequencer.Marshal.Queue + Sound.ALSA.Sequencer.Marshal.Event + Sound.ALSA.Sequencer.Marshal.RealTime + Sound.ALSA.Sequencer.Marshal.Time + Sound.ALSA.Sequencer.Area + Sound.ALSA.Sequencer.Sequencer + Sound.ALSA.Sequencer.Event.Remove + Common + Build-Depends: + alsa-core >=0.5 && <0.6, + enumset >=0.0.3 && <0.1, + transformers >=0.2 && <0.4, + array >=0.1 && <0.5, + bytestring >=0.9 && <0.10, + data-accessor >=0.2.2 && <0.3, + utility-ht >=0.0.7 && <0.1, + base >=3 && <5 + +Executable alsa-seq-sysex + Main-Is: sysex.hs + If !flag(buildExamples) + Buildable: False + Hs-Source-Dirs: src, examples + Include-Dirs: src + If flag(modifyFilter) + Hs-Source-Dirs: filter/modify + Else + Hs-Source-Dirs: filter/setget + GHC-Options: -Wall + Extensions: + ForeignFunctionInterface + GeneralizedNewtypeDeriving + EmptyDataDecls + Other-modules: + Sound.ALSA.Sequencer.Marshal.Sequencer + Sound.ALSA.Sequencer.Marshal.Address + Sound.ALSA.Sequencer.Marshal.Client + Sound.ALSA.Sequencer.Marshal.ClientInfo + Sound.ALSA.Sequencer.Marshal.Connect + Sound.ALSA.Sequencer.Marshal.Port + Sound.ALSA.Sequencer.Marshal.PortInfo + Sound.ALSA.Sequencer.Marshal.Queue + Sound.ALSA.Sequencer.Marshal.Event + Sound.ALSA.Sequencer.Marshal.RealTime + Sound.ALSA.Sequencer.Marshal.Time + Sound.ALSA.Sequencer.Area + Sound.ALSA.Sequencer.Sequencer + Sound.ALSA.Sequencer.Subscribe.Query + Common + Build-Depends: + alsa-core >=0.5 && <0.6, + enumset >=0.0.3 && <0.1, + transformers >=0.2 && <0.4, + array >=0.1 && <0.5, + bytestring >=0.9 && <0.10, + data-accessor >=0.2.2 && <0.3, + utility-ht >=0.0.7 && <0.1, base >=3 && <5 diff --git a/examples/Common.hs b/examples/Common.hs new file mode 100644 --- /dev/null +++ b/examples/Common.hs @@ -0,0 +1,35 @@ +module Common where + +import qualified Sound.ALSA.Sequencer.Connect as Connect +import qualified Sound.ALSA.Sequencer.Address as Addr +import qualified Sound.ALSA.Sequencer.Port as Port +import qualified Sound.ALSA.Sequencer as SndSeq + +import qualified System.Exit as Exit +import qualified System.IO as IO + + +parseAndConnect :: + (SndSeq.AllowOutput mode) => + SndSeq.T mode -> Port.T -> String -> IO Connect.T +parseAndConnect h p dest = + Connect.createTo h p =<< Addr.parse h dest + +parseDestArgs :: + (SndSeq.AllowOutput mode) => + SndSeq.T mode -> Addr.T -> [String] -> IO Connect.T +parseDestArgs h me args = do + let p = Addr.port me + case args of + [] -> do + putStrLn "Enter destination or connect to a synthesizer and hit ENTER" + destStr <- getLine + if null destStr + then return (Connect.toSubscribers me) + else parseAndConnect h p destStr + [destStr] -> + parseAndConnect h p destStr + _ -> + IO.hPutStrLn IO.stderr "too many arguments" + >> + Exit.exitFailure diff --git a/examples/beat.hs b/examples/beat.hs new file mode 100644 --- /dev/null +++ b/examples/beat.hs @@ -0,0 +1,201 @@ +{- | +Play two precisely timed beats simultaneously +where the speed can be controlled by MIDI controllers. + +Whenever the speed is changed we have to cancel +the events that are already scheduled. +So we use this example to demonstrate removing output events. +-} +import qualified Sound.ALSA.Sequencer.Connect as Connect +import qualified Sound.ALSA.Sequencer.Address as Addr +import qualified Sound.ALSA.Sequencer.Client as Client +import qualified Sound.ALSA.Sequencer.Port.InfoMonad as PortInfo +import qualified Sound.ALSA.Sequencer.Port as Port +import qualified Sound.ALSA.Sequencer.Event.RemoveMonad as Remove +import qualified Sound.ALSA.Sequencer.Event as Event +import qualified Sound.ALSA.Sequencer.Queue as Queue +import qualified Sound.ALSA.Sequencer.RealTime as RealTime +import qualified Sound.ALSA.Sequencer.Time as Time +import qualified Sound.ALSA.Sequencer as SndSeq +import qualified Sound.ALSA.Exception as AlsaExc + +import System.Environment (getArgs, ) +import qualified System.Exit as Exit +import qualified System.IO as IO + +import Control.Monad (mplus, ) +import Data.Maybe.HT (toMaybe, ) + + +data Message = Echo Event.Tag | Tempo Event.Tag Event.Value Double + deriving (Show) + + +data Track = + Track { + tag :: Event.Tag, + pitch :: Event.Pitch, + defaultPeriod, range :: Double, + cc :: Event.Parameter + } + + +trackA, trackB :: Track + +trackA = + Track { + tag = Event.Tag 0, + pitch = Event.Pitch 60, + defaultPeriod = 1, + range = 2, + cc = Event.Parameter 16 + } + +trackB = + Track { + tag = Event.Tag 1, + pitch = Event.Pitch 64, + defaultPeriod = 1/7, + range = 2, + cc = Event.Parameter 17 + } + + +data State = State { _lastTime, _remainingPortion, _period :: Double } + +initState :: Track -> State +initState track = State 0 0 (defaultPeriod track) + + +main :: IO () +main = (do + SndSeq.withDefault SndSeq.Block $ \h -> do + Client.setName (h :: SndSeq.T SndSeq.DuplexMode) "Haskell-Beat" + Port.withSimple h "inout" + (Port.caps [Port.capRead, Port.capSubsRead, + Port.capWrite, Port.capSubsWrite]) + (Port.types [Port.typeMidiGeneric, Port.typeApplication]) $ \public -> do + Port.withSimple h "private" + (Port.caps [Port.capRead, Port.capWrite]) + (Port.types [Port.typeMidiGeneric]) $ \private -> do + Queue.with h $ \q -> do + + PortInfo.modify h public $ do + PortInfo.setTimestamping True + PortInfo.setTimestampReal True + PortInfo.setTimestampQueue q + + c <- Client.getId h + let publicAddr = Addr.Cons c public + privateAddr = Addr.Cons c private + args <- getArgs + case args of + [input, output] -> + (Connect.createFrom h public =<< Addr.parse h input) + >> + (Connect.createTo h public =<< Addr.parse h output) + >> + return () + _ -> + IO.hPutStrLn IO.stderr "need arguments: input-client output-client" + >> + Exit.exitFailure + + let mkEv tg t e = + (Event.simple publicAddr e) { + Event.tag = tg, + Event.queue = q, + Event.time = Time.consAbs $ Time.Real $ RealTime.fromDouble t + } + + play tg t onoff p = + (Event.output h $ mkEv tg t $ Event.NoteEv onoff $ + Event.simpleNote (Event.Channel 0) p Event.normalVelocity) + >> + return () + + echo tg t = + Event.output h + ((mkEv tg t $ Event.CustomEv Event.Echo $ Event.Custom 0 0 0) { + Event.dest = privateAddr + }) + >> + return () + + Queue.control h q Event.QueueStart Nothing + + let start track = do + play (tag track) 0 Event.NoteOn (pitch track) + echo (tag track) 0 + + start trackA + start trackB + _ <- Event.drainOutput h + + let checkCC ctrl track = + toMaybe (Event.ctrlParam ctrl == cc track) (tag track) + + wait = do + ev <- Event.input h + case Event.body ev of + Event.CustomEv Event.Echo _ -> + if Event.dest ev == privateAddr + then return $ Echo $ Event.tag ev + else wait + Event.CtrlEv Event.Controller ctrl -> + case mplus (checkCC ctrl trackA) (checkCC ctrl trackB) of + Just tg -> + case Event.time ev of + Time.Cons Time.Absolute (Time.Real t) -> + return $ Tempo tg (Event.ctrlValue ctrl) $ + RealTime.toDouble t + _ -> error "got time in a format that we did not request" + Nothing -> wait + _ -> wait + + let schedule track t = do + play (tag track) t Event.NoteOff (pitch track) + play (tag track) t Event.NoteOn (pitch track) + echo (tag track) t + _ <- Event.drainOutput h + return () + + {- + Cancel the Echo and Notes we already sent, + and replace them by ones with updated timestamp. + -} + let tempo track val t1 (State t0 r0 p0) = do + Remove.run h $ do + Remove.setOutput + Remove.setTag $ tag track + let r1 = r0 - (t1-t0) / p0 + let p1 = defaultPeriod track * + range track ** ((fromIntegral val - 64) / 64) + schedule track $ t1 + r1 * p1 + return (State t1 r1 p1) + + let next track (State t0 r p) = + let {- + t1 should be the current time. + In principle we could use the timestamp from the Echo message, + but this will be slightly later than the reference time. + -} + t1 = t0 + r*p + in schedule track (t1+p) >> return (State t1 1 p) + + let go (sa, sb) = do + msg <- wait + case msg of + Echo tg -> + if tg == tag trackA + then next trackA sa >>= \s -> go (s, sb) + else next trackB sb >>= \s -> go (sa, s) + Tempo tg (Event.Value val) t -> + if tg == tag trackA + then tempo trackA val t sa >>= \s -> go (s, sb) + else tempo trackB val t sb >>= \s -> go (sa, s) + + go (initState trackA, initState trackB)) + + `AlsaExc.catch` \e -> + putStrLn $ "alsa_exception: " ++ AlsaExc.show e diff --git a/examples/broadcast.hs b/examples/broadcast.hs --- a/examples/broadcast.hs +++ b/examples/broadcast.hs @@ -8,18 +8,19 @@ main :: IO () main = (do putStrLn "Starting." - SndSeq.with SndSeq.defaultName SndSeq.Block $ \h -> do + SndSeq.withDefault SndSeq.Block $ \h -> do Client.setName (h :: SndSeq.T SndSeq.OutputMode) "Haskell-Broadcast" c <- Client.getId h putStrLn ("Created sequencer with id: " ++ show c) - -- tgt_addr <- Addr.parse h "HS1:255" - let tgt_addr = Addr.Cons Client.broadcast Port.unknown - print tgt_addr + -- dst <- Addr.parse h "HS1:255" + let dst = Addr.broadcast + print dst let ev n = (Event.simple (Addr.Cons c Port.unknown) - (Event.NoteEv n $ Event.simpleNote 0 60 64)) - {Event.dest = tgt_addr} + (Event.NoteEv n $ + Event.simpleNote (Event.Channel 0) (Event.Pitch 60) Event.normalVelocity)) + {Event.dest = dst} _ <- Event.outputDirect h $ ev Event.NoteOn _ <- getChar _ <- Event.outputDirect h $ ev Event.NoteOff diff --git a/examples/dump.hs b/examples/dump.hs --- a/examples/dump.hs +++ b/examples/dump.hs @@ -8,7 +8,7 @@ main :: IO () main = (do putStrLn "Starting." - SndSeq.with SndSeq.defaultName SndSeq.Block $ \h -> do + SndSeq.withDefault SndSeq.Block $ \h -> do Client.setName (h :: SndSeq.T SndSeq.InputMode) "Haskell-Dump" putStrLn "Created sequencer." Port.withSimple h "primary" diff --git a/examples/list-clients.hs b/examples/list-clients.hs deleted file mode 100644 --- a/examples/list-clients.hs +++ /dev/null @@ -1,13 +0,0 @@ -import qualified Sound.ALSA.Sequencer.Client.Info as ClientInfo -import qualified Sound.ALSA.Sequencer as SndSeq - -import Control.Monad (when, ) - -main :: IO () -main = - SndSeq.with SndSeq.defaultName SndSeq.Block $ \h -> do - i <- ClientInfo.queryFirst (h :: SndSeq.T SndSeq.OutputMode) - let loop = do putStrLn =<< ClientInfo.getName i - more <- ClientInfo.queryNext h i - when more loop - loop diff --git a/examples/list-ports.hs b/examples/list-ports.hs new file mode 100644 --- /dev/null +++ b/examples/list-ports.hs @@ -0,0 +1,31 @@ +import qualified Sound.ALSA.Sequencer.Client.Info as ClientInfo +import qualified Sound.ALSA.Sequencer.Port.Info as PortInfo +import qualified Sound.ALSA.Sequencer.Client as Client +import qualified Sound.ALSA.Sequencer.Port as Port +import qualified Sound.ALSA.Sequencer as SndSeq +import qualified Data.EnumSet as EnumSet +import Text.Printf (printf, ) +import Control.Monad (liftM5, join, ) + +main :: IO () +main = do + putStrLn " Port Client name Port name Caps" + SndSeq.withDefault SndSeq.Block $ \h -> + ClientInfo.queryLoop_ (h :: SndSeq.T SndSeq.OutputMode) $ \cinfo -> do + client <- ClientInfo.getClient cinfo + PortInfo.queryLoop_ h client $ \pinfo -> do + join $ liftM5 (printf "%3d:%-3d %-32.32s %-24.24s %s\n") + (fmap (\(Client.Cons p) -> p) $ PortInfo.getClient pinfo) + (fmap (\(Port.Cons p) -> p) $ PortInfo.getPort pinfo) + (ClientInfo.getName cinfo) + (PortInfo.getName pinfo) + (do + caps <- PortInfo.getCapability pinfo + let disp (cap, char) = + if EnumSet.disjoint caps cap then ' ' else char + return $ map disp $ + (Port.capRead, 'r') : + (Port.capSubsRead, 'R') : + (Port.capWrite, 'w') : + (Port.capSubsWrite, 'W') : + []) diff --git a/examples/list-subscribers.hs b/examples/list-subscribers.hs --- a/examples/list-subscribers.hs +++ b/examples/list-subscribers.hs @@ -8,7 +8,7 @@ main :: IO () main = (do args <- getArgs - SndSeq.with SndSeq.defaultName SndSeq.Block $ \h -> forM_ args $ \arg -> do + SndSeq.withDefault SndSeq.Block $ \h -> forM_ args $ \arg -> do a <- Addr.parse (h :: SndSeq.T SndSeq.InputMode) arg let showQ q = do ad <- Query.getAddr q diff --git a/examples/melody.hs b/examples/melody.hs --- a/examples/melody.hs +++ b/examples/melody.hs @@ -3,67 +3,45 @@ Demonstrate how to wait on the end of a performance of events, by sending an Echo message to ourselves. -} +import Common (parseDestArgs, ) + import qualified Sound.ALSA.Sequencer.Address as Addr import qualified Sound.ALSA.Sequencer.Client as Client import qualified Sound.ALSA.Sequencer.Port as Port import qualified Sound.ALSA.Sequencer.Event as Event import qualified Sound.ALSA.Sequencer.Queue as Queue +import qualified Sound.ALSA.Sequencer.Time as Time import qualified Sound.ALSA.Sequencer as SndSeq import qualified Sound.ALSA.Exception as AlsaExc -import qualified System.Exit as Exit -import qualified System.IO as IO import System.Environment (getArgs, ) import Control.Monad (zipWithM_, ) -parseAndConnect :: - (SndSeq.AllowOutput mode) => - SndSeq.T mode -> Port.T -> String -> IO Addr.T -parseAndConnect h p destStr = do - dest <- Addr.parse h destStr - SndSeq.connectTo h p dest - return dest - main :: IO () main = (do - SndSeq.with SndSeq.defaultName SndSeq.Block $ \h -> do + SndSeq.withDefault SndSeq.Block $ \h -> do Client.setName (h :: SndSeq.T SndSeq.DuplexMode) "Haskell-Melody" Port.withSimple h "out" (Port.caps [Port.capRead, Port.capSubsRead, Port.capWrite]) (Port.types [Port.typeMidiGeneric, Port.typeApplication]) $ \p -> do Queue.with h $ \q -> do - args <- getArgs - dest <- - case args of - [] -> do - putStrLn "Enter destination or connect to a synthesizer and hit ENTER" - destStr <- getLine - if null destStr - then return Addr.subscribers - else parseAndConnect h p destStr - [destStr] -> - parseAndConnect h p destStr - _ -> - IO.hPutStrLn IO.stderr "too many arguments" - >> - Exit.exitFailure - c <- Client.getId h let me = Addr.Cons c p - ev t e = - (Event.simple me e) { + conn <- parseDestArgs h me =<< getArgs + + let ev t e = + (Event.forConnection conn e) { Event.queue = q, - Event.dest = dest, - Event.timestamp = Event.TickTime t + Event.time = Time.consAbs $ Time.Tick t } - play t chan pitch vel = + play t chan pitch = Event.output h (ev t $ - Event.NoteEv Event.NoteOn $ Event.simpleNote chan pitch vel) + Event.NoteEv Event.NoteOn $ Event.simpleNote chan pitch Event.normalVelocity) >> Event.output h (ev (t+1) $ - Event.NoteEv Event.NoteOn $ Event.simpleNote chan pitch 0) + Event.NoteEv Event.NoteOff $ Event.simpleNote chan pitch Event.normalVelocity) >> return () @@ -73,12 +51,13 @@ Event.dest = me }) - Queue.control h q Event.QueueStart 0 Nothing - Queue.control h q Event.QueueTempo 10000000 Nothing + Queue.control h q Event.QueueStart Nothing + Queue.control h q (Event.QueueTempo (Event.Tempo 10000000)) Nothing zipWithM_ (\t -> - maybe (echo t) (\n -> play t 0 n 64)) [0..] $ + maybe (echo t) (play t (Event.Channel 0))) [0..] $ (++[Nothing]) $ concat $ concatMap (replicate 4 . map Just) $ + map (map Event.Pitch) $ [57, 59, 60, 64] : [57, 59, 60, 65] : [57, 62, 64, 65] : diff --git a/examples/send-note.hs b/examples/send-note.hs --- a/examples/send-note.hs +++ b/examples/send-note.hs @@ -1,3 +1,5 @@ +import Common (parseDestArgs, ) + import qualified Sound.ALSA.Sequencer.Address as Addr import qualified Sound.ALSA.Sequencer.Client as Client import qualified Sound.ALSA.Sequencer.Port as Port @@ -5,48 +7,23 @@ import qualified Sound.ALSA.Sequencer as SndSeq import qualified Sound.ALSA.Exception as AlsaExc -import qualified System.Exit as Exit -import qualified System.IO as IO import System.Environment (getArgs, ) -parseAndConnect :: - (SndSeq.AllowOutput mode) => - SndSeq.T mode -> Port.T -> String -> IO Addr.T -parseAndConnect h p destStr = do - dest <- Addr.parse h destStr - SndSeq.connectTo h p dest - return dest main :: IO () main = (do putStrLn "Starting." - SndSeq.with SndSeq.defaultName SndSeq.Block $ \h -> do + SndSeq.withDefault SndSeq.Block $ \h -> do Client.setName (h :: SndSeq.T SndSeq.OutputMode) "Haskell-Send-Note" c <- Client.getId h putStrLn ("Created sequencer with id: " ++ show c) Port.withSimple h "out" (Port.caps [Port.capRead, Port.capSubsRead]) Port.typeMidiGeneric $ \ p -> do putStrLn "Created port." - args <- getArgs - dest <- - case args of - [] -> do - putStrLn "Enter destination or connect to a synthesizer and hit ENTER" - destStr <- getLine - if null destStr - then return Addr.subscribers - else parseAndConnect h p destStr - [destStr] -> - parseAndConnect h p destStr - _ -> - IO.hPutStrLn IO.stderr "too many arguments" - >> - Exit.exitFailure - + conn <- parseDestArgs h (Addr.Cons c p) =<< getArgs let ev n = - (Event.simple (Addr.Cons c p) $ - Event.NoteEv n $ Event.simpleNote 0 60 64) - {Event.dest = dest} + Event.forConnection conn $ Event.NoteEv n $ + Event.simpleNote (Event.Channel 0) (Event.Pitch 60) Event.normalVelocity _ <- Event.outputDirect h $ ev Event.NoteOn putStrLn "press Enter for stopping the note" _ <- getChar diff --git a/examples/sysex.hs b/examples/sysex.hs new file mode 100644 --- /dev/null +++ b/examples/sysex.hs @@ -0,0 +1,46 @@ +import Common (parseDestArgs, ) + +import qualified Sound.ALSA.Sequencer.Connect as Connect +import qualified Sound.ALSA.Sequencer.Address as Addr +import qualified Sound.ALSA.Sequencer.Client as Client +import qualified Sound.ALSA.Sequencer.Port as Port +import qualified Sound.ALSA.Sequencer.Event as Event +import qualified Sound.ALSA.Sequencer as SndSeq +import qualified Sound.ALSA.Exception as AlsaExc + +import qualified Data.ByteString as B + +import System.Environment (getArgs, ) + + +main :: IO () +main = (do + putStrLn "Starting." + SndSeq.withDefault SndSeq.Block $ \h -> do + Client.setName (h :: SndSeq.T SndSeq.DuplexMode) "Haskell-SysEx" + c <- Client.getId h + putStrLn ("Created sequencer with id: " ++ show c) + Port.withSimple h "out" + (Port.caps [Port.capRead, Port.capSubsRead, + Port.capWrite, Port.capSubsWrite]) Port.typeMidiGeneric $ \ p -> do + putStrLn "Created port." + let me = Addr.Cons c p + conn <- parseDestArgs h me =<< getArgs + + putStrLn "enter a text line for submission as SysEx message" + text <- getLine + let dat = + Event.ExtEv Event.SysEx $ + B.pack $ map (fromIntegral . fromEnum) text + _ <- Event.outputDirect h $ Event.forConnection conn dat + _ <- Event.outputDirect h $ Event.forConnection (Connect.Cons me me) dat + let waitForSysEx = do + ev <- Event.input h + case Event.body ev of + Event.ExtEv Event.SysEx str -> + putStrLn $ "got: " ++ show str + _ -> waitForSysEx + waitForSysEx + return ()) + `AlsaExc.catch` \e -> + putStrLn $ "alsa_exception: " ++ AlsaExc.show e diff --git a/filter/modify/Sound/ALSA/Sequencer/Client/Info/EventFilter.hs b/filter/modify/Sound/ALSA/Sequencer/Client/Info/EventFilter.hs --- a/filter/modify/Sound/ALSA/Sequencer/Client/Info/EventFilter.hs +++ b/filter/modify/Sound/ALSA/Sequencer/Client/Info/EventFilter.hs @@ -1,42 +1,41 @@ module Sound.ALSA.Sequencer.Client.Info.EventFilter where -import qualified Sound.ALSA.Sequencer.Area as Area +import Sound.ALSA.Sequencer.Marshal.ClientInfo (T, T_, with, ) import qualified Sound.ALSA.Sequencer.Marshal.Event as Event -import Foreign.C.Types(CInt, ) +import qualified Foreign.C.Types as C import Foreign.Ptr(Ptr, ) -type T = Area.ClientInfo -type T_ = Area.ClientInfo_ - - clear :: T -> IO () add :: Event.Type e => T -> e -> IO () delete :: Event.Type e => T -> e -> IO () check :: Event.Type e => T -> e -> IO Bool -clear i = - Area.with_client_info i snd_seq_client_info_event_filter_clear +clear i = with i clear_ foreign import ccall unsafe "alsa/asoundlib.h snd_seq_client_info_event_filter_clear" - snd_seq_client_info_event_filter_clear :: Ptr T_ -> IO () + clear_ :: Ptr T_ -> IO () add i e = - Area.with_client_info i (`snd_seq_client_info_event_filter_add` fromIntegral (Event.expEv e)) + with i (flip add_ $ unpackEType e) foreign import ccall unsafe "alsa/asoundlib.h snd_seq_client_info_event_filter_add" - snd_seq_client_info_event_filter_add :: Ptr T_ -> CInt -> IO () + add_ :: Ptr T_ -> C.CInt -> IO () delete i e = - Area.with_client_info i (`snd_seq_client_info_event_filter_del` fromIntegral (Event.expEv e)) + with i (flip del_ $ unpackEType e) foreign import ccall unsafe "alsa/asoundlib.h snd_seq_client_info_event_filter_del" - snd_seq_client_info_event_filter_del :: Ptr T_ -> CInt -> IO () + del_ :: Ptr T_ -> C.CInt -> IO () check i e = - fmap (/= 0) $ Area.with_client_info i (`snd_seq_client_info_event_filter_check` fromIntegral (Event.expEv e)) + fmap (/= 0) $ with i (flip check_ $ unpackEType e) foreign import ccall unsafe "alsa/asoundlib.h snd_seq_client_info_event_filter_check" - snd_seq_client_info_event_filter_check :: Ptr T_ -> CInt -> IO CInt + check_ :: Ptr T_ -> C.CInt -> IO C.CInt + + +unpackEType :: Event.Type e => e -> C.CInt +unpackEType e = fromIntegral $ Event.unEType $ Event.expEv e diff --git a/filter/setget/Sound/ALSA/Sequencer/Client/Info/EventFilter.hs b/filter/setget/Sound/ALSA/Sequencer/Client/Info/EventFilter.hs --- a/filter/setget/Sound/ALSA/Sequencer/Client/Info/EventFilter.hs +++ b/filter/setget/Sound/ALSA/Sequencer/Client/Info/EventFilter.hs @@ -1,7 +1,7 @@ -- | Emulate new api using the old functions module Sound.ALSA.Sequencer.Client.Info.EventFilter where -import qualified Sound.ALSA.Sequencer.Area as Area +import Sound.ALSA.Sequencer.Marshal.ClientInfo (T, T_, with, ) import qualified Sound.ALSA.Sequencer.Marshal.Event as Event import Foreign.C.Types (CUInt, ) @@ -11,9 +11,6 @@ import Data.Bits (testBit, setBit, clearBit, ) -type T = Area.ClientInfo -type T_ = Area.ClientInfo_ - {- | Although alsa/seq.h says CUChar, that's not true, because internally it uses CUInt and @@ -28,13 +25,12 @@ delete :: Event.Type e => T -> e -> IO () check :: Event.Type e => T -> e -> IO Bool -clear i = - Area.with_client_info i (`snd_seq_client_info_set_event_filter` nullPtr) +clear i = with i (flip set_ nullPtr) bit :: Event.Type e => e -> (Int, Int) bit e = divMod - (fromIntegral $ Event.expEv e) + (fromIntegral $ Event.unEType $ Event.expEv e) (8 * sizeOf (undefined :: EventTypeSubset)) size :: Int @@ -42,7 +38,7 @@ -- succ $ fst $ bit Event.maxEventType get :: T -> IO EventTypeSet -get i = Area.with_client_info i snd_seq_client_info_get_event_filter +get i = with i get_ check i e = do ef <- get i @@ -51,8 +47,7 @@ return $ testBit w b set :: T -> EventTypeSet -> IO () -set i ef = - Area.with_client_info i (`snd_seq_client_info_set_event_filter` ef) +set i ef = with i (flip set_ ef) modify :: T -> (EventTypeSet -> IO ()) -> IO () modify i f = @@ -74,7 +69,7 @@ delete = modifyByte clearBit foreign import ccall unsafe "alsa/asoundlib.h snd_seq_client_info_get_event_filter" - snd_seq_client_info_get_event_filter :: Ptr T_ -> IO EventTypeSet + get_ :: Ptr T_ -> IO EventTypeSet foreign import ccall unsafe "alsa/asoundlib.h snd_seq_client_info_set_event_filter" - snd_seq_client_info_set_event_filter :: Ptr T_ -> EventTypeSet -> IO () + set_ :: Ptr T_ -> EventTypeSet -> IO () diff --git a/src/Sound/ALSA/Sequencer.hs b/src/Sound/ALSA/Sequencer.hs --- a/src/Sound/ALSA/Sequencer.hs +++ b/src/Sound/ALSA/Sequencer.hs @@ -26,8 +26,10 @@ , BlockMode(..) , open + , openDefault , close , with + , withDefault , defaultName , getName , setBlocking @@ -44,20 +46,7 @@ , resetPoolOutput , setPoolInput , resetPoolInput - - - -- ** Connections - , connectFrom - , connectTo - , disconnectFrom - , disconnectTo ) where import Sound.ALSA.Sequencer.Marshal.Sequencer as Seq import Sound.ALSA.Sequencer.Sequencer - - - --- | This is the name that should be passed to 'open' in most cases. -defaultName :: String -defaultName = "default" diff --git a/src/Sound/ALSA/Sequencer/Address.hs b/src/Sound/ALSA/Sequencer/Address.hs --- a/src/Sound/ALSA/Sequencer/Address.hs +++ b/src/Sound/ALSA/Sequencer/Address.hs @@ -1,20 +1,39 @@ module Sound.ALSA.Sequencer.Address ( Addr.T(Addr.Cons, Addr.client, Addr.port) + , Addr.unknown , Addr.subscribers + , Addr.broadcast + , Addr.systemTimer + , Addr.systemAnnounce , parse ) where import qualified Sound.ALSA.Sequencer.Marshal.Address as Addr -import qualified Sound.ALSA.Sequencer.Marshal.Sequencer as MSeq -import qualified Sound.ALSA.Sequencer.Sequencer as Seq +import qualified Sound.ALSA.Sequencer.Marshal.Sequencer as Seq +import qualified Sound.ALSA.Exception as Exc +import qualified Foreign.C.Types as C +import Foreign.C.String (CString, withCAString, ) +import Foreign.Ptr (Ptr, ) +import Foreign.Marshal.Alloc (alloca, ) +import Foreign.Storable (peek, ) + + {- | Parse the given string into sequencer address. The client and port are separated by either colon or period, e.g. 128:1. -The function also accepts client names. +The function also accepts client names or prefixes thereof. +Throws @(Errno 2)@ exception if no client name matches. -} parse - :: MSeq.T mode -- ^ Sequencer handle. + :: Seq.T mode -- ^ Sequencer handle. -> String -- ^ String to be parsed. -> IO Addr.T -- ^ The parsed address. -parse = Seq.parseAddress +parse (Seq.Cons h) s = + alloca $ \pa -> + withCAString s $ \ps -> + do Exc.checkResult_ "Address.parse" =<< snd_seq_parse_address h pa ps + peek pa + +foreign import ccall unsafe "alsa/asoundlib.h snd_seq_parse_address" + snd_seq_parse_address :: Ptr Seq.Core -> Ptr Addr.T -> CString -> IO C.CInt diff --git a/src/Sound/ALSA/Sequencer/Area.h b/src/Sound/ALSA/Sequencer/Area.h new file mode 100644 --- /dev/null +++ b/src/Sound/ALSA/Sequencer/Area.h @@ -0,0 +1,188 @@ +#include + +#define hsc_alignment(t) \ + printf("(%ld)", (unsigned long)offsetof(struct {char x__; t (y__); }, y__)); + +char *area_name = NULL; + +#define hsc_area(y) \ + area_name = ""y""; \ + puts( \ + "data T_\n" \ + "newtype T = Cons (Area.ForeignPtr T_)\n" \ + "\n" \ + "with :: T -> (Area.Ptr T_ -> IO a) -> IO a\n" \ + "with (Cons p) f = Area.withForeignPtr p f\n" \ + "\n" \ + "-- | Allocate an uninitialized object. (Not exported)\n" \ + "malloc :: IO T\n" \ + "malloc = Area.alloca $ \\p ->\n" \ + " do Exc.checkResult_ \"Sequencer."y"\" =<< malloc_ p\n" \ + " fmap Cons (Area.newForeignPtr free =<< Area.peek p)\n" \ + "\n" \ + "foreign import ccall unsafe \"alsa/asoundlib.h snd_seq_"y"_malloc\"\n" \ + " malloc_ :: Area.Ptr (Area.Ptr T_) -> IO C.CInt\n" \ + "\n" \ + "foreign import ccall unsafe \"alsa/asoundlib.h &snd_seq_"y"_free\"\n" \ + " free :: Area.FunPtr (Area.Ptr T_ -> IO ())\n" \ + "\n" \ + "-- | Copy the content of one object into another.\n" \ + "copy\n" \ + " :: T -- ^ Destination\n" \ + " -> T -- ^ Source\n" \ + " -> IO ()\n" \ + "\n" \ + "copy to from =\n" \ + " with to $ \\p1 ->\n" \ + " with from $ \\p2 ->\n" \ + " copy_ p1 p2\n" \ + "\n" \ + "foreign import ccall unsafe \"alsa/asoundlib.h snd_seq_"y"_copy\"\n" \ + " copy_ :: Area.Ptr T_ -> Area.Ptr T_ -> IO ()\n" \ + "\n" \ + "-- | Copy the content of an object to a newly created object.\n" \ + "clone :: T -> IO T\n" \ + "clone from =\n" \ + " do to <- malloc\n" \ + " copy to from\n" \ + " return to\n" \ + "\n" \ + "instance Area.C T where\n" \ + " malloc = malloc\n" \ + " copy = copy\n" \ + " clone = clone\n" \ + "\n" \ + ); + +#define hsc_get_area(x) \ + printf( \ + "get :: Seq.T mode -> "x" -> IO T\n" \ + "get h q =\n" \ + " do status <- malloc\n" \ + " Exc.checkResult_ \"get_%s\"\n" \ + " =<< with status (get_ h q)\n" \ + " return status\n" \ + "\n" \ + "foreign import ccall unsafe \"alsa/asoundlib.h snd_seq_get_%s\"\n" \ + " get_ :: Seq.T mode -> "x" -> Area.Ptr T_ -> IO C.CInt\n" \ + , area_name, area_name); + +#define hsc_set_area(x) \ + printf( \ + "set :: Seq.T mode -> "x" -> T -> IO ()\n" \ + "set h q info =\n" \ + " Exc.checkResult_ \"set_%s\" =<< with info (set_ h q)\n" \ + "\n" \ + "foreign import ccall unsafe \"alsa/asoundlib.h snd_seq_set_%s\"\n" \ + " set_ :: Seq.T mode -> "x" -> Area.Ptr T_ -> IO C.CInt\n" \ + , area_name, area_name); + + + +#define hsc_get_set_name() \ + printf( \ + "getName :: T -> IO String\n" \ + "getName i = Area.peekCString =<< with i getName_\n" \ + "\n" \ + "foreign import ccall unsafe \"alsa/asoundlib.h snd_seq_%s_get_name\"\n" \ + " getName_ :: Area.Ptr T_ -> IO Area.CString\n" \ + "\n" \ + "setName :: T -> String -> IO ()\n" \ + "setName i c =\n" \ + " Area.withCAString c $ \\p -> with i (flip setName_ p)\n" \ + "\n" \ + "foreign import ccall unsafe \"alsa/asoundlib.h snd_seq_%s_set_name\"\n" \ + " setName_ :: Area.Ptr T_ -> Area.CString -> IO ()\n" \ + "\n" \ + , area_name, area_name); + +#define hsc_get_bool(z,nm) \ + printf( \ + "get"nm" :: T -> IO Bool\n" \ + "get"nm" i =\n" \ + " fmap (0 /=) $ with i get"nm"_\n" \ + "\n" \ + "foreign import ccall unsafe \"alsa/asoundlib.h snd_seq_%s_get_"z"\"\n" \ + " get"nm"_ :: Area.Ptr T_ -> IO C.CInt\n" \ + "\n" \ + , area_name); + +#define hsc_set_bool(z,nm) \ + printf( \ + "set"nm" :: T -> Bool -> IO ()\n" \ + "set"nm" i c =\n" \ + " let x = if c then 1 else 0\n" \ + " in with i (flip set"nm"_ x)\n" \ + "\n" \ + "foreign import ccall unsafe \"alsa/asoundlib.h snd_seq_%s_set_"z"\"\n" \ + " set"nm"_ :: Area.Ptr T_ -> C.CInt -> IO ()\n" \ + "\n" \ + , area_name); + +#define hsc_get_set_bool(z,nm) \ + hsc_get_bool(z,nm) \ + hsc_set_bool(z,nm) + +#define hsc_get_int_gen(z,nm,t,mk,int) \ + printf( \ + "get"nm" :: T -> IO "t"\n" \ + "get"nm" i =\n" \ + " fmap "mk" $ with i get"nm"_\n" \ + "\n" \ + "foreign import ccall unsafe \"alsa/asoundlib.h snd_seq_%s_get_"z"\"\n" \ + " get"nm"_ :: Area.Ptr T_ -> IO "int"\n" \ + "\n" \ + , area_name); + +#define hsc_set_int_gen(z,nm,t,brk,int) \ + printf( \ + "set"nm" :: T -> "t" -> IO ()\n" \ + "set"nm" i c =\n" \ + " with i (flip set"nm"_ ("brk" c))\n" \ + "\n" \ + "foreign import ccall unsafe \"alsa/asoundlib.h snd_seq_%s_set_"z"\"\n" \ + " set"nm"_ :: Area.Ptr T_ -> "int" -> IO ()\n" \ + "\n" \ + , area_name); + +#define hsc_get_set_int_gen(z,nm,t,mk,brk,int) \ + hsc_get_int_gen(z,nm,t,mk,int) \ + hsc_set_int_gen(z,nm,t,brk,int) + + +#define hsc_get_int(z,nm,t,mk) \ + hsc_get_int_gen(z,nm,t,mk,"C.CInt") + +#define hsc_set_int(z,nm,t,brk) \ + hsc_set_int_gen(z,nm,t,brk,"C.CInt") + +#define hsc_get_set_int(z,nm,t,mk,brk) \ + hsc_get_int(z,nm,t,mk) \ + hsc_set_int(z,nm,t,brk) + + +#define hsc_get_ptr(z,nm,t) \ + printf( \ + "get"nm" :: T -> IO "t"\n" \ + "get"nm" i =\n" \ + " Area.peek =<< with i get"nm"_\n" \ + "\n" \ + "foreign import ccall unsafe \"alsa/asoundlib.h snd_seq_%s_get_"z"\"\n" \ + " get"nm"_ :: Area.Ptr T_ -> IO (Area.Ptr "t")\n" \ + "\n" \ + , area_name); + +#define hsc_set_ptr(z,nm,t) \ + printf( \ + "set"nm" :: T -> "t" -> IO ()\n" \ + "set"nm" i c =\n" \ + " with i (\\iptr -> Area.with c (set"nm"_ iptr))\n" \ + "\n" \ + "foreign import ccall unsafe \"alsa/asoundlib.h snd_seq_%s_set_"z"\"\n" \ + " set"nm"_ :: Area.Ptr T_ -> (Area.Ptr "t") -> IO ()\n" \ + "\n" \ + , area_name); + +#define hsc_get_set_ptr(z,nm,t) \ + hsc_get_ptr(z,nm,t) \ + hsc_set_ptr(z,nm,t) diff --git a/src/Sound/ALSA/Sequencer/Area.hs b/src/Sound/ALSA/Sequencer/Area.hs new file mode 100644 --- /dev/null +++ b/src/Sound/ALSA/Sequencer/Area.hs @@ -0,0 +1,38 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Sound.ALSA.Sequencer.Area +-- Copyright : (c) Henning Thielemann, 2010-2012 +-- (c) Iavor S. Diatchki, 2007 +-- License : BSD3 +-- +-- Maintainer: Henning Thielemann +-- Stability : provisional +-- +-- PRIVATE MODULE. +-- +-- Here we have macros to deal with the various information +-- areas present in the library. +-------------------------------------------------------------------------------- + +module Sound.ALSA.Sequencer.Area ( + C(..), + MU.with, + MA.alloca, + St.peek, + Ptr.Ptr, Ptr.FunPtr, + FPtr.ForeignPtr, FPtr.newForeignPtr, FPtr.withForeignPtr, + CStr.CString, CStr.peekCString, CStr.withCAString, + ) where + +import qualified Foreign.Marshal.Utils as MU +import qualified Foreign.Marshal.Alloc as MA +import qualified Foreign.C.String as CStr +import qualified Foreign.Storable as St +import qualified Foreign.ForeignPtr as FPtr +import qualified Foreign.Ptr as Ptr + + +class C area where + malloc :: IO area + copy :: area -> area -> IO () + clone :: area -> IO area diff --git a/src/Sound/ALSA/Sequencer/Area.hsc b/src/Sound/ALSA/Sequencer/Area.hsc deleted file mode 100644 --- a/src/Sound/ALSA/Sequencer/Area.hsc +++ /dev/null @@ -1,315 +0,0 @@ --------------------------------------------------------------------------------- --- | --- Module : Sound.ALSA.Sequencer.Area --- Copyright : (c) Henning Thielemann, 2010 --- (c) Iavor S. Diatchki, 2007 --- License : BSD3 --- --- Maintainer: Henning Thielemann --- Stability : provisional --- --- PRIVATE MODULE. --- --- Here we have macros to deal with the various information --- areas present in the library. --------------------------------------------------------------------------------- - -module Sound.ALSA.Sequencer.Area where - -import qualified Sound.ALSA.Sequencer.Marshal.Client as Client -import qualified Sound.ALSA.Sequencer.Marshal.Port as Port -import qualified Sound.ALSA.Sequencer.Marshal.Queue as Queue -import qualified Sound.ALSA.Sequencer.Marshal.QueueTimer as QueueTimer -import qualified Sound.ALSA.Sequencer.Marshal.QuerySubscribe as QuerySubscribe -import qualified Sound.ALSA.Exception as Exc - -import qualified Data.EnumSet as EnumSet -import Foreign.C.Types (CInt, ) -import Foreign.C.String (CString, peekCString, withCAString, ) -import Foreign.Storable (Storable, peek, ) -import Foreign.Marshal.Alloc (alloca, ) -import Foreign.ForeignPtr (ForeignPtr, newForeignPtr, withForeignPtr, ) -import Foreign.Ptr (Ptr, FunPtr, ) -import Data.Word (Word, ) - - -class C area where - malloc :: IO area - copy :: area -> area -> IO () - clone :: area -> IO area - -#{let area x,y = -"data "x"_\n" -"newtype "x" = "x" (ForeignPtr "x"_)\n" -"\n" -"with_"y" :: "x" -> (Ptr "x"_ -> IO a) -> IO a\n" -"with_"y" ("x" p) f = withForeignPtr p f\n" -"\n" -"-- | Allocate an uninitialized object. (Not exported)\n" -y"_malloc :: IO "x"\n" -y"_malloc = alloca $ \\p ->\n" -" do Exc.checkResult_ \"Sequencer."y"\" =<< snd_seq_"y"_malloc p\n" -" "x" `fmap` (newForeignPtr snd_seq_"y"_free =<< peek p)\n" -"\n" -"foreign import ccall unsafe \"alsa/asoundlib.h snd_seq_"y"_malloc\"\n" -" snd_seq_"y"_malloc :: Ptr (Ptr "x"_) -> IO CInt\n" -"\n" -"foreign import ccall unsafe \"alsa/asoundlib.h &snd_seq_"y"_free\"\n" -" snd_seq_"y"_free :: FunPtr (Ptr "x"_ -> IO ())\n" -"\n" -"-- | Copy the content of one object into another.\n" -y"_copy\n" -" :: "x" -- ^ Destination\n" -" -> "x" -- ^ Source\n" -" -> IO ()\n" -"\n" -y"_copy to from =\n" -" with_"y" to $ \\p1 ->\n" -" with_"y" from $ \\p2 ->\n" -" snd_seq_"y"_copy p1 p2\n" -"\n" -"foreign import ccall unsafe \"alsa/asoundlib.h snd_seq_"y"_copy\"\n" -" snd_seq_"y"_copy :: Ptr "x"_ -> Ptr "x"_ -> IO ()\n" -"\n" -"-- | Copy the content of an object to a newly created object.\n" -y"_clone :: "x" -> IO "x"\n" -y"_clone from =\n" -" do to <- "y"_malloc\n" -" "y"_copy to from\n" -" return to\n" -"\n" -"instance C "x" where\n" -" malloc = "y"_malloc\n" -" copy = "y"_copy\n" -" clone = "y"_clone\n" -} - -#{let get_set_name x,y = -y"_get_name :: "x" -> IO String\n" -y"_get_name i = peekCString =<< with_"y" i snd_seq_"y"_get_name\n" -"\n" -"foreign import ccall unsafe \"alsa/asoundlib.h snd_seq_"y"_get_name\"\n" -" snd_seq_"y"_get_name :: Ptr "x"_ -> IO CString\n" -"\n" -y"_set_name :: "x" -> String -> IO ()\n" -y"_set_name i c =\n" -" withCAString c $ \\p -> with_"y" i (`snd_seq_"y"_set_name` p)\n" -"\n" -"foreign import ccall unsafe \"alsa/asoundlib.h snd_seq_"y"_set_name\"\n" -" snd_seq_"y"_set_name :: Ptr "x"_ -> CString -> IO ()\n" -} - -#{let get_bool x,y,z = -y"_get_"z" :: "x" -> IO Bool\n" -y"_get_"z" i =\n" -" (0 /=) `fmap` with_"y" i snd_seq_"y"_get_"z"\n" -"\n" -"foreign import ccall unsafe \"alsa/asoundlib.h snd_seq_"y"_get_"z"\"\n" -" snd_seq_"y"_get_"z" :: Ptr "x"_ -> IO CInt\n" -} - -#{let get_set_bool x,y,z = -y"_get_"z" :: "x" -> IO Bool\n" -y"_get_"z" i =\n" -" (0 /=) `fmap` with_"y" i snd_seq_"y"_get_"z"\n" -"\n" -"foreign import ccall unsafe \"alsa/asoundlib.h snd_seq_"y"_get_"z"\"\n" -" snd_seq_"y"_get_"z" :: Ptr "x"_ -> IO CInt\n" -"\n" -y"_set_"z" :: "x" -> Bool -> IO ()\n" -y"_set_"z" i c =\n" -" let x = if c then 1 else 0\n" -" in with_"y" i (`snd_seq_"y"_set_"z"` x)\n" -"\n" -"foreign import ccall unsafe \"alsa/asoundlib.h snd_seq_"y"_set_"z"\"\n" -" snd_seq_"y"_set_"z" :: Ptr "x"_ -> CInt -> IO ()\n" -} - -#{let get_int x,y,z,t,mk = -y"_get_"z" :: "x" -> IO "t"\n" -y"_get_"z" i =\n" -" "mk"\n" -" `fmap` with_"y" i snd_seq_"y"_get_"z"\n" -"\n" -"foreign import ccall unsafe \"alsa/asoundlib.h snd_seq_"y"_get_"z"\"\n" -" snd_seq_"y"_get_"z" :: Ptr "x"_ -> IO CInt\n" -} - -#{let set_int x,y,z,t,brk = -y"_set_"z" :: "x" -> "t" -> IO ()\n" -y"_set_"z" i c =\n" -" with_"y" i (`snd_seq_"y"_set_"z"` "brk" c)\n" -"\n" -"foreign import ccall unsafe \"alsa/asoundlib.h snd_seq_"y"_set_"z"\"\n" -" snd_seq_"y"_set_"z" :: Ptr "x"_ -> CInt -> IO ()\n" -} - - - --- Client.T Info ----------------------------------------------------------------- -#area "ClientInfo", "client_info" - --- read/write -#get_set_name "ClientInfo", "client_info" -#get_set_bool "ClientInfo", "client_info", "broadcast_filter" -#get_set_bool "ClientInfo", "client_info", "error_bounce" -#{get_int "ClientInfo", "client_info", "client", - "Client.T", "Client.imp"} -#{set_int "ClientInfo", "client_info", "client", - "Client.T", "Client.exp"} - --- read only -#{get_int "ClientInfo", "client_info", "type", - "Client.Type", "Client.impType"} -#{get_int "ClientInfo", "client_info", "num_ports", - "Word", "fromIntegral"} -#{get_int "ClientInfo", "client_info", "event_lost", - "Word", "fromIntegral"} - - --- Port Info ------------------------------------------------------------------- -#area "PortInfo", "port_info" - --- read/write -#get_set_name "PortInfo", "port_info" - -#get_set_bool "PortInfo", "port_info", "port_specified" -#get_set_bool "PortInfo", "port_info", "timestamping" -#get_set_bool "PortInfo", "port_info", "timestamp_real" - -#{get_int "PortInfo", "port_info", "port", - "Port.T", "Port.imp"} -#{set_int "PortInfo", "port_info", "port", - "Port.T", "Port.exp"} -#{get_int "PortInfo", "port_info", "client", - "Client.T","Client.imp"} -#{set_int "PortInfo", "port_info", "client", - "Client.T","Client.exp"} -#{get_int "PortInfo", "port_info", "capability", - "Port.Cap","(EnumSet.Cons . fromIntegral)"} -#{set_int "PortInfo", "port_info", "capability", - "Port.Cap","(fromIntegral . EnumSet.decons)"} - -#{get_int "PortInfo", "port_info", "midi_channels", - "Word","fromIntegral"} -#{set_int "PortInfo", "port_info", "midi_channels", - "Word","fromIntegral"} -#{get_int "PortInfo", "port_info", "midi_voices", - "Word","fromIntegral"} -#{set_int "PortInfo", "port_info", "midi_voices", - "Word","fromIntegral"} -#{get_int "PortInfo", "port_info", "synth_voices", - "Word","fromIntegral"} -#{set_int "PortInfo", "port_info", "synth_voices", - "Word","fromIntegral"} - -#{get_int "PortInfo", "port_info", "timestamp_queue", - "Queue.T","Queue.imp"} -#{set_int "PortInfo", "port_info", "timestamp_queue", - "Queue.T","Queue.exp"} - --- read only -#{get_int "PortInfo", "port_info", "read_use", - "Word","fromIntegral"} -#{get_int "PortInfo", "port_info", "write_use", - "Word","fromIntegral"} - --- Subscribe Port ---------------------------------------------------------------- -#area "PortSubscribe", "port_subscribe" - -#{get_int "PortSubscribe", "port_subscribe", "queue", - "Queue.T","Queue.imp"} -#{set_int "PortSubscribe", "port_subscribe", "queue", - "Queue.T","Queue.exp"} -#get_set_bool "PortSubscribe", "port_subscribe", "exclusive" -#get_set_bool "PortSubscribe", "port_subscribe", "time_update" -#get_set_bool "PortSubscribe", "port_subscribe", "time_real" - --- Subscribe Query --------------------------------------------------------------- -#area "QuerySubscribe", "query_subscribe" - -#{get_int "QuerySubscribe", "query_subscribe", "client", - "Client.T", "Client.imp"} -#{set_int "QuerySubscribe", "query_subscribe", "client", - "Client.T", "Client.exp"} -#{get_int "QuerySubscribe", "query_subscribe", "port", - "Port.T", "Port.imp"} -#{set_int "QuerySubscribe", "query_subscribe", "port", - "Port.T", "Port.exp"} -#{get_int "QuerySubscribe", "query_subscribe", "type", - "QuerySubscribe.Type", "QuerySubscribe.impType"} -#{set_int "QuerySubscribe", "query_subscribe", "type", - "QuerySubscribe.Type", "QuerySubscribe.expType"} -#{get_int "QuerySubscribe", "query_subscribe", "index", - "Word", "fromIntegral"} -#{set_int "QuerySubscribe", "query_subscribe", "index", - "Word", "fromIntegral"} - --- RO -#{get_int "QuerySubscribe", "query_subscribe", "num_subs", - "Word", "fromIntegral"} -#{get_int "QuerySubscribe", "query_subscribe", "queue", - "Queue.T", "Queue.imp"} -#get_bool "QuerySubscribe", "query_subscribe", "exclusive" -#get_bool "QuerySubscribe", "query_subscribe", "time_update" -#get_bool "QuerySubscribe", "query_subscribe", "time_real" - --- Queue.T Info ------------------------------------------------------------------ -#area "QueueInfo", "queue_info" -#get_set_name "QueueInfo", "queue_info" -#get_set_bool "QueueInfo", "queue_info", "locked" - -#{get_int "QueueInfo", "queue_info", "owner", - "Client.T", "Client.imp"} -#{set_int "QueueInfo", "queue_info", "owner", - "Client.T", "Client.exp"} -#{get_int "QueueInfo", "queue_info", "flags", - "Word", "fromIntegral"} -#{set_int "QueueInfo", "queue_info", "flags", - "Word", "fromIntegral"} - --- RO -#{get_int "QueueInfo", "queue_info", "queue", - "Queue.T","Queue.imp"} - --- Queue.T Status ---------------------------------------------------------------- -#area "QueueStatus", "queue_status" - --- Queue.T Tempo ----------------------------------------------------------------- -#area "QueueTempo", "queue_tempo" - --- RO -#{get_int "QueueTempo", "queue_tempo", "queue", - "Queue.T","Queue.imp"} - --- RW -#{get_int "QueueTempo", "queue_tempo", "tempo", "Word", "fromIntegral"} -#{set_int "QueueTempo", "queue_tempo", "tempo", "Word", "fromIntegral"} - -#{get_int "QueueTempo", "queue_tempo", "ppq", "Int", "fromIntegral"} -#{set_int "QueueTempo", "queue_tempo", "ppq", "Int", "fromIntegral"} - -#{get_int "QueueTempo", "queue_tempo", "skew", "Word", "fromIntegral"} -#{set_int "QueueTempo", "queue_tempo", "skew", "Word", "fromIntegral"} - -#{get_int "QueueTempo", "queue_tempo", "skew_base", "Word", "fromIntegral"} -#{set_int "QueueTempo", "queue_tempo", "skew_base", "Word", "fromIntegral"} - --- Queue.T Timer ----------------------------------------------------------------- -#area "QueueTimer", "queue_timer" - - --- RO -#{get_int "QueueTimer", "queue_timer", "queue", - "Queue.T","Queue.imp"} - --- RW - -#{get_int "QueueTimer", "queue_timer", "type", - "QueueTimer.Type", "QueueTimer.impType"} -#{set_int "QueueTimer", "queue_timer", "type", - "QueueTimer.Type", "QueueTimer.expType"} - -#{get_int "QueueTimer", "queue_timer", "resolution", "Word", "fromIntegral"} -#{set_int "QueueTimer", "queue_timer", "resolution", "Word", "fromIntegral"} - diff --git a/src/Sound/ALSA/Sequencer/Client.hs b/src/Sound/ALSA/Sequencer/Client.hs --- a/src/Sound/ALSA/Sequencer/Client.hs +++ b/src/Sound/ALSA/Sequencer/Client.hs @@ -14,7 +14,7 @@ -------------------------------------------------------------------------------- module Sound.ALSA.Sequencer.Client - ( Client.T + ( Client.T(Client.Cons) , Client.unknown , Client.system , Client.subscribers @@ -26,7 +26,7 @@ , Client.Type(..) ) where -import qualified Sound.ALSA.Sequencer.Client.Info as ClientInfo +import qualified Sound.ALSA.Sequencer.Client.InfoMonad as ClientInfo import qualified Sound.ALSA.Sequencer.Marshal.Client as Client import qualified Sound.ALSA.Sequencer.Marshal.Sequencer as Seq @@ -41,12 +41,9 @@ -- | Get the client identifier for the sequencer. -- A convinience function. getId :: Seq.T mode -> IO Client.T -getId h = ClientInfo.getClient =<< ClientInfo.get h +getId h = ClientInfo.get h ClientInfo.getClient -- | Set the name for the sequencer client. -- A convinience function. setName :: Seq.T mode -> String -> IO () -setName h s = - do i <- ClientInfo.get h - ClientInfo.setName i s - ClientInfo.set h i +setName h s = ClientInfo.modify h $ ClientInfo.setName s diff --git a/src/Sound/ALSA/Sequencer/Client/Info.hs b/src/Sound/ALSA/Sequencer/Client/Info.hs --- a/src/Sound/ALSA/Sequencer/Client/Info.hs +++ b/src/Sound/ALSA/Sequencer/Client/Info.hs @@ -1,7 +1,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Sound.ALSA.Sequencer.Client --- Copyright : (c) Henning Thielemann, 2010 +-- Copyright : (c) Henning Thielemann, 2010-2012 -- (c) Iavor S. Diatchki, 2007 -- License : BSD3 -- @@ -20,8 +20,9 @@ , getAny , queryFirst , queryNext + , queryLoop_ + , queryLoop , set - , modify , copy , clone @@ -45,84 +46,23 @@ , filterCheck ) where +import Sound.ALSA.Sequencer.Marshal.ClientInfo + import qualified Sound.ALSA.Sequencer.Client.Info.EventFilter as Filter -import qualified Sound.ALSA.Sequencer.Marshal.Client as Client import qualified Sound.ALSA.Sequencer.Marshal.Sequencer as Seq -import qualified Sound.ALSA.Sequencer.Area as Area import qualified Sound.ALSA.Sequencer.Marshal.Event as Event -import qualified Sound.ALSA.Exception as Exc - -import Foreign.C.Types(CInt, ) -import Foreign.Ptr(Ptr, ) -import Data.Word (Word, ) - -import Control.Monad (guard, ) - - --------------------------------------------------------------------------------- - -type T = Area.ClientInfo -type T_ = Area.ClientInfo_ - --- | Create a new information area filled with data about the sequencer client. -get :: Seq.T mode -> IO T -get (Seq.Cons h) = - do info <- Area.client_info_malloc - Exc.checkResult_ "get_client_info" =<< Area.with_client_info info (snd_seq_get_client_info h) - return info - -foreign import ccall unsafe "alsa/asoundlib.h snd_seq_get_client_info" - snd_seq_get_client_info :: Ptr Seq.Core -> Ptr T_ -> IO CInt - - --- | Create a new information area filled with data about an arbitrary client. -getAny :: Seq.T mode -> Client.T -> IO T -getAny (Seq.Cons h) c = - do info <- Area.client_info_malloc - Exc.checkResult_ "get_any_client_info" =<< Area.with_client_info info - (snd_seq_get_any_client_info h (Client.exp c)) - return info - -foreign import ccall unsafe "alsa/asoundlib.h snd_seq_get_any_client_info" - snd_seq_get_any_client_info - :: Ptr Seq.Core -> CInt -> Ptr T_ -> IO CInt - +import qualified Sound.ALSA.Sequencer.Query as Query queryFirst :: Seq.T mode -> IO T -queryFirst h = - do x <- Area.client_info_malloc - Area.with_client_info x (`Area.snd_seq_client_info_set_client` (-1)) - _b <- queryNext h x - -- XXX: check that we did get the first client (should be System) - return x - - --- | Get information about the client with the next biggest identifier. -queryNext :: Seq.T mode -> T - -> IO Bool -- ^ Was there a next client? -queryNext (Seq.Cons h) info = - Exc.checkResultMaybe "query_next_client" - (const True) (\x -> guard (x == -2) >> return False) - =<< Area.with_client_info info (snd_seq_query_next_client h) - -foreign import ccall unsafe "alsa/asoundlib.h snd_seq_query_next_client" - snd_seq_query_next_client :: Ptr Seq.Core -> Ptr T_ -> IO CInt - - --- | Set the information for the sequencer client based on the data --- in the given information area. -set :: Seq.T mode -> T -> IO () -set (Seq.Cons h) info = - Exc.checkResult_ "set_client_info" =<< Area.with_client_info info (snd_seq_set_client_info h) - -foreign import ccall unsafe "alsa/asoundlib.h snd_seq_set_client_info" - snd_seq_set_client_info :: Ptr Seq.Core -> Ptr T_ -> IO CInt +queryFirst = Query.first +queryLoop_ :: Seq.T mode -> (T -> IO ()) -> IO () +queryLoop_ h = Query.loop_ h (const $ return ()) -modify :: Seq.T mode -> (T -> IO T) -> IO () -modify ss f = set ss =<< f =<< get ss +queryLoop :: Seq.T mode -> (T -> IO a) -> IO [a] +queryLoop h = Query.loop h (const $ return ()) filterClear :: T -> IO () @@ -134,32 +74,3 @@ filterAdd = Filter.add filterDel = Filter.delete filterCheck = Filter.check - - -copy :: T -> T -> IO () -clone :: T -> IO T -getClient :: T -> IO Client.T -getType :: T -> IO Client.Type -getName :: T -> IO String -getBroadcastFilter :: T -> IO Bool -getErrorBounce :: T -> IO Bool -getNumPorts :: T -> IO Word -getEventLost :: T -> IO Word -setClient :: T -> Client.T -> IO () -setName :: T -> String -> IO () -setBroadcastFilter :: T -> Bool -> IO () -setErrorBounce :: T -> Bool -> IO () - -copy = Area.client_info_copy -clone = Area.client_info_clone -getClient = Area.client_info_get_client -getType = Area.client_info_get_type -getName = Area.client_info_get_name -getBroadcastFilter = Area.client_info_get_broadcast_filter -getErrorBounce = Area.client_info_get_error_bounce -getNumPorts = Area.client_info_get_num_ports -getEventLost = Area.client_info_get_event_lost -setClient = Area.client_info_set_client -setName = Area.client_info_set_name -setBroadcastFilter = Area.client_info_set_broadcast_filter -setErrorBounce = Area.client_info_set_error_bounce diff --git a/src/Sound/ALSA/Sequencer/Client/InfoMonad.hs b/src/Sound/ALSA/Sequencer/Client/InfoMonad.hs new file mode 100644 --- /dev/null +++ b/src/Sound/ALSA/Sequencer/Client/InfoMonad.hs @@ -0,0 +1,82 @@ +module Sound.ALSA.Sequencer.Client.InfoMonad ( + T, + + run, + get, + modify, + + getClient, + getType, + getName, + getBroadcastFilter, + getErrorBounce, + getNumPorts, + getEventLost, + + setClient, + setName, + setBroadcastFilter, + setErrorBounce, + ) where + +import qualified Sound.ALSA.Sequencer.Marshal.ClientInfo as ClientInfo +import qualified Sound.ALSA.Sequencer.Marshal.Client as Client +import qualified Sound.ALSA.Sequencer.Marshal.Sequencer as Seq + +import qualified Control.Monad.Trans.Reader as MR +import Control.Applicative (Applicative, ) + +import Data.Word (Word, ) + + +newtype T a = Cons (MR.ReaderT ClientInfo.T IO a) + deriving (Functor, Applicative, Monad) + + +run :: T a -> ClientInfo.T -> IO a +run (Cons m) = MR.runReaderT m + +get :: Seq.T mode -> T a -> IO a +get h m = run m =<< ClientInfo.get h + +modify :: Seq.T mode -> T a -> IO a +modify h m = do + i <- ClientInfo.get h + a <- run m i + ClientInfo.set h i + return a + + +liftGet :: (ClientInfo.T -> IO a) -> T a +liftGet f = Cons $ MR.ReaderT f + +liftSet :: (ClientInfo.T -> b -> IO a) -> b -> T a +liftSet f x = Cons $ MR.ReaderT $ flip f x + + +getClient :: T Client.T +getType :: T Client.Type +getName :: T String +getBroadcastFilter :: T Bool +getErrorBounce :: T Bool +getNumPorts :: T Word +getEventLost :: T Word + +getClient = liftGet ClientInfo.getClient +getType = liftGet ClientInfo.getType +getName = liftGet ClientInfo.getName +getBroadcastFilter = liftGet ClientInfo.getBroadcastFilter +getErrorBounce = liftGet ClientInfo.getErrorBounce +getNumPorts = liftGet ClientInfo.getNumPorts +getEventLost = liftGet ClientInfo.getEventLost + + +setClient :: Client.T -> T () +setName :: String -> T () +setBroadcastFilter :: Bool -> T () +setErrorBounce :: Bool -> T () + +setClient = liftSet ClientInfo.setClient +setName = liftSet ClientInfo.setName +setBroadcastFilter = liftSet ClientInfo.setBroadcastFilter +setErrorBounce = liftSet ClientInfo.setErrorBounce diff --git a/src/Sound/ALSA/Sequencer/Concurrent.hs b/src/Sound/ALSA/Sequencer/Concurrent.hs new file mode 100644 --- /dev/null +++ b/src/Sound/ALSA/Sequencer/Concurrent.hs @@ -0,0 +1,107 @@ +module Sound.ALSA.Sequencer.Concurrent + ( threadWaitInput + , threadWaitOutput + , threadWaitDuplex + + , input + , output + , drainOutput + ) where + +import qualified Sound.ALSA.Sequencer.Poll as AlsaPoll +import qualified Sound.ALSA.Sequencer.Marshal.Sequencer as Seq +import qualified Sound.ALSA.Sequencer.Event as Event +import Sound.ALSA.Exception (code, ) + +import Control.Concurrent (yield, threadWaitRead, threadWaitWrite, forkIO, killThread, ) +import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar, ) +import Control.Exception (catchJust, catch, ) +import Control.Monad (guard, when, ) +import Data.Function (fix, ) +import Data.Word (Word, ) +import Foreign.C.Error (eINTR, ) +import System.IO.Error (isFullError, ) +import System.Posix.Types (Fd, ) +import qualified System.Posix.Poll as Poll +import qualified Data.EnumSet as EnumSet + +import Prelude hiding (catch, ) + + +data WaitFd + = WaitRead Fd + | WaitWrite Fd + +pollWaits :: Poll.Fd -> [WaitFd] +pollWaits (Poll.Fd f e _) = + (if EnumSet.subset Poll.inp e then [WaitRead f] else []) ++ + (if EnumSet.subset Poll.out e then [WaitWrite f] else []) + +-- | Wait for any of the given events, like poll, and return the one that is ready +threadWaitPolls :: [WaitFd] -> IO WaitFd +threadWaitPolls [] = yield >> return undefined +threadWaitPolls [p@(WaitRead f)] = threadWaitRead f >> return p +threadWaitPolls [p@(WaitWrite f)] = threadWaitWrite f >> return p +threadWaitPolls l = do + w <- newEmptyMVar + let poll1 p = catch (threadWaitPolls [p] >>= putMVar w . Right) (putMVar w . Left) + t <- mapM (forkIO . poll1) l + r <- takeMVar w + mapM_ killThread t + either ioError return r + +threadWaitEvents :: Poll.Events -> Seq.T mode -> IO () +threadWaitEvents e sh = + AlsaPoll.descriptors sh e >>= + threadWaitPolls . concatMap pollWaits >> + return () + +-- | Wait for new input to be available from the sequencer (even if there is already input in the buffer) +threadWaitInput :: Seq.AllowInput mode => Seq.T mode -> IO () +threadWaitInput = threadWaitEvents Poll.inp + +-- | Wait until new output may be drained from the buffer to the sequencer (even if the output buffer is already empty) +threadWaitOutput :: Seq.AllowOutput mode => Seq.T mode -> IO () +threadWaitOutput = threadWaitEvents Poll.out + +-- | Wait until new input is available or new output may be drained +threadWaitDuplex :: (Seq.AllowInput mode, Seq.AllowOutput mode) => Seq.T mode -> IO () +threadWaitDuplex = threadWaitEvents (Poll.inp EnumSet..|. Poll.out) + +catchFull :: IO a -> IO a -> IO a +catchFull f e = catchJust (guard . isFullError) f (\() -> e) + +catchIntr :: IO a -> IO a +catchIntr f = catchJust (guard . (eINTR ==) . code) f (\() -> catchIntr f) + +-- | A thread-compatible version of @Sound.ALSA.Sequencer.Event.input@. +-- This call is always blocking (unless there are already event in the input +-- buffer) but will not block other threads. The sequencer, however, must be +-- set non-blocking or this will not work as expected. +input :: Seq.AllowInput mode => Seq.T mode -> IO Event.T +input sh = do + n <- catchIntr $ Event.inputPending sh True + when (n == 0) $ threadWaitInput sh + fix $ catchFull (Event.input sh) . (threadWaitInput sh >>) + +-- | A thread-compatible version of @Sound.ALSA.Sequencer.Event.output@. +-- This call is always blocking (unless there is space in the output +-- buffer) but will not block other threads. The sequencer, however, must be +-- set non-blocking or this will not work as expected. +output :: Seq.AllowOutput mode => Seq.T mode -> Event.T -> IO Word +output sh ev = + Event.outputBuffer sh ev `catchFull` do + threadWaitOutput sh + _ <- Event.drainOutput sh `catchFull` return (-1) + output sh ev + +-- | A thread-compatible version of @Sound.ALSA.Sequencer.Event.drainBuffer@. +-- This call is always blocking but will not block other threads. The +-- sequencer, however, must be set non-blocking or this will not work as +-- expected. +drainOutput :: Seq.AllowOutput mode => Seq.T mode -> IO () +drainOutput sh = do + n <- Event.drainOutput sh `catchFull` return (-1) + when (n /= 0) $ do + threadWaitOutput sh + drainOutput sh diff --git a/src/Sound/ALSA/Sequencer/Connect.hs b/src/Sound/ALSA/Sequencer/Connect.hs new file mode 100644 --- /dev/null +++ b/src/Sound/ALSA/Sequencer/Connect.hs @@ -0,0 +1,86 @@ +module Sound.ALSA.Sequencer.Connect ( + Connect.T(Connect.Cons, Connect.source, Connect.dest), + reverse, + toSubscribers, fromSubscribers, + + createFrom, deleteFrom, withFrom, + createTo, deleteTo, withTo, + ) where + +import qualified Sound.ALSA.Sequencer.Marshal.Connect as Connect +import qualified Sound.ALSA.Sequencer.Marshal.Address as Addr +import qualified Sound.ALSA.Sequencer.Marshal.Port as Port +import qualified Sound.ALSA.Sequencer.Marshal.Sequencer as Seq +import qualified Sound.ALSA.Sequencer.Client as Client +import qualified Sound.ALSA.Exception as Exc + +import qualified Foreign.C.Types as C +import Foreign.Ptr (Ptr, ) + +import Control.Exception (bracket, ) + +import Prelude hiding (reverse, ) + + +reverse :: Connect.T -> Connect.T +reverse (Connect.Cons src dst) = Connect.Cons dst src + +toSubscribers :: Addr.T -> Connect.T +toSubscribers src = Connect.Cons src Addr.subscribers + +fromSubscribers :: Addr.T -> Connect.T +fromSubscribers dst = Connect.Cons Addr.subscribers dst + + +-- | Simple subscription (w\/o exclusive & time conversion). +createFrom :: Seq.AllowInput mode => Seq.T mode -> Port.T -> Addr.T -> IO Connect.T +createFrom s@(Seq.Cons h) me a = + do Exc.checkResult_ "connect_from" =<< + uncurry (snd_seq_connect_from h (Port.exp me)) (Addr.exp a) + mec <- Client.getId s + return $ Connect.Cons a (Addr.Cons mec me) + +foreign import ccall unsafe "alsa/asoundlib.h snd_seq_connect_from" + snd_seq_connect_from :: Ptr Seq.Core -> C.CInt -> C.CInt -> C.CInt -> IO C.CInt + + +-- | Simple subscription (w\/o exclusive & time conversion). +createTo :: Seq.AllowOutput mode => Seq.T mode -> Port.T -> Addr.T -> IO Connect.T +createTo s@(Seq.Cons h) me a = + do Exc.checkResult_ "connect_to" =<< + uncurry (snd_seq_connect_to h (Port.exp me)) (Addr.exp a) + mec <- Client.getId s + return $ Connect.Cons (Addr.Cons mec me) a + +foreign import ccall unsafe "alsa/asoundlib.h snd_seq_connect_to" + snd_seq_connect_to :: Ptr Seq.Core -> C.CInt -> C.CInt -> C.CInt -> IO C.CInt + + +-- | Simple disconnection. +deleteFrom :: Seq.AllowInput mode => Seq.T mode -> Port.T -> Addr.T -> IO () +deleteFrom (Seq.Cons h) me a = + Exc.checkResult_ "disconnect_from" =<< snd_seq_disconnect_from h (Port.exp me) c p + where (c,p) = Addr.exp a + +foreign import ccall unsafe "alsa/asoundlib.h snd_seq_disconnect_from" + snd_seq_disconnect_from :: Ptr Seq.Core -> C.CInt -> C.CInt -> C.CInt -> IO C.CInt + +-- | Simple disconnection. +deleteTo :: Seq.AllowOutput mode => Seq.T mode -> Port.T -> Addr.T -> IO () +deleteTo (Seq.Cons h) me a = + Exc.checkResult_ "disconnect_to" =<< snd_seq_disconnect_to h (Port.exp me) c p + where (c,p) = Addr.exp a + +foreign import ccall unsafe "alsa/asoundlib.h snd_seq_disconnect_to" + snd_seq_disconnect_to :: Ptr Seq.Core -> C.CInt -> C.CInt -> C.CInt -> IO C.CInt + + +-- | Temporary subscription. +withFrom :: Seq.AllowInput mode => Seq.T mode -> Port.T -> Addr.T -> (Connect.T -> IO a) -> IO a +withFrom h me a = + bracket (createFrom h me a) (const $ deleteFrom h me a) + +-- | Temporary subscription. +withTo :: Seq.AllowOutput mode => Seq.T mode -> Port.T -> Addr.T -> (Connect.T -> IO a) -> IO a +withTo h me a = + bracket (createTo h me a) (const $ deleteTo h me a) diff --git a/src/Sound/ALSA/Sequencer/Event.hs b/src/Sound/ALSA/Sequencer/Event.hs --- a/src/Sound/ALSA/Sequencer/Event.hs +++ b/src/Sound/ALSA/Sequencer/Event.hs @@ -1,11 +1,11 @@ -------------------------------------------------------------------------------- -- | -- Module : Sound.ALSA.Sequencer.Event --- Copyright : (c) Henning Thielemann, 2010 +-- Copyright : (c) Henning Thielemann, 2011 -- (c) Iavor S. Diatchki, 2007 -- License : BSD3 -- --- Maintainer: Iavor S. Diatchki +-- Maintainer: Henning Thielemann -- Stability : provisional -- -- This module contains functions for working with events. @@ -13,63 +13,125 @@ -- -------------------------------------------------------------------------------- -module Sound.ALSA.Sequencer.Event - ( syncOutputQueue - , input - , inputPending - , output - , outputBuffer - , outputDirect - , outputPending - , extractOutput - , removeOutput - , drainOutput - , dropOutput - , dropOutputBuffer - , dropInput - , dropInputBuffer +module Sound.ALSA.Sequencer.Event ( + -- * Output - , TimeStamp(..) - , InstrCluster - , Instr(..) - , Sample(..) - , Cluster(..) - , Volume(..), volumeSame + -- $trouble - , Event.T(..), simple - , Event.Data(..) - , NoteEv(..), Note(..), simpleNote - , CtrlEv(..), Ctrl(..) - , CustomEv(..), Custom(..) - , QueueEv(..) - , AddrEv(..) - , ConnEv(..), Connect - , EmptyEv(..) + output, + outputBuffer, + outputDirect, + outputPending, + extractOutput, + removeOutput, + drainOutput, + dropOutput, + dropOutputBuffer, + syncOutputQueue, + + -- * Input + + input, + inputPending, + dropInput, + dropInputBuffer, + + -- * Data types + + Event.T(..), simple, forSourcePort, forConnection, + Event.Data(..), + Event.Type, + NoteEv(..), Note(..), simpleNote, + CtrlEv(..), Ctrl(..), + CustomEv(..), Custom(..), customZero, + ExtEv(..), + QueueEv(..), + AddrEv(..), + ConnEv(..), + EmptyEv(..), + + Tag(..), + Tempo(..), + + Parameter(..), + Value(..), + Channel(..), + Pitch(..), + Velocity(..), normalVelocity, offVelocity, + Duration(..), + +{- available in alsa-1.0.14, but gone in 1.0.22 + Instr(..), + Sample(..), + Cluster(..), + VolumeControl(..), + + InstrCluster(..), + StandardId(..), + Bank(..), + Program(..), + Volume(..), volumeSame, + Balance(..), +-} ) where +import Sound.ALSA.Sequencer.Marshal.Event as Event import qualified Sound.ALSA.Sequencer.Address as Addr +import qualified Sound.ALSA.Sequencer.Port as Port +import qualified Sound.ALSA.Sequencer.Client as Client +import qualified Sound.ALSA.Sequencer.Connect as Connect import qualified Sound.ALSA.Sequencer.Queue as Queue import qualified Sound.ALSA.Sequencer.Marshal.Sequencer as Seq -import Sound.ALSA.Sequencer.Marshal.Event as Event +import qualified Sound.ALSA.Sequencer.Marshal.Time as Time import qualified Sound.ALSA.Exception as Exc -import Foreign.C.Types (CInt, ) +import qualified Foreign.C.Types as C import Foreign.Ptr (Ptr, nullPtr, ) import Foreign.Marshal.Alloc (alloca, ) import Foreign.Storable (peek, ) -import Data.Word (Word, Word8, ) -import Data.Int (Int16, ) +import Data.Word (Word, ) +{- $trouble +If you send an event but you do not hear something, +then check the following conditions: + +* Check whether your event was actually delivered. + E.g. use the event monitor @aseqdump@ in order to see sent messages. + +* If the message was not delivered, + maybe you quit the program too early + and thus destroyed pending messages. + Use 'syncOutputQueue' at the end of the program + in order to wait for all messages to be sent. + +* Make sure the sequencer supports output + and the target port supports input. + +* Make sure to setup a connection to the receiver. + +* Make sure to have called 'drainOutput' after 'output'. + +* If you use a timestamp in an event, + make sure you also declare a queue (and create one before). + +* Make sure you started the queue you used for sending. + +* Be aware of that 'Event.QueueStart' clears the queue before running the queue. + That is, events sent before 'Event.QueueStart' are deleted. + If you want to keep these events, then use 'Event.QueueContinue' instead. +-} + + -- | Wait until all events of the client are processed. syncOutputQueue :: Seq.T mode -> IO () syncOutputQueue (Seq.Cons h) = Exc.checkResult_ "syncOutputQueue" =<< snd_seq_sync_output_queue h foreign import ccall safe "alsa/asoundlib.h snd_seq_sync_output_queue" - snd_seq_sync_output_queue :: Ptr Seq.Core -> IO CInt + snd_seq_sync_output_queue :: Ptr Seq.Core -> IO C.CInt -- | Get an event from the input buffer. @@ -88,10 +150,10 @@ peek =<< peek p foreign import ccall safe "alsa/asoundlib.h snd_seq_event_input" - snd_seq_event_input :: Ptr Seq.Core -> Ptr (Ptr Event.T) -> IO CInt + snd_seq_event_input :: Ptr Seq.Core -> Ptr (Ptr Event.T) -> IO C.CInt -checkResult :: String -> CInt -> IO Word +checkResult :: String -> C.CInt -> IO Word checkResult loc n = fmap fromIntegral $ Exc.checkResult loc n @@ -110,7 +172,7 @@ checkResult "inputPending" =<< snd_seq_event_input_pending h (if fill then 1 else 0) foreign import ccall unsafe "alsa/asoundlib.h snd_seq_event_input_pending" - snd_seq_event_input_pending :: Ptr Seq.Core -> Int -> IO CInt + snd_seq_event_input_pending :: Ptr Seq.Core -> Int -> IO C.CInt @@ -118,17 +180,17 @@ -- Throws exceptions. -- See also: 'outputDirect', 'outputBuffer', -- 'outputPending', 'drainOutput', 'dropOutput', --- 'extractOutput', 'removeEvents' +-- 'extractOutput', 'removeOutput' output :: Seq.AllowOutput mode => Seq.T mode -> Event.T -> IO Word -- ^ the number of remaining events (or bytes?) output (Seq.Cons h) e = - Event.allocaEv e $ \p -> checkResult "output" =<< snd_seq_event_output h p + Event.with e $ \p -> checkResult "output" =<< snd_seq_event_output h p foreign import ccall safe "alsa/asoundlib.h snd_seq_event_output" - snd_seq_event_output :: Ptr Seq.Core -> Ptr Event.T -> IO CInt + snd_seq_event_output :: Ptr Seq.Core -> Ptr Event.T -> IO C.CInt @@ -142,10 +204,10 @@ -> IO Word -- ^ the byte size of remaining events outputBuffer (Seq.Cons h) e = - Event.allocaEv e $ \p -> checkResult "outputBuffer" =<< snd_seq_event_output_buffer h p + Event.with e $ \p -> checkResult "outputBuffer" =<< snd_seq_event_output_buffer h p foreign import ccall unsafe "alsa/asoundlib.h snd_seq_event_output_buffer" - snd_seq_event_output_buffer :: Ptr Seq.Core -> Ptr Event.T -> IO CInt + snd_seq_event_output_buffer :: Ptr Seq.Core -> Ptr Event.T -> IO C.CInt -- | Output an event directly to the sequencer, NOT through the output buffer. @@ -159,10 +221,10 @@ -> IO Word -- ^ number of bytes sent to the sequencer outputDirect (Seq.Cons h) e = - Event.allocaEv e $ \p -> checkResult "outputDirect" =<< snd_seq_event_output_direct h p + Event.with e $ \p -> checkResult "outputDirect" =<< snd_seq_event_output_direct h p foreign import ccall safe "alsa/asoundlib.h snd_seq_event_output_direct" - snd_seq_event_output_direct :: Ptr Seq.Core -> Ptr Event.T -> IO CInt + snd_seq_event_output_direct :: Ptr Seq.Core -> Ptr Event.T -> IO C.CInt -- | Return the size (in bytes) of pending events on output buffer. @@ -175,11 +237,11 @@ fromIntegral `fmap` snd_seq_event_output_pending h foreign import ccall unsafe "alsa/asoundlib.h snd_seq_event_output_pending" - snd_seq_event_output_pending :: Ptr Seq.Core -> IO CInt + snd_seq_event_output_pending :: Ptr Seq.Core -> IO C.CInt -- | Extract the first event in output buffer. --- Throws an exception on error. +-- Throws @(Errno 2)@ exception if output buffer is empty. -- See also 'output'. extractOutput :: Seq.AllowOutput mode @@ -197,7 +259,7 @@ removeOutput (Seq.Cons h) = Exc.checkResult_ "removeOutput" =<< snd_seq_extract_output h nullPtr foreign import ccall unsafe "alsa/asoundlib.h snd_seq_extract_output" - snd_seq_extract_output :: Ptr Seq.Core -> Ptr (Ptr Event.T) -> IO CInt + snd_seq_extract_output :: Ptr Seq.Core -> Ptr (Ptr Event.T) -> IO C.CInt -- | Drain output buffer to sequencer. @@ -217,19 +279,19 @@ drainOutput (Seq.Cons h) = checkResult "drainOutput" =<< snd_seq_drain_output h foreign import ccall safe "alsa/asoundlib.h snd_seq_drain_output" - snd_seq_drain_output :: Ptr Seq.Core -> IO CInt + snd_seq_drain_output :: Ptr Seq.Core -> IO C.CInt -- | Remove events from both the user-space output buffer, -- and the kernel-space sequencer queue. --- See also: 'drainOutput', 'dropOutputBuffer', 'removeEvents'. +-- See also: 'drainOutput', 'dropOutputBuffer', 'removeOutput'. dropOutput :: Seq.AllowOutput mode => Seq.T mode -> IO () dropOutput (Seq.Cons h) = Exc.checkResult_ "dropOutput" =<< snd_seq_drop_output h foreign import ccall unsafe "alsa/asoundlib.h snd_seq_drop_output" - snd_seq_drop_output :: Ptr Seq.Core -> IO CInt + snd_seq_drop_output :: Ptr Seq.Core -> IO C.CInt -- | Remove events from the user-space output buffer. @@ -240,19 +302,19 @@ dropOutputBuffer (Seq.Cons h) = Exc.checkResult_ "dropOutputBuffer" =<< snd_seq_drop_output_buffer h foreign import ccall unsafe "alsa/asoundlib.h snd_seq_drop_output_buffer" - snd_seq_drop_output_buffer :: Ptr Seq.Core -> IO CInt + snd_seq_drop_output_buffer :: Ptr Seq.Core -> IO C.CInt -- | Remove events from both the user-space input buffer, -- and the kernel-space sequencer queue. --- See also: 'dropInputBuffer', 'removeEvents'. +-- See also: 'dropInputBuffer', 'removeOutput'. dropInput :: Seq.AllowInput mode => Seq.T mode -> IO () dropInput (Seq.Cons h) = Exc.checkResult_ "dropInput" =<< snd_seq_drop_input h foreign import ccall unsafe "alsa/asoundlib.h snd_seq_drop_input" - snd_seq_drop_input :: Ptr Seq.Core -> IO CInt + snd_seq_drop_input :: Ptr Seq.Core -> IO C.CInt -- | Remove events from the user-space input buffer. @@ -263,43 +325,58 @@ dropInputBuffer (Seq.Cons h) = Exc.checkResult_ "dropInputBuffer" =<< snd_seq_drop_input_buffer h foreign import ccall unsafe "alsa/asoundlib.h snd_seq_drop_input_buffer" - snd_seq_drop_input_buffer :: Ptr Seq.Core -> IO CInt + snd_seq_drop_input_buffer :: Ptr Seq.Core -> IO C.CInt -- | Make a note whose unspecified fields contain 0. -simpleNote - :: Word8 -- ^ Channel. - -> Word8 -- ^ Note. - -> Word8 -- ^ Velocity. - -> Event.Note +simpleNote :: Channel -> Pitch -> Velocity -> Event.Note simpleNote c n v = Event.Note { Event.noteChannel = c, Event.noteNote = n, Event.noteVelocity = v, - Event.noteOffVelocity = 0, - Event.noteDuration = 0 + Event.noteOffVelocity = offVelocity, + Event.noteDuration = Duration 0 } +normalVelocity, offVelocity :: Velocity +normalVelocity = Velocity 64 +offVelocity = Velocity 0 + {- | Construct an ALSA sequencer event from very few information. Most fields are initialized with sensible defaults. You may use this as a start and alter its fields for your special needs. -> (Event.simple myAddr (Event.simpleNote 0 60 64)) {Event.dest = destAddr} +> (Event.simple myAddr (Event.simpleNote (Event.Channel 0) (Event.Pitch 60) Event.normalVelocity)) {Event.dest = destAddr} -} simple :: Addr.T -> Event.Data -> Event.T simple src bdy = Cons { Event.highPriority = False - , Event.tag = 0 + , Event.tag = Tag 0 , Event.queue = Queue.direct - , Event.timestamp = Event.TickTime 0 + , Event.time = Time.consAbs $ Time.Tick 0 , Event.source = src , Event.dest = Addr.subscribers , Event.body = bdy } +forSourcePort :: Port.T -> Event.Data -> Event.T +forSourcePort port = + simple (Addr.Cons Client.unknown port) + +forConnection :: Connect.T -> Event.Data -> Event.T +forConnection (Connect.Cons src dst) bdy = + (simple src bdy) { Event.dest = dst } + + +customZero :: Event.Custom +customZero = Event.Custom 0 0 0 + + +{- available in alsa-1.0.14, but gone in 1.0.22 -- | Used for volume control: means do not change the volume. -volumeSame :: Int16 -volumeSame = -1 +volumeSame :: Volume +volumeSame = Volume (-1) +-} diff --git a/src/Sound/ALSA/Sequencer/Event/Accessor.hs b/src/Sound/ALSA/Sequencer/Event/Accessor.hs --- a/src/Sound/ALSA/Sequencer/Event/Accessor.hs +++ b/src/Sound/ALSA/Sequencer/Event/Accessor.hs @@ -2,29 +2,31 @@ highPriority, tag, queue, - timestamp, + time, + timeStamp, source, dest, connect, body, ) where +import qualified Sound.ALSA.Sequencer.Connect as Connect import qualified Sound.ALSA.Sequencer.Address as Addr import qualified Sound.ALSA.Sequencer.Queue as Queue +import qualified Sound.ALSA.Sequencer.Marshal.Time as Time import qualified Sound.ALSA.Sequencer.Marshal.Event as Event import qualified Data.Accessor.Basic as Acc -import Data.Word (Word8, ) - highPriority :: Acc.T Event.T Bool -tag :: Acc.T Event.T Word8 +tag :: Acc.T Event.T Event.Tag queue :: Acc.T Event.T Queue.T -timestamp :: Acc.T Event.T Event.TimeStamp +time :: Acc.T Event.T Time.T +timeStamp :: Acc.T Event.T Time.Stamp source :: Acc.T Event.T Addr.T dest :: Acc.T Event.T Addr.T -connect :: Acc.T Event.T Event.Connect +connect :: Acc.T Event.T Connect.T body :: Acc.T Event.T Event.Data highPriority = @@ -33,15 +35,18 @@ Acc.fromSetGet (\x ev -> ev{Event.tag = x}) Event.tag queue = Acc.fromSetGet (\x ev -> ev{Event.queue = x}) Event.queue -timestamp = - Acc.fromSetGet (\x ev -> ev{Event.timestamp = x}) Event.timestamp +time = + Acc.fromSetGet (\x ev -> ev{Event.time = x}) Event.time +timeStamp = time Acc..> Time.stampAcc source = Acc.fromSetGet (\x ev -> ev{Event.source = x}) Event.source dest = Acc.fromSetGet (\x ev -> ev{Event.dest = x}) Event.dest connect = - Acc.fromSetGet - (\(Event.Connect src dst) ev -> ev{Event.source = src, Event.dest = dst}) - (\ev -> Event.Connect (Event.source ev) (Event.dest ev)) + Acc.fromWrapper + (\(Connect.Cons src dst) -> (src, dst)) + (uncurry Connect.Cons) + Acc.<. + Acc.merge source dest body = Acc.fromSetGet (\x ev -> ev{Event.body = x}) Event.body diff --git a/src/Sound/ALSA/Sequencer/Event/Remove.hsc b/src/Sound/ALSA/Sequencer/Event/Remove.hsc new file mode 100644 --- /dev/null +++ b/src/Sound/ALSA/Sequencer/Event/Remove.hsc @@ -0,0 +1,94 @@ +module Sound.ALSA.Sequencer.Event.Remove ( + T, + malloc, + run, + + Condition, + getCondition, + setCondition, + + condInput, + condOutput, + condDest, + condDestChannel, + condTimeBefore, + condTimeAfter, + condTimeTick, + condEventType, + condIgnoreOff, + condTagMatch, + + getQueue, + getChannel, + getEventType, + getTag, + getDest, + getRealTime, + getTickTime, + + setQueue, + setChannel, + setEventType, + setTag, + setDest, + setRealTime, + setTickTime, + ) where + +#include +#include + +import qualified Sound.ALSA.Sequencer.Marshal.Sequencer as Seq +import qualified Sound.ALSA.Sequencer.Marshal.Address as Addr +import qualified Sound.ALSA.Sequencer.Marshal.Queue as Queue +import qualified Sound.ALSA.Sequencer.Marshal.Event as Event +import qualified Sound.ALSA.Sequencer.Marshal.RealTime as RealTime +import qualified Sound.ALSA.Sequencer.Marshal.Time as Time +import qualified Sound.ALSA.Sequencer.Area as Area +import qualified Sound.ALSA.Exception as Exc + +import qualified Data.EnumSet as EnumSet +import qualified Foreign.C.Types as C +import Foreign.Ptr (Ptr, ) + + +#area "remove_events" + +-- | Remove events according to the given conditions +run :: Seq.T mode -> T -> IO () +run (Seq.Cons h) info = + Exc.checkResult_ "EventRemove.run" =<< with info (run_ h) + +foreign import ccall unsafe "alsa/asoundlib.h snd_seq_remove_events" + run_ :: Ptr Seq.Core -> Ptr T_ -> IO C.CInt + + +#{get_set_int_gen "condition", "Condition", "Condition", "EnumSet.Cons", "EnumSet.decons", "C.CUInt"} + +#{get_set_int "queue", "Queue", "Queue.T", "Queue.imp", "Queue.exp"} +#{get_set_int "channel", "Channel", "Event.Channel", "(Event.Channel . fromIntegral)", "(fromIntegral . Event.unChannel)"} +#{get_set_int "event_type", "EventType", "Event.EType", "(Event.EType . fromIntegral)", "(fromIntegral . Event.unEType)"} +#{get_set_int "tag", "Tag", "Event.Tag", "(Event.Tag . fromIntegral)", "(fromIntegral . Event.unTag)"} +#{get_set_ptr "dest", "Dest", "Addr.T"} +#{get_set_ptr "time", "RealTime", "RealTime.T"} +#{get_set_ptr "time", "TickTime", "Time.Tick"} + + +newtype ConditionFlag = ConditionFlag Int + deriving (Eq, Ord, Enum) + +type Condition = EnumSet.T C.CUInt ConditionFlag + + +#{enum Condition, EnumSet.Cons + , condInput = SND_SEQ_REMOVE_INPUT /* Flush input queues */ + , condOutput = SND_SEQ_REMOVE_OUTPUT /* Flush output queues */ + , condDest = SND_SEQ_REMOVE_DEST /* Restrict by destination q:client:port */ + , condDestChannel = SND_SEQ_REMOVE_DEST_CHANNEL /* Restrict by channel */ + , condTimeBefore = SND_SEQ_REMOVE_TIME_BEFORE /* Restrict to before time */ + , condTimeAfter = SND_SEQ_REMOVE_TIME_AFTER /* Restrict to time or after */ + , condTimeTick = SND_SEQ_REMOVE_TIME_TICK /* Time is in ticks */ + , condEventType = SND_SEQ_REMOVE_EVENT_TYPE /* Restrict to event type */ + , condIgnoreOff = SND_SEQ_REMOVE_IGNORE_OFF /* Do not flush off events */ + , condTagMatch = SND_SEQ_REMOVE_TAG_MATCH /* Restrict to events with given tag */ + } diff --git a/src/Sound/ALSA/Sequencer/Event/RemoveMonad.hs b/src/Sound/ALSA/Sequencer/Event/RemoveMonad.hs new file mode 100644 --- /dev/null +++ b/src/Sound/ALSA/Sequencer/Event/RemoveMonad.hs @@ -0,0 +1,241 @@ +{- | +This module allows to cancel events according to some criteria. +In all cases other than 'setInput' and 'setOutput' +the criteria are combined by logical AND. +For every criterion we provide three kinds of accessors: + +* @set@: enable a criterion + +* @put@: enable or disable a criterion + +* @get@: query, whether the criterion is enabled or disabled. + +Currently only the @set@ functions are really usable. +The @put@ and @get@ functions would become useful +for manipulating the remove criterion record, that ALSA maintains. +-} +module Sound.ALSA.Sequencer.Event.RemoveMonad ( + T, + run, + -- no need to export this, since Event.Remove is not exported as well + -- apply, + + setInput, putInput, getInput, + setOutput, putOutput, getOutput, + setChannel, putChannel, getChannel, + setEventType, putEventType, + setTag, putTag, getTag, + setDest, putDest, getDest, + setTime, putTime, getTime, + setIgnoreOff, putIgnoreOff, getIgnoreOff, + ) where + +import qualified Sound.ALSA.Sequencer.Event.Remove as Remove + +import qualified Sound.ALSA.Sequencer.Marshal.Sequencer as Seq +import qualified Sound.ALSA.Sequencer.Marshal.Address as Addr +import qualified Sound.ALSA.Sequencer.Marshal.Queue as Queue +import qualified Sound.ALSA.Sequencer.Marshal.Event as Event +import qualified Sound.ALSA.Sequencer.Marshal.Time as Time + +import qualified Control.Monad.Trans.Reader as MR +import qualified Control.Monad.Trans.State as MS +import qualified Control.Monad.Trans.Class as MT +import Control.Applicative (Applicative, ) + +import qualified Data.EnumSet as EnumSet +import Data.EnumSet ((.-.), (.|.), ) + +import Control.Monad (liftM2, ) +import Data.Monoid (mempty, mappend, ) + + +newtype T a = Cons (MR.ReaderT Remove.T (MS.StateT Remove.Condition IO) a) + deriving (Functor, Applicative, Monad) + + +unpack :: T a -> Remove.T -> Remove.Condition -> IO (a, Remove.Condition) +unpack (Cons m) r = MS.runStateT (MR.runReaderT m r) + +-- | apply the changes in the Remove monad to the Remove record +_apply :: T a -> Remove.T -> IO a +_apply m r = do + c0 <- Remove.getCondition r + (a,c1) <- unpack m r c0 + Remove.setCondition r c1 + return a + +-- | Remove events according to the given conditions +run :: Seq.T mode -> T a -> IO a +run h m = do + r <- Remove.malloc + (a,c) <- unpack m r EnumSet.empty + Remove.setCondition r c + Remove.run h r + return a + + + +liftGet :: (Remove.T -> IO a) -> T a +liftGet f = Cons $ MR.ReaderT $ MT.lift . f + +liftGetCond :: (Remove.T -> IO a) -> Remove.Condition -> T (Maybe a) +liftGetCond f cond = do + b <- getCond cond + if b + then fmap Just $ liftGet f + else return Nothing + +liftSet :: (Remove.T -> b -> IO a) -> b -> T a +liftSet f x = Cons $ MR.ReaderT $ MT.lift . flip f x + +liftSetCond :: (Remove.T -> a -> IO b) -> Remove.Condition -> a -> T b +liftSetCond f cond x = do + modifyCond $ mappend cond + liftSet f x + +liftPutCond :: (Remove.T -> a -> IO ()) -> Remove.Condition -> Maybe a -> T () +liftPutCond f cond mx = + case mx of + Nothing -> modifyCond $ (.-. cond) + Just x -> liftSetCond f cond x + +getCond :: Remove.Condition -> T Bool +getCond cond = + Cons $ MT.lift $ MS.gets $ EnumSet.subset cond + +setCond :: Remove.Condition -> T () +setCond cond = + modifyCond $ mappend cond + +putCond :: Remove.Condition -> Bool -> T () +putCond cond b = + modifyCond $ (if b then (.|.) else flip (.-.)) cond + +modifyCond :: (Remove.Condition -> Remove.Condition) -> T () +modifyCond f = + Cons $ MT.lift $ MS.modify f + +{- | +All events in the local input buffer are removed. +The conditions are not checked for these events. +This is equivalent to 'Event.dropInputBuffer'. +-} +setInput :: T () +putInput :: Bool -> T () +getInput :: T Bool + +{- | +Matching events in the local output buffer are removed, too. +Matching events in the kernel buffer are removed in any case. +If there are no further conditions, +then this is equivalent to 'Event.dropOutputBuffer'. +-} +setOutput :: T () +putOutput :: Bool -> T () +getOutput :: T Bool + +setChannel :: Event.Channel -> T () +putChannel :: Maybe Event.Channel -> T () +getChannel :: T (Maybe Event.Channel) + +_setEventType :: Event.EType -> T () +_getEventType :: T Event.EType +setEventType :: Event.Type e => e -> T () +putEventType :: Event.Type e => Maybe e -> T () + +setTag :: Event.Tag -> T () +putTag :: Maybe Event.Tag -> T () +getTag :: T (Maybe Event.Tag) + +{- | +ALSA maintainers say, that destination address and queue are checked together, +at least in the kernel buffer. +However up to ALSA-1.0.22 the check for the queue is missing in libasound +for the local buffer. +-} +setDest :: (Addr.T, Queue.T) -> T () +putDest :: Maybe (Addr.T, Queue.T) -> T () +getDest :: T (Maybe (Addr.T, Queue.T)) + +{- | +NoteOff events are kept in any case. +-} +setIgnoreOff :: T () +putIgnoreOff :: Bool -> T () +getIgnoreOff :: T Bool + + +getInput = getCond Remove.condInput +setInput = setCond Remove.condInput +putInput = putCond Remove.condInput + +getOutput = getCond Remove.condOutput +setOutput = setCond Remove.condOutput +putOutput = putCond Remove.condOutput + +getChannel = liftGetCond Remove.getChannel Remove.condDestChannel +setChannel = liftSetCond Remove.setChannel Remove.condDestChannel +putChannel = liftPutCond Remove.setChannel Remove.condDestChannel + +_getEventType = liftGet Remove.getEventType +_setEventType = liftSetCond Remove.setEventType Remove.condEventType +setEventType = + liftSetCond Remove.setEventType Remove.condEventType . Event.expEv +putEventType = + liftPutCond Remove.setEventType Remove.condEventType . fmap Event.expEv + +getTag = liftGetCond Remove.getTag Remove.condTagMatch +setTag = liftSetCond Remove.setTag Remove.condTagMatch +putTag = liftPutCond Remove.setTag Remove.condTagMatch + +getDestQueue :: Remove.T -> IO (Addr.T, Queue.T) +getDestQueue r = liftM2 (,) (Remove.getDest r) (Remove.getQueue r) +setDestQueue :: Remove.T -> (Addr.T, Queue.T) -> IO () +setDestQueue r (a,q) = Remove.setDest r a >> Remove.setQueue r q + +getDest = liftGetCond getDestQueue Remove.condDest +setDest = liftSetCond setDestQueue Remove.condDest +putDest = liftPutCond setDestQueue Remove.condDest + +getIgnoreOff = getCond Remove.condIgnoreOff +setIgnoreOff = setCond Remove.condIgnoreOff +putIgnoreOff = putCond Remove.condIgnoreOff + + +getTime :: T (Maybe Ordering, Time.Stamp) +getTime = do + ticks <- getCond Remove.condTimeTick + stamp <- + if ticks + then fmap Time.Tick $ liftGet Remove.getTickTime + else fmap Time.Real $ liftGet Remove.getRealTime + after <- getCond Remove.condTimeAfter + before <- getCond Remove.condTimeBefore + let mo = + case (after, before) of + (False, False) -> Nothing + (True, False) -> Just GT + (False, True ) -> Just LT + (True, True ) -> Just EQ + return (mo, stamp) + +setTime :: Ordering -> Time.Stamp -> T () +setTime o = putTime $ Just o + +putTime :: Maybe Ordering -> Time.Stamp -> T () +putTime mo t = do + modifyCond ( .-. (Remove.condTimeAfter .|. Remove.condTimeBefore)) + modifyCond $ mappend $ + case mo of + Nothing -> mempty + Just LT -> Remove.condTimeBefore + Just GT -> Remove.condTimeAfter + Just EQ -> mappend Remove.condTimeBefore Remove.condTimeAfter + case t of + Time.Tick x -> do + modifyCond $ (.-. Remove.condTimeTick) + liftSet Remove.setTickTime x + Time.Real x -> do + modifyCond $ (.|. Remove.condTimeTick) + liftSet Remove.setRealTime x diff --git a/src/Sound/ALSA/Sequencer/Marshal/Address.hsc b/src/Sound/ALSA/Sequencer/Marshal/Address.hsc --- a/src/Sound/ALSA/Sequencer/Marshal/Address.hsc +++ b/src/Sound/ALSA/Sequencer/Marshal/Address.hsc @@ -1,13 +1,14 @@ module Sound.ALSA.Sequencer.Marshal.Address where #include +#include import qualified Sound.ALSA.Sequencer.Marshal.Client as Client import qualified Sound.ALSA.Sequencer.Marshal.Port as Port import qualified Sound.ALSA.Sequencer.Utility as U -import Foreign.C.Types (CInt, ) +import qualified Foreign.C.Types as C import Foreign.Storable (Storable, sizeOf, alignment, peek, poke, pokeByteOff, peekByteOff, ) @@ -22,13 +23,13 @@ U.showsRecord prec "Address" [U.showsField c, U.showsField p] -exp :: T -> (CInt,CInt) +exp :: T -> (C.CInt,C.CInt) exp a = (Client.exp (client a), Port.exp (port a)) instance Storable T where - sizeOf _ = #size snd_seq_real_time_t - alignment _ = 4 -- XXX + sizeOf _ = #{size snd_seq_real_time_t} + alignment _ = #{alignment snd_seq_real_time_t} peek p = do cl <- #{peek snd_seq_addr_t, client} p po <- #{peek snd_seq_addr_t, port} p return Cons { client = cl, port = po } @@ -36,10 +37,38 @@ >> #{poke snd_seq_addr_t, port} p (port v) +unknown :: T +unknown = + Cons { + client = Client.unknown, + port = Port.unknown + } + -- | The address of all subscribed ports. subscribers :: T subscribers = Cons { client = Client.subscribers, port = Port.unknown + } + +broadcast :: T +broadcast = + Cons { + client = Client.broadcast, + port = Port.unknown + } + +systemTimer :: T +systemTimer = + Cons { + client = Client.system, + port = Port.systemTimer + } + +systemAnnounce :: T +systemAnnounce = + Cons { + client = Client.system, + port = Port.systemAnnounce } diff --git a/src/Sound/ALSA/Sequencer/Marshal/Client.hsc b/src/Sound/ALSA/Sequencer/Marshal/Client.hsc --- a/src/Sound/ALSA/Sequencer/Marshal/Client.hsc +++ b/src/Sound/ALSA/Sequencer/Marshal/Client.hsc @@ -13,24 +13,28 @@ -- Here we have the various types used by the library, -- and how they are imported\/exported to C. -- --- NOTE: In the translations bellow we make the following assumptions --- about the sizes of C types. --- CChar = 8 bits --- CShort = 16 bit --- CInt = 32 bits +-- We use Hsc for expanding C types to Haskell types like Word32. +-- However if a C type is translated to Word32 +-- you should not assume that it is translated to Word32 on every platform. +-- On a 64bit machine it may well be Word64. +-- Thus you should use our wrapper types whereever possible. -------------------------------------------------------------------------------- module Sound.ALSA.Sequencer.Marshal.Client where #include +#include + import qualified Sound.ALSA.Sequencer.Utility as U -import Foreign.C.Types (CInt, ) +import qualified Foreign.C.Types as C +import qualified Data.Word as Word import Foreign.Storable (Storable, ) -import Data.Word (Word8, ) -- | The type of client identifiers. -newtype T = Cons Word8 deriving (Eq, Ord, Storable) +newtype T = + Cons #{intfieldtype snd_seq_addr_t, client} + deriving (Eq, Ord, Storable) instance Show T where showsPrec prec (Cons x) = @@ -46,16 +50,16 @@ -exp :: T -> CInt +exp :: T -> C.CInt exp (Cons c) = fromIntegral c -imp :: CInt -> T +imp :: C.CInt -> T imp p = Cons (fromIntegral p) -- | The different types of clients. data Type = User | Kernel -impType :: CInt -> Type +impType :: C.CInt -> Type impType x = if x == #{const SND_SEQ_USER_CLIENT} then User diff --git a/src/Sound/ALSA/Sequencer/Marshal/ClientInfo.hsc b/src/Sound/ALSA/Sequencer/Marshal/ClientInfo.hsc new file mode 100644 --- /dev/null +++ b/src/Sound/ALSA/Sequencer/Marshal/ClientInfo.hsc @@ -0,0 +1,104 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Sound.ALSA.Sequencer.Client +-- Copyright : (c) Henning Thielemann, 2010-2012 +-- (c) Iavor S. Diatchki, 2007 +-- License : BSD3 +-- +-- Maintainer: Henning Thielemann +-- Stability : provisional +-- +-- This module contains functions for working with sequencer clients. +-- Reference: +-- +-------------------------------------------------------------------------------- + +module Sound.ALSA.Sequencer.Marshal.ClientInfo where + +#include + +import qualified Sound.ALSA.Sequencer.Marshal.Client as Client +import qualified Sound.ALSA.Sequencer.Marshal.Sequencer as Seq +import qualified Sound.ALSA.Sequencer.Area as Area +import qualified Sound.ALSA.Sequencer.Query as Query +import qualified Sound.ALSA.Sequencer.Utility as U +import qualified Sound.ALSA.Exception as Exc + +import qualified Foreign.C.Types as C +import Foreign.Ptr (Ptr, ) +import Data.Word (Word, ) + + +#area "client_info" + +-- read/write +#get_set_name +#get_set_bool "broadcast_filter", "BroadcastFilter" +#get_set_bool "error_bounce", "ErrorBounce" +#{get_set_int "client", "Client", + "Client.T", "Client.imp", "Client.exp"} + +-- read only +#{get_int "type", "Type", + "Client.Type", "Client.impType"} +#{get_int "num_ports", "NumPorts", + "Word", "fromIntegral"} +#{get_int "event_lost", "EventLost", + "Word", "fromIntegral"} + + + +-- | Create a new information area filled with data about the sequencer client. +get :: Seq.T mode -> IO T +get (Seq.Cons h) = + do info <- malloc + Exc.checkResult_ "ClientInfo.get" =<< with info (get_ h) + return info + +foreign import ccall unsafe "alsa/asoundlib.h snd_seq_get_client_info" + get_ :: Ptr Seq.Core -> Ptr T_ -> IO C.CInt + + +-- | Create a new information area filled with data about an arbitrary client. +getAny :: Seq.T mode -> Client.T -> IO T +getAny (Seq.Cons h) c = + do info <- malloc + Exc.checkResult_ "ClientInfo.getAny" =<< + with info (getAny_ h (Client.exp c)) + return info + +foreign import ccall unsafe "alsa/asoundlib.h snd_seq_get_any_client_info" + getAny_ + :: Ptr Seq.Core -> C.CInt -> Ptr T_ -> IO C.CInt + + +-- | Set the information for the sequencer client based on the data +-- in the given information area. +set :: Seq.T mode -> T -> IO () +set (Seq.Cons h) info = + Exc.checkResult_ "set_client_info" =<< with info (set_ h) + +foreign import ccall unsafe "alsa/asoundlib.h snd_seq_set_client_info" + set_ :: Ptr Seq.Core -> Ptr T_ -> IO C.CInt + + + +queryInit :: T -> IO () +queryInit x = + {- + we cannot use setClient here, + since Client uses an unsigned type and thus cannot represent -1 + -} + with x (flip setClient_ (-1)) + +-- | Get information about the client with the next biggest identifier. +queryNext :: Seq.T mode -> T -> IO Bool -- ^ Was there a next client? +queryNext (Seq.Cons h) info = + U.checkResultQuery "ClientInfo.queryNext" =<< with info (queryNext_ h) + +foreign import ccall unsafe "alsa/asoundlib.h snd_seq_query_next_client" + queryNext_ :: Ptr Seq.Core -> Ptr T_ -> IO C.CInt + +instance Query.C T where + init = queryInit + next = queryNext diff --git a/src/Sound/ALSA/Sequencer/Marshal/Connect.hsc b/src/Sound/ALSA/Sequencer/Marshal/Connect.hsc new file mode 100644 --- /dev/null +++ b/src/Sound/ALSA/Sequencer/Marshal/Connect.hsc @@ -0,0 +1,24 @@ +module Sound.ALSA.Sequencer.Marshal.Connect where + +#include +#include + +import qualified Sound.ALSA.Sequencer.Marshal.Address as Addr + +import Foreign.Storable + (Storable, sizeOf, alignment, peek, poke, pokeByteOff, peekByteOff, ) + + +data T = Cons + { source :: !Addr.T + , dest :: !Addr.T + } deriving (Show,Eq,Ord) + +instance Storable T where + sizeOf _ = #{size snd_seq_connect_t} + alignment _ = #{alignment snd_seq_connect_t} + peek p = do s <- #{peek snd_seq_connect_t, sender} p + d <- #{peek snd_seq_connect_t, dest} p + return Cons { source = s, dest = d } + poke p v = #{poke snd_seq_connect_t, sender} p (source v) + >> #{poke snd_seq_connect_t, dest} p (dest v) diff --git a/src/Sound/ALSA/Sequencer/Marshal/Event.hsc b/src/Sound/ALSA/Sequencer/Marshal/Event.hsc --- a/src/Sound/ALSA/Sequencer/Marshal/Event.hsc +++ b/src/Sound/ALSA/Sequencer/Marshal/Event.hsc @@ -1,7 +1,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Sound.ALSA.Sequencer.Marshal.Event --- Copyright : (c) Henning Thielemann, 2011 +-- Copyright : (c) Henning Thielemann, 2011-2012 -- (c) Iavor S. Diatchki, 2007 -- License : BSD3 -- @@ -13,58 +13,46 @@ -- Here we have the various types used by the library, -- and how they are imported\/exported to C. -- --- NOTE: In the translations bellow we make the following assumptions --- about the sizes of C types. --- CChar = 8 bits --- CShort = 16 bit --- CInt = 32 bits +-- We use Hsc for expanding C types to Haskell types like Word32. +-- However if a C type is translated to Word32 +-- you should not assume that it is translated to Word32 on every platform. +-- On a 64bit machine it may well be Word64. +-- Thus you should use our wrapper types whereever possible. -------------------------------------------------------------------------------- module Sound.ALSA.Sequencer.Marshal.Event where #include +#include +import qualified Sound.ALSA.Sequencer.Marshal.Connect as Connect import qualified Sound.ALSA.Sequencer.Marshal.Address as Addr import qualified Sound.ALSA.Sequencer.Marshal.Queue as Queue import qualified Sound.ALSA.Sequencer.Marshal.RealTime as RealTime +import qualified Sound.ALSA.Sequencer.Marshal.Time as Time -import Foreign.C.Types (CUInt, ) +import qualified Data.ByteString.Unsafe as BU +import qualified Data.ByteString as B + +import qualified Foreign.Marshal.Alloc as MA +import qualified Foreign.C.Types as C +import qualified Data.Int as Int +import qualified Data.Word as Word import Foreign.Storable (Storable, sizeOf, alignment, peek, poke, pokeByteOff, peekByteOff, ) import Foreign.Ptr (Ptr, castPtr, nullPtr, plusPtr, ) -import Foreign.Marshal.Alloc (alloca, ) +import Control.Monad (liftM2, ) import Data.Monoid (mappend, ) import qualified Data.FlagSet as FlagSet -import Data.Int (Int16, Int32, ) -import Data.Word (Word8, Word16, Word32, ) -import Data.Array (Array, (!), accumArray, ) +import Data.Array (Ix, Array, (!), accumArray, ) +import Data.Tuple.HT (mapFst, ) data Flag -type Flags = FlagSet.T Word8 Flag -type FlagValue = FlagSet.MaskedValue Word8 Flag - - -timeStampTick, timeStampReal :: FlagValue -timeStampTick = - FlagSet.MaskedValue - #{const SND_SEQ_TIME_STAMP_MASK} - #{const SND_SEQ_TIME_STAMP_TICK} -timeStampReal = - FlagSet.MaskedValue - #{const SND_SEQ_TIME_STAMP_MASK} - #{const SND_SEQ_TIME_STAMP_REAL} - +type Flags = FlagSet.T #{intfieldtype snd_seq_event_t, flags} Flag +type FlagValue = FlagSet.MaskedValue #{intfieldtype snd_seq_event_t, flags} Flag -timeModeAbs, timeModeRel :: FlagValue -timeModeAbs = - FlagSet.MaskedValue - #{const SND_SEQ_TIME_MODE_MASK} - #{const SND_SEQ_TIME_MODE_ABS} -timeModeRel = - FlagSet.MaskedValue - #{const SND_SEQ_TIME_MODE_MASK} - #{const SND_SEQ_TIME_MODE_REL} +instance Time.Flag Flag where eventLengthFixed, eventLengthVariable, eventLengthVarUser :: FlagValue @@ -93,81 +81,58 @@ #{const SND_SEQ_PRIORITY_NORMAL} -data Connect = Connect - { connSource :: !Addr.T - , connDest :: !Addr.T - } deriving (Show,Eq,Ord) -instance Storable Connect where - sizeOf _ = #size snd_seq_connect_t - alignment _ = 4 -- XXX - peek p = do s <- #{peek snd_seq_connect_t, sender} p - d <- #{peek snd_seq_connect_t, dest} p - return Connect { connSource = s, connDest = d } - poke p v = #{poke snd_seq_connect_t, sender} p (connSource v) - >> #{poke snd_seq_connect_t, dest} p (connDest v) - - -data TimeStamp = TickTime !Word32 - | RealTime !RealTime.T - deriving Show - -peekTimestamp :: Flags -> Ptr TimeStamp -> IO TimeStamp -peekTimestamp flags p = - if FlagSet.match flags timeStampTick - then fmap TickTime $ peek $ castPtr p - else fmap RealTime $ peek $ castPtr p - -pokeTimestamp :: Ptr TimeStamp -> TimeStamp -> IO FlagValue -pokeTimestamp p ts = case ts of - TickTime t -> poke (castPtr p) t >> return timeStampTick - RealTime t -> poke (castPtr p) t >> return timeStampReal - - +{- available in alsa-1.0.14, but gone in 1.0.22 +#{newinttype "InstrCluster", snd_seq_instr_cluster_t} -newtype InstrCluster = InstrCluster CUInt - deriving (Show,Eq,Ord,Num,Enum,Storable) +#{newintfieldtype "StandardId", snd_seq_instr_t, std} +#{newintfieldtype "Bank", snd_seq_instr_t, bank} +#{newintfieldtype "Program", snd_seq_instr_t, prg} data Instr = Instr { instrCluster :: !InstrCluster -- XXX: perhaps use Sample? - , instrStd :: !Word32 - , instrBank :: !Word16 - , instrPrg :: !Word16 + , instrStd :: !StandardId + , instrBank :: !Bank + , instrPrg :: !Program } deriving (Show) -{- instance Storable Instr where sizeOf _ = #{size snd_seq_instr_t} - alignment _ = 4 -- XXX + alignment _ = #{alignment snd_seq_instr_t} peek p = do cl <- #{peek snd_seq_instr_t, cluster} p st <- #{peek snd_seq_instr_t, std} p ba <- #{peek snd_seq_instr_t, bank} p pr <- #{peek snd_seq_instr_t, prg} p - return Instr { instr_cluster = cl - , instr_std = st - , instr_bank = ba - , instr_prg = pr + return Instr { instrCluster = cl + , instrStd = st + , instrBank = ba + , instrPrg = pr } - poke p v = #{poke snd_seq_instr_t, cluster} p (instr_cluster v) - >> #{poke snd_seq_instr_t, std} p (instr_std v) - >> #{poke snd_seq_instr_t, bank} p (instr_bank v) - >> #{poke snd_seq_instr_t, prg} p (instr_prg v) + poke p v = #{poke snd_seq_instr_t, cluster} p (instrCluster v) + >> #{poke snd_seq_instr_t, std} p (instrStd v) + >> #{poke snd_seq_instr_t, bank} p (instrBank v) + >> #{poke snd_seq_instr_t, prg} p (instrPrg v) -} +#{newintfieldtype "Channel", snd_seq_ev_note_t, channel} +#{newintfieldtype "Pitch", snd_seq_ev_note_t, note} +#{newintfieldtype "Velocity", snd_seq_ev_note_t, velocity} +#{newintfieldtype "Duration", snd_seq_ev_note_t, duration} + data Note = Note - { noteChannel :: !Word8 - , noteNote :: !Word8 - , noteVelocity :: !Word8 - , noteOffVelocity :: !Word8 - , noteDuration :: !Word32 + { noteChannel :: !Channel + , noteNote :: !Pitch + , noteVelocity :: !Velocity + , noteOffVelocity :: !Velocity + , noteDuration :: !Duration } deriving (Show) instance Storable Note where sizeOf _ = #{size snd_seq_ev_note_t} - alignment _ = 4 -- XXX + alignment _ = #{alignment snd_seq_ev_note_t} peek p = do c <- #{peek snd_seq_ev_note_t, channel} p n <- #{peek snd_seq_ev_note_t, note} p v <- #{peek snd_seq_ev_note_t, velocity} p @@ -186,15 +151,18 @@ >> #{poke snd_seq_ev_note_t, duration} p (noteDuration v) +#{newintfieldtype "Parameter", snd_seq_ev_ctrl_t, param} +#{newintfieldtype "Value", snd_seq_ev_ctrl_t, value} + data Ctrl = Ctrl - { ctrlChannel :: !Word8 - , ctrlParam :: !Word32 - , ctrlValue :: !Int32 + { ctrlChannel :: !Channel + , ctrlParam :: !Parameter + , ctrlValue :: !Value } deriving (Show) instance Storable Ctrl where sizeOf _ = #{size snd_seq_ev_ctrl_t} - alignment _ = 4 -- XXX + alignment _ = #{alignment snd_seq_ev_ctrl_t} peek p = do ct <- #{peek snd_seq_ev_ctrl_t, channel} p pa <- #{peek snd_seq_ev_ctrl_t, param} p va <- #{peek snd_seq_ev_ctrl_t, value} p @@ -207,28 +175,40 @@ >> #{poke snd_seq_ev_ctrl_t, value} p (ctrlValue v) +pokeQueue :: + Ptr Data -> QueueEv -> Queue.T -> IO EType +pokeQueue p e q = do + poke (castPtr p) q + case e of + QueueSetPosTick t -> #{poke snd_seq_ev_queue_control_t, param.time.tick} p t + QueueSetPosTime t -> #{poke snd_seq_ev_queue_control_t, param.time.time} p t + QueueTempo t -> #{poke snd_seq_ev_queue_control_t, param.value} p t + QueueSkew s -> #{poke snd_seq_ev_queue_control_t, param.skew} p s + QueueSyncPos s -> #{poke snd_seq_ev_queue_control_t, param.position} p s + _ -> return () + return (expEv e) + +{- available in alsa-1.0.14, but gone in 1.0.22 data Sample = Sample - { sampleStd :: !Word32 - , sampleBank :: !Word16 - , samplePrg :: !Word16 + { sampleStd :: !StandardId + , sampleBank :: !Bank + , samplePrg :: !Program } deriving (Show) -{- instance Storable Sample where sizeOf _ = #{size snd_seq_ev_sample_t} - alignment _ = 4 -- XXX + alignment _ = #{alignment snd_seq_ev_sample_t} peek p = do st <- #{peek snd_seq_ev_sample_t, std} p ba <- #{peek snd_seq_ev_sample_t, bank} p pr <- #{peek snd_seq_ev_sample_t, prg} p - return Sample { sample_std = st - , sample_bank = ba - , sample_prg = pr + return Sample { sampleStd = st + , sampleBank = ba + , samplePrg = pr } poke p v = #{poke snd_seq_ev_sample_t, std} p (sampleStd v) >> #{poke snd_seq_ev_sample_t, bank} p (sampleBank v) >> #{poke snd_seq_ev_sample_t, prg} p (samplePrg v) --} newtype Cluster = Cluster @@ -236,26 +216,29 @@ } deriving (Show, Eq, Storable) +#{newintfieldtype "Volume", snd_seq_ev_volume_t, volume} +#{newintfieldtype "Balance", snd_seq_ev_volume_t, lr} + -- | These are all 14 bit values. -data Volume = Volume - { volumeVolume :: !Int16 - , volumeLR :: !Int16 - , volumeFR :: !Int16 - , volumeDU :: !Int16 +data VolumeControl = VolumeControl + { volumeVolume :: !Volume + , volumeLR :: !Balance + , volumeFR :: !Balance + , volumeDU :: !Balance } deriving (Show) -{- -instance Storable Volume where +instance Storable VolumeControl where sizeOf _ = #{size snd_seq_ev_volume_t} - alignment _ = 4 -- XXX + alignment _ = #{alignment snd_seq_ev_volume_t} peek p = do v <- #{peek snd_seq_ev_volume_t, volume} p l <- #{peek snd_seq_ev_volume_t, lr} p f <- #{peek snd_seq_ev_volume_t, fr} p d <- #{peek snd_seq_ev_volume_t, du} p - return Volume { volume_volume = v - , volume_lr = l - , volume_fr = f - , volume_du = d + return VolumeControl + { volumeVolume = v + , volumeLR = l + , volumeFR = f + , volumeDU = d } poke p v = #{poke snd_seq_ev_volume_t, volume} p (volumeVolume v) >> #{poke snd_seq_ev_volume_t, lr} p (volumeLR v) @@ -264,12 +247,14 @@ -} -data Custom = Custom { custom0, custom1, custom2 :: !Word32 } - deriving (Show) +data Custom = + Custom { + custom0, custom1, custom2 :: ! #{intfieldtype snd_seq_ev_raw32_t, d[0]} + } deriving (Show) instance Storable Custom where sizeOf _ = #{size snd_seq_ev_raw32_t} - alignment _ = 4 -- XXX + alignment _ = #{alignment snd_seq_ev_raw32_t} peek p = do d0 <- #{peek snd_seq_ev_raw32_t, d[0]} p d1 <- #{peek snd_seq_ev_raw32_t, d[1]} p d2 <- #{peek snd_seq_ev_raw32_t, d[2]} p @@ -282,12 +267,13 @@ >> #{poke snd_seq_ev_raw32_t, d[2]} p (custom2 v) +#{newintfieldtype "Tag", snd_seq_event_t, tag} data T = Cons { highPriority :: !Bool - , tag :: !Word8 + , tag :: !Tag , queue :: !Queue.T - , timestamp :: !TimeStamp + , time :: !Time.T , source :: !Addr.T , dest :: !Addr.T , body :: !Data @@ -295,13 +281,13 @@ instance Storable T where sizeOf _ = #{size snd_seq_event_t} - alignment _ = 4 -- XXX + alignment _ = #{alignment snd_seq_event_t} peek p = do ty <- #{peek snd_seq_event_t, type} p flags <- #{peek snd_seq_event_t, flags} p tg <- #{peek snd_seq_event_t, tag} p q <- #{peek snd_seq_event_t, queue} p - time <- peekTimestamp flags (#{ptr snd_seq_event_t, time} p) + t <- Time.peek flags (#{ptr snd_seq_event_t, time} p) src <- #{peek snd_seq_event_t, source} p dst <- #{peek snd_seq_event_t, dest} p d <- (peekData ! ty) (#{ptr snd_seq_event_t, data} p) @@ -309,53 +295,78 @@ { highPriority = not $ FlagSet.match flags priorityNormal , tag = tg , queue = q - , timestamp = time + , time = t , source = src , dest = dst , body = d } - poke p e = do - { ty <- pokeData (#{ptr snd_seq_event_t, data} p) (body e) - ; #{poke snd_seq_event_t, type} p ty - ; #{poke snd_seq_event_t, tag} p (tag e) - ; #{poke snd_seq_event_t, queue} p (queue e) - ; real <- pokeTimestamp (#{ptr snd_seq_event_t, time} p) (timestamp e) - ; #{poke snd_seq_event_t, source} p (source e) - ; #{poke snd_seq_event_t, dest} p (dest e) - ; let flags = - (if highPriority e - then priorityHigh - else priorityNormal) - `mappend` real - `mappend` eventLengthFixed - ; #{poke snd_seq_event_t, flags} p (FlagSet.fromMaskedValue flags) - } + poke p e = + pokeHeader p e eventLengthFixed + =<< pokeData (#{ptr snd_seq_event_t, data} p) (body e) -allocaEv :: T -> (Ptr T -> IO a) -> IO a -allocaEv e h = alloca (\p -> poke p e >> h p) +withMaybe :: Maybe T -> (Ptr T -> IO a) -> IO a +withMaybe me f = + maybe (f nullPtr) (flip with f) me -allocaMaybeEv :: Maybe T -> (Ptr T -> IO a) -> IO a -allocaMaybeEv me h = - maybe (h nullPtr) (\e -> allocaEv e h) me +with :: T -> (Ptr T -> IO a) -> IO a +with ev f = + MA.alloca $ \p -> + case body ev of + ExtEv e d -> do + let lengthFlag = + case e of + SysEx -> eventLengthVariable + Bounce -> eventLengthVariable + _ -> eventLengthVarUser + pokeHeader p ev lengthFlag (expEv e) + BU.unsafeUseAsCString d $ \ptr -> do + #{poke snd_seq_event_t, data.ext.len} p (B.length d) + #{poke snd_seq_event_t, data.ext.ptr} p ptr + f p + b -> do + pokeHeader p ev eventLengthFixed + =<< pokeData (#{ptr snd_seq_event_t, data} p) b + f p + pokeBody :: (Storable d, Type e) => - Ptr Data -> e -> d -> IO Word8 + Ptr Data -> e -> d -> IO EType pokeBody p e d = poke (castPtr p) d >> return (expEv e) -pokeData :: Ptr Data -> Data -> IO Word8 +pokeData :: Ptr Data -> Data -> IO EType pokeData p dt = case dt of NoteEv e d -> pokeBody p e d CtrlEv e d -> pokeBody p e d + QueueEv e d -> pokeQueue p e d AddrEv e d -> pokeBody p e d ConnEv e d -> pokeBody p e d CustomEv e d -> pokeBody p e d + ExtEv _ _ -> error "cannot simply poke ExtEv, because it needs allocation - use Event.with instead" EmptyEv e -> return (expEv e) +pokeHeader :: Ptr T -> T -> FlagValue -> EType -> IO () +pokeHeader p e lengthFlag ty = do + #{poke snd_seq_event_t, type} p ty + #{poke snd_seq_event_t, tag} p (tag e) + #{poke snd_seq_event_t, queue} p (queue e) + real <- Time.poke (#{ptr snd_seq_event_t, time} p) (time e) + #{poke snd_seq_event_t, source} p (source e) + #{poke snd_seq_event_t, dest} p (dest e) + let flags = + (if highPriority e + then priorityHigh + else priorityNormal) + `mappend` real + `mappend` lengthFlag + #{poke snd_seq_event_t, flags} p (FlagSet.fromMaskedValue flags) -peekData :: Array Word8 (Ptr Data -> IO Data) -peekData = accumArray (const id) unknown (0,255) + +peekData :: Array EType (Ptr Data -> IO Data) +peekData = + accumArray (const id) unknown (EType 0, EType 255) $ + map (mapFst EType) $ [ -- result events (2) (#{const SND_SEQ_EVENT_SYSTEM}, unknown) , (#{const SND_SEQ_EVENT_RESULT}, unknown) @@ -381,16 +392,16 @@ , (#{const SND_SEQ_EVENT_KEYSIGN}, peekCtrlEv KeySign) -- queue control (10) - , (#{const SND_SEQ_EVENT_START}, unknown) - , (#{const SND_SEQ_EVENT_CONTINUE}, unknown) - , (#{const SND_SEQ_EVENT_STOP}, unknown) - , (#{const SND_SEQ_EVENT_SETPOS_TICK}, unknown) - , (#{const SND_SEQ_EVENT_SETPOS_TIME}, unknown) - , (#{const SND_SEQ_EVENT_TEMPO}, unknown) - , (#{const SND_SEQ_EVENT_CLOCK}, unknown) - , (#{const SND_SEQ_EVENT_TICK}, unknown) - , (#{const SND_SEQ_EVENT_QUEUE_SKEW}, unknown) - , (#{const SND_SEQ_EVENT_SYNC_POS}, unknown) + , (#{const SND_SEQ_EVENT_START}, peekQueueEv QueueStart) + , (#{const SND_SEQ_EVENT_CONTINUE}, peekQueueEv QueueContinue) + , (#{const SND_SEQ_EVENT_STOP}, peekQueueEv QueueStop) + , (#{const SND_SEQ_EVENT_SETPOS_TICK}, peekQueueExt QueueSetPosTick #{peek snd_seq_ev_queue_control_t, param.time.tick}) + , (#{const SND_SEQ_EVENT_SETPOS_TIME}, peekQueueExt QueueSetPosTime #{peek snd_seq_ev_queue_control_t, param.time.time}) + , (#{const SND_SEQ_EVENT_TEMPO}, peekQueueExt QueueTempo #{peek snd_seq_ev_queue_control_t, param.value}) + , (#{const SND_SEQ_EVENT_CLOCK}, peekQueueEv QueueClock) + , (#{const SND_SEQ_EVENT_TICK}, peekQueueEv QueueTick) + , (#{const SND_SEQ_EVENT_QUEUE_SKEW}, peekQueueExt QueueSkew #{peek snd_seq_ev_queue_control_t, param.skew}) + , (#{const SND_SEQ_EVENT_SYNC_POS}, peekQueueExt QueueSyncPos #{peek snd_seq_ev_queue_control_t, param.position}) -- misc (3) , (#{const SND_SEQ_EVENT_TUNE_REQUEST}, peekEmptyEv TuneRequest) @@ -410,7 +421,7 @@ , (#{const SND_SEQ_EVENT_PORT_SUBSCRIBED}, peekConnEv PortSubscribed) , (#{const SND_SEQ_EVENT_PORT_UNSUBSCRIBED}, peekConnEv PortUnsubscribed) -{- +{- available in alsa-1.0.14, but gone in 1.0.22 , (#{const SND_SEQ_EVENT_SAMPLE}, unknown) , (#{const SND_SEQ_EVENT_SAMPLE_CLUSTER}, unknown) , (#{const SND_SEQ_EVENT_SAMPLE_START}, unknown) @@ -432,7 +443,7 @@ , (#{const SND_SEQ_EVENT_USR8}, peekCustomEv User8) , (#{const SND_SEQ_EVENT_USR9}, peekCustomEv User9) -{- +{- available in alsa-1.0.14, but gone in 1.0.22 , (#{const SND_SEQ_EVENT_INSTR_BEGIN}, unknown) , (#{const SND_SEQ_EVENT_INSTR_END}, unknown) , (#{const SND_SEQ_EVENT_INSTR_INFO}, unknown) @@ -454,14 +465,13 @@ , (#{const SND_SEQ_EVENT_INSTR_CHANGE}, unknown) -} - , (#{const SND_SEQ_EVENT_SYSEX}, unknown) - , (#{const SND_SEQ_EVENT_BOUNCE}, unknown) - - , (#{const SND_SEQ_EVENT_USR_VAR0}, unknown) - , (#{const SND_SEQ_EVENT_USR_VAR1}, unknown) - , (#{const SND_SEQ_EVENT_USR_VAR2}, unknown) - , (#{const SND_SEQ_EVENT_USR_VAR3}, unknown) - , (#{const SND_SEQ_EVENT_USR_VAR3}, unknown) + , (#{const SND_SEQ_EVENT_SYSEX}, peekExtEv SysEx ) + , (#{const SND_SEQ_EVENT_BOUNCE}, peekExtEv Bounce ) + , (#{const SND_SEQ_EVENT_USR_VAR0}, peekExtEv UserVar0) + , (#{const SND_SEQ_EVENT_USR_VAR1}, peekExtEv UserVar1) + , (#{const SND_SEQ_EVENT_USR_VAR2}, peekExtEv UserVar2) + , (#{const SND_SEQ_EVENT_USR_VAR3}, peekExtEv UserVar3) + , (#{const SND_SEQ_EVENT_USR_VAR3}, peekExtEv UserVar4) , (#{const SND_SEQ_EVENT_NONE}, peekEmptyEv None) ] @@ -480,17 +490,19 @@ | TimeSign | KeySign deriving (Show, Eq, Ord, Enum, Bounded) +#{newintfieldtype "Tempo", snd_seq_ev_queue_control_t, param.value} + data QueueEv = QueueStart | QueueContinue | QueueStop - | QueueSetPosTick - | QueueSetPosTime - | QueueTempo + | QueueSetPosTick !Time.Tick + | QueueSetPosTime !RealTime.T + | QueueTempo !Tempo | QueueClock | QueueTick - | QueueSkew - | QueueSyncPos - deriving (Show, Eq, Ord, Enum, Bounded) + | QueueSkew !Queue.Skew + | QueueSyncPos !Queue.Position + deriving (Show, Eq) data EmptyEv = TuneRequest | Reset | Sensing | None | Unknown deriving (Show, Eq, Ord, Enum, Bounded) @@ -500,6 +512,10 @@ | User5 | User6 | User7 | User8 | User9 deriving (Show, Eq, Ord, Enum, Bounded) +data ExtEv = SysEx | Bounce + | UserVar0 | UserVar1 | UserVar2 | UserVar3 | UserVar4 + deriving (Show, Eq, Ord, Enum, Bounded) + data AddrEv = ClientStart | ClientExit | ClientChange | PortStart | PortExit | PortChange deriving (Show, Eq, Ord, Enum, Bounded) @@ -508,18 +524,23 @@ deriving (Show, Eq, Ord, Enum, Bounded) +#{newinttype "EType", snd_seq_event_type_t} + +-- type EType = #{inttype snd_seq_event_type_t} + + class Type e where - expEv :: e -> Word8 + expEv :: e -> EType -instance Type NoteEv where - expEv e = case e of +instance Type NoteEv where + expEv e = EType $ case e of ANote -> #{const SND_SEQ_EVENT_NOTE} NoteOn -> #{const SND_SEQ_EVENT_NOTEON} NoteOff -> #{const SND_SEQ_EVENT_NOTEOFF} KeyPress -> #{const SND_SEQ_EVENT_KEYPRESS} -instance Type CtrlEv where - expEv e = case e of +instance Type CtrlEv where + expEv e = EType $ case e of Controller -> #{const SND_SEQ_EVENT_CONTROLLER} PgmChange -> #{const SND_SEQ_EVENT_PGMCHANGE} ChanPress -> #{const SND_SEQ_EVENT_CHANPRESS} @@ -533,29 +554,34 @@ TimeSign -> #{const SND_SEQ_EVENT_TIMESIGN} KeySign -> #{const SND_SEQ_EVENT_KEYSIGN} -instance Type QueueEv where - expEv e = case e of - QueueStart -> #{const SND_SEQ_EVENT_START} - QueueContinue -> #{const SND_SEQ_EVENT_CONTINUE} - QueueStop -> #{const SND_SEQ_EVENT_STOP} - QueueSetPosTick -> #{const SND_SEQ_EVENT_SETPOS_TICK} - QueueSetPosTime -> #{const SND_SEQ_EVENT_SETPOS_TIME} - QueueTempo -> #{const SND_SEQ_EVENT_TEMPO} - QueueClock -> #{const SND_SEQ_EVENT_CLOCK} - QueueTick -> #{const SND_SEQ_EVENT_TICK} - QueueSkew -> #{const SND_SEQ_EVENT_QUEUE_SKEW} - QueueSyncPos -> #{const SND_SEQ_EVENT_SYNC_POS} +instance Type QueueEv where + expEv = fst . expQueueEv -instance Type EmptyEv where - expEv e = case e of +-- setPosTick should be an error +expQueueEv :: QueueEv -> (EType, C.CInt) +expQueueEv e = mapFst EType $ case e of + QueueStart -> (#{const SND_SEQ_EVENT_START} , 0) + QueueContinue -> (#{const SND_SEQ_EVENT_CONTINUE} , 0) + QueueStop -> (#{const SND_SEQ_EVENT_STOP} , 0) + QueueSetPosTick _ -> (#{const SND_SEQ_EVENT_SETPOS_TICK} , error "expQueueEv.QueueSetPosTick: cannot represent position as int") + QueueSetPosTime _ -> (#{const SND_SEQ_EVENT_SETPOS_TIME} , error "expQueueEv.QueueSetPosTime: cannot represent position as int") + QueueTempo x -> (#{const SND_SEQ_EVENT_TEMPO} , fromIntegral $ unTempo x) + QueueClock -> (#{const SND_SEQ_EVENT_CLOCK} , 0) + QueueTick -> (#{const SND_SEQ_EVENT_TICK} , 0) + QueueSkew _ -> (#{const SND_SEQ_EVENT_QUEUE_SKEW} , error "expQueueEv.QueueSkew: cannot represent skew record as int") + QueueSyncPos x -> (#{const SND_SEQ_EVENT_SYNC_POS} , fromIntegral $ Queue.unPosition x) + + +instance Type EmptyEv where + expEv e = EType $ case e of TuneRequest -> #{const SND_SEQ_EVENT_TUNE_REQUEST} Reset -> #{const SND_SEQ_EVENT_RESET} Sensing -> #{const SND_SEQ_EVENT_SENSING} None -> #{const SND_SEQ_EVENT_NONE} Unknown -> #{const SND_SEQ_EVENT_NONE} -instance Type CustomEv where - expEv e = case e of +instance Type CustomEv where + expEv e = EType $ case e of Echo -> #{const SND_SEQ_EVENT_ECHO} OSS -> #{const SND_SEQ_EVENT_OSS} User0 -> #{const SND_SEQ_EVENT_USR0} @@ -569,8 +595,18 @@ User8 -> #{const SND_SEQ_EVENT_USR8} User9 -> #{const SND_SEQ_EVENT_USR9} -instance Type AddrEv where - expEv e = case e of +instance Type ExtEv where + expEv e = EType $ case e of + SysEx -> #{const SND_SEQ_EVENT_SYSEX} + Bounce -> #{const SND_SEQ_EVENT_BOUNCE} + UserVar0 -> #{const SND_SEQ_EVENT_USR_VAR0} + UserVar1 -> #{const SND_SEQ_EVENT_USR_VAR1} + UserVar2 -> #{const SND_SEQ_EVENT_USR_VAR2} + UserVar3 -> #{const SND_SEQ_EVENT_USR_VAR3} + UserVar4 -> #{const SND_SEQ_EVENT_USR_VAR4} + +instance Type AddrEv where + expEv e = EType $ case e of ClientStart -> #{const SND_SEQ_EVENT_CLIENT_START} ClientExit -> #{const SND_SEQ_EVENT_CLIENT_EXIT} ClientChange -> #{const SND_SEQ_EVENT_CLIENT_CHANGE} @@ -578,8 +614,8 @@ PortExit -> #{const SND_SEQ_EVENT_PORT_EXIT} PortChange -> #{const SND_SEQ_EVENT_PORT_CHANGE} -instance Type ConnEv where - expEv e = case e of +instance Type ConnEv where + expEv e = EType $ case e of PortSubscribed -> #{const SND_SEQ_EVENT_PORT_SUBSCRIBED} PortUnsubscribed -> #{const SND_SEQ_EVENT_PORT_UNSUBSCRIBED} @@ -600,6 +636,13 @@ peekCtrlEv :: CtrlEv -> Ptr Data -> IO Data peekCtrlEv e = peekBody (CtrlEv e) +peekQueueEv :: QueueEv -> Ptr Data -> IO Data +peekQueueEv e = peekBody (QueueEv e) + +peekQueueExt :: (a -> QueueEv) -> (Ptr Data -> IO a) -> Ptr Data -> IO Data +peekQueueExt makeQ peekParam p = + liftM2 (QueueEv . makeQ) (peekParam p) (peek (castPtr p)) + peekAddrEv :: AddrEv -> Ptr Data -> IO Data peekAddrEv e = peekBody (AddrEv e) @@ -612,12 +655,20 @@ peekCustomEv :: CustomEv -> Ptr Data -> IO Data peekCustomEv e = peekBody (CustomEv e) +peekExtEv :: ExtEv -> Ptr Data -> IO Data +peekExtEv e p = do + len <- #{peek snd_seq_ev_ext_t, len} p + ptr <- #{peek snd_seq_ev_ext_t, ptr} p + fmap (ExtEv e) $ B.packCStringLen (ptr,len) + data Data = NoteEv NoteEv Note | CtrlEv CtrlEv Ctrl + | QueueEv QueueEv Queue.T | AddrEv AddrEv Addr.T - | ConnEv ConnEv Connect + | ConnEv ConnEv Connect.T | EmptyEv EmptyEv | CustomEv CustomEv Custom + | ExtEv ExtEv B.ByteString deriving Show diff --git a/src/Sound/ALSA/Sequencer/Marshal/Port.hsc b/src/Sound/ALSA/Sequencer/Marshal/Port.hsc --- a/src/Sound/ALSA/Sequencer/Marshal/Port.hsc +++ b/src/Sound/ALSA/Sequencer/Marshal/Port.hsc @@ -1,6 +1,6 @@ -------------------------------------------------------------------------------- -- | --- Module : Sound.ALSA.Sequencer.Marshal +-- Module : Sound.ALSA.Sequencer.Marshal.Port -- Copyright : (c) Henning Thielemann, 2011 -- (c) Iavor S. Diatchki, 2007 -- License : BSD3 @@ -13,38 +13,42 @@ -- Here we have the various types used by the library, -- and how they are imported\/exported to C. -- --- NOTE: In the translations bellow we make the following assumptions --- about the sizes of C types. --- CChar = 8 bits --- CShort = 16 bit --- CInt = 32 bits +-- We use Hsc for expanding C types to Haskell types like Word32. +-- However if a C type is translated to Word32 +-- you should not assume that it is translated to Word32 on every platform. +-- On a 64bit machine it may well be Word64. +-- Thus you should use our wrapper types whereever possible. -------------------------------------------------------------------------------- module Sound.ALSA.Sequencer.Marshal.Port where #include +#include + import qualified Sound.ALSA.Sequencer.Utility as U -import Foreign.C.Types (CInt, CUInt, ) +import qualified Foreign.C.Types as C +import qualified Data.Word as Word import Foreign.Storable (Storable, ) import Data.Ix (Ix, range, index, inRange, rangeSize, ) -import Data.Word (Word8, ) import Data.Maybe (fromMaybe, ) import qualified Data.Ix.Enum as IxEnum import qualified Data.EnumSet as EnumSet -- The type of client ports. -newtype T = Cons Word8 deriving (Eq, Ord, Storable) +newtype T = + Cons #{intfieldtype snd_seq_addr_t, port} + deriving (Eq, Ord, Storable) instance Show T where showsPrec prec (Cons x) = U.showsRecord prec "Port" [U.showsField x] -exp :: T -> CInt +exp :: T -> C.CInt exp (Cons p) = fromIntegral p -imp :: CInt -> T +imp :: C.CInt -> T imp p = Cons (fromIntegral p) @@ -194,10 +198,10 @@ -- | Port capabilities. -type Cap = EnumSet.T CUInt CapabilityFlag +type Cap = EnumSet.T C.CUInt CapabilityFlag -- | Port types. -type Type = EnumSet.T CUInt TypeFlag +type Type = EnumSet.T C.CUInt TypeFlag #{enum T, Cons , systemTimer = SND_SEQ_PORT_SYSTEM_TIMER diff --git a/src/Sound/ALSA/Sequencer/Marshal/PortInfo.hsc b/src/Sound/ALSA/Sequencer/Marshal/PortInfo.hsc new file mode 100644 --- /dev/null +++ b/src/Sound/ALSA/Sequencer/Marshal/PortInfo.hsc @@ -0,0 +1,126 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Sound.ALSA.Sequencer.Marshal.PortInfo +-- Copyright : (c) Henning Thielemann, 2010-2012 +-- (c) Iavor S. Diatchki, 2007 +-- License : BSD3 +-- +-- Maintainer: Henning Thielemann +-- Stability : provisional +-- +-- This module contains functions for working with ports. +-- Reference: +-- +-------------------------------------------------------------------------------- + +module Sound.ALSA.Sequencer.Marshal.PortInfo where + +#include + +import qualified Sound.ALSA.Sequencer.Marshal.Client as Client +import qualified Sound.ALSA.Sequencer.Marshal.Port as Port +import qualified Sound.ALSA.Sequencer.Marshal.Queue as Queue +import qualified Sound.ALSA.Sequencer.Marshal.Sequencer as Seq +import qualified Sound.ALSA.Sequencer.Marshal.Address as Addr +import qualified Sound.ALSA.Sequencer.Area as Area +import qualified Sound.ALSA.Sequencer.Query as Query +import qualified Sound.ALSA.Sequencer.Utility as U +import qualified Sound.ALSA.Exception as Exc + +import qualified Data.EnumSet as EnumSet + +import qualified Foreign.C.Types as C +import Foreign.Ptr (Ptr, ) +import Data.Word (Word, ) + + +#area "port_info" + +{- | +Create a new information area filled with data +about a specific port on our client. +-} +#get_area "Port.T" +{- | +Set the information for the sequencer port +based on the data in the given information area. +-} +#set_area "Port.T" + +-- read/write +#get_set_name + +#get_set_bool "port_specified", "PortSpecified" +#get_set_bool "timestamping", "Timestamping" +#get_set_bool "timestamp_real", "TimestampReal" + +#{get_set_int "port", "Port", + "Port.T", "Port.imp", "Port.exp"} +#{get_set_int "client", "Client", + "Client.T", "Client.imp", "Client.exp"} +#{get_set_int "capability", "Capability", + "Port.Cap", "(EnumSet.Cons . fromIntegral)", "(fromIntegral . EnumSet.decons)"} + +#{get_set_int "midi_channels", "MidiChannels", + "Word", "fromIntegral", "fromIntegral"} +#{get_set_int "midi_voices", "MidiVoices", + "Word", "fromIntegral", "fromIntegral"} +#{get_set_int "synth_voices", "SynthVoices", + "Word", "fromIntegral", "fromIntegral"} + +#{get_set_int "timestamp_queue", "TimestampQueue", + "Queue.T", "Queue.imp", "Queue.exp"} + + +-- | Get the address of the information area. +#{get_ptr "addr", "Addr", "Addr.T"} + +-- | Set the port address. +#{set_ptr "addr", "Addr", "Addr.T"} + + +-- read only +#{get_int "read_use", "ReadUse", "Word", "fromIntegral"} +#{get_int "write_use", "WriteUse", "Word", "fromIntegral"} + + + +-- | Create a new information area filled with data about an given +-- port on a given client. +getAny :: Seq.T mode -> Client.T -> Port.T -> IO T +getAny (Seq.Cons h) c p = + do info <- malloc + Exc.checkResult_ "getAny" =<< + with info (getAny_ h (Client.exp c) (Port.exp p)) + return info + +foreign import ccall unsafe "alsa/asoundlib.h snd_seq_get_any_port_info" + getAny_ + :: Ptr Seq.Core -> C.CInt -> C.CInt -> Ptr T_ -> IO C.CInt + +queryInit :: T -> IO () +queryInit x = + {- + we cannot use setPort here, + since Port uses an unsigned type and thus cannot represent -1 + -} + with x (flip setPort_ (-1)) + +-- | Get information about the first port on our client. +queryFirst :: Seq.T mode -> IO T +queryFirst = Query.first + +-- | Get information about the port with the next biggest identifier. +-- If a matching port is found, then its information is stored in the +-- given area and 'True' is returned. +queryNext :: Seq.T mode -> T -> IO Bool +queryNext (Seq.Cons h) info = + U.checkResultQuery "PortInfo.queryNext" =<< with info (queryNext_ h) + +foreign import ccall unsafe "alsa/asoundlib.h snd_seq_query_next_port" + queryNext_ :: Ptr Seq.Core -> Ptr T_ -> IO C.CInt + + +instance Query.C T where + init = queryInit + next = queryNext diff --git a/src/Sound/ALSA/Sequencer/Marshal/QuerySubscribe.hsc b/src/Sound/ALSA/Sequencer/Marshal/QuerySubscribe.hsc deleted file mode 100644 --- a/src/Sound/ALSA/Sequencer/Marshal/QuerySubscribe.hsc +++ /dev/null @@ -1,21 +0,0 @@ -module Sound.ALSA.Sequencer.Marshal.QuerySubscribe where - -#include -import Foreign.C.Types (CInt, ) - - -data Type = - Read - | Write - deriving (Show, Eq, Ord, Enum) - -expType :: Type -> CInt -expType t = case t of - Read -> #{const SND_SEQ_QUERY_SUBS_READ} - Write -> #{const SND_SEQ_QUERY_SUBS_WRITE} - -impType :: CInt -> Type -impType t = case t of - #{const SND_SEQ_QUERY_SUBS_READ} -> Read - #{const SND_SEQ_QUERY_SUBS_WRITE} -> Write - _ -> error ("QuerySubscribe.impType: unknown subscription type (" ++ show t ++ ")") diff --git a/src/Sound/ALSA/Sequencer/Marshal/Queue.hsc b/src/Sound/ALSA/Sequencer/Marshal/Queue.hsc --- a/src/Sound/ALSA/Sequencer/Marshal/Queue.hsc +++ b/src/Sound/ALSA/Sequencer/Marshal/Queue.hsc @@ -13,37 +13,66 @@ -- Here we have the various types used by the library, -- and how they are imported\/exported to C. -- --- NOTE: In the translations bellow we make the following assumptions --- about the sizes of C types. --- CChar = 8 bits --- CShort = 16 bit --- CInt = 32 bits +-- We use Hsc for expanding C types to Haskell types like Word32. +-- However if a C type is translated to Word32 +-- you should not assume that it is translated to Word32 on every platform. +-- On a 64bit machine it may well be Word64. +-- Thus you should use our wrapper types whereever possible. -------------------------------------------------------------------------------- module Sound.ALSA.Sequencer.Marshal.Queue where #include +#include + import qualified Sound.ALSA.Sequencer.Utility as U -import Foreign.C.Types (CInt, ) -import Foreign.Storable (Storable, ) -import Data.Word (Word8, ) +import qualified Foreign.C.Types as C +import Foreign.Storable (Storable, sizeOf, alignment, peek, peekByteOff, poke, pokeByteOff, ) +import Data.Array (Ix, ) +import qualified Data.Word as Word + + + -- | The type of queue identifiers. -newtype T = Cons Word8 deriving (Eq, Ord, Storable) +newtype T = + Cons #{intfieldtype snd_seq_event_t, queue} + deriving (Eq, Ord, Storable) instance Show T where showsPrec prec (Cons x) = U.showsRecord prec "Queue" [U.showsField x] -imp :: CInt -> T +imp :: C.CInt -> T imp x = Cons (fromIntegral x) -exp :: T -> CInt +exp :: T -> C.CInt exp (Cons x) = fromIntegral x #{enum T, Cons , direct = SND_SEQ_QUEUE_DIRECT } + + +data Skew = + Skew { + skewValue :: ! #{intfieldtype snd_seq_queue_skew_t, value}, + skewBase :: ! #{intfieldtype snd_seq_queue_skew_t, base} + } deriving (Show, Eq) + +instance Storable Skew where + sizeOf _ = #{size snd_seq_queue_skew_t} + alignment _ = #{alignment snd_seq_queue_skew_t} + peek p = do v <- #{peek snd_seq_queue_skew_t, value} p + b <- #{peek snd_seq_queue_skew_t, base} p + return Skew { skewValue = v + , skewBase = b + } + poke p v = #{poke snd_seq_queue_skew_t, value} p (skewValue v) + >> #{poke snd_seq_queue_skew_t, base} p (skewBase v) + + +#{newintfieldtype "Position", snd_seq_ev_queue_control_t, param.position} diff --git a/src/Sound/ALSA/Sequencer/Marshal/QueueTimer.hsc b/src/Sound/ALSA/Sequencer/Marshal/QueueTimer.hsc deleted file mode 100644 --- a/src/Sound/ALSA/Sequencer/Marshal/QueueTimer.hsc +++ /dev/null @@ -1,46 +0,0 @@ --------------------------------------------------------------------------------- --- | --- Module : Sound.ALSA.Sequencer.Marshal.QueueTimer --- Copyright : (c) Henning Thielemann, 2010 --- (c) Iavor S. Diatchki, 2007 --- License : BSD3 --- --- Maintainer: Henning Thielemann --- Stability : provisional --- --- PRIVATE MODULE. --- --- Here we have the various types used by the library, --- and how they are imported\/exported to C. --- --- NOTE: In the translations bellow we make the following assumptions --- about the sizes of C types. --- CChar = 8 bits --- CShort = 16 bit --- CInt = 32 bits --------------------------------------------------------------------------------- - -module Sound.ALSA.Sequencer.Marshal.QueueTimer where - -#include -import Foreign.C.Types (CInt, ) - - -data Type = - Alsa - | MidiClock - | MidiTick - deriving (Show, Eq, Ord, Enum) - -expType :: Type -> CInt -expType t = case t of - Alsa -> #{const SND_SEQ_TIMER_ALSA} - MidiClock -> #{const SND_SEQ_TIMER_MIDI_CLOCK} - MidiTick -> #{const SND_SEQ_TIMER_MIDI_TICK} - -impType :: CInt -> Type -impType t = case t of - #{const SND_SEQ_TIMER_ALSA} -> Alsa - #{const SND_SEQ_TIMER_MIDI_CLOCK} -> MidiClock - #{const SND_SEQ_TIMER_MIDI_TICK} -> MidiTick - _ -> error ("QueueTimer.impType: unknown timer type (" ++ show t ++ ")") diff --git a/src/Sound/ALSA/Sequencer/Marshal/RealTime.hsc b/src/Sound/ALSA/Sequencer/Marshal/RealTime.hsc --- a/src/Sound/ALSA/Sequencer/Marshal/RealTime.hsc +++ b/src/Sound/ALSA/Sequencer/Marshal/RealTime.hsc @@ -1,18 +1,20 @@ module Sound.ALSA.Sequencer.Marshal.RealTime where #include +#include import qualified Sound.ALSA.Sequencer.Utility as U +import qualified Data.Word as Word import Foreign.Storable (Storable, sizeOf, alignment, peek, poke, pokeByteOff, peekByteOff, ) -import Data.Word (Word32, ) data T = Cons - { secs :: !Word32 - , nano :: !Word32 + { secs :: ! #{intfieldtype snd_seq_real_time_t, tv_sec} + , nano :: ! #{intfieldtype snd_seq_real_time_t, tv_nsec} } + deriving (Eq) instance Show T where showsPrec prec (Cons s n) = @@ -21,7 +23,7 @@ instance Storable T where sizeOf _ = #{size snd_seq_real_time_t} - alignment _ = 4 -- XXX + alignment _ = #{alignment snd_seq_real_time_t} peek p = do s <- #{peek snd_seq_real_time_t, tv_sec} p n <- #{peek snd_seq_real_time_t, tv_nsec} p return Cons { secs = s, nano = n } diff --git a/src/Sound/ALSA/Sequencer/Marshal/Sequencer.hsc b/src/Sound/ALSA/Sequencer/Marshal/Sequencer.hsc --- a/src/Sound/ALSA/Sequencer/Marshal/Sequencer.hsc +++ b/src/Sound/ALSA/Sequencer/Marshal/Sequencer.hsc @@ -12,25 +12,19 @@ -- -- Here we have the various types used by the library, -- and how they are imported\/exported to C. --- --- NOTE: In the translations bellow we make the following assumptions --- about the sizes of C types. --- CChar = 8 bits --- CShort = 16 bit --- CInt = 32 bits -------------------------------------------------------------------------------- module Sound.ALSA.Sequencer.Marshal.Sequencer where #include -import Foreign.C.Types (CInt, ) +import qualified Foreign.C.Types as C import Foreign.Ptr (Ptr, ) -- | Read\/Write permissions for the sequencer device. -- This way we prevent the ALSA exception 22 "Invalid argument" -- when calling @event_output@ on an input-only sequencer. -class OpenMode mode where expOpenMode :: mode -> CInt +class OpenMode mode where expOpenMode :: mode -> C.CInt class OpenMode mode => AllowInput mode where class OpenMode mode => AllowOutput mode where @@ -54,7 +48,7 @@ | Nonblock -- ^ Throw exceptions instead of blocking. deriving (Show,Eq) -expBlockMode :: BlockMode -> CInt +expBlockMode :: BlockMode -> C.CInt expBlockMode x = case x of Block -> 0 Nonblock -> #{const SND_SEQ_NONBLOCK} diff --git a/src/Sound/ALSA/Sequencer/Marshal/Template.h b/src/Sound/ALSA/Sequencer/Marshal/Template.h new file mode 100644 --- /dev/null +++ b/src/Sound/ALSA/Sequencer/Marshal/Template.h @@ -0,0 +1,31 @@ +#include + +#define hsc_alignment(t) \ + printf("(%ld)", (unsigned long)offsetof(struct {char x__; t (y__); }, y__)); + +#define hsc_inttype(t) \ + printf ("%s%lu", \ + (t)(-1) < (t)0 ? "Int.Int" : "Word.Word", \ + (unsigned long)sizeof (t) * 8); \ + +#define hsc_intfieldtype(r,f) \ + { \ + r x, y; \ + x.f = -1; \ + y.f = 0; \ + printf ("%s%lu", \ + x.f < y.f ? "Int.Int" : "Word.Word", \ + (unsigned long)sizeof (x.f) * 8); \ + } + +#define hsc_newinttype(nm,t) \ + printf ("newtype "nm" = "nm" { un"nm" :: "); \ + hsc_inttype(t); \ + printf (" }\n"); \ + printf (" deriving (Show, Eq, Ord, Ix, Storable)\n"); + +#define hsc_newintfieldtype(nm,r,f) \ + printf ("newtype "nm" = "nm" { un"nm" :: "); \ + hsc_intfieldtype(r,f); \ + printf (" }\n"); \ + printf (" deriving (Show, Eq, Ord, Ix, Storable)\n"); diff --git a/src/Sound/ALSA/Sequencer/Marshal/Time.hsc b/src/Sound/ALSA/Sequencer/Marshal/Time.hsc new file mode 100644 --- /dev/null +++ b/src/Sound/ALSA/Sequencer/Marshal/Time.hsc @@ -0,0 +1,107 @@ +module Sound.ALSA.Sequencer.Marshal.Time where + +#include +#include + +import qualified Sound.ALSA.Sequencer.Marshal.RealTime as RealTime + +import qualified Sound.ALSA.Sequencer.Utility as U +import qualified Foreign.Storable as St +-- import qualified Foreign.C.Types as C +import Foreign.Ptr (Ptr, castPtr, ) +import qualified Data.FlagSet as FlagSet +import qualified Data.Word as Word +import Data.Monoid (mappend, ) + +import qualified Data.Accessor.Basic as Acc + + +data T = Cons {mode :: Mode, stamp :: Stamp} + +instance Show T where + showsPrec prec (Cons m st) = + U.showsRecord prec "Time" + [U.showsField m, U.showsField st] + + +consAbs :: Stamp -> T +consAbs = Cons Absolute + +consRel :: Stamp -> T +consRel = Cons Relative + + +modeAcc :: Acc.T T Mode +modeAcc = + Acc.fromSetGet (\x ev -> ev{mode = x}) mode + +stampAcc :: Acc.T T Stamp +stampAcc = + Acc.fromSetGet (\x ev -> ev{stamp = x}) stamp + + +type Tick = #{inttype snd_seq_tick_time_t} + +data Mode = Absolute | Relative + deriving (Eq, Show, Enum) + +data Stamp = + Tick !Tick + | Real !RealTime.T + deriving Show + + +class Flag flag where + +type FlagContainer = #{intfieldtype snd_seq_event_t, flags} + +stampTick, stampReal :: Flag flag => FlagSet.MaskedValue FlagContainer flag +stampTick = + FlagSet.MaskedValue + #{const SND_SEQ_TIME_STAMP_MASK} + #{const SND_SEQ_TIME_STAMP_TICK} +stampReal = + FlagSet.MaskedValue + #{const SND_SEQ_TIME_STAMP_MASK} + #{const SND_SEQ_TIME_STAMP_REAL} + + +modeAbs, modeRel :: Flag flag => FlagSet.MaskedValue FlagContainer flag +modeAbs = + FlagSet.MaskedValue + #{const SND_SEQ_TIME_MODE_MASK} + #{const SND_SEQ_TIME_MODE_ABS} +modeRel = + FlagSet.MaskedValue + #{const SND_SEQ_TIME_MODE_MASK} + #{const SND_SEQ_TIME_MODE_REL} + + +peek :: Flag flag => FlagSet.T FlagContainer flag -> Ptr T -> IO T +peek flags p = + fmap + (Cons + (if FlagSet.match flags modeAbs + then Absolute + else Relative)) $ + peekStamp flags $ castPtr p + +poke :: Flag flag => Ptr T -> T -> IO (FlagSet.MaskedValue FlagContainer flag) +poke p (Cons m st) = + fmap (mappend + (case m of + Absolute -> modeAbs + Relative -> modeRel)) $ + pokeStamp (castPtr p) st + + +peekStamp :: Flag flag => FlagSet.T FlagContainer flag -> Ptr Stamp -> IO Stamp +peekStamp flags p = + if FlagSet.match flags stampTick + then fmap Tick $ St.peek $ castPtr p + else fmap Real $ St.peek $ castPtr p + +pokeStamp :: Flag flag => Ptr Stamp -> Stamp -> IO (FlagSet.MaskedValue FlagContainer flag) +pokeStamp p ts = case ts of + Tick t -> St.poke (castPtr p) t >> return stampTick + Real t -> St.poke (castPtr p) t >> return stampReal diff --git a/src/Sound/ALSA/Sequencer/Poll.hs b/src/Sound/ALSA/Sequencer/Poll.hs new file mode 100644 --- /dev/null +++ b/src/Sound/ALSA/Sequencer/Poll.hs @@ -0,0 +1,29 @@ +module Sound.ALSA.Sequencer.Poll + ( descriptors + ) where + +import qualified Sound.ALSA.Sequencer.Marshal.Sequencer as Seq +import qualified System.Posix.Poll as Poll + +import qualified Foreign.C.Types as C +import Foreign.Marshal.Array (peekArray, allocaArray, ) +import Foreign.Ptr (Ptr, ) + +-- expose EnumSet.Cons for foreign call +import qualified Data.EnumSet as EnumSet + +_dummyEnumSet :: EnumSet.T Int Bool +_dummyEnumSet = undefined + + +descriptors :: Seq.T mode -> Poll.Events -> IO [Poll.Fd] +descriptors (Seq.Cons h) e = do + n <- snd_seq_poll_descriptors_count h e + allocaArray (fromIntegral n) $ \p -> + flip peekArray p . fromIntegral =<< snd_seq_poll_descriptors h p n e + +foreign import ccall unsafe "alsa/asoundlib.h snd_seq_poll_descriptors_count" + snd_seq_poll_descriptors_count :: Ptr Seq.Core -> Poll.Events -> IO C.CInt + +foreign import ccall unsafe "alsa/asoundlib.h snd_seq_poll_descriptors" + snd_seq_poll_descriptors :: Ptr Seq.Core -> Ptr Poll.Fd -> C.CInt -> Poll.Events -> IO C.CInt diff --git a/src/Sound/ALSA/Sequencer/Port.hs b/src/Sound/ALSA/Sequencer/Port.hs --- a/src/Sound/ALSA/Sequencer/Port.hs +++ b/src/Sound/ALSA/Sequencer/Port.hs @@ -14,7 +14,7 @@ -------------------------------------------------------------------------------- module Sound.ALSA.Sequencer.Port - ( Port.T + ( Port.T(Port.Cons) , create , createSimple , delete @@ -60,14 +60,16 @@ ) where import qualified Sound.ALSA.Sequencer.Marshal.Port as Port +import qualified Sound.ALSA.Sequencer.Marshal.PortInfo as PortInfo import qualified Sound.ALSA.Sequencer.Marshal.Sequencer as Seq import qualified Sound.ALSA.Exception as Exc -import Sound.ALSA.Sequencer.Area -import Foreign.C.Types (CInt, ) +import qualified Foreign.C.Types as C import Foreign.C.String (CString, withCAString, ) import Foreign.Ptr (Ptr, ) +import qualified Data.EnumSet as EnumSet -- expose EnumSet.Cons for foreign call + import Control.Exception (bracket, ) @@ -82,7 +84,7 @@ foreign import ccall unsafe "alsa/asoundlib.h snd_seq_create_simple_port" snd_seq_create_simple_port :: Ptr Seq.Core -> CString -> Port.Cap -> Port.Type - -> IO CInt + -> IO C.CInt -- | Delete the port. @@ -91,7 +93,7 @@ Exc.checkResult_ "delete_simple_port" =<< snd_seq_delete_simple_port h (fromIntegral p) foreign import ccall unsafe "alsa/asoundlib.h snd_seq_delete_simple_port" - snd_seq_delete_simple_port :: Ptr Seq.Core -> CInt -> IO CInt + snd_seq_delete_simple_port :: Ptr Seq.Core -> C.CInt -> IO C.CInt withSimple :: @@ -106,12 +108,12 @@ -------------------------------------------------------------------------------- -- | Create a new port, as described by the info structure. -create :: Seq.T mode -> PortInfo -> IO () +create :: Seq.T mode -> PortInfo.T -> IO () create (Seq.Cons h) p = - Exc.checkResult_ "create_port" =<< with_port_info p (snd_seq_create_port h) + Exc.checkResult_ "create_port" =<< PortInfo.with p (snd_seq_create_port h) foreign import ccall unsafe "alsa/asoundlib.h snd_seq_create_port" - snd_seq_create_port :: Ptr Seq.Core -> Ptr PortInfo_ -> IO CInt + snd_seq_create_port :: Ptr Seq.Core -> Ptr PortInfo.T_ -> IO C.CInt -- | Delete the port. delete :: Seq.T mode -> Port.T -> IO () @@ -119,4 +121,9 @@ Exc.checkResult_ "delete_port" =<< snd_seq_delete_port h (fromIntegral p) foreign import ccall unsafe "alsa/asoundlib.h snd_seq_delete_port" - snd_seq_delete_port :: Ptr Seq.Core -> CInt -> IO CInt + snd_seq_delete_port :: Ptr Seq.Core -> C.CInt -> IO C.CInt + + + +_dummyEnumSet :: EnumSet.T Int Bool +_dummyEnumSet = undefined diff --git a/src/Sound/ALSA/Sequencer/Port/Info.hs b/src/Sound/ALSA/Sequencer/Port/Info.hs --- a/src/Sound/ALSA/Sequencer/Port/Info.hs +++ b/src/Sound/ALSA/Sequencer/Port/Info.hs @@ -1,7 +1,7 @@ -------------------------------------------------------------------------------- -- | --- Module : Sound.ALSA.Sequencer.Port --- Copyright : (c) Henning Thielemann, 2010 +-- Module : Sound.ALSA.Sequencer.Port.Info +-- Copyright : (c) Henning Thielemann, 2010-2012 -- (c) Iavor S. Diatchki, 2007 -- License : BSD3 -- @@ -20,6 +20,8 @@ , getAny , queryFirst , queryNext + , queryLoop_ + , queryLoop , set , copy @@ -55,152 +57,16 @@ , setTimestampQueue ) where +import Sound.ALSA.Sequencer.Marshal.PortInfo + import qualified Sound.ALSA.Sequencer.Marshal.Client as Client -import qualified Sound.ALSA.Sequencer.Marshal.Port as Port -import qualified Sound.ALSA.Sequencer.Marshal.Queue as Queue import qualified Sound.ALSA.Sequencer.Marshal.Sequencer as Seq -import qualified Sound.ALSA.Sequencer.Area as Area -import qualified Sound.ALSA.Sequencer.Marshal.Address as Addr -import qualified Sound.ALSA.Exception as Exc -import Foreign.C.Types (CInt, ) -import Foreign.Ptr (Ptr, ) -import Foreign.Marshal.Alloc (alloca, ) -import Foreign.Storable (poke, peek, ) -import Data.Word (Word, ) - - -type T = Area.PortInfo -type T_ = Area.PortInfo_ - - --- | Create a new information area filled with data about a specific --- port on our client. -get :: Seq.T mode -> Port.T -> IO T -get (Seq.Cons h) p = - do info <- Area.port_info_malloc - Exc.checkResult_ "get_port_info" =<< Area.with_port_info info (snd_seq_get_port_info h (Port.exp p)) - return info - -foreign import ccall unsafe "alsa/asoundlib.h snd_seq_get_port_info" - snd_seq_get_port_info :: Ptr Seq.Core -> CInt -> Ptr T_ -> IO CInt - - --- | Create a new information area filled with data about an given --- port on a given client. -getAny :: Seq.T mode -> Client.T -> Port.T -> IO T -getAny (Seq.Cons h) c p = - do info <- Area.port_info_malloc - Exc.checkResult_ "get_any_port_info" =<< Area.with_port_info info - (snd_seq_get_any_port_info h (Client.exp c) (Port.exp p)) - return info - -foreign import ccall unsafe "alsa/asoundlib.h snd_seq_get_any_port_info" - snd_seq_get_any_port_info - :: Ptr Seq.Core -> CInt -> CInt -> Ptr T_ -> IO CInt - --- | Get information about the first port on our client. -queryFirst :: Seq.T mode -> IO T -queryFirst s = - do x <- Area.port_info_malloc - Area.with_port_info x (`Area.snd_seq_port_info_set_port` (-1)) - queryNext s x - return x - - --- | Get information about the port with the next biggest identifier. --- If a matching port is found, then its information is stored in the --- given area, otherwise we throw an error. -queryNext :: Seq.T mode -> T -> IO () -queryNext (Seq.Cons h) info = - Exc.checkResult_ "query_next_port" =<< Area.with_port_info info (snd_seq_query_next_port h) - -foreign import ccall unsafe "alsa/asoundlib.h snd_seq_query_next_port" - snd_seq_query_next_port :: Ptr Seq.Core -> Ptr T_ -> IO CInt - --- | Set the information for the sequencer port based on the data --- in the given information area. -set :: Seq.T mode -> Port.T -> T -> IO () -set (Seq.Cons h) p info = - Exc.checkResult_ "set_port_info" =<< Area.with_port_info info (snd_seq_set_port_info h (Port.exp p)) - -foreign import ccall unsafe "alsa/asoundlib.h snd_seq_set_port_info" - snd_seq_set_port_info :: Ptr Seq.Core -> CInt -> Ptr T_ -> IO CInt - - - --- | Get the address of the information area. -getAddr :: T -> IO Addr.T -getAddr i = - peek =<< Area.with_port_info i snd_seq_port_info_get_addr - -foreign import ccall unsafe "alsa/asoundlib.h snd_seq_port_info_get_addr" - snd_seq_port_info_get_addr :: Ptr T_ -> IO (Ptr Addr.T) - - --- | Set the port address. -setAddr :: T -> Addr.T -> IO () -setAddr i c = - alloca $ \p -> poke p c >> Area.with_port_info i (`snd_seq_port_info_set_addr` p) - -foreign import ccall unsafe "alsa/asoundlib.h snd_seq_port_info_set_addr" - snd_seq_port_info_set_addr :: Ptr T_ -> Ptr Addr.T -> IO () - +import qualified Sound.ALSA.Sequencer.Query as Query -copy :: T -> T -> IO () -clone :: T -> IO T -getPort :: T -> IO Port.T -getClient :: T -> IO Client.T -getName :: T -> IO String -getCapability :: T -> IO Port.Cap -getMidiChannels :: T -> IO Word -getMidiVoices :: T -> IO Word -getSynthVoices :: T -> IO Word -getPortSpecified :: T -> IO Bool -getTimestamping :: T -> IO Bool -getTimestampReal :: T -> IO Bool -getTimestampQueue :: T -> IO Queue.T -getReadUse :: T -> IO Word -getWriteUse :: T -> IO Word -setPort :: T -> Port.T -> IO () -setClient :: T -> Client.T -> IO () -setName :: T -> String -> IO () -setCapability :: T -> Port.Cap -> IO () -setMidiChannels :: T -> Word -> IO () -setSynthVoices :: T -> Word -> IO () -setMidiVoices :: T -> Word -> IO () -setPortSpecified :: T -> Bool -> IO () -setTimestamping :: T -> Bool -> IO () -setTimestampReal :: T -> Bool -> IO () -setTimestampQueue :: T -> Queue.T -> IO () - -copy = Area.port_info_copy -clone = Area.port_info_clone - -getPort = Area.port_info_get_port -getClient = Area.port_info_get_client -getName = Area.port_info_get_name -getCapability = Area.port_info_get_capability -getMidiChannels = Area.port_info_get_midi_channels -getMidiVoices = Area.port_info_get_midi_voices -getSynthVoices = Area.port_info_get_synth_voices -getPortSpecified = Area.port_info_get_port_specified -getTimestamping = Area.port_info_get_timestamping -getTimestampReal = Area.port_info_get_timestamp_real -getTimestampQueue = Area.port_info_get_timestamp_queue - -getReadUse = Area.port_info_get_read_use -getWriteUse = Area.port_info_get_write_use +queryLoop_ :: Seq.T mode -> Client.T -> (T -> IO ()) -> IO () +queryLoop_ h c = Query.loop_ h (flip setClient c) -setPort = Area.port_info_set_port -setClient = Area.port_info_set_client -setName = Area.port_info_set_name -setCapability = Area.port_info_set_capability -setMidiChannels = Area.port_info_set_midi_channels -setSynthVoices = Area.port_info_set_synth_voices -setMidiVoices = Area.port_info_set_midi_voices -setPortSpecified = Area.port_info_set_port_specified -setTimestamping = Area.port_info_set_timestamping -setTimestampReal = Area.port_info_set_timestamp_real -setTimestampQueue = Area.port_info_set_timestamp_queue +queryLoop :: Seq.T mode -> Client.T -> (T -> IO a) -> IO [a] +queryLoop h c = Query.loop h (flip setClient c) diff --git a/src/Sound/ALSA/Sequencer/Port/InfoMonad.hs b/src/Sound/ALSA/Sequencer/Port/InfoMonad.hs new file mode 100644 --- /dev/null +++ b/src/Sound/ALSA/Sequencer/Port/InfoMonad.hs @@ -0,0 +1,147 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Sound.ALSA.Sequencer.Port.Info +-- Copyright : (c) Henning Thielemann, 2010-2012 +-- (c) Iavor S. Diatchki, 2007 +-- License : BSD3 +-- +-- Maintainer: Henning Thielemann +-- Stability : provisional +-- +-- This module contains functions for working with ports. +-- Reference: +-- +-------------------------------------------------------------------------------- + +module Sound.ALSA.Sequencer.Port.InfoMonad ( + T, + + run, + get, + modify, + + getPort, + getClient, + getAddr, + getName, + getCapability, + getMidiChannels, + getMidiVoices, + getSynthVoices, + getPortSpecified, + getTimestamping, + getTimestampReal, + getTimestampQueue, + + getReadUse, + getWriteUse, + + setPort, + setClient, + setAddr, + setName, + setCapability, + setMidiChannels, + setSynthVoices, + setMidiVoices, + setPortSpecified, + setTimestamping, + setTimestampReal, + setTimestampQueue, + ) where + +import qualified Sound.ALSA.Sequencer.Marshal.PortInfo as PortInfo +import qualified Sound.ALSA.Sequencer.Marshal.Port as Port +import qualified Sound.ALSA.Sequencer.Marshal.Client as Client +import qualified Sound.ALSA.Sequencer.Marshal.Queue as Queue +import qualified Sound.ALSA.Sequencer.Marshal.Address as Addr +import qualified Sound.ALSA.Sequencer.Marshal.Sequencer as Seq + +import qualified Control.Monad.Trans.Reader as MR +import Control.Applicative (Applicative, ) + +import Data.Word (Word, ) + + +newtype T a = Cons (MR.ReaderT PortInfo.T IO a) + deriving (Functor, Applicative, Monad) + + +run :: T a -> PortInfo.T -> IO a +run (Cons m) = MR.runReaderT m + +get :: Seq.T mode -> Port.T -> T a -> IO a +get h p m = run m =<< PortInfo.get h p + +modify :: Seq.T mode -> Port.T -> T a -> IO a +modify h p m = do + i <- PortInfo.get h p + a <- run m i + PortInfo.set h p i + return a + + +liftGet :: (PortInfo.T -> IO a) -> T a +liftGet f = Cons $ MR.ReaderT f + +liftSet :: (PortInfo.T -> b -> IO a) -> b -> T a +liftSet f x = Cons $ MR.ReaderT $ flip f x + + +getPort :: T Port.T +getClient :: T Client.T +getAddr :: T Addr.T +getName :: T String +getCapability :: T Port.Cap +getMidiChannels :: T Word +getMidiVoices :: T Word +getSynthVoices :: T Word +getPortSpecified :: T Bool +getTimestamping :: T Bool +getTimestampReal :: T Bool +getTimestampQueue :: T Queue.T +getReadUse :: T Word +getWriteUse :: T Word + +getPort = liftGet PortInfo.getPort +getClient = liftGet PortInfo.getClient +getAddr = liftGet PortInfo.getAddr +getName = liftGet PortInfo.getName +getCapability = liftGet PortInfo.getCapability +getMidiChannels = liftGet PortInfo.getMidiChannels +getMidiVoices = liftGet PortInfo.getMidiVoices +getSynthVoices = liftGet PortInfo.getSynthVoices +getPortSpecified = liftGet PortInfo.getPortSpecified +getTimestamping = liftGet PortInfo.getTimestamping +getTimestampReal = liftGet PortInfo.getTimestampReal +getTimestampQueue = liftGet PortInfo.getTimestampQueue + +getReadUse = liftGet PortInfo.getReadUse +getWriteUse = liftGet PortInfo.getWriteUse + + +setPort :: Port.T -> T () +setClient :: Client.T -> T () +setAddr :: Addr.T -> T () +setName :: String -> T () +setCapability :: Port.Cap -> T () +setMidiChannels :: Word -> T () +setSynthVoices :: Word -> T () +setMidiVoices :: Word -> T () +setPortSpecified :: Bool -> T () +setTimestamping :: Bool -> T () +setTimestampReal :: Bool -> T () +setTimestampQueue :: Queue.T -> T () + +setPort = liftSet PortInfo.setPort +setClient = liftSet PortInfo.setClient +setAddr = liftSet PortInfo.setAddr +setName = liftSet PortInfo.setName +setCapability = liftSet PortInfo.setCapability +setMidiChannels = liftSet PortInfo.setMidiChannels +setSynthVoices = liftSet PortInfo.setSynthVoices +setMidiVoices = liftSet PortInfo.setMidiVoices +setPortSpecified = liftSet PortInfo.setPortSpecified +setTimestamping = liftSet PortInfo.setTimestamping +setTimestampReal = liftSet PortInfo.setTimestampReal +setTimestampQueue = liftSet PortInfo.setTimestampQueue diff --git a/src/Sound/ALSA/Sequencer/Query.hs b/src/Sound/ALSA/Sequencer/Query.hs new file mode 100644 --- /dev/null +++ b/src/Sound/ALSA/Sequencer/Query.hs @@ -0,0 +1,47 @@ +module Sound.ALSA.Sequencer.Query ( + C, + init, + next, + first, + loop_, + loop, + ) where + +import qualified Sound.ALSA.Sequencer.Marshal.Sequencer as Seq +import qualified Sound.ALSA.Sequencer.Area as Area + +import Control.Monad (liftM2, when, ) + +import Prelude hiding (init, ) + + +class Area.C info => C info where + init :: info -> IO () + next :: Seq.T mode -> info -> IO Bool + +first :: (C info) => Seq.T mode -> IO info +first h = do + i <- Area.malloc + init i + _b <- next h i + return i + +loop_ :: (C info) => Seq.T mode -> (info -> IO ()) -> (info -> IO ()) -> IO () +loop_ h start f = do + i <- Area.malloc + start i + init i + let go = do + b <- next h i + when b $ f i >> go + go + +loop :: (C info) => Seq.T mode -> (info -> IO ()) -> (info -> IO a) -> IO [a] +loop h start f = do + i <- Area.malloc + start i + init i + let go = do + b <- next h i + if b then liftM2 (:) (f i) go else return [] + go diff --git a/src/Sound/ALSA/Sequencer/Queue.hs b/src/Sound/ALSA/Sequencer/Queue.hs --- a/src/Sound/ALSA/Sequencer/Queue.hs +++ b/src/Sound/ALSA/Sequencer/Queue.hs @@ -1,7 +1,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Sound.ALSA.Sequencer.Queue --- Copyright : (c) Henning Thielemann, 2010 +-- Copyright : (c) Henning Thielemann, 2010-2012 -- (c) Iavor S. Diatchki, 2007 -- License : BSD3 -- @@ -27,23 +27,26 @@ ) where import qualified Sound.ALSA.Sequencer.Marshal.Sequencer as Seq +import qualified Sound.ALSA.Sequencer.Marshal.Address as Addr import qualified Sound.ALSA.Sequencer.Marshal.Event as Event import qualified Sound.ALSA.Sequencer.Marshal.Queue as Queue +import qualified Sound.ALSA.Sequencer.Marshal.Time as Time import qualified Sound.ALSA.Exception as Exc -import Foreign.Ptr (Ptr, ) -import Foreign.C.Types (CInt, ) +import qualified Foreign.C.Types as C import Foreign.C.String (CString, withCAString, ) +import Foreign.Ptr (Ptr, ) import Control.Exception (bracket, ) +import Control.Functor.HT (void, ) alloc :: Seq.T mode -> IO Queue.T -- ^ Queue.T identifier. alloc (Seq.Cons h) = - Queue.imp `fmap` (Exc.checkResult "alloc_queue" =<< snd_seq_alloc_queue h) + fmap Queue.imp $ Exc.checkResult "Queue.alloc" =<< alloc_ h foreign import ccall unsafe "alsa/asoundlib.h snd_seq_alloc_queue" - snd_seq_alloc_queue :: Ptr Seq.Core -> IO CInt + alloc_ :: Ptr Seq.Core -> IO C.CInt with :: Seq.T mode -> (Queue.T -> IO a) -> IO a with s = bracket (alloc s) (free s) @@ -51,10 +54,10 @@ allocNamed :: Seq.T mode -> String -> IO Queue.T allocNamed (Seq.Cons h) x = withCAString x $ \s -> - Queue.imp `fmap` (Exc.checkResult "alloc_named_queue" =<< snd_seq_alloc_named_queue h s) + fmap Queue.imp $ Exc.checkResult "Queue.allocNamed" =<< allocNamed_ h s foreign import ccall unsafe "alsa/asoundlib.h snd_seq_alloc_named_queue" - snd_seq_alloc_named_queue :: Ptr Seq.Core -> CString -> IO CInt + allocNamed_ :: Ptr Seq.Core -> CString -> IO C.CInt withNamed :: Seq.T mode -> String -> (Queue.T -> IO a) -> IO a withNamed s nm = bracket (allocNamed s nm) (free s) @@ -66,22 +69,72 @@ -> Queue.T -- ^ Queue.T identifier. -> IO () free (Seq.Cons h) q = - Exc.checkResult_ "free_queue" =<< snd_seq_free_queue h (Queue.exp q) + Exc.checkResult_ "Queue.free" =<< free_ h (Queue.exp q) foreign import ccall unsafe "alsa/asoundlib.h snd_seq_free_queue" - snd_seq_free_queue :: Ptr Seq.Core -> CInt -> IO CInt + free_ :: Ptr Seq.Core -> C.CInt -> IO C.CInt --- | Queue.T controls - start/stop/continue +{- | +start/stop/continue a queue + +In the prototype event you can provide additional information. +The prototype event does not need to be a queue control event, +this part is ignored anyway. +In the prototype event you may also specify a queue. +This is the queue that the timestamp of the prototype event refers to. +This way you can control the target queue using timing from another queue. +-} control - :: Seq.T mode -- ^ Sequencer handle. - -> Queue.T -- ^ Queue.T identifier. + :: Seq.T mode -- ^ Sequencer handle. + -> Queue.T -- ^ target Queue.T. -> Event.QueueEv - -> Int - -> Maybe Event.T + -> Maybe Event.T -- ^ prototype event that may provide timestamp, source queue -> IO () -control (Seq.Cons h) q a b me = - Event.allocaMaybeEv me $ \p -> Exc.checkResult_ "control_queue" =<< snd_seq_control_queue h (Queue.exp q) (fromIntegral $ Event.expEv a) (fromIntegral b) p +control h q cmd me = + case cmd of + Event.QueueSetPosTick _ -> controlCustom h q cmd me + Event.QueueSetPosTime _ -> controlCustom h q cmd me + Event.QueueSkew _ -> controlCustom h q cmd me + _ -> controlPlain h q cmd me +controlCustom, controlPlain :: + Seq.T mode -> Queue.T -> Event.QueueEv -> Maybe Event.T -> IO () +controlCustom h q cmd me = + eventOutput h $ + case me of + Nothing -> + -- cf. Event.simple + Event.Cons { + Event.highPriority = False, + Event.tag = Event.Tag 0, + Event.queue = Queue.direct, + Event.time = Time.consAbs $ Time.Tick 0, + Event.source = Addr.unknown, + Event.dest = Addr.systemTimer, + Event.body = Event.QueueEv cmd q + } + Just ev -> + ev { + Event.dest = Addr.systemTimer, + Event.body = Event.QueueEv cmd q + } + +eventOutput :: Seq.T mode -> Event.T -> IO () +eventOutput h e = + void $ + Event.with e $ \p -> + Exc.checkResult "Queue.control.eventOutput" =<< eventOutput_ h p + +foreign import ccall safe "alsa/asoundlib.h snd_seq_event_output" + eventOutput_ :: Seq.T mode -> Ptr Event.T -> IO C.CInt + +controlPlain h q cmd me = + Event.withMaybe me $ \p -> + let (c,v) = Event.expQueueEv cmd + in Exc.checkResult_ "Queue.control" + =<< control_ h (Queue.exp q) + (fromIntegral $ Event.unEType c) v p + foreign import ccall unsafe "alsa/asoundlib.h snd_seq_control_queue" - snd_seq_control_queue :: Ptr Seq.Core -> CInt -> CInt -> CInt -> Ptr Event.T -> IO CInt + control_ :: Seq.T mode -> C.CInt -> C.CInt -> C.CInt -> Ptr Event.T -> IO C.CInt diff --git a/src/Sound/ALSA/Sequencer/Queue/Info.hs b/src/Sound/ALSA/Sequencer/Queue/Info.hs deleted file mode 100644 --- a/src/Sound/ALSA/Sequencer/Queue/Info.hs +++ /dev/null @@ -1,95 +0,0 @@ --------------------------------------------------------------------------------- --- | --- Module : Sound.ALSA.Sequencer.Queue.Info --- Copyright : (c) Henning Thielemann, 2010 --- (c) Iavor S. Diatchki, 2007 --- License : BSD3 --- --- Maintainer: Henning Thielemann --- Stability : provisional --- --- This module contains functions for working with sequencer queue. --- Reference: --- --------------------------------------------------------------------------------- - -module Sound.ALSA.Sequencer.Queue.Info - ( T - , get - , set - , copy - , clone - - , getQueue - , getName - , getLocked - , getOwner - , getFlags - - , setName - , setLocked - , setOwner - , setFlags - ) where - -import qualified Sound.ALSA.Sequencer.Marshal.Sequencer as Seq -import qualified Sound.ALSA.Sequencer.Marshal.Client as Client -import qualified Sound.ALSA.Sequencer.Marshal.Queue as Queue -import qualified Sound.ALSA.Sequencer.Area as Area -import qualified Sound.ALSA.Exception as Exc - -import Foreign.Ptr (Ptr, ) -import Foreign.C.Types (CInt, ) -import Data.Word (Word, ) - - -type T = Area.QueueInfo -type T_ = Area.QueueInfo_ - - --- XXX: Lots of duplication. - -get :: Seq.T mode -> Queue.T -> IO T -get (Seq.Cons h) q = - do info <- Area.queue_info_malloc - Exc.checkResult_ "get_queue_info" =<< Area.with_queue_info info - (snd_seq_get_queue_info h (Queue.exp q)) - return info - -foreign import ccall unsafe "alsa/asoundlib.h snd_seq_get_queue_info" - snd_seq_get_queue_info :: Ptr Seq.Core -> CInt -> Ptr T_ -> IO CInt - - -set :: Seq.T mode -> Queue.T -> T -> IO () -set (Seq.Cons h) p info = - Exc.checkResult_ "set_queue_info" =<< Area.with_queue_info info (snd_seq_set_queue_info h (Queue.exp p)) - -foreign import ccall unsafe "alsa/asoundlib.h snd_seq_set_queue_info" - snd_seq_set_queue_info :: Ptr Seq.Core -> CInt -> Ptr T_ -> IO CInt - - -copy :: T -> T -> IO () -clone :: T -> IO T -getQueue :: T -> IO Queue.T -getName :: T -> IO String -getLocked :: T -> IO Bool -getOwner :: T -> IO Client.T -getFlags :: T -> IO Word -setName :: T -> String -> IO () -setLocked :: T -> Bool -> IO () -setOwner :: T -> Client.T -> IO () -setFlags :: T -> Word -> IO () - -copy = Area.queue_info_copy -clone = Area.queue_info_clone - -getQueue = Area.queue_info_get_queue -getName = Area.queue_info_get_name -getLocked = Area.queue_info_get_locked -getOwner = Area.queue_info_get_owner -getFlags = Area.queue_info_get_flags - -setName = Area.queue_info_set_name -setLocked = Area.queue_info_set_locked -setOwner = Area.queue_info_set_owner -setFlags = Area.queue_info_set_flags diff --git a/src/Sound/ALSA/Sequencer/Queue/Info.hsc b/src/Sound/ALSA/Sequencer/Queue/Info.hsc new file mode 100644 --- /dev/null +++ b/src/Sound/ALSA/Sequencer/Queue/Info.hsc @@ -0,0 +1,61 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Sound.ALSA.Sequencer.Queue.Info +-- Copyright : (c) Henning Thielemann, 2010-2012 +-- (c) Iavor S. Diatchki, 2007 +-- License : BSD3 +-- +-- Maintainer: Henning Thielemann +-- Stability : provisional +-- +-- This module contains functions for working with sequencer queue. +-- Reference: +-- +-------------------------------------------------------------------------------- + +module Sound.ALSA.Sequencer.Queue.Info + ( T + , get + , set + , copy + , clone + + , getQueue + , getName + , getLocked + , getOwner + , getFlags + + , setName + , setLocked + , setOwner + , setFlags + ) where + +#include + +import qualified Sound.ALSA.Sequencer.Marshal.Sequencer as Seq +import qualified Sound.ALSA.Sequencer.Marshal.Client as Client +import qualified Sound.ALSA.Sequencer.Marshal.Queue as Queue +import qualified Sound.ALSA.Sequencer.Area as Area +import qualified Sound.ALSA.Exception as Exc + +import qualified Foreign.C.Types as C +import Data.Word (Word, ) + + +#area "queue_info" + +#{get_area "Queue.T"} +#{set_area "Queue.T"} + + +#{get_set_name} +#{get_set_bool "locked", "Locked"} + +#{get_set_int "owner", "Owner", "Client.T", "Client.imp", "Client.exp"} +#{get_set_int "flags", "Flags", "Word", "fromIntegral", "fromIntegral"} + + +-- RO +#{get_int "queue", "Queue", "Queue.T", "Queue.imp"} diff --git a/src/Sound/ALSA/Sequencer/Queue/Status.hs b/src/Sound/ALSA/Sequencer/Queue/Status.hs deleted file mode 100644 --- a/src/Sound/ALSA/Sequencer/Queue/Status.hs +++ /dev/null @@ -1,106 +0,0 @@ --------------------------------------------------------------------------------- --- | --- Module : Sound.ALSA.Sequencer.Queue.Status --- Copyright : (c) Henning Thielemann, 2010 --- (c) Iavor S. Diatchki, 2007 --- License : BSD3 --- --- Maintainer: Henning Thielemann --- Stability : provisional --- --- This module contains functions for working with sequencer queue. --- Reference: --- --------------------------------------------------------------------------------- - -module Sound.ALSA.Sequencer.Queue.Status - ( T - , get - , copy - , clone - - , getQueue - , getEvents - , getTickTime - , getRealTime - ) where - -import qualified Sound.ALSA.Sequencer.Marshal.Sequencer as Seq -import qualified Sound.ALSA.Sequencer.Marshal.RealTime as RealTime -import qualified Sound.ALSA.Sequencer.Marshal.Queue as Queue -import qualified Sound.ALSA.Sequencer.Area as Area -import qualified Sound.ALSA.Exception as Exc - -import Foreign.Ptr (Ptr, ) -import Foreign.C.Types (CInt, CUInt, ) -import Foreign.Storable (peek, ) -import Data.Word (Word32, ) - - -type T = Area.QueueStatus -type T_ = Area.QueueStatus_ - - -get :: Seq.T mode -> Queue.T -> IO T -get (Seq.Cons h) q = - do status <- Area.queue_status_malloc - Exc.checkResult_ "get_queue_status" =<< Area.with_queue_status status - (snd_seq_get_queue_status h (Queue.exp q)) - return status - -foreign import ccall unsafe "alsa/asoundlib.h snd_seq_get_queue_status" - snd_seq_get_queue_status :: Ptr Seq.Core -> CInt -> Ptr T_ -> IO CInt - - - -copy :: T -> T -> IO () -clone :: T -> IO T - -copy = Area.queue_status_copy -clone = Area.queue_status_clone - - -foreign import ccall unsafe "alsa/asoundlib.h" - snd_seq_queue_status_get_queue - :: Ptr T_ -> IO CInt -foreign import ccall unsafe "alsa/asoundlib.h" - snd_seq_queue_status_get_events - :: Ptr T_ -> IO CInt -foreign import ccall unsafe "alsa/asoundlib.h" - snd_seq_queue_status_get_tick_time - :: Ptr T_ -> IO Word32 -foreign import ccall unsafe "alsa/asoundlib.h" - snd_seq_queue_status_get_real_time - :: Ptr T_ -> IO (Ptr RealTime.T) -foreign import ccall unsafe "alsa/asoundlib.h" - snd_seq_queue_status_get_status - :: Ptr T_ -> IO CUInt - - -getQueue :: T -> IO Queue.T -getQueue status = - fmap Queue.imp $ - Area.with_queue_status status snd_seq_queue_status_get_queue - -getEvents :: T -> IO Int -getEvents status = - fmap fromIntegral $ - Area.with_queue_status status snd_seq_queue_status_get_events - -getTickTime :: T -> IO Word32 -getTickTime status = - Area.with_queue_status status snd_seq_queue_status_get_tick_time - -getRealTime :: T -> IO RealTime.T -getRealTime status = - peek =<< - Area.with_queue_status status snd_seq_queue_status_get_real_time - -{- -This function shall return status bits of the queue, -but the ALSA headers do not define any bits. -I would prefer a data type that handles this bitfield. --} -_getStatus :: T -> IO CUInt -_getStatus status = - Area.with_queue_status status snd_seq_queue_status_get_status diff --git a/src/Sound/ALSA/Sequencer/Queue/Status.hsc b/src/Sound/ALSA/Sequencer/Queue/Status.hsc new file mode 100644 --- /dev/null +++ b/src/Sound/ALSA/Sequencer/Queue/Status.hsc @@ -0,0 +1,56 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Sound.ALSA.Sequencer.Queue.Status +-- Copyright : (c) Henning Thielemann, 2010-2012 +-- (c) Iavor S. Diatchki, 2007 +-- License : BSD3 +-- +-- Maintainer: Henning Thielemann +-- Stability : provisional +-- +-- This module contains functions for working with sequencer queue. +-- Reference: +-- +-------------------------------------------------------------------------------- + +module Sound.ALSA.Sequencer.Queue.Status + ( T + , get + , copy + , clone + + , getQueue + , getEvents + , getTickTime + , getRealTime + ) where + +#include + +import qualified Sound.ALSA.Sequencer.Marshal.Sequencer as Seq +import qualified Sound.ALSA.Sequencer.Marshal.RealTime as RealTime +import qualified Sound.ALSA.Sequencer.Marshal.Time as Time +import qualified Sound.ALSA.Sequencer.Marshal.Queue as Queue +import qualified Sound.ALSA.Sequencer.Area as Area +import qualified Sound.ALSA.Exception as Exc + +import qualified Foreign.C.Types as C + + +#area "queue_status" + + +#{get_area "Queue.T"} + +#{get_int "tick_time", "TickTime", "Time.Tick", "fromIntegral"} +#{get_ptr "real_time", "RealTime", "RealTime.T"} +#{get_int "queue", "Queue", "Queue.T", "Queue.imp"} +#{get_int "events", "Events", "Int", "fromIntegral"} + +{- +This function shall return status bits of the queue, +but the ALSA headers do not define any bits. +I would prefer a data type that handles this bitfield. + +#{get_int "status", "Status", "C.CUInt", "fromIntegral"} +-} diff --git a/src/Sound/ALSA/Sequencer/Queue/Tempo.hs b/src/Sound/ALSA/Sequencer/Queue/Tempo.hs deleted file mode 100644 --- a/src/Sound/ALSA/Sequencer/Queue/Tempo.hs +++ /dev/null @@ -1,91 +0,0 @@ --------------------------------------------------------------------------------- --- | --- Module : Sound.ALSA.Sequencer.Queue.Tempo --- Copyright : (c) Henning Thielemann, 2010 --- (c) Iavor S. Diatchki, 2007 --- License : BSD3 --- --- Maintainer: Henning Thielemann --- Stability : provisional --- --- This module contains functions for working with sequencer queue. --- Reference: --- --------------------------------------------------------------------------------- - -module Sound.ALSA.Sequencer.Queue.Tempo - ( T - , get - , set - , copy - , clone - - , getQueue - , getTempo - , getPPQ - , getSkew - , getSkewBase - - , setTempo - , setPPQ - , setSkew - , setSkewBase - ) where - -import qualified Sound.ALSA.Sequencer.Marshal.Queue as Queue -import qualified Sound.ALSA.Sequencer.Marshal.Sequencer as Seq -import qualified Sound.ALSA.Sequencer.Area as Area -import qualified Sound.ALSA.Exception as Exc - -import Foreign.Ptr (Ptr, ) -import Foreign.C.Types (CInt, ) -import Data.Word (Word, ) - - -type T = Area.QueueTempo -type T_ = Area.QueueTempo_ - -get :: Seq.T mode -> Queue.T -> IO T -get (Seq.Cons h) q = - do tempo <- Area.queue_tempo_malloc - Exc.checkResult_ "get_queue_tempo" =<< Area.with_queue_tempo tempo - (snd_seq_get_queue_tempo h (Queue.exp q)) - return tempo - -foreign import ccall unsafe "alsa/asoundlib.h snd_seq_get_queue_tempo" - snd_seq_get_queue_tempo :: Ptr Seq.Core -> CInt -> Ptr T_ -> IO CInt - - -set :: Seq.T mode -> Queue.T -> T -> IO () -set (Seq.Cons h) p tempo = - Exc.checkResult_ "set_queue_tempo" =<< Area.with_queue_tempo tempo (snd_seq_set_queue_tempo h (Queue.exp p)) - -foreign import ccall unsafe "alsa/asoundlib.h snd_seq_set_queue_tempo" - snd_seq_set_queue_tempo :: Ptr Seq.Core -> CInt -> Ptr T_ -> IO CInt - - -copy :: T -> T -> IO () -clone :: T -> IO T -getQueue :: T -> IO Queue.T -getTempo :: T -> IO Word -getPPQ :: T -> IO Int -getSkew :: T -> IO Word -getSkewBase :: T -> IO Word -setTempo :: T -> Word -> IO () -setPPQ :: T -> Int -> IO () -setSkew :: T -> Word -> IO () -setSkewBase :: T -> Word -> IO () - -copy = Area.queue_tempo_copy -clone = Area.queue_tempo_clone - -getQueue = Area.queue_tempo_get_queue -getTempo = Area.queue_tempo_get_tempo -getPPQ = Area.queue_tempo_get_ppq -getSkew = Area.queue_tempo_get_skew -getSkewBase = Area.queue_tempo_get_skew_base - -setTempo = Area.queue_tempo_set_tempo -setPPQ = Area.queue_tempo_set_ppq -setSkew = Area.queue_tempo_set_skew -setSkewBase = Area.queue_tempo_set_skew_base diff --git a/src/Sound/ALSA/Sequencer/Queue/Tempo.hsc b/src/Sound/ALSA/Sequencer/Queue/Tempo.hsc new file mode 100644 --- /dev/null +++ b/src/Sound/ALSA/Sequencer/Queue/Tempo.hsc @@ -0,0 +1,59 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Sound.ALSA.Sequencer.Queue.Tempo +-- Copyright : (c) Henning Thielemann, 2010-2012 +-- (c) Iavor S. Diatchki, 2007 +-- License : BSD3 +-- +-- Maintainer: Henning Thielemann +-- Stability : provisional +-- +-- This module contains functions for working with sequencer queue. +-- Reference: +-- +-------------------------------------------------------------------------------- + +module Sound.ALSA.Sequencer.Queue.Tempo + ( T + , get + , set + , copy + , clone + + , getQueue + , getTempo + , getPPQ + , getSkew + , getSkewBase + + , setTempo + , setPPQ + , setSkew + , setSkewBase + ) where + +#include + +import qualified Sound.ALSA.Sequencer.Marshal.Queue as Queue +import qualified Sound.ALSA.Sequencer.Marshal.Sequencer as Seq +import qualified Sound.ALSA.Sequencer.Area as Area +import qualified Sound.ALSA.Exception as Exc + +import qualified Foreign.C.Types as C +import Data.Word (Word, ) + + +#area "queue_tempo" + +#{get_area "Queue.T"} +#{set_area "Queue.T"} + + +-- RO +#{get_int "queue", "Queue", "Queue.T", "Queue.imp"} + +-- RW +#{get_set_int "tempo", "Tempo", "Word", "fromIntegral", "fromIntegral"} +#{get_set_int "ppq", "PPQ", "Int", "fromIntegral", "fromIntegral"} +#{get_set_int "skew", "Skew", "Word", "fromIntegral", "fromIntegral"} +#{get_set_int "skew_base", "SkewBase", "Word", "fromIntegral", "fromIntegral"} diff --git a/src/Sound/ALSA/Sequencer/Queue/Timer.hs b/src/Sound/ALSA/Sequencer/Queue/Timer.hs deleted file mode 100644 --- a/src/Sound/ALSA/Sequencer/Queue/Timer.hs +++ /dev/null @@ -1,80 +0,0 @@ --------------------------------------------------------------------------------- --- | --- Module : Sound.ALSA.Sequencer.Queue.Timer --- Copyright : (c) Henning Thielemann, 2010 --- (c) Iavor S. Diatchki, 2007 --- License : BSD3 --- --- Maintainer: Henning Thielemann --- Stability : provisional --- --- This module contains functions for working with sequencer queue. --- Reference: --- --------------------------------------------------------------------------------- - -module Sound.ALSA.Sequencer.Queue.Timer - ( T - , get - , set - , copy - , clone - - , getQueue - , getType - , getResolution - - , setType - , setResolution - - , QueueTimer.Type(..) - ) where - -import qualified Sound.ALSA.Sequencer.Marshal.Queue as Queue -import qualified Sound.ALSA.Sequencer.Marshal.QueueTimer as QueueTimer -import qualified Sound.ALSA.Sequencer.Marshal.Sequencer as Seq -import qualified Sound.ALSA.Sequencer.Area as Area -import qualified Sound.ALSA.Exception as Exc - -import Foreign.Ptr (Ptr, ) -import Foreign.C.Types (CInt, ) -import Data.Word (Word, ) - - -type T = Area.QueueTimer -type T_ = Area.QueueTimer_ - -get :: Seq.T mode -> Queue.T -> IO T -get (Seq.Cons h) q = - do timer <- Area.queue_timer_malloc - Exc.checkResult_ "get_queue_timer" =<< Area.with_queue_timer timer - (snd_seq_get_queue_timer h (Queue.exp q)) - return timer - -foreign import ccall unsafe "alsa/asoundlib.h snd_seq_get_queue_timer" - snd_seq_get_queue_timer :: Ptr Seq.Core -> CInt -> Ptr T_ -> IO CInt - - -set :: Seq.T mode -> Queue.T -> T -> IO () -set (Seq.Cons h) p timer = - Exc.checkResult_ "set_queue_timer" =<< Area.with_queue_timer timer (snd_seq_set_queue_timer h (Queue.exp p)) - -foreign import ccall unsafe "alsa/asoundlib.h snd_seq_set_queue_timer" - snd_seq_set_queue_timer :: Ptr Seq.Core -> CInt -> Ptr T_ -> IO CInt - - -copy :: T -> T -> IO () -clone :: T -> IO T -getQueue :: T -> IO Queue.T -getType :: T -> IO QueueTimer.Type -getResolution :: T -> IO Word -setType :: T -> QueueTimer.Type -> IO () -setResolution :: T -> Word -> IO () - -copy = Area.queue_timer_copy -clone = Area.queue_timer_clone -getQueue = Area.queue_timer_get_queue -getType = Area.queue_timer_get_type -getResolution = Area.queue_timer_get_resolution -setType = Area.queue_timer_set_type -setResolution = Area.queue_timer_set_resolution diff --git a/src/Sound/ALSA/Sequencer/Queue/Timer.hsc b/src/Sound/ALSA/Sequencer/Queue/Timer.hsc new file mode 100644 --- /dev/null +++ b/src/Sound/ALSA/Sequencer/Queue/Timer.hsc @@ -0,0 +1,80 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Sound.ALSA.Sequencer.Queue.Timer +-- Copyright : (c) Henning Thielemann, 2010-2012 +-- (c) Iavor S. Diatchki, 2007 +-- License : BSD3 +-- +-- Maintainer: Henning Thielemann +-- Stability : provisional +-- +-- This module contains functions for working with sequencer queue. +-- Reference: +-- +-------------------------------------------------------------------------------- + +module Sound.ALSA.Sequencer.Queue.Timer + ( T + , get + , set + , copy + , clone + + , getQueue + , getType + , getResolution + + , setType + , setResolution + + , Type(..) + ) where + +#include +#include + +import qualified Sound.ALSA.Sequencer.Marshal.Queue as Queue +import qualified Sound.ALSA.Sequencer.Marshal.Sequencer as Seq +import qualified Sound.ALSA.Sequencer.Area as Area +import qualified Sound.ALSA.Exception as Exc + +import qualified Foreign.C.Types as C +import Data.Word (Word, ) + + +#area "queue_timer" + +#{get_area "Queue.T"} +#{set_area "Queue.T"} + + +-- RO +#{get_int "queue", "Queue", "Queue.T", "Queue.imp"} + +-- RW + +#{get_set_int "type", "Type", + "Type", "impType", "expType"} + +#{get_set_int "resolution", "Resolution", + "Word", "fromIntegral", "fromIntegral"} + + +data Type = + Alsa + | MidiClock + | MidiTick + deriving (Show, Eq, Ord, Enum) + +expType :: Type -> C.CInt +expType t = case t of + Alsa -> #{const SND_SEQ_TIMER_ALSA} + MidiClock -> #{const SND_SEQ_TIMER_MIDI_CLOCK} + MidiTick -> #{const SND_SEQ_TIMER_MIDI_TICK} + +impType :: C.CInt -> Type +impType t = case t of + #{const SND_SEQ_TIMER_ALSA} -> Alsa + #{const SND_SEQ_TIMER_MIDI_CLOCK} -> MidiClock + #{const SND_SEQ_TIMER_MIDI_TICK} -> MidiTick + _ -> error ("QueueTimer.impType: unknown timer type (" ++ show t ++ ")") diff --git a/src/Sound/ALSA/Sequencer/RealTime.hs b/src/Sound/ALSA/Sequencer/RealTime.hs --- a/src/Sound/ALSA/Sequencer/RealTime.hs +++ b/src/Sound/ALSA/Sequencer/RealTime.hs @@ -1,7 +1,7 @@ module Sound.ALSA.Sequencer.RealTime ( RealTime.T(..) - , fromDouble, fromInteger - , toDouble, toInteger + , fromDouble, fromFractional, fromInteger + , toDouble, toFractional, toInteger ) where import qualified Sound.ALSA.Sequencer.Marshal.RealTime as RealTime @@ -18,9 +18,15 @@ let (s,n) = divMod t nanoPerSecond in RealTime.Cons (fromIntegral s) (fromIntegral n) --- | Convert fractional number of seconds to 'RealTime.T' +{- | +Convert fractional number of seconds to 'RealTime.T' +Time must be non-negative. +-} fromDouble :: Double -> RealTime.T -fromDouble t = +fromDouble = fromFractional + +fromFractional :: (RealFrac a) => a -> RealTime.T +fromFractional t = let (s,n) = properFraction t in RealTime.Cons s (floor $ n * nanoPerSecond) @@ -31,5 +37,8 @@ -- | Convert fractional number of seconds to 'RealTime.T' toDouble :: RealTime.T -> Double -toDouble (RealTime.Cons s n) = +toDouble = toFractional + +toFractional :: (RealFrac a) => RealTime.T -> a +toFractional (RealTime.Cons s n) = fromIntegral s + fromIntegral n / nanoPerSecond diff --git a/src/Sound/ALSA/Sequencer/Sequencer.hs b/src/Sound/ALSA/Sequencer/Sequencer.hs --- a/src/Sound/ALSA/Sequencer/Sequencer.hs +++ b/src/Sound/ALSA/Sequencer/Sequencer.hs @@ -5,12 +5,11 @@ module Sound.ALSA.Sequencer.Sequencer where -import qualified Sound.ALSA.Sequencer.Marshal.Port as Port import qualified Sound.ALSA.Sequencer.Marshal.Sequencer as Seq -import qualified Sound.ALSA.Sequencer.Marshal.Address as Addr import qualified Sound.ALSA.Exception as Exc -import Foreign.C.Types (CInt, CSize, ) +import qualified Foreign.C.Types as C +import Foreign.C.Types (CSize, ) import Foreign.C.String (CString, withCAString, peekCString, ) import Foreign.Ptr (Ptr, ) import Foreign.Marshal.Alloc (alloca, ) @@ -30,20 +29,32 @@ open :: Seq.OpenMode mode - -- Read\/Write permissions - => String -- ^ The sequencer's \"name\". This is not a name that you - -- make up for your own purposes; it has special significance - -- to the ALSA library. Usually you need to pass 'default_name' - -- here. - -> Seq.BlockMode -- Blocking behavior - -> IO (Seq.T mode) -- Handle to the sequencer. + -- Read\/Write permissions + => String + {- ^ + The sequencer's \"name\". + This is not a name that you make up for your own purposes; + it has special significance to the ALSA library. + Usually you need to pass 'defaultName' here + or simply use 'openDefault'. + -} + -> Seq.BlockMode -- ^ Blocking behavior + -> IO (Seq.T mode) -- ^ Handle to the sequencer. open t bm = withOpenMode $ \om -> alloca $ \p -> withCAString t $ \s -> do Exc.checkResult_ "open" =<< snd_seq_open p s (Seq.expOpenMode om) (Seq.expBlockMode bm) fmap Seq.Cons $ peek p +openDefault + :: Seq.OpenMode mode + -- Read\/Write permissions + => Seq.BlockMode -- ^ Blocking behavior + -> IO (Seq.T mode) -- ^ Handle to the sequencer. +openDefault = open defaultName + + foreign import ccall unsafe "alsa/asoundlib.h snd_seq_open" - snd_seq_open :: Ptr (Ptr Seq.Core) -> CString -> CInt -> CInt -> IO CInt + snd_seq_open :: Ptr (Ptr Seq.Core) -> CString -> C.CInt -> C.CInt -> IO C.CInt withOpenMode :: (mode -> IO (Seq.T mode)) -> IO (Seq.T mode) withOpenMode f = f undefined @@ -61,30 +72,46 @@ close (Seq.Cons h) = Exc.checkResult_ "close" =<< snd_seq_close h foreign import ccall unsafe "alsa/asoundlib.h snd_seq_close" - snd_seq_close :: Ptr Seq.Core -> IO CInt + snd_seq_close :: Ptr Seq.Core -> IO C.CInt with :: Seq.OpenMode mode - -- Read\/Write permissions - => String -- ^ The sequencer's \"name\". This is not a name that you - -- make up for your own purposes; it has special significance - -- to the ALSA library. Usually you need to pass 'default_name' - -- here. + -- Read\/Write permissions + => String + {- ^ + The sequencer's \"name\". + This is not a name that you make up for your own purposes; + it has special significance to the ALSA library. + Usually you need to pass 'defaultName' here + or simply use 'withDefault'. + -} -> Seq.BlockMode - -- Blocking behavior + -- ^ Blocking behavior -> (Seq.T mode -> IO a) - -- Action on the sequencer, the result must be computed strictly. + -- ^ Action on the sequencer, the result must be computed strictly. -> IO a with t bm = bracket (open t bm) close +withDefault + :: Seq.OpenMode mode + => Seq.BlockMode + -> (Seq.T mode -> IO a) + -> IO a +withDefault = with defaultName + +-- | This is the name that should be passed to 'open' in most cases. +defaultName :: String +defaultName = "default" + + -- | Get identifier of a sequencer handle. -- It is the same identifier specified in the call to 'open'. getName - :: Seq.T mode -- ^ sequencer handle - -> IO String -- ^ ALSA identifier for the handel + :: Seq.T mode -- ^ sequencer handle + -> IO String -- ^ ALSA identifier for the handle getName (Seq.Cons h) = peekCString =<< snd_seq_name h foreign import ccall unsafe "alsa/asoundlib.h snd_seq_name" @@ -104,7 +131,7 @@ setBlocking (Seq.Cons h) m = Exc.checkResult_ "set_blocking" =<< snd_seq_nonblock h(Seq.expBlockMode m) foreign import ccall unsafe "alsa/asoundlib.h snd_seq_nonblock" - snd_seq_nonblock :: Ptr Seq.Core -> CInt -> IO CInt + snd_seq_nonblock :: Ptr Seq.Core -> C.CInt -> IO C.CInt @@ -133,7 +160,7 @@ Exc.checkResult_ "set_output_buffer_size" =<< snd_seq_set_output_buffer_size h (fromIntegral x) foreign import ccall unsafe "alsa/asoundlib.h snd_seq_set_output_buffer_size" - snd_seq_set_output_buffer_size :: Ptr Seq.Core -> CSize -> IO CInt + snd_seq_set_output_buffer_size :: Ptr Seq.Core -> CSize -> IO C.CInt -- | Return the byte size of input buffer. @@ -159,7 +186,7 @@ Exc.checkResult_ "set_input_buffer_size" =<< snd_seq_set_input_buffer_size h (fromIntegral x) foreign import ccall unsafe "alsa/asoundlib.h snd_seq_set_input_buffer_size" - snd_seq_set_input_buffer_size :: Ptr Seq.Core -> CSize -> IO CInt + snd_seq_set_input_buffer_size :: Ptr Seq.Core -> CSize -> IO C.CInt @@ -175,7 +202,7 @@ Exc.checkResult_ "set_pool_output" =<< snd_seq_set_client_pool_output h (fromIntegral x) foreign import ccall unsafe "alsa/asoundlib.h snd_seq_set_client_pool_output" - snd_seq_set_client_pool_output :: Ptr Seq.Core -> CSize -> IO CInt + snd_seq_set_client_pool_output :: Ptr Seq.Core -> CSize -> IO C.CInt -- | Specify how much space should become free before waking clients @@ -189,7 +216,7 @@ Exc.checkResult_ "set_pool_output_room" =<< snd_seq_set_client_pool_output_room h (fromIntegral x) foreign import ccall unsafe "alsa/asoundlib.h snd_seq_set_client_pool_output_room" - snd_seq_set_client_pool_output_room :: Ptr Seq.Core -> CSize -> IO CInt + snd_seq_set_client_pool_output_room :: Ptr Seq.Core -> CSize -> IO C.CInt -- | Reset the output pool. @@ -201,7 +228,7 @@ Exc.checkResult_ "reset_pool_output" =<< snd_seq_reset_pool_output h foreign import ccall unsafe "alsa/asoundlib.h snd_seq_reset_pool_output" - snd_seq_reset_pool_output :: Ptr Seq.Core -> IO CInt + snd_seq_reset_pool_output :: Ptr Seq.Core -> IO C.CInt @@ -215,7 +242,7 @@ Exc.checkResult_ "set_pool_input" =<< snd_seq_set_client_pool_input h (fromIntegral x) foreign import ccall unsafe "alsa/asoundlib.h snd_seq_set_client_pool_input" - snd_seq_set_client_pool_input :: Ptr Seq.Core -> CSize -> IO CInt + snd_seq_set_client_pool_input :: Ptr Seq.Core -> CSize -> IO C.CInt -- | Reset the input pool. @@ -227,71 +254,4 @@ Exc.checkResult_ "reset_pool_input" =<< snd_seq_reset_pool_input h foreign import ccall unsafe "alsa/asoundlib.h snd_seq_reset_pool_input" - snd_seq_reset_pool_input :: Ptr Seq.Core -> IO CInt - - - - - - - - - ---Middle Level Interface ------------------------------------------------------- - - --- | Simple subscription (w\/o exclusive & time conversion). -connectFrom :: Seq.AllowInput mode => Seq.T mode -> Port.T -> Addr.T -> IO () -connectFrom (Seq.Cons h) me a = - Exc.checkResult_ "connect_from" =<< snd_seq_connect_from h (Port.exp me) c p - where (c,p) = Addr.exp a - -foreign import ccall unsafe "alsa/asoundlib.h snd_seq_connect_from" - snd_seq_connect_from :: Ptr Seq.Core -> CInt -> CInt -> CInt -> IO CInt - - --- | Simple subscription (w\/o exclusive & time conversion). -connectTo :: Seq.AllowOutput mode => Seq.T mode -> Port.T -> Addr.T -> IO () -connectTo (Seq.Cons h) me a = - Exc.checkResult_ "connect_to" =<< snd_seq_connect_to h (Port.exp me) c p - where (c,p) = Addr.exp a - -foreign import ccall unsafe "alsa/asoundlib.h snd_seq_connect_to" - snd_seq_connect_to :: Ptr Seq.Core -> CInt -> CInt -> CInt -> IO CInt - - --- | Simple disconnection. -disconnectFrom :: Seq.AllowInput mode => Seq.T mode -> Port.T -> Addr.T -> IO () -disconnectFrom (Seq.Cons h) me a = - Exc.checkResult_ "disconnect_from" =<< snd_seq_disconnect_from h (Port.exp me) c p - where (c,p) = Addr.exp a - -foreign import ccall unsafe "alsa/asoundlib.h snd_seq_disconnect_from" - snd_seq_disconnect_from :: Ptr Seq.Core -> CInt -> CInt -> CInt -> IO CInt - --- | Simple disconnection. -disconnectTo :: Seq.AllowOutput mode => Seq.T mode -> Port.T -> Addr.T -> IO () -disconnectTo (Seq.Cons h) me a = - Exc.checkResult_ "disconnect_to" =<< snd_seq_disconnect_to h (Port.exp me) c p - where (c,p) = Addr.exp a - -foreign import ccall unsafe "alsa/asoundlib.h snd_seq_disconnect_to" - snd_seq_disconnect_to :: Ptr Seq.Core -> CInt -> CInt -> CInt -> IO CInt - - --- | Parse the given string into sequencer address. --- The client and port are separated by either colon or period, e.g. 128:1. --- The function also accepts client names. -parseAddress - :: Seq.T mode -- ^ Sequencer handle. - -> String -- ^ String to be parsed. - -> IO Addr.T -- ^ The parsed address. - -parseAddress (Seq.Cons h) s = - alloca $ \pa -> - withCAString s $ \ps -> - do Exc.checkResult_ "parse_address" =<< snd_seq_parse_address h pa ps - peek pa - -foreign import ccall unsafe "alsa/asoundlib.h snd_seq_parse_address" - snd_seq_parse_address :: Ptr Seq.Core -> Ptr Addr.T -> CString -> IO CInt + snd_seq_reset_pool_input :: Ptr Seq.Core -> IO C.CInt diff --git a/src/Sound/ALSA/Sequencer/Subscribe.hs b/src/Sound/ALSA/Sequencer/Subscribe.hs deleted file mode 100644 --- a/src/Sound/ALSA/Sequencer/Subscribe.hs +++ /dev/null @@ -1,147 +0,0 @@ --------------------------------------------------------------------------------- --- | --- Module : Sound.ALSA.Sequencer.Subscribe --- Copyright : (c) Dylan Simon, 2011 --- License : BSD3 --- --- Stability : provisional --- --- This module contains functions for working with subscriptions. --- Reference: --- --------------------------------------------------------------------------------- - -module Sound.ALSA.Sequencer.Subscribe - ( {- T - - , alloc - , copy - , clone - - , getSender - , getDest - , getQueue - , getExclusive - , getTimeUpdate - , getTimeReal - - , setSender - , setDest - , setQueue - , setExclusive - , setTimeUpdate - , setTimeReal - - , subscribePort - , unsubscribePort - - , create - , -} subscribe - , unsubscribe - ) where - -import qualified Sound.ALSA.Sequencer.Marshal.Sequencer as Seq -import qualified Sound.ALSA.Sequencer.Area as Area -import qualified Sound.ALSA.Sequencer.Marshal.Address as Addr -import qualified Sound.ALSA.Sequencer.Marshal.Queue as Queue -import qualified Sound.ALSA.Exception as Exc - -import Foreign.C.Types (CInt, ) -import Foreign.Ptr (Ptr, ) -import Foreign.Marshal.Alloc (alloca, ) -import Foreign.Storable (peek, poke, ) - -type T = Area.PortSubscribe -type T_ = Area.PortSubscribe_ - -alloc :: IO T -_copy :: T -> T -> IO () -_clone :: T -> IO T -_getQueue :: T -> IO Queue.T -_getExclusive :: T -> IO Bool -_getTimeUpdate:: T -> IO Bool -_getTimeReal :: T -> IO Bool -setQueue :: T -> Queue.T -> IO () -setExclusive :: T -> Bool -> IO () -setTimeUpdate :: T -> Bool -> IO () -setTimeReal :: T -> Bool -> IO () - -alloc = Area.port_subscribe_malloc -_copy = Area.port_subscribe_copy -_clone = Area.port_subscribe_clone -_getQueue = Area.port_subscribe_get_queue -_getExclusive = Area.port_subscribe_get_exclusive -_getTimeUpdate= Area.port_subscribe_get_time_update -_getTimeReal = Area.port_subscribe_get_time_real -setQueue = Area.port_subscribe_set_queue -setExclusive = Area.port_subscribe_set_exclusive -setTimeUpdate = Area.port_subscribe_set_time_update -setTimeReal = Area.port_subscribe_set_time_real - --- | Get sender address of a port subscription -_getSender :: T -> IO Addr.T -_getSender s = - peek =<< Area.with_port_subscribe s snd_seq_port_subscribe_get_sender - -foreign import ccall unsafe "alsa/asoundlib.h snd_seq_port_subscribe_get_sender" - snd_seq_port_subscribe_get_sender :: Ptr T_ -> IO (Ptr Addr.T) - --- | Get destination address of a port subscription -_getDest :: T -> IO Addr.T -_getDest s = - peek =<< Area.with_port_subscribe s snd_seq_port_subscribe_get_dest - -foreign import ccall unsafe "alsa/asoundlib.h snd_seq_port_subscribe_get_dest" - snd_seq_port_subscribe_get_dest :: Ptr T_ -> IO (Ptr Addr.T) - --- | Set sender address of a port subscription -setSender :: T -> Addr.T -> IO () -setSender s c = - alloca $ \p -> poke p c >> Area.with_port_subscribe s (`snd_seq_port_subscribe_set_sender` p) - -foreign import ccall unsafe "alsa/asoundlib.h snd_seq_port_subscribe_set_sender" - snd_seq_port_subscribe_set_sender :: Ptr T_ -> Ptr Addr.T -> IO () - --- | Set destination address of a port subscription -setDest :: T -> Addr.T -> IO () -setDest s c = - alloca $ \p -> poke p c >> Area.with_port_subscribe s (`snd_seq_port_subscribe_set_dest` p) - -foreign import ccall unsafe "alsa/asoundlib.h snd_seq_port_subscribe_set_dest" - snd_seq_port_subscribe_set_dest :: Ptr T_ -> Ptr Addr.T -> IO () - --- | Subscribe a port connection -subscribePort :: Seq.T mode -> T -> IO () -subscribePort (Seq.Cons h) s = - Exc.checkResult_ "subscribe_port" =<< Area.with_port_subscribe s (snd_seq_subscribe_port h) - -foreign import ccall unsafe "alsa/asoundlib.h snd_seq_subscribe_port" - snd_seq_subscribe_port :: Ptr Seq.Core -> Ptr T_ -> IO CInt - --- | Unsubscribe a connection between ports -unsubscribePort :: Seq.T mode -> T -> IO () -unsubscribePort (Seq.Cons h) s = - Exc.checkResult_ "unsubscribe_port" =<< Area.with_port_subscribe s (snd_seq_unsubscribe_port h) - -foreign import ccall unsafe "alsa/asoundlib.h snd_seq_unsubscribe_port" - snd_seq_unsubscribe_port :: Ptr Seq.Core -> Ptr T_ -> IO CInt - -create :: Addr.T -> Addr.T -> Bool -> Maybe (Queue.T, Bool) -> IO T -create sender dest excl time = do - s <- alloc - setSender s sender - setDest s dest - setExclusive s excl - maybe (return ()) (\(queue, realtime) -> do - setTimeUpdate s True - setQueue s queue - setTimeReal s realtime) time - return s - --- | Subscribe a port connection: @'subscribeSimple' sender dest exclusive (Just (updatequeue, realtime))@ -subscribe :: Seq.T mode -> Addr.T -> Addr.T -> Bool -> Maybe (Queue.T, Bool) -> IO () -subscribe ss sender dest excl time = subscribePort ss =<< create sender dest excl time - --- | Unsubscribe a port connection: @'unsubscribeSimple' sender dest@ -unsubscribe :: Seq.T mode -> Addr.T -> Addr.T -> IO () -unsubscribe ss sender dest = unsubscribePort ss =<< create sender dest False Nothing diff --git a/src/Sound/ALSA/Sequencer/Subscribe.hsc b/src/Sound/ALSA/Sequencer/Subscribe.hsc new file mode 100644 --- /dev/null +++ b/src/Sound/ALSA/Sequencer/Subscribe.hsc @@ -0,0 +1,115 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Sound.ALSA.Sequencer.Subscribe +-- Copyright : (c) Henning Thielemann, 2012 +-- (c) Dylan Simon, 2011 +-- License : BSD3 +-- +-- Stability : provisional +-- +-- This module contains functions for working with subscriptions. +-- Reference: +-- +-------------------------------------------------------------------------------- + +module Sound.ALSA.Sequencer.Subscribe + ( T + + , malloc + , copy + , clone + + , getSender + , getDest + , getQueue + , getExclusive + , getTimeUpdate + , getTimeReal + + , setSender + , setDest + , setQueue + , setExclusive + , setTimeUpdate + , setTimeReal + + , subscribePort + , unsubscribePort + + , create + , subscribe + , unsubscribe + ) where + +#include + +import qualified Sound.ALSA.Sequencer.Marshal.Sequencer as Seq +import qualified Sound.ALSA.Sequencer.Marshal.Address as Addr +import qualified Sound.ALSA.Sequencer.Marshal.Queue as Queue +import qualified Sound.ALSA.Sequencer.Area as Area +import qualified Sound.ALSA.Exception as Exc + +import Data.Foldable (forM_, ) + +import qualified Foreign.C.Types as C +import Foreign.Ptr (Ptr, ) + + +#area "port_subscribe" + +#{get_set_int "queue", "Queue", + "Queue.T", "Queue.imp", "Queue.exp"} +#get_set_bool "exclusive", "Exclusive" +#get_set_bool "time_update", "TimeUpdate" +#get_set_bool "time_real", "TimeReal" + + +-- | Get sender address of a port subscription +#{get_ptr "sender", "Sender", "Addr.T"} + +-- | Get destination address of a port subscription +#{get_ptr "dest", "Dest", "Addr.T"} + +-- | Set sender address of a port subscription +#{set_ptr "sender", "Sender", "Addr.T"} + +-- | Set destination address of a port subscription +#{set_ptr "dest", "Dest", "Addr.T"} + +-- | Subscribe a port connection +subscribePort :: Seq.T mode -> T -> IO () +subscribePort (Seq.Cons h) s = + Exc.checkResult_ "subscribePort" =<< with s (subscribePort_ h) + +foreign import ccall unsafe "alsa/asoundlib.h snd_seq_subscribe_port" + subscribePort_ :: Ptr Seq.Core -> Ptr T_ -> IO C.CInt + +-- | Unsubscribe a connection between ports +unsubscribePort :: Seq.T mode -> T -> IO () +unsubscribePort (Seq.Cons h) s = + Exc.checkResult_ "unsubscribePort" =<< with s (unsubscribePort_ h) + +foreign import ccall unsafe "alsa/asoundlib.h snd_seq_unsubscribe_port" + unsubscribePort_ :: Ptr Seq.Core -> Ptr T_ -> IO C.CInt + +create :: Addr.T -> Addr.T -> Bool -> Maybe (Queue.T, Bool) -> IO T +create sender dest excl time = do + s <- malloc + setSender s sender + setDest s dest + setExclusive s excl + forM_ time $ \(queue, realtime) -> do + setTimeUpdate s True + setQueue s queue + setTimeReal s realtime + return s + +-- | Subscribe a port connection: @'subscribeSimple' sender dest exclusive (Just (updatequeue, realtime))@ +subscribe :: Seq.T mode -> Addr.T -> Addr.T -> Bool -> Maybe (Queue.T, Bool) -> IO () +subscribe ss sender dest excl time = + subscribePort ss =<< create sender dest excl time + +-- | Unsubscribe a port connection: @'unsubscribeSimple' sender dest@ +unsubscribe :: Seq.T mode -> Addr.T -> Addr.T -> IO () +unsubscribe ss sender dest = + unsubscribePort ss =<< create sender dest False Nothing diff --git a/src/Sound/ALSA/Sequencer/Subscribe/Query.hs b/src/Sound/ALSA/Sequencer/Subscribe/Query.hs deleted file mode 100644 --- a/src/Sound/ALSA/Sequencer/Subscribe/Query.hs +++ /dev/null @@ -1,150 +0,0 @@ --------------------------------------------------------------------------------- --- | --- Module : Sound.ALSA.Sequencer.Subscribe.Query --- Copyright : (c) Dylan Simon, 2011 --- License : BSD3 --- --- Stability : provisional --- --- This module contains functions for working with subscriptions. --- Reference: --- --------------------------------------------------------------------------------- - -module Sound.ALSA.Sequencer.Subscribe.Query - ( T - , Query.Type(..) - - {- - , alloc - , copy - , clone - -} - - , getClient - , getPort - , getRoot - , getType - , getIndex - , getNumSubs - , getAddr - , getQueue - , getExclusive - , getTimeUpdate - , getTimeReal - - {- - , setClient - , setPort - , setType - , setIndex - -} - - , query - , queryAll - ) where - -import qualified Sound.ALSA.Sequencer.Marshal.QuerySubscribe as Query -import qualified Sound.ALSA.Sequencer.Marshal.Sequencer as Seq -import qualified Sound.ALSA.Sequencer.Area as Area -import qualified Sound.ALSA.Sequencer.Marshal.Address as Addr -import qualified Sound.ALSA.Sequencer.Marshal.Client as Client -import qualified Sound.ALSA.Sequencer.Marshal.Port as Port -import qualified Sound.ALSA.Sequencer.Marshal.Queue as Queue -import qualified Sound.ALSA.Exception as Exc - -import Foreign.C.Error (Errno(Errno), eNOENT, ) -import Foreign.C.Types (CInt, ) -import Foreign.Ptr (Ptr, ) -import Foreign.Marshal.Alloc (alloca, ) -import Foreign.Storable (peek, poke, ) -import Data.Word (Word, ) - -type T = Area.QuerySubscribe -type T_ = Area.QuerySubscribe_ - -alloc :: IO T -_copy :: T -> T -> IO () -_clone :: T -> IO T -getClient :: T -> IO Client.T -getPort :: T -> IO Port.T -getType :: T -> IO Query.Type -getIndex :: T -> IO Word -getNumSubs :: T -> IO Word -getQueue :: T -> IO Queue.T -getExclusive :: T -> IO Bool -getTimeUpdate :: T -> IO Bool -getTimeReal :: T -> IO Bool -_setClient :: T -> Client.T -> IO () -_setPort :: T -> Port.T -> IO () -setType :: T -> Query.Type -> IO () -setIndex :: T -> Word -> IO () - -alloc = Area.query_subscribe_malloc -_copy = Area.query_subscribe_copy -_clone = Area.query_subscribe_clone -getClient = Area.query_subscribe_get_client -getPort = Area.query_subscribe_get_port -getType = Area.query_subscribe_get_type -getIndex = Area.query_subscribe_get_index -getNumSubs = Area.query_subscribe_get_num_subs -getQueue = Area.query_subscribe_get_queue -getExclusive = Area.query_subscribe_get_exclusive -getTimeUpdate = Area.query_subscribe_get_time_update -getTimeReal = Area.query_subscribe_get_time_real -_setClient = Area.query_subscribe_set_client -_setPort = Area.query_subscribe_set_port -setType = Area.query_subscribe_set_type -setIndex = Area.query_subscribe_set_index - --- | Get the client/port address of a query -getRoot :: T -> IO Addr.T -getRoot q = - peek =<< Area.with_query_subscribe q snd_seq_query_subscribe_get_root - -foreign import ccall unsafe "alsa/asoundlib.h snd_seq_query_subscribe_get_root" - snd_seq_query_subscribe_get_root :: Ptr T_ -> IO (Ptr Addr.T) - --- | Get the address of subscriber of query -getAddr :: T -> IO Addr.T -getAddr q = - peek =<< Area.with_query_subscribe q snd_seq_query_subscribe_get_addr - -foreign import ccall unsafe "alsa/asoundlib.h snd_seq_query_subscribe_get_addr" - snd_seq_query_subscribe_get_addr :: Ptr T_ -> IO (Ptr Addr.T) - - --- | Set the client/port address of a query -setRoot :: T -> Addr.T -> IO () -setRoot q c = - alloca $ \p -> poke p c >> Area.with_query_subscribe q (`snd_seq_query_subscribe_set_root` p) - -foreign import ccall unsafe "alsa/asoundlib.h snd_seq_query_subscribe_set_root" - snd_seq_query_subscribe_set_root :: Ptr T_ -> Ptr Addr.T -> IO () - - --- | Query port subscriber list -queryPort :: Seq.T mode -> T -> IO Bool -queryPort (Seq.Cons h) q = - Exc.checkResultMaybe "query_port_subscribers" (const True) (\e -> if Errno (negate e) == eNOENT then Just False else Nothing) =<< - Area.with_query_subscribe q (snd_seq_query_port_subscribers h) - -foreign import ccall unsafe "alsa/asoundlib.h snd_seq_query_port_subscribers" - snd_seq_query_port_subscribers :: Ptr Seq.Core -> Ptr T_ -> IO CInt - --- | Queries a subscriber connected to (Write) or from (Read) a given address: @'query' seq addr typ index@ -query :: Seq.T mode -> Addr.T -> Query.Type -> Word -> IO (Maybe T) -query ss root t i = do - q <- alloc - setRoot q root - setType q t - setIndex q i - r <- queryPort ss q - return $ if r then Just q else Nothing - --- | Queries the list of subscribers accessing a port -queryAll :: Seq.T mode -> Addr.T -> Query.Type -> IO [T] -queryAll ss root t = queryRest 0 where - queryRest i = query ss root t i >>= - maybe (return []) (\q -> (q:) `fmap` queryRest (succ i)) - diff --git a/src/Sound/ALSA/Sequencer/Subscribe/Query.hsc b/src/Sound/ALSA/Sequencer/Subscribe/Query.hsc new file mode 100644 --- /dev/null +++ b/src/Sound/ALSA/Sequencer/Subscribe/Query.hsc @@ -0,0 +1,128 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Sound.ALSA.Sequencer.Subscribe.Query +-- Copyright : (c) Henning Thielemann, 2012 +-- (c) Dylan Simon, 2011 +-- License : BSD3 +-- +-- Stability : provisional +-- +-- This module contains functions for working with subscriptions. +-- Reference: +-- +-------------------------------------------------------------------------------- + +module Sound.ALSA.Sequencer.Subscribe.Query + ( T + , Type(..) + + , malloc + , copy + , clone + + , getClient + , getPort + , getRoot + , getType + , getIndex + , getNumSubs + , getAddr + , getQueue + , getExclusive + , getTimeUpdate + , getTimeReal + + , setClient + , setPort + , setType + , setIndex + + , query + , queryAll + ) where + +#include +#include + +import qualified Sound.ALSA.Sequencer.Marshal.Sequencer as Seq +import qualified Sound.ALSA.Sequencer.Marshal.Address as Addr +import qualified Sound.ALSA.Sequencer.Marshal.Client as Client +import qualified Sound.ALSA.Sequencer.Marshal.Port as Port +import qualified Sound.ALSA.Sequencer.Marshal.Queue as Queue +import qualified Sound.ALSA.Sequencer.Area as Area +import qualified Sound.ALSA.Sequencer.Utility as U +import qualified Sound.ALSA.Exception as Exc + +import qualified Foreign.C.Types as C +import Foreign.Ptr (Ptr, ) +import Data.Word (Word, ) +import Data.Maybe.HT (toMaybe, ) + + +#area "query_subscribe" + +#{get_set_int "client", "Client", + "Client.T", "Client.imp", "Client.exp"} +#{get_set_int "port", "Port", + "Port.T", "Port.imp", "Port.exp"} +#{get_set_int "type", "Type", + "Type", "impType", "expType"} +#{get_set_int "index", "Index", + "Word", "fromIntegral", "fromIntegral"} + +-- RO +#{get_int "num_subs", "NumSubs", "Word", "fromIntegral"} +#{get_int "queue", "Queue", "Queue.T", "Queue.imp"} +#get_bool "exclusive", "Exclusive" +#get_bool "time_update", "TimeUpdate" +#get_bool "time_real", "TimeReal" + + +-- | Get the client/port address of a query +#{get_ptr "root", "Root", "Addr.T"} +-- | Set the client/port address of a query +#{set_ptr "root", "Root", "Addr.T"} +-- | Get the address of subscriber of query +#{get_ptr "addr", "Addr", "Addr.T"} + + +-- | Query port subscriber list +queryPort :: Seq.T mode -> T -> IO Bool +queryPort (Seq.Cons h) q = + U.checkResultQuery "Subscribe.queryPort" =<< with q (queryPort_ h) + +foreign import ccall unsafe "alsa/asoundlib.h snd_seq_query_port_subscribers" + queryPort_ :: Ptr Seq.Core -> Ptr T_ -> IO C.CInt + +-- | Queries a subscriber connected to (Write) or from (Read) a given address: @'query' seq addr typ index@ +query :: Seq.T mode -> Addr.T -> Type -> Word -> IO (Maybe T) +query ss root t i = do + q <- malloc + setRoot q root + setType q t + setIndex q i + r <- queryPort ss q + return $ toMaybe r q + +-- | Queries the list of subscribers accessing a port +queryAll :: Seq.T mode -> Addr.T -> Type -> IO [T] +queryAll ss root t = queryRest 0 where + queryRest i = query ss root t i >>= + maybe (return []) (\q -> (q:) `fmap` queryRest (succ i)) + + +data Type = + Read + | Write + deriving (Show, Eq, Ord, Enum) + +expType :: Type -> C.CInt +expType t = case t of + Read -> #{const SND_SEQ_QUERY_SUBS_READ} + Write -> #{const SND_SEQ_QUERY_SUBS_WRITE} + +impType :: C.CInt -> Type +impType t = case t of + #{const SND_SEQ_QUERY_SUBS_READ} -> Read + #{const SND_SEQ_QUERY_SUBS_WRITE} -> Write + _ -> error ("QuerySubscribe.impType: unknown subscription type (" ++ show t ++ ")") diff --git a/src/Sound/ALSA/Sequencer/Time.hs b/src/Sound/ALSA/Sequencer/Time.hs new file mode 100644 --- /dev/null +++ b/src/Sound/ALSA/Sequencer/Time.hs @@ -0,0 +1,7 @@ +module Sound.ALSA.Sequencer.Time ( + T(Cons, mode, stamp), consAbs, consRel, + Mode(Absolute, Relative), Stamp (Tick, Real), + ) where + +import Sound.ALSA.Sequencer.Marshal.Time as Time + diff --git a/src/Sound/ALSA/Sequencer/Utility.hs b/src/Sound/ALSA/Sequencer/Utility.hs --- a/src/Sound/ALSA/Sequencer/Utility.hs +++ b/src/Sound/ALSA/Sequencer/Utility.hs @@ -1,5 +1,13 @@ module Sound.ALSA.Sequencer.Utility where +import qualified Sound.ALSA.Exception as Exc + +import qualified Foreign.C.Types as C +import Foreign.C.Error (Errno(Errno), eNOENT, ) + +import Data.Maybe.HT (toMaybe, ) + + showsField :: Show a => a -> ShowS showsField = showsPrec 11 @@ -8,3 +16,10 @@ showParen (prec >= 10) $ showString name . showString ".Cons" . foldr (.) id (map (\f -> showChar ' ' . f) fields) + +-- might be moved to Sound.ALSA.Exception +checkResultQuery :: String -> C.CInt -> IO Bool +checkResultQuery name = + Exc.checkResultMaybe name + (const True) + (\e -> toMaybe (Errno (negate e) == eNOENT) False)