From 666a7d84a17dbf93af63cb5d41c084568086ae43 Mon Sep 17 00:00:00 2001 From: Andrew Cady Date: Thu, 17 Dec 2015 15:56:19 -0500 Subject: Fix some lint errors, fix formatting, etc. (No semantic changes.) --- AlsaSeq.hs | 154 +++++++++++++++++++++++++------------------------------------ 1 file changed, 64 insertions(+), 90 deletions(-) diff --git a/AlsaSeq.hs b/AlsaSeq.hs index 0512c80..33680b1 100644 --- a/AlsaSeq.hs +++ b/AlsaSeq.hs @@ -1,5 +1,4 @@ -{-# LANGUAGE NondecreasingIndentation #-} -module AlsaSeq (withAlsaInit, parseAlsaEvents, parseAlsaEvents', parseAlsaEvents'', forwardNoteEvent, +module AlsaSeq (withAlsaInit, parseAlsaEvents, parseAlsaEvents'', forwardNoteEvent, cmdlineAlsaConnect, printChordLn, printChordLn', showChord, pitchList, showPitch, unPitch, unChannel, MidiHook, MidiPitchSet, MidiPitchMap) where import qualified Sound.ALSA.Exception as AlsaExc @@ -10,17 +9,17 @@ import qualified Sound.ALSA.Sequencer.Client.Info as ClientInfo import qualified Sound.ALSA.Sequencer.Port.Info as PortInfo import qualified Sound.ALSA.Sequencer.Connect as Connect import qualified Sound.ALSA.Sequencer.Event as Event -import qualified Sound.ALSA.Sequencer.Event.RemoveMonad as Remove +-- import qualified Sound.ALSA.Sequencer.Event.RemoveMonad as Remove import qualified Sound.ALSA.Sequencer.Port as Port import qualified Sound.ALSA.Sequencer.Port.InfoMonad as PortInfoM 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.RealTime as RealTime +-- import qualified Sound.ALSA.Sequencer.Time as Time import qualified System.Exit as Exit import qualified System.IO as IO import System.Environment (getArgs, ) import Text.Printf -import Control.Monad (when, forM_, forM) +import Control.Monad import qualified Data.Set as Set import qualified Data.Map.Strict as Map @@ -48,7 +47,7 @@ showPitch x = in Haskore.Basic.Pitch.classFormat pitch (show octave) pitchWords set = map showPitch $ pitchList set -pitchList set = map Event.unPitch $ map (\ (c, n) -> n) $ Set.toList set +pitchList set = map (Event.unPitch . snd) (Set.toList set) pitchLists set = map (\ (c, n) -> (Event.unChannel c, Event.unPitch n)) $ Set.toList set prettyNote :: Event.Note -> String @@ -65,82 +64,76 @@ showAlsaPorts h = do putStrLn "" printf "%15s %s\n" "Ports" "Names" printf "%15s %s\n" "=====" "=====" - forM c (\(name, ports) -> printf "%15s %s\n" (showPorts ports) name) + forM_ c (\(name, ports) -> printf "%15s %s\n" (showPorts ports) name) putStrLn "" -alsaClients h = do - portsNames <- ClientInfo.queryLoop h $ \cinfo -> do +alsaClients h = + ClientInfo.queryLoop h $ \cinfo -> do ports <- alsaClientPorts h cinfo name <- ClientInfo.getName cinfo return (name, ports) - return portsNames alsaClientPorts h cinfo = do client <- ClientInfo.getClient cinfo - ports <- PortInfo.queryLoop h client $ \pinfo -> do - c <- PortInfo.getClient pinfo - let (Client.Cons p) = c in - return p - return ports + PortInfo.queryLoop h client $ \pinfo -> do + (Client.Cons ports) <- PortInfo.getClient pinfo + return ports -withAlsaInit k = do +withAlsaInit k = SndSeq.withDefault SndSeq.Nonblock $ \h -> do - - 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! - - 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 - - PortInfoM.modify h public $ do - PortInfoM.setTimestamping True - PortInfoM.setTimestampReal True - PortInfoM.setTimestampQueue q - - c <- Client.getId h - let publicAddr = Addr.Cons c public - privateAddr = Addr.Cons c private - - Queue.control h q Event.QueueStart Nothing - - k h public private q publicAddr privateAddr + 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! + Port.withSimple h "inout" inout_caps inout_types $ \public -> + Port.withSimple h "private" private_caps private_types $ \private -> Queue.with h $ \q -> do + PortInfoM.modify h public $ do + PortInfoM.setTimestamping True + PortInfoM.setTimestampReal True + PortInfoM.setTimestampQueue q + + c <- Client.getId h + let publicAddr = Addr.Cons c public + privateAddr = Addr.Cons c private + + Queue.control h q Event.QueueStart Nothing + + k h public private q publicAddr privateAddr + where + inout_caps = Port.caps [Port.capRead, Port.capSubsRead, Port.capWrite, Port.capSubsWrite] + inout_types = Port.types [Port.typeMidiGeneric, Port.typeApplication] + private_caps = Port.caps [Port.capRead, Port.capWrite] + private_types = Port.types [Port.typeMidiGeneric] cmdlineAlsaConnect h public = do args <- getArgs case args of + ["0"] -> + return () - ["0"] -> do - return () - - ["0", output] -> do - (Connect.createTo h public =<< Addr.parse h output) - return () + ["0", output] -> + void $ Connect.createTo h public =<< Addr.parse h output - [input] -> do - (Connect.createFrom h public =<< Addr.parse h input) - return () + [input] -> + void $ Connect.createFrom h public =<< Addr.parse h input - [input, output] -> do - (Connect.createFrom h public =<< Addr.parse h input) - (Connect.createTo h public =<< Addr.parse h output) - return () + [input, output] -> do + void $ Connect.createFrom h public =<< Addr.parse h input + void $ Connect.createTo h public =<< Addr.parse h output - _ -> do - showAlsaPorts h - IO.hPutStrLn IO.stderr "need arguments: [output-port]" - IO.hPutStrLn IO.stderr " (use port 0 for no input)" - Exit.exitFailure + _ -> do + showAlsaPorts h + IO.hPutStrLn IO.stderr "need arguments: [output-port]" + IO.hPutStrLn IO.stderr " (use port 0 for no input)" + Exit.exitFailure inputPendingLoop h b = do - mres <- try (Event.inputPending h b >>= return) + mres <- try (Event.inputPending h b) case mres of (Left e) -> case e of - (AlsaExc.Cons _ _ (Errno 4)) -> inputPendingLoop h b >>= return -- axis: AlsaException.Cons "inputPending" "Interrupted system call" (Errno 4) + (AlsaExc.Cons _ _ (Errno 4)) -> inputPendingLoop h b + -- axis: AlsaException.Cons "inputPending" "Interrupted system call" (Errno 4) + -- Happens all the time, means nothing. (AlsaExc.Cons location _ code) -> do putStrLn $ "alsa_exception: " ++ AlsaExc.show e -- TODO: log this to a file AlsaExc.throw location code @@ -150,18 +143,18 @@ type MidiPitchSet = Set.Set (Event.Channel, Event.Pitch) type MidiPitchMap = Map.Map (Event.Channel, Event.Pitch) Event.Velocity parseAlsaEvents :: SndSeq.AllowInput mode => SndSeq.T mode -> Set.Set (Event.Channel, Event.Pitch) -> (Event.T -> IO a) -> IO MidiPitchSet -parseAlsaEvents h keysDown immediate = loop keysDown +parseAlsaEvents h keysDownInit immediate = loop keysDownInit where loop keysDown = do pending <- inputPendingLoop h True - if (pending == 0) then + if pending == 0 then return keysDown else do ev <- Event.input h - immediate ev + _ <- immediate ev case Event.body ev of Event.NoteEv Event.NoteOn n -> - if (Event.unVelocity (Event.noteVelocity n) == 0) then + if Event.unVelocity (Event.noteVelocity n) == 0 then loop (Set.delete (Event.noteChannel n, Event.noteNote n) keysDown) else loop (Set.insert (Event.noteChannel n, Event.noteNote n) keysDown) @@ -169,37 +162,19 @@ parseAlsaEvents h keysDown immediate = loop keysDown loop (Set.delete (Event.noteChannel n, Event.noteNote n) keysDown) _ -> loop keysDown -parseAlsaEvents' h keysDown immediate = loop [] keysDown - where - loop events keysDown = do - pending <- inputPendingLoop h True - if (pending == 0) then - return (events, keysDown) - else do - ev <- Event.input h - immediate ev - case Event.body ev of - Event.NoteEv Event.NoteOn n -> - if (Event.unVelocity (Event.noteVelocity n) == 0) then - loop (ev:events) (Set.delete (Event.noteChannel n, Event.noteNote n) keysDown) - else - loop (ev:events) (Set.insert (Event.noteChannel n, Event.noteNote n) keysDown) - Event.NoteEv Event.NoteOff n -> - loop (ev:events) (Set.delete (Event.noteChannel n, Event.noteNote n) keysDown) - _ -> loop (ev:events) keysDown - -parseAlsaEvents'' h keysDown immediate = loop [] keysDown +parseAlsaEvents'' :: SndSeq.AllowInput mode => SndSeq.T mode -> MidiPitchMap -> (Event.T -> IO t) -> IO ([Event.T], MidiPitchMap) +parseAlsaEvents'' h keysDownInit immediate = loop [] keysDownInit where loop events keysDown = do pending <- inputPendingLoop h True - if (pending == 0) then + if pending == 0 then return (events, keysDown) else do ev <- Event.input h - immediate ev + _ <- immediate ev case Event.body ev of Event.NoteEv Event.NoteOn n -> - if (Event.unVelocity (Event.noteVelocity n) == 0) then + if Event.unVelocity (Event.noteVelocity n) == 0 then loop (ev:events) (Map.delete (Event.noteChannel n, Event.noteNote n) keysDown) else 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 -- data T = Cons { highPriority :: !Bool , tag :: !Tag , queue :: !Queue.T , time :: !Time.T , source :: !Addr.T , dest :: !Addr.T , body :: !Data } deriving Show let (Event.Cons highPriority tag _ time _ _ body) = ev - Event.output h (Event.Cons highPriority tag q time publicAddr Addr.subscribers body) - Event.drainOutput h - return () + void $ Event.output h (Event.Cons highPriority tag q time publicAddr Addr.subscribers body) + void $ Event.drainOutput h -- cgit v1.2.3