diff options
Diffstat (limited to 'AlsaSeq.hs')
-rw-r--r-- | AlsaSeq.hs | 154 |
1 files changed, 64 insertions, 90 deletions
@@ -1,5 +1,4 @@ | |||
1 | {-# LANGUAGE NondecreasingIndentation #-} | 1 | module AlsaSeq (withAlsaInit, parseAlsaEvents, parseAlsaEvents'', forwardNoteEvent, |
2 | module AlsaSeq (withAlsaInit, parseAlsaEvents, parseAlsaEvents', parseAlsaEvents'', forwardNoteEvent, | ||
3 | cmdlineAlsaConnect, printChordLn, printChordLn', showChord, pitchList, showPitch, | 2 | cmdlineAlsaConnect, printChordLn, printChordLn', showChord, pitchList, showPitch, |
4 | unPitch, unChannel, MidiHook, MidiPitchSet, MidiPitchMap) where | 3 | unPitch, unChannel, MidiHook, MidiPitchSet, MidiPitchMap) where |
5 | import qualified Sound.ALSA.Exception as AlsaExc | 4 | import qualified Sound.ALSA.Exception as AlsaExc |
@@ -10,17 +9,17 @@ import qualified Sound.ALSA.Sequencer.Client.Info as ClientInfo | |||
10 | import qualified Sound.ALSA.Sequencer.Port.Info as PortInfo | 9 | import qualified Sound.ALSA.Sequencer.Port.Info as PortInfo |
11 | import qualified Sound.ALSA.Sequencer.Connect as Connect | 10 | import qualified Sound.ALSA.Sequencer.Connect as Connect |
12 | import qualified Sound.ALSA.Sequencer.Event as Event | 11 | import qualified Sound.ALSA.Sequencer.Event as Event |
13 | import qualified Sound.ALSA.Sequencer.Event.RemoveMonad as Remove | 12 | -- import qualified Sound.ALSA.Sequencer.Event.RemoveMonad as Remove |
14 | import qualified Sound.ALSA.Sequencer.Port as Port | 13 | import qualified Sound.ALSA.Sequencer.Port as Port |
15 | import qualified Sound.ALSA.Sequencer.Port.InfoMonad as PortInfoM | 14 | import qualified Sound.ALSA.Sequencer.Port.InfoMonad as PortInfoM |
16 | import qualified Sound.ALSA.Sequencer.Queue as Queue | 15 | import qualified Sound.ALSA.Sequencer.Queue as Queue |
17 | import qualified Sound.ALSA.Sequencer.RealTime as RealTime | 16 | -- import qualified Sound.ALSA.Sequencer.RealTime as RealTime |
18 | import qualified Sound.ALSA.Sequencer.Time as Time | 17 | -- import qualified Sound.ALSA.Sequencer.Time as Time |
19 | import qualified System.Exit as Exit | 18 | import qualified System.Exit as Exit |
20 | import qualified System.IO as IO | 19 | import qualified System.IO as IO |
21 | import System.Environment (getArgs, ) | 20 | import System.Environment (getArgs, ) |
22 | import Text.Printf | 21 | import Text.Printf |
23 | import Control.Monad (when, forM_, forM) | 22 | import Control.Monad |
24 | 23 | ||
25 | import qualified Data.Set as Set | 24 | import qualified Data.Set as Set |
26 | import qualified Data.Map.Strict as Map | 25 | import qualified Data.Map.Strict as Map |
@@ -48,7 +47,7 @@ showPitch x = | |||
48 | in Haskore.Basic.Pitch.classFormat pitch (show octave) | 47 | in Haskore.Basic.Pitch.classFormat pitch (show octave) |
49 | 48 | ||
50 | pitchWords set = map showPitch $ pitchList set | 49 | pitchWords set = map showPitch $ pitchList set |
51 | pitchList set = map Event.unPitch $ map (\ (c, n) -> n) $ Set.toList set | 50 | pitchList set = map (Event.unPitch . snd) (Set.toList set) |
52 | pitchLists set = map (\ (c, n) -> (Event.unChannel c, Event.unPitch n)) $ Set.toList set | 51 | pitchLists set = map (\ (c, n) -> (Event.unChannel c, Event.unPitch n)) $ Set.toList set |
53 | 52 | ||
54 | prettyNote :: Event.Note -> String | 53 | prettyNote :: Event.Note -> String |
@@ -65,82 +64,76 @@ showAlsaPorts h = do | |||
65 | putStrLn "" | 64 | putStrLn "" |
66 | printf "%15s %s\n" "Ports" "Names" | 65 | printf "%15s %s\n" "Ports" "Names" |
67 | printf "%15s %s\n" "=====" "=====" | 66 | printf "%15s %s\n" "=====" "=====" |
68 | forM c (\(name, ports) -> printf "%15s %s\n" (showPorts ports) name) | 67 | forM_ c (\(name, ports) -> printf "%15s %s\n" (showPorts ports) name) |
69 | putStrLn "" | 68 | putStrLn "" |
70 | 69 | ||
71 | alsaClients h = do | 70 | alsaClients h = |
72 | portsNames <- ClientInfo.queryLoop h $ \cinfo -> do | 71 | ClientInfo.queryLoop h $ \cinfo -> do |
73 | ports <- alsaClientPorts h cinfo | 72 | ports <- alsaClientPorts h cinfo |
74 | name <- ClientInfo.getName cinfo | 73 | name <- ClientInfo.getName cinfo |
75 | return (name, ports) | 74 | return (name, ports) |
76 | return portsNames | ||
77 | 75 | ||
78 | alsaClientPorts h cinfo = do | 76 | alsaClientPorts h cinfo = do |
79 | client <- ClientInfo.getClient cinfo | 77 | client <- ClientInfo.getClient cinfo |
80 | ports <- PortInfo.queryLoop h client $ \pinfo -> do | 78 | PortInfo.queryLoop h client $ \pinfo -> do |
81 | c <- PortInfo.getClient pinfo | 79 | (Client.Cons ports) <- PortInfo.getClient pinfo |
82 | let (Client.Cons p) = c in | 80 | return ports |
83 | return p | ||
84 | return ports | ||
85 | 81 | ||
86 | withAlsaInit k = do | 82 | withAlsaInit k = |
87 | SndSeq.withDefault SndSeq.Nonblock $ \h -> do | 83 | SndSeq.withDefault SndSeq.Nonblock $ \h -> do |
88 | 84 | Client.setName (h :: SndSeq.T SndSeq.DuplexMode) "Haskell Beats" | |
89 | Client.setName (h :: SndSeq.T SndSeq.DuplexMode) "Haskell Beats" -- In imperative language MIDI sequencer, you rock beat. In Haskell language MIDI sequencer, rock beat you! | 85 | -- In imperative language MIDI sequencer, you rock beat. In Haskell language MIDI sequencer, rock |
90 | 86 | -- beat you! | |
91 | Port.withSimple h "inout" | 87 | Port.withSimple h "inout" inout_caps inout_types $ \public -> |
92 | (Port.caps [Port.capRead, Port.capSubsRead, Port.capWrite, Port.capSubsWrite]) | 88 | Port.withSimple h "private" private_caps private_types $ \private -> Queue.with h $ \q -> do |
93 | (Port.types [Port.typeMidiGeneric, Port.typeApplication]) $ \public -> do | 89 | PortInfoM.modify h public $ do |
94 | Port.withSimple h "private" | 90 | PortInfoM.setTimestamping True |
95 | (Port.caps [Port.capRead, Port.capWrite]) | 91 | PortInfoM.setTimestampReal True |
96 | (Port.types [Port.typeMidiGeneric]) $ \private -> do | 92 | PortInfoM.setTimestampQueue q |
97 | Queue.with h $ \q -> do | 93 | |
98 | 94 | c <- Client.getId h | |
99 | PortInfoM.modify h public $ do | 95 | let publicAddr = Addr.Cons c public |
100 | PortInfoM.setTimestamping True | 96 | privateAddr = Addr.Cons c private |
101 | PortInfoM.setTimestampReal True | 97 | |
102 | PortInfoM.setTimestampQueue q | 98 | Queue.control h q Event.QueueStart Nothing |
103 | 99 | ||
104 | c <- Client.getId h | 100 | k h public private q publicAddr privateAddr |
105 | let publicAddr = Addr.Cons c public | 101 | where |
106 | privateAddr = Addr.Cons c private | 102 | inout_caps = Port.caps [Port.capRead, Port.capSubsRead, Port.capWrite, Port.capSubsWrite] |
107 | 103 | inout_types = Port.types [Port.typeMidiGeneric, Port.typeApplication] | |
108 | Queue.control h q Event.QueueStart Nothing | 104 | private_caps = Port.caps [Port.capRead, Port.capWrite] |
109 | 105 | private_types = Port.types [Port.typeMidiGeneric] | |
110 | k h public private q publicAddr privateAddr | ||
111 | 106 | ||
112 | cmdlineAlsaConnect h public = do | 107 | cmdlineAlsaConnect h public = do |
113 | args <- getArgs | 108 | args <- getArgs |
114 | case args of | 109 | case args of |
110 | ["0"] -> | ||
111 | return () | ||
115 | 112 | ||
116 | ["0"] -> do | 113 | ["0", output] -> |
117 | return () | 114 | void $ Connect.createTo h public =<< Addr.parse h output |
118 | |||
119 | ["0", output] -> do | ||
120 | (Connect.createTo h public =<< Addr.parse h output) | ||
121 | return () | ||
122 | 115 | ||
123 | [input] -> do | 116 | [input] -> |
124 | (Connect.createFrom h public =<< Addr.parse h input) | 117 | void $ Connect.createFrom h public =<< Addr.parse h input |
125 | return () | ||
126 | 118 | ||
127 | [input, output] -> do | 119 | [input, output] -> do |
128 | (Connect.createFrom h public =<< Addr.parse h input) | 120 | void $ Connect.createFrom h public =<< Addr.parse h input |
129 | (Connect.createTo h public =<< Addr.parse h output) | 121 | void $ Connect.createTo h public =<< Addr.parse h output |
130 | return () | ||
131 | 122 | ||
132 | _ -> do | 123 | _ -> do |
133 | showAlsaPorts h | 124 | showAlsaPorts h |
134 | IO.hPutStrLn IO.stderr "need arguments: <input-port> [output-port]" | 125 | IO.hPutStrLn IO.stderr "need arguments: <input-port> [output-port]" |
135 | IO.hPutStrLn IO.stderr " (use port 0 for no input)" | 126 | IO.hPutStrLn IO.stderr " (use port 0 for no input)" |
136 | Exit.exitFailure | 127 | Exit.exitFailure |
137 | 128 | ||
138 | inputPendingLoop h b = do | 129 | inputPendingLoop h b = do |
139 | mres <- try (Event.inputPending h b >>= return) | 130 | mres <- try (Event.inputPending h b) |
140 | case mres of | 131 | case mres of |
141 | (Left e) -> | 132 | (Left e) -> |
142 | case e of | 133 | case e of |
143 | (AlsaExc.Cons _ _ (Errno 4)) -> inputPendingLoop h b >>= return -- axis: AlsaException.Cons "inputPending" "Interrupted system call" (Errno 4) | 134 | (AlsaExc.Cons _ _ (Errno 4)) -> inputPendingLoop h b |
135 | -- axis: AlsaException.Cons "inputPending" "Interrupted system call" (Errno 4) | ||
136 | -- Happens all the time, means nothing. | ||
144 | (AlsaExc.Cons location _ code) -> do | 137 | (AlsaExc.Cons location _ code) -> do |
145 | putStrLn $ "alsa_exception: " ++ AlsaExc.show e -- TODO: log this to a file | 138 | putStrLn $ "alsa_exception: " ++ AlsaExc.show e -- TODO: log this to a file |
146 | AlsaExc.throw location code | 139 | AlsaExc.throw location code |
@@ -150,18 +143,18 @@ type MidiPitchSet = Set.Set (Event.Channel, Event.Pitch) | |||
150 | type MidiPitchMap = Map.Map (Event.Channel, Event.Pitch) Event.Velocity | 143 | type MidiPitchMap = Map.Map (Event.Channel, Event.Pitch) Event.Velocity |
151 | parseAlsaEvents :: SndSeq.AllowInput mode => | 144 | parseAlsaEvents :: SndSeq.AllowInput mode => |
152 | SndSeq.T mode -> Set.Set (Event.Channel, Event.Pitch) -> (Event.T -> IO a) -> IO MidiPitchSet | 145 | SndSeq.T mode -> Set.Set (Event.Channel, Event.Pitch) -> (Event.T -> IO a) -> IO MidiPitchSet |
153 | parseAlsaEvents h keysDown immediate = loop keysDown | 146 | parseAlsaEvents h keysDownInit immediate = loop keysDownInit |
154 | where | 147 | where |
155 | loop keysDown = do | 148 | loop keysDown = do |
156 | pending <- inputPendingLoop h True | 149 | pending <- inputPendingLoop h True |
157 | if (pending == 0) then | 150 | if pending == 0 then |
158 | return keysDown | 151 | return keysDown |
159 | else do | 152 | else do |
160 | ev <- Event.input h | 153 | ev <- Event.input h |
161 | immediate ev | 154 | _ <- immediate ev |
162 | case Event.body ev of | 155 | case Event.body ev of |
163 | Event.NoteEv Event.NoteOn n -> | 156 | Event.NoteEv Event.NoteOn n -> |
164 | if (Event.unVelocity (Event.noteVelocity n) == 0) then | 157 | if Event.unVelocity (Event.noteVelocity n) == 0 then |
165 | loop (Set.delete (Event.noteChannel n, Event.noteNote n) keysDown) | 158 | loop (Set.delete (Event.noteChannel n, Event.noteNote n) keysDown) |
166 | else | 159 | else |
167 | loop (Set.insert (Event.noteChannel n, Event.noteNote n) keysDown) | 160 | loop (Set.insert (Event.noteChannel n, Event.noteNote n) keysDown) |
@@ -169,37 +162,19 @@ parseAlsaEvents h keysDown immediate = loop keysDown | |||
169 | loop (Set.delete (Event.noteChannel n, Event.noteNote n) keysDown) | 162 | loop (Set.delete (Event.noteChannel n, Event.noteNote n) keysDown) |
170 | _ -> loop keysDown | 163 | _ -> loop keysDown |
171 | 164 | ||
172 | parseAlsaEvents' h keysDown immediate = loop [] keysDown | 165 | parseAlsaEvents'' :: SndSeq.AllowInput mode => SndSeq.T mode -> MidiPitchMap -> (Event.T -> IO t) -> IO ([Event.T], MidiPitchMap) |
173 | where | 166 | parseAlsaEvents'' h keysDownInit immediate = loop [] keysDownInit |
174 | loop events keysDown = do | ||
175 | pending <- inputPendingLoop h True | ||
176 | if (pending == 0) then | ||
177 | return (events, keysDown) | ||
178 | else do | ||
179 | ev <- Event.input h | ||
180 | immediate ev | ||
181 | case Event.body ev of | ||
182 | Event.NoteEv Event.NoteOn n -> | ||
183 | if (Event.unVelocity (Event.noteVelocity n) == 0) then | ||
184 | loop (ev:events) (Set.delete (Event.noteChannel n, Event.noteNote n) keysDown) | ||
185 | else | ||
186 | loop (ev:events) (Set.insert (Event.noteChannel n, Event.noteNote n) keysDown) | ||
187 | Event.NoteEv Event.NoteOff n -> | ||
188 | loop (ev:events) (Set.delete (Event.noteChannel n, Event.noteNote n) keysDown) | ||
189 | _ -> loop (ev:events) keysDown | ||
190 | |||
191 | parseAlsaEvents'' h keysDown immediate = loop [] keysDown | ||
192 | where | 167 | where |
193 | loop events keysDown = do | 168 | loop events keysDown = do |
194 | pending <- inputPendingLoop h True | 169 | pending <- inputPendingLoop h True |
195 | if (pending == 0) then | 170 | if pending == 0 then |
196 | return (events, keysDown) | 171 | return (events, keysDown) |
197 | else do | 172 | else do |
198 | ev <- Event.input h | 173 | ev <- Event.input h |
199 | immediate ev | 174 | _ <- immediate ev |
200 | case Event.body ev of | 175 | case Event.body ev of |
201 | Event.NoteEv Event.NoteOn n -> | 176 | Event.NoteEv Event.NoteOn n -> |
202 | if (Event.unVelocity (Event.noteVelocity n) == 0) then | 177 | if Event.unVelocity (Event.noteVelocity n) == 0 then |
203 | loop (ev:events) (Map.delete (Event.noteChannel n, Event.noteNote n) keysDown) | 178 | loop (ev:events) (Map.delete (Event.noteChannel n, Event.noteNote n) keysDown) |
204 | else | 179 | else |
205 | loop (ev:events) (Map.insert (Event.noteChannel n, Event.noteNote n) (Event.noteVelocity n) keysDown) | 180 | loop (ev:events) (Map.insert (Event.noteChannel n, Event.noteNote n) (Event.noteVelocity n) keysDown) |
@@ -216,6 +191,5 @@ forwardNoteEvent h q publicAddr ev = do | |||
216 | -- data T = Cons { highPriority :: !Bool , tag :: !Tag , queue :: !Queue.T , time :: !Time.T , source :: !Addr.T , dest :: !Addr.T , body :: !Data } deriving Show | 191 | -- data T = Cons { highPriority :: !Bool , tag :: !Tag , queue :: !Queue.T , time :: !Time.T , source :: !Addr.T , dest :: !Addr.T , body :: !Data } deriving Show |
217 | 192 | ||
218 | let (Event.Cons highPriority tag _ time _ _ body) = ev | 193 | let (Event.Cons highPriority tag _ time _ _ body) = ev |
219 | Event.output h (Event.Cons highPriority tag q time publicAddr Addr.subscribers body) | 194 | void $ Event.output h (Event.Cons highPriority tag q time publicAddr Addr.subscribers body) |
220 | Event.drainOutput h | 195 | void $ Event.drainOutput h |
221 | return () | ||