live-sequencer 0.0.2 → 0.0.3
raw patch · 9 files changed
+605/−317 lines, 9 filesdep +concurrent-splitdep +stm-splitdep ~alsa-seqdep ~mididep ~midi-alsa
Dependencies added: concurrent-split, stm-split
Dependency ranges changed: alsa-seq, midi, midi-alsa, wx, wxcore
Files
- http/disable/HTTPServer/GUI.hs +2/−2
- http/enable/HTTPServer/GUI.hs +17/−17
- live-sequencer.cabal +16/−13
- src/ALSA.hs +163/−59
- src/Console.hs +24/−13
- src/Event.hs +219/−95
- src/GUI.hs +145/−112
- src/Option.hs +19/−0
- src/Utility/Concurrent.hs +0/−6
http/disable/HTTPServer/GUI.hs view
@@ -11,7 +11,7 @@ import qualified Module import qualified Graphics.UI.WX as WX-import Control.Concurrent.MVar+import qualified Control.Concurrent.Split.MVar as MVar import qualified Control.Monad.Exception.Synchronous as Exc @@ -35,7 +35,7 @@ methods _output = Methods update ::- (MVar Feedback -> Module.Name -> String -> Int -> IO ()) ->+ (MVar.In Feedback -> Module.Name -> String -> Int -> IO ()) -> WX.StatusField -> M.Map Module.Name (WX.TextCtrl ()) -> GuiUpdate ->
http/enable/HTTPServer/GUI.hs view
@@ -14,7 +14,7 @@ import qualified Graphics.UI.WX as WX import Graphics.UI.WX.Attributes ( Prop((:=)), set, get ) import Graphics.UI.WX.Classes ( text )-import Control.Concurrent.MVar+import qualified Control.Concurrent.Split.MVar as MVar import qualified Control.Monad.Exception.Synchronous as Exc import Control.Monad.Trans.Class ( lift )@@ -23,14 +23,14 @@ data GuiUpdate =- GetModuleList { _moduleList :: MVar [ Module.Name ] }+ GetModuleList { _moduleList :: MVar.In [ Module.Name ] } | GetModuleContent { _moduleName :: Module.Name,- _moduleContent :: MVar (Exc.Exceptional HTTPServer.Error String) }+ _moduleContent :: MVar.In (Exc.Exceptional HTTPServer.Error String) } | UpdateModuleContent { _moduleName :: Module.Name, _moduleEditableContent :: String,- _moduleNewContent :: MVar Feedback }+ _moduleNewContent :: MVar.In Feedback } type Feedback = Exc.Exceptional HTTPServer.Error (Maybe String, String) @@ -39,21 +39,21 @@ methods output = HTTPServer.Methods { HTTPServer.getModuleList = do- modList <- newEmptyMVar- output $ GetModuleList modList- takeMVar modList,+ (modListIn,modListOut) <- MVar.new+ output $ GetModuleList modListIn+ MVar.take modListOut, HTTPServer.getModuleContent = \name -> Exc.ExceptionalT $ do- content <- newEmptyMVar- output $ GetModuleContent name content- takeMVar content,+ (contentIn,contentOut) <- MVar.new+ output $ GetModuleContent name contentIn+ MVar.take contentOut, HTTPServer.updateModuleContent = \name edited -> Exc.ExceptionalT $ do- newContent <- newEmptyMVar- output $ UpdateModuleContent name edited newContent- takeMVar newContent+ (newContentIn,newContentOut) <- MVar.new+ output $ UpdateModuleContent name edited newContentIn+ MVar.take newContentOut } update ::- (MVar Feedback -> Module.Name -> String -> Int -> IO ()) ->+ (MVar.In Feedback -> Module.Name -> String -> Int -> IO ()) -> WX.StatusField -> M.Map Module.Name (WX.TextCtrl ()) -> GuiUpdate ->@@ -61,10 +61,10 @@ update input status editors req = case req of GetModuleList modList ->- putMVar modList . M.keys $ editors+ MVar.put modList . M.keys $ editors GetModuleContent name content ->- (putMVar content =<<) $ Exc.runExceptionalT $ do+ (MVar.put content =<<) $ Exc.runExceptionalT $ do editor <- getModule editors name lift $ set status [ text := Module.tellName name ++ " downloaded by web client" ]@@ -97,7 +97,7 @@ return (newContent, pos) case result of Exc.Exception (e, protected) ->- putMVar contentMVar $+ MVar.put contentMVar $ Exc.Success (Just e, protected ++ HTTPServer.separatorLine ++ '\n' : content) Exc.Success (newContent, pos) ->
live-sequencer.cabal view
@@ -1,5 +1,5 @@ Name: live-sequencer-Version: 0.0.2+Version: 0.0.3 Author: Henning Thielemann and Johannes Waldmann Maintainer: Johannes Waldmann <waldmann@imn.htwk-leipzig.de>, Henning Thielemann <haskell@henning-thielemann.de> Category: Sound, Music, GUI@@ -300,7 +300,7 @@ Source-Repository this Type: git- Tag: 0.0.2+ Tag: 0.0.3 Location: http://code.haskell.org/~thielema/livesequencer/ Flag gui@@ -373,13 +373,15 @@ If impl(ghc>=7.0) GHC-Options: -fwarn-unused-do-bind -fwarn-missing-import-lists Build-Depends:+ stm-split >=0.0 && <0.1,+ concurrent-split >=0.0 && <0.1, transformers >=0.2.2 && <0.4, explicit-exception >=0.1.5 && <0.2, parsec >=2.1 && <3.2, pretty >=1.0 && <1.2,- midi-alsa >=0.1.1 && <0.2,- midi >=0.1.5 && <0.2,- alsa-seq >=0.5 && <0.6,+ midi-alsa >=0.2 && <0.3,+ midi >=0.2 && <0.3,+ alsa-seq >=0.6 && <0.7, alsa-core >=0.5 && <0.6, data-accessor-transformers >=0.2.1 && <0.3, data-accessor >=0.2.1 && <0.3,@@ -394,16 +396,17 @@ Executable live-sequencer-gui If flag(gui) Build-Depends:- wx >=0.12.1 && <0.13,- wxcore >=0.12.1 && <0.13,+ wx >=0.12.1 && <0.14,+ wxcore >=0.12.1 && <0.14, stm >=2.2 && <2.4,+ concurrent-split >=0.0 && <0.1, transformers >=0.2.2 && <0.4, explicit-exception >=0.1.5 && <0.2, parsec >=2.1 && <3.2, pretty >=1.0 && <1.2,- midi-alsa >=0.1.1 && <0.2,- midi >=0.1.5 && <0.2,- alsa-seq >=0.5 && <0.6,+ midi-alsa >=0.2 && <0.3,+ midi >=0.2 && <0.3,+ alsa-seq >=0.6 && <0.7, alsa-core >=0.5 && <0.6, data-accessor-transformers >=0.2.1 && <0.3, data-accessor >=0.2.1 && <0.3,@@ -465,9 +468,9 @@ Executable live-mplayer-control If flag(mplayer) Build-Depends:- midi-alsa >=0.1.1 && <0.2,- midi >=0.1.5 && <0.2,- alsa-seq >=0.5 && <0.6,+ midi-alsa >=0.2 && <0.3,+ midi >=0.2 && <0.3,+ alsa-seq >=0.6 && <0.7, alsa-core >=0.5 && <0.6, unix >=2.4 && <2.6, directory >=1.0 && <1.2,
src/ALSA.hs view
@@ -1,7 +1,13 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-} module ALSA where import qualified Option+import qualified Time+-- import qualified Log +import qualified Sound.ALSA.Sequencer.RealTime as RealTime+import qualified Sound.ALSA.Sequencer.Time as ATime+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@@ -18,9 +24,13 @@ import qualified Data.Sequence as Seq import qualified Utility.NonEmptyList as NEList +import qualified Control.Monad.Trans.Class as MT+import qualified Control.Monad.Trans.State as MS+import qualified Control.Monad.Trans.Reader as MR import Control.Monad.IO.Class ( liftIO ) import Control.Monad.Trans.Cont ( ContT(ContT), runContT, mapContT ) import Control.Monad ( (<=<) )+import Control.Applicative ( Applicative ) import Control.Functor.HT ( void ) import qualified Data.Foldable as Fold import Data.Foldable ( Foldable, forM_, foldMap )@@ -32,86 +42,171 @@ handle :: SndSeq.T mode, publicPort, privatePort :: Port.T, ports :: Seq.Seq Port.T,- queue :: Queue.T+ queue :: Queue.T,+ latencyNano :: Time.Nanoseconds Integer,+ latencyMicro :: Time.Microseconds Int } -sendEvent ::- (SndSeq.AllowOutput mode) =>- Sequencer mode -> Port.T -> Event.Data -> IO ()-sendEvent sq port ev = do+privateAddress ::+ (SndSeq.OpenMode mode) =>+ Sequencer mode -> IO Addr.T+privateAddress sq = do c <- Client.getId (handle sq)- void $- Event.outputDirect (handle sq) $- Event.simple (Addr.Cons c port) ev -queueControl ::- Sequencer mode -> Event.QueueEv -> IO ()-queueControl sq cmd =- Queue.control (handle sq) (queue sq) cmd 0 Nothing+ return $+ Addr.Cons {+ Addr.client = c,+ Addr.port = privatePort sq+ } -drainOutput ::- (SndSeq.AllowOutput mode) =>- Sequencer mode -> IO ()-drainOutput sq =++type Time = Time.Nanoseconds Integer++realTime :: Time -> RealTime.T+realTime (Time.Time time) =+ RealTime.fromInteger time++realTimeStamp :: Time -> ATime.T+realTimeStamp =+ ATime.consAbs . ATime.Real . realTime+++newtype Send a = Send (MR.ReaderT (Sequencer SndSeq.DuplexMode) IO a)+ deriving (Functor, Applicative, Monad)++runSend :: Sequencer SndSeq.DuplexMode -> Send a -> IO a+runSend sq (Send m) = do+ a <- MR.runReaderT m sq void $ Event.drainOutput (handle sq)+ return a -startQueue ::- (SndSeq.AllowOutput mode) =>- Sequencer mode -> IO ()-startQueue sq = do++class Monad send => SendClass send where+ liftSend :: Send a -> send a++instance SendClass Send where+ liftSend = id++instance SendClass send => SendClass (MS.StateT s send) where+ liftSend = MT.lift . liftSend++makeSend ::+ SendClass send =>+ (Sequencer SndSeq.DuplexMode -> IO a) -> send a+makeSend act =+ liftSend $ Send $ MR.ReaderT act++askSeq ::+ SendClass send =>+ send (Sequencer SndSeq.DuplexMode)+askSeq = makeSend return+++sendEvent :: SendClass send => Event.T -> send ()+sendEvent ev = makeSend $ \sq ->+ void $ Event.output (handle sq) ev++sendEventOnQueue :: SendClass send => Event.T -> send ()+sendEventOnQueue ev = do+ sq <- askSeq+ sendEvent $ ev { Event.queue = queue sq }++queueControl ::+ SendClass send =>+ Event.QueueEv -> Maybe Event.T -> send ()+queueControl cmd proto =+ makeSend $ \sq -> Queue.control (handle sq) (queue sq) cmd proto++startQueue :: SendClass send => send ()+startQueue = do -- Log.put "start queue"- queueControl sq Event.QueueStart- drainOutput sq+ queueControl Event.QueueStart Nothing -stopQueue ::- (SndSeq.AllowOutput mode) =>- Sequencer mode -> IO ()-stopQueue sq = do+stopQueue :: SendClass send => send ()+stopQueue = do -- Log.put "stop queue"- mapM_ (Event.output (handle sq)) =<< allNotesOff sq- queueControl sq Event.QueueStop- drainOutput sq+ mapM_ sendEvent =<< allNotesOff+ queueControl Event.QueueStop Nothing -pauseQueue ::- (SndSeq.AllowOutput mode) =>- Sequencer mode -> IO ()-pauseQueue sq = do+stopQueueLater :: SendClass send => Time -> send Time+stopQueueLater t = do+ sq <- askSeq+ let targetTime = mappend t $ latencyNano sq+ -- Log.put $ "stop queue delayed from " ++ show t ++ " to " ++ show targetTime+ sendAllNotesOffLater targetTime+ pauseQueueLater targetTime+ return targetTime++pauseQueue ::SendClass send => send ()+pauseQueue = do -- Log.put "pause queue"- queueControl sq Event.QueueStop- drainOutput sq+ queueControl Event.QueueStop Nothing -continueQueue ::- (SndSeq.AllowOutput mode) =>- Sequencer mode -> IO ()-continueQueue sq = do- -- Log.put "continue queue"- queueControl sq Event.QueueContinue- drainOutput sq+pauseQueueLater ::SendClass send => Time -> send ()+pauseQueueLater t = do+ -- Log.put "pause queue later"+ queueControl Event.QueueStop . Just =<< stampedQueueEvent t -quietContinueQueue ::- (SndSeq.AllowOutput mode) =>- Sequencer mode -> IO ()-quietContinueQueue sq = do+continueQueue :: SendClass send => send ()+continueQueue = do -- Log.put "continue queue"- mapM_ (Event.output (handle sq)) =<< allNotesOff sq- queueControl sq Event.QueueContinue- drainOutput sq+ queueControl Event.QueueContinue Nothing -allNotesOff ::- (SndSeq.AllowOutput mode) =>- Sequencer mode -> IO [Event.T]-allNotesOff sq = do- c <- Client.getId (handle sq)- return $ do+sendAllNotesOffLater :: SendClass send => Time -> send ()+sendAllNotesOffLater t = do+ mapM_ (sendEvent <=< stamp t) =<< allNotesOff++stamp :: SendClass send => Time -> Event.T -> send Event.T+stamp t ev = do+ sq <- askSeq+ return $+ ev{Event.queue = queue sq,+ Event.time = realTimeStamp t}++stampedQueueEvent :: SendClass send => Time -> send Event.T+stampedQueueEvent t =+ stamp t $ Event.simple Addr.unknown $ Event.EmptyEv Event.None++allNotesOff :: SendClass send => send [Event.T]+allNotesOff =+ makeSend $ \sq -> return $ do port <- Fold.toList $ ports sq chan <- [minBound .. maxBound] return $- Event.simple (Addr.Cons c port) $+ Event.forSourcePort port $ Event.CtrlEv Event.Controller $ MIDI.modeEvent chan ModeMsg.AllNotesOff ++forwardQueue :: SendClass send => Time -> send ()+forwardQueue t = do+ -- Log.put "forward queue"+ queueControl (Event.QueueSetPosTime (realTime t)) Nothing++forwardStoppedQueue :: SendClass send => Time -> send ()+forwardStoppedQueue t = do+ -- Log.put "forward stopped queue"+ {-+ This event is not scheduled,+ since it must work also if the queue is stopped.+ -}+ queueControl Event.QueueContinue Nothing+ queueControl (Event.QueueSetPosTime (realTime t)) Nothing+ {-+ This event is scheduled,+ because it must wait until after the AllNotesOff events.+ -}+ pauseQueueLater t++forwardContinueQueue :: SendClass send => Time -> send ()+forwardContinueQueue t = do+ -- Log.put "forward and continue queue"+ queueControl (Event.QueueSetPosTime (realTime t)) Nothing+ queueControl Event.QueueContinue Nothing++ parseAndConnect :: (SndSeq.AllowInput mode, SndSeq.AllowOutput mode) => SndSeq.T mode ->@@ -125,8 +220,8 @@ Port.withSimple h name caps (Port.types [Port.typeMidiGeneric, Port.typeSoftware, Port.typeApplication])- liftIO $ forM_ from $ mapM_ (SndSeq.connectFrom h p <=< Addr.parse h)- liftIO $ forM_ to $ mapM_ (SndSeq.connectTo h p <=< Addr.parse h)+ liftIO $ forM_ from $ mapM_ (Connect.createFrom h p <=< Addr.parse h)+ liftIO $ forM_ to $ mapM_ (Connect.createTo h p <=< Addr.parse h) return p @@ -148,4 +243,13 @@ (Port.caps [Port.capRead, Port.capWrite]) (Port.types [Port.typeSpecific]) q <- ContT $ Queue.with h- return $ Sequencer h public private ps q+ return $+ Sequencer {+ handle = h,+ publicPort = public,+ privatePort = private,+ ports = ps,+ queue = q,+ latencyNano = fmap round $ Time.seconds (Option.latency opt),+ latencyMicro = fmap round $ Time.seconds (Option.latency opt)+ }
src/Console.hs view
@@ -3,6 +3,7 @@ import Term ( Term ) import Program ( Program ) import qualified Program+import qualified Time import qualified Term import qualified Event import qualified Rewrite@@ -12,9 +13,10 @@ import qualified ALSA import qualified Sound.ALSA.Sequencer as SndSeq+-- import qualified Sound.ALSA.Sequencer.Event as SeqEvent import Control.Concurrent ( forkIO )-import Control.Concurrent.Chan ( Chan, newChan )+import qualified Control.Concurrent.Split.Chan as Chan import qualified Control.Monad.Trans.Writer as MW import qualified Control.Monad.Trans.State as MS@@ -22,7 +24,7 @@ ( mapExceptionalT, resolveT, throwT ) import Control.Monad.IO.Class ( liftIO ) import Control.Monad.Trans.Class ( lift )-import Control.Monad ( when, forM_, (>=>) )+import Control.Monad ( when, (>=>) ) import Control.Functor.HT ( void ) import qualified System.IO as IO@@ -42,13 +44,14 @@ Program.chaseMany (Option.importPaths opt) (Option.moduleNames opt) Program.empty ALSA.withSequencer opt $ \sq -> do- waitChan <- newChan- void $ forkIO $ Event.listen sq print waitChan- ALSA.startQueue sq+ (waitIn,waitOut) <- Chan.new+ (visIn,visOut) <- Chan.new+ void $ forkIO $ Event.listen sq print (Chan.read visOut >>= print) waitIn+ ALSA.runSend sq ALSA.startQueue Event.runState $ execute (Option.maxReductions $ Option.limits opt)- p sq waitChan Term.mainName+ p sq visIn waitOut Term.mainName writeExcMsg :: Exception.Message -> IO () writeExcMsg = putStrLn . Exception.statusFromMessage@@ -57,25 +60,33 @@ Rewrite.Count -> Program -> ALSA.Sequencer SndSeq.DuplexMode ->- Chan Event.WaitResult ->+ Chan.In Term ->+ Chan.Out Event.WaitResult -> Term -> MS.StateT Event.State IO ()-execute maxRed p sq waitChan =+execute maxRed p sq visIn waitOut = let go t = do s <- mapExceptionalT- (MW.runWriterT >=> \(ms,log) ->- forM_ log (liftIO . print) >> return ms) $+ (MW.runWriterT >=> \(ms,_log) ->+ {- liftIO (mapM_ print log) >> -} return ms) $ Rewrite.runEval maxRed p (Rewrite.forceHead t)- lift $ liftIO $ print s+ lift $ liftIO $ Chan.write visIn s+ lift $ void $ Event.runSend sq$+ Event.sendEcho Event.visualizeId $ ALSA.latencyNano sq case Term.viewNode s of- Just ("[]", []) -> return () Just (":", [x, xs]) -> do mdur <- lift $ resolveT (liftIO . fmap (const Nothing) . writeExcMsg) (Event.play sq writeExcMsg x)- lift $ Event.wait sq waitChan mdur+ lift $ Event.wait sq waitOut mdur go xs+ Just ("[]", []) ->+ lift $ liftIO $+ Time.pause $ ALSA.latencyMicro sq+ {- says: operation not permitted+ SeqEvent.syncOutputQueue (ALSA.handle sq)+ -} _ -> throwT (Term.termRange s, "do not know how to handle term\n" ++ show s)
src/Event.hs view
@@ -1,7 +1,88 @@+{- |+The tricky part of the event scheduling is how to achieve precise timing.++We want to achieve:++* Precisely timed sending of MIDI events.++* Immediate start of music when you start the interpreter.++* Immediate stop of music when you stop the interpreter.++We achieve precise timing by sending the events with a fixed delay+that the user can set with the 'latency' command line option.+That is, if latency is 0.1s,+then we tell ALSA at time point t to send an event at t+0.1s.+This way we make ALSA responsible for precise timing,+and it actually makes a good job.+In order to prevent cumulation of rounding errors+we maintain the ideal time in the 'stateTime' field of our 'State' record.+This time should always be a little bit smaller than the time in the ALSA queue.++In total, for every element in the MIDI stream we send two ALSA events:++* If the current event is @Wait@ and we are in real-time mode,+ then we send an Echo event with evaluateId to ourselves+ with a delay according to the @Wait@ value.++* If the current event is @Event@,+ then we send the according MIDI event via ALSA with a delay of latency+ with respect to the current ideal time.++* In any case we send a delayed Echo event with visualizeId to ourselves.+ This Echo makes sure that the display is updated+ when ALSA ships the event and+ not immediately after the computation of the event.++The 'wait' function is responsible for waiting between events+depending on the execution mode.+Actually, the essence of execution modes is how we wait.+In real-time mode it waits according to @Wait@ events.+In slow-motion mode it waits a fixed duration between events.+In single-step mode it waits for @Next step@ user commands.+The function also reacts to execution mode changes within a waiting period.+Actually, changes to execution mode can only happen during waiting.++The very tricky part is how to react immediately+to start and stop of the interpreter.+Of course, if the user requests interpreter start+we cannot send an event immediately+because we have to compute one first.+However, we pretend that the first event is sent immediately+and send following events according to the ideal start time.+The interpreter has to compute many events at once+until it is @latency@ ahead of the current ALSA queue time.+If the interpreter is paused+then events for the duration of @latency@ will remain in the queue.+If the user switches back from pause to realtime execution+then the stored events shall be shipped regularly.+However, if the user requests the next step in single step mode,+then these events must be shipped at once,+since we do not want to simply drop them.+If we would drop them we would risk hanging tones.+We achieve the shipping at once+by moving the ALSA queue time by @latency@ forward.++We use the trick of increasing the ALSA queue time at several places.+We use it whenever it is necessary to react immediately to a user request.+In order to avoid adding up multiple latencies+we always add the latency to the ideal time,+not to the current ALSA queue time.+We also have to take care of order of ALSA MIDI events.+Although stopping the interpreter+shall immediately send an AllNotesOff,+we must schedule the AllNotesOff event with a latency+and increment ALSA queue time+in order to assert correct ordering with previous and following MIDI events.+In contrast to that we must send some Queue control commands+like QueueContinue immediately,+because the queue might be stopped and+in this state scheduled events may not be processed.+-} module Event where import Term ( Term(Number, StringLiteral), termRange )-import ALSA ( Sequencer(handle, queue, privatePort), sendEvent )+import ALSA ( Sequencer(handle), Time ) import qualified Term import qualified ALSA import qualified Time@@ -12,9 +93,8 @@ import qualified Sound.MIDI.Message.Channel.Voice as VM import qualified Sound.MIDI.ALSA as MidiAlsa -import qualified Sound.ALSA.Sequencer.Address as Addr import qualified Sound.ALSA.Sequencer.RealTime as RealTime-import qualified Sound.ALSA.Sequencer.Client as Client+import qualified Sound.ALSA.Sequencer.Time as ATime import qualified Sound.ALSA.Sequencer.Port as Port import qualified Sound.ALSA.Sequencer.Event as SeqEvent import qualified Sound.ALSA.Sequencer as SndSeq@@ -40,19 +120,18 @@ import qualified Data.Sequence as Seq import Data.Maybe ( isJust ) -import Control.Concurrent.Chan ( Chan, readChan, writeChan )+import qualified Control.Concurrent.Split.Chan as Chan import Control.Concurrent ( forkIO ) +import Data.Bool.HT ( if' ) -type Time = Time.Nanoseconds Integer- data WaitMode = RealTime | SlowMotion (Time.Milliseconds Integer) | SingleStep deriving (Eq, Show) data WaitResult =- ModeChange WaitMode | ReachedTime SeqEvent.TimeStamp | NextStep- deriving (Show)+ ModeChange WaitMode | ReachedTime Time | NextStep |+ AlsaSend (MS.StateT State ALSA.Send ()) termException ::@@ -115,9 +194,15 @@ runState = flip MS.evalStateT Event.initState +runSend ::+ Sequencer SndSeq.DuplexMode ->+ MS.StateT s ALSA.Send a ->+ MS.StateT s IO a+runSend sq = MS.mapStateT (ALSA.runSend sq)++ play ::- (SndSeq.AllowInput mode, SndSeq.AllowOutput mode) =>- Sequencer mode ->+ Sequencer SndSeq.DuplexMode -> (Exception.Message -> IO ()) -> Term -> ExceptionalT Exception.Message (MS.StateT State IO) (Maybe Time)@@ -134,6 +219,7 @@ [ "echo", show arg, "|", "festival", "--tts" ] Log.put cmd void $ forkIO $ do+ Time.pause $ ALSA.latencyMicro sq (inp,_out,err,pid) <- Proc.runInteractiveProcess "festival" [ "--tts" ] Nothing Nothing@@ -163,8 +249,7 @@ _ -> termException x "can only process Wait or Event, but not " processChannelMsg ::- (SndSeq.AllowOutput mode) =>- Sequencer mode ->+ Sequencer SndSeq.DuplexMode -> (Port.T, CM.Channel) -> Term -> ExceptionalT Exception.Message (MS.StateT State IO) (Maybe Time) processChannelMsg sq chanPort@(port, chan) body = do@@ -172,138 +257,158 @@ let checkVelocity = checkRange "velocity" CM.toVelocity CM.fromVelocity (CM.toVelocity 1) (CM.toVelocity 127)+ runSendE = MT.lift . runSend sq case Term.viewNode body of Just ("On", [pn, vn]) -> do p <- checkRangeAuto "pitch" CM.toPitch CM.fromPitch pn v <- checkVelocity vn- runIO $ sendNote sq SeqEvent.NoteOn chanPort p v+ runSendE $ sendNote SeqEvent.NoteOn chanPort p v Just ("Off", [pn, vn]) -> do p <- checkRangeAuto "pitch" CM.toPitch CM.fromPitch pn v <- checkVelocity vn- runIO $ sendNote sq SeqEvent.NoteOff chanPort p v+ runSendE $ sendNote SeqEvent.NoteOff chanPort p v Just ("PgmChange", [pn]) -> do p <- checkRangeAuto "program" CM.toProgram CM.fromProgram pn- runIO $- sendEvent sq port $ SeqEvent.CtrlEv SeqEvent.PgmChange $+ runSendE $+ sendEvent port $ SeqEvent.CtrlEv SeqEvent.PgmChange $ MidiAlsa.programChangeEvent chan p Just ("Controller", [ccn, vn]) -> do cc <- checkRangeAuto "controller" CM.toController CM.fromController ccn v <- checkRange "controller value" id id 0 127 vn- runIO $- sendEvent sq port $ SeqEvent.CtrlEv SeqEvent.Controller $+ runSendE $+ sendEvent port $ SeqEvent.CtrlEv SeqEvent.Controller $ MidiAlsa.controllerEvent chan cc (fromIntegral v) _ -> termException body "invalid channel event: " return Nothing wait ::- (SndSeq.AllowOutput mode) =>- Sequencer mode ->- Chan WaitResult ->+ Sequencer SndSeq.DuplexMode ->+ Chan.Out WaitResult -> Maybe Time -> MS.StateT State IO () wait sq waitChan mdur = do let loop target = do- liftIO $ Log.put $ "readChan waitChan"- ev <- liftIO $ readChan waitChan- liftIO $ Log.put $ "read from waitChan: " ++ show ev+ liftIO $ Log.put $ "Chan.read waitChan"+ ev <- liftIO $ Chan.read waitChan+ -- liftIO $ Log.put $ "read from waitChan: " ++ show ev case ev of ModeChange newMode -> do oldMode <- AccM.get stateWaitMode if newMode /= oldMode then do AccM.set stateWaitMode newMode- (cont,newTarget) <- prepare sq mdur+ (cont,newTarget) <- runSend sq $ prepare mdur when cont $ loop newTarget else loop target- ReachedTime stamp ->- case stamp of- SeqEvent.RealTime rt ->- let reached =- Time.nanoseconds $ RealTime.toInteger rt- in if Just reached == target- then AccM.set stateTime reached- else loop target- _ -> loop target- NextStep ->+ ReachedTime reached ->+ {- check for equality only works+ because we have not set TimeStamping -}+ if Just reached == target+ then AccM.set stateTime reached+ else loop target+ NextStep -> do+ runSend sq forwardStoppedQueue when (isJust target) $ loop target+ AlsaSend send -> do+ runSend sq send+ loop target - (cont,targetTime) <- prepare sq mdur+ (cont,targetTime) <- runSend sq $ prepare mdur when cont $ loop targetTime +forwardStoppedQueue ::+ MS.StateT State ALSA.Send ()+forwardStoppedQueue = do+ sq <- ALSA.askSeq+ t <- fmap (mappend (ALSA.latencyNano sq)) $ AccM.get stateTime+ ALSA.forwardStoppedQueue t++forwardQuietContinueQueue ::+ MS.StateT State ALSA.Send ()+forwardQuietContinueQueue = do+ sq <- ALSA.askSeq+ t <- fmap (mappend (ALSA.latencyNano sq)) $ AccM.get stateTime+ ALSA.sendAllNotesOffLater t+ ALSA.forwardContinueQueue t++forwardStopQueue ::+ MS.StateT State ALSA.Send ()+forwardStopQueue = do+ sq <- ALSA.askSeq+ t <- fmap (mappend (ALSA.latencyNano sq)) $ AccM.get stateTime+ ALSA.sendAllNotesOffLater t+ ALSA.forwardStoppedQueue t++ prepare ::- (SndSeq.AllowOutput mode) =>- Sequencer mode -> Maybe Time ->- MS.StateT State IO (Bool, Maybe Time)-prepare sq mt = do- liftIO $ Log.put $ "prepare waiting for " ++ show mt- (State waitMode _ currentTime _) <- MS.get+ Maybe Time ->+ MS.StateT State ALSA.Send (Bool, Maybe Time)+prepare mdur = do+ -- liftIO $ Log.put $ "prepare waiting for " ++ show mdur+ waitMode <- AccM.get stateWaitMode+ let sendEchoCont d = do+ t <- sendEcho evaluateId d+ return (True, Just t) case waitMode of RealTime -> do- case mt of+ case mdur of Nothing -> return (False, Nothing)- Just dur -> do- let t = mappend currentTime dur- sendEcho sq t- return (True, Just t)- SlowMotion dur -> do- let t = mappend currentTime $ Time.up $ Time.up dur- sendEcho sq t- return (True, Just t)- SingleStep ->- return (True, Nothing)+ Just dur -> sendEchoCont dur+ SlowMotion dur -> sendEchoCont $ Time.up $ Time.up dur+ SingleStep -> return (True, Nothing) -sendEcho ::- (MonadIO io, SndSeq.AllowOutput mode) =>- Sequencer mode -> Time ->- io ()-sendEcho sq (Time.Time t) = do- c <- liftIO $ Client.getId (handle sq)+newtype EchoId = EchoId SeqEvent.Tag+ deriving (Eq, Show) +evaluateId, visualizeId :: EchoId+evaluateId = EchoId (SeqEvent.Tag 0)+visualizeId = EchoId (SeqEvent.Tag 1)+++sendEcho ::+ EchoId -> Time ->+ MS.StateT State ALSA.Send Time+sendEcho (EchoId echoId) dur = do {- liftIO $ Log.put . ("wait, send echo for " ++) . show =<< MS.get -}- let dest =- Addr.Cons {- Addr.client = c,- Addr.port = privatePort sq- }+ dest <- ALSA.makeSend ALSA.privateAddress - liftIO $ Log.put $ "send echo message to " ++ show dest- liftIO $ void $ SeqEvent.output (handle sq) $- (SeqEvent.simple- (Addr.Cons c Port.unknown)- (SeqEvent.CustomEv SeqEvent.Echo (SeqEvent.Custom 0 0 0)))- { SeqEvent.queue = queue sq- , SeqEvent.timestamp =- SeqEvent.RealTime $ RealTime.fromInteger t- , SeqEvent.dest = dest- }+ currentTime <- AccM.get stateTime+ let targetTime = mappend currentTime dur - liftIO $ void $ SeqEvent.drainOutput (handle sq)+ -- liftIO $ Log.put $ "send echo message to " ++ show dest+ ALSA.sendEventOnQueue $+ (SeqEvent.simple dest+ (SeqEvent.CustomEv SeqEvent.Echo+ (SeqEvent.customZero)))+ { SeqEvent.tag = echoId,+ SeqEvent.dest = dest,+ SeqEvent.time =+ ALSA.realTimeStamp targetTime+ } + return targetTime + {--We cannot concurrently wait for different kinds of events.-Thus we run one thread that listens to all incoming events+We cannot concurrently wait for different kinds of ALSA sequencer events.+Thus we run one thread that listens to all incoming ALSA sequencer events and distributes them to who they might concern. -} listen :: (SndSeq.AllowInput mode) => Sequencer mode -> (VM.Pitch -> IO ()) ->- Chan WaitResult -> IO ()-listen sq noteInput waitChan = do+ IO () ->+ Chan.In WaitResult -> IO ()+listen sq noteInput visualize waitChan = do Log.put "listen to ALSA port"- c <- Client.getId (handle sq) - let dest =- Addr.Cons {- Addr.client = c,- Addr.port = privatePort sq- }+ dest <- ALSA.privateAddress sq forever $ do Log.put "wait, wait for echo"@@ -312,21 +417,40 @@ case SeqEvent.body ev of SeqEvent.NoteEv SeqEvent.NoteOn note -> noteInput $ note ^. MidiAlsa.notePitch- SeqEvent.CustomEv SeqEvent.Echo _ ->- when (dest == SeqEvent.dest ev) $ do- Log.put "write waitChan"- writeChan waitChan $ ReachedTime $ SeqEvent.timestamp ev+ SeqEvent.CustomEv SeqEvent.Echo _cust ->+ when (dest == SeqEvent.dest ev) $+ if' (EchoId (SeqEvent.tag ev) == evaluateId)+ (case SeqEvent.time ev of+ ATime.Cons ATime.Absolute (ATime.Real rt) -> do+ Log.put "write waitChan"+ Chan.write waitChan $ ReachedTime $ + Time.nanoseconds $ RealTime.toInteger rt+ _ -> return ())+ (do+ Log.put "visualize"+ visualize) _ -> return () sendNote ::- (SndSeq.AllowOutput mode) =>- Sequencer mode -> SeqEvent.NoteEv -> (Port.T, CM.Channel) -> CM.Pitch -> CM.Velocity ->- IO ()-sendNote sq onoff (port,chan) pitch velocity =- sendEvent sq port $- SeqEvent.NoteEv onoff $ MidiAlsa.noteEvent chan pitch velocity velocity 0+ MS.StateT State ALSA.Send ()+sendNote onoff (port,chan) pitch velocity =+ sendEvent port $ SeqEvent.NoteEv onoff $+ MidiAlsa.noteEvent chan pitch velocity velocity 0++sendEvent ::+ Port.T -> SeqEvent.Data ->+ MS.StateT State ALSA.Send ()+sendEvent p ev = do+ sq <- ALSA.askSeq+ currentTime <- AccM.get stateTime+ ALSA.sendEventOnQueue $+ (SeqEvent.forSourcePort p ev) {+ SeqEvent.time =+ ALSA.realTimeStamp $+ mappend currentTime $ ALSA.latencyNano sq+ }
src/GUI.hs view
@@ -51,7 +51,6 @@ import Program ( Program ) import Term ( Term, Identifier, mainName ) import Option.Utility ( exitFailureMsg )-import Utility.Concurrent ( writeTMVar, writeTChanIO, liftSTM ) import Utility.WX ( cursor, editable, notebookSelection, splitterWindowSetSashGravity ) import qualified HTTPServer.GUI as HTTPGui@@ -72,11 +71,12 @@ ( Color, rgb, fontFixed, Point2(Point), sz, varCreate, varSwap, varUpdate ) import Control.Concurrent ( forkIO )-import Control.Concurrent.MVar ( MVar, putMVar )-import Control.Concurrent.Chan ( Chan, newChan, readChan, writeChan )-import Control.Concurrent.STM.TChan ( TChan, newTChanIO, readTChan, writeTChan )+import qualified Control.Concurrent.Split.MVar as MVar+import qualified Control.Concurrent.Split.Chan as Chan+import qualified Control.Concurrent.STM.Split.Chan as TChan import Control.Concurrent.STM.TVar ( TVar, newTVarIO, readTVarIO, readTVar, writeTVar ) import Control.Concurrent.STM.TMVar ( TMVar, newTMVarIO, putTMVar, readTMVar, takeTMVar )+import Utility.Concurrent ( writeTMVar, liftSTM ) import Control.Monad.STM ( STM ) import qualified Control.Monad.STM as STM @@ -173,18 +173,18 @@ Program.addModule (Module.empty name)) names - input <- newChan- output <- newTChanIO- STM.atomically $ registerProgram output mainMod p+ (guiIn,guiOut) <- Chan.new+ (machineIn,machineOut) <- TChan.newIO+ STM.atomically $ registerProgram machineIn mainMod p ALSA.withSequencer opt $ \sq -> do- flip finally (ALSA.stopQueue sq) $ WX.start $ do- gui input output+ flip finally (ALSA.runSend sq ALSA.stopQueue) $ WX.start $ do+ gui guiIn machineIn (forEvent machineOut) void $ forkIO $- machine input output+ machine guiOut machineIn (Option.limits opt) (Option.importPaths opt) p sq void $ forkIO $ HTTPGui.run- (HTTPGui.methods (writeTChanIO output . HTTP))+ (HTTPGui.methods (TChan.writeIO machineIn . HTTP)) (Option.httpOption opt) @@ -203,7 +203,7 @@ | NewModule | CloseModule Module.Name | FlushModules Module.Name- | RefreshModule (Maybe (MVar HTTPGui.Feedback)) Module.Name String Int+ | RefreshModule (Maybe (MVar.In HTTPGui.Feedback)) Module.Name String Int -- ^ MVar of the HTTP server, modulename, sourcetext, position @@ -226,18 +226,18 @@ exceptionToGUI ::- TChan GuiUpdate ->+ TChan.In GuiUpdate -> Exc.ExceptionalT Exception.Message STM () -> STM () exceptionToGUI output =- Exc.resolveT (writeTChan output . Exception)+ Exc.resolveT (TChan.write output . Exception) exceptionToGUIIO ::- TChan GuiUpdate ->+ TChan.In GuiUpdate -> Exc.ExceptionalT Exception.Message IO () -> IO () exceptionToGUIIO output =- Exc.resolveT (writeTChanIO output . Exception)+ Exc.resolveT (TChan.writeIO output . Exception) parseTerm :: (Monad m, IO.Input a) =>@@ -290,7 +290,7 @@ modifyModule :: [ FilePath ] -> TVar Program ->- TChan GuiUpdate ->+ TChan.In GuiUpdate -> Module.Name -> String -> Int ->@@ -299,11 +299,11 @@ p <- readTVarIO program Exception.switchT (\e -> do- writeTChanIO output $ Exception e+ TChan.writeIO output $ Exception e return $ Just e) (\(newP, updates) -> do STM.atomically $ do- mapM_ ( writeTChan output ) updates+ mapM_ ( TChan.write output ) updates writeTVar program newP -- Log.put "parsed and modified OK" return Nothing) $ do@@ -352,15 +352,15 @@ RebuildControls $ Program.controls p2 ] return p2 -registerProgram :: TChan GuiUpdate -> Module.Name -> Program -> STM ()+registerProgram :: TChan.In GuiUpdate -> Module.Name -> Program -> STM () registerProgram output mainModName p = do- writeTChan output $ Register mainModName $ Program.modules p- writeTChan output $ RebuildControls $ Program.controls p+ TChan.write output $ Register mainModName $ Program.modules p+ TChan.write output $ RebuildControls $ Program.controls p -updateProgram :: TVar Program -> TChan GuiUpdate -> Program -> STM ()+updateProgram :: TVar Program -> TChan.In GuiUpdate -> Program -> STM () updateProgram program output p = do liftSTM $ writeTVar program p- liftSTM $ writeTChan output $ RebuildControls $ Program.controls p+ liftSTM $ TChan.write output $ RebuildControls $ Program.controls p {-@@ -370,9 +370,9 @@ Since parsing is a bit of work we can keep the GUI and the execution of code going while parsing. -}-machine :: Chan Action -- ^ machine reads program text from here+machine :: Chan.Out Action -- ^ machine reads program text from here -- (module name, module contents)- -> TChan GuiUpdate -- ^ and writes output to here+ -> TChan.In GuiUpdate -- ^ and writes output to here -- (log message (for highlighting), current term) -> Option.Limits -> [FilePath]@@ -382,14 +382,15 @@ machine input output limits importPaths progInit sq = do program <- newTVarIO progInit term <- newTMVarIO mainName- waitChan <- newChan+ (waitIn,waitOut) <- Chan.new void $ forkIO $ forever $ do- action <- readChan input- let withMode mode transaction = do- writeChan waitChan $ Event.ModeChange mode+ action <- Chan.read input+ let withMode mode send transaction = do+ Chan.write waitIn $ Event.AlsaSend send+ Chan.write waitIn $ Event.ModeChange mode STM.atomically $ do- writeTChan output $ Running mode+ TChan.write output $ Running mode transaction case action of Control event -> do@@ -403,26 +404,26 @@ Execution exec -> case exec of- Mode mode -> do- case mode of- Event.RealTime -> do- ALSA.continueQueue sq- Event.SlowMotion _ -> do- ALSA.continueQueue sq- Event.SingleStep -> do- ALSA.pauseQueue sq- withMode mode $ return ()- Restart -> do- ALSA.quietContinueQueue sq- withMode Event.RealTime $ writeTMVar term mainName- Stop -> do- ALSA.stopQueue sq- withMode Event.SingleStep $ writeTMVar term mainName- NextStep -> writeChan waitChan Event.NextStep+ Mode mode ->+ flip (withMode mode) (return ()) $+ case mode of+ Event.RealTime -> ALSA.continueQueue+ Event.SlowMotion _ -> ALSA.continueQueue+ Event.SingleStep -> ALSA.pauseQueue+ Restart ->+ withMode Event.RealTime+ Event.forwardQuietContinueQueue+ (writeTMVar term mainName)+ Stop ->+ withMode Event.SingleStep+ Event.forwardStopQueue+ (writeTMVar term mainName)+ NextStep -> Chan.write waitIn Event.NextStep PlayTerm txt -> exceptionToGUIIO output $ do t <- parseTerm txt- lift $ ALSA.quietContinueQueue sq- lift $ withMode Event.RealTime $ writeTMVar term t+ lift $ withMode Event.RealTime+ Event.forwardQuietContinueQueue+ (writeTMVar term t) ApplyTerm txt -> exceptionToGUIIO output $ do fterm <- parseTerm txt case fterm of@@ -431,8 +432,8 @@ t0 <- readTMVar term let t1 = Term.Node f (xs++[t0]) writeTMVar term t1- writeTChan output $ CurrentTerm $ show t1- writeTChan output $ StatusLine $+ TChan.write output $ CurrentTerm $ show t1+ TChan.write output $ StatusLine $ "applied function term " ++ show (markedString txt) _ ->@@ -453,7 +454,7 @@ modifyModule importPaths program output moduleName sourceCode pos Just mvar -> do x <- modifyModule importPaths program output moduleName sourceCode pos- putMVar mvar $ Exc.Success+ MVar.put mvar $ Exc.Success (fmap Exception.multilineFromMessage x, sourceCode) @@ -466,12 +467,11 @@ Program.load importPaths stem filePath Program.empty lift $ do- ALSA.stopQueue sq- withMode Event.RealTime $ do+ withMode Event.RealTime+ Event.forwardQuietContinueQueue $ do writeTVar program p writeTMVar term mainName registerProgram output (Module.Name stem) p- ALSA.continueQueue sq Log.put "chased and parsed OK" NewModule ->@@ -489,7 +489,7 @@ error ("new module has no declarations and thus should not lead to conflicts with existing modules - " ++ Exception.statusFromMessage e) Exc.Success newPrg -> liftSTM $ updateProgram program output newPrg- liftSTM $ writeTChan output $ InsertPage True modu+ liftSTM $ TChan.write output $ InsertPage True modu CloseModule modName -> STM.atomically $ exceptionToGUI output $@@ -512,41 +512,59 @@ "there must remain at least one module" liftSTM $ updateProgram program output $ Program.removeModule modName prg- liftSTM $ writeTChan output $ DeletePage modName+ liftSTM $ TChan.write output $ DeletePage modName FlushModules modName -> STM.atomically $ do prg <- readTVar program let (removed, minPrg) = Program.minimize modName prg updateProgram program output minPrg- Fold.mapM_ (writeTChan output . DeletePage) removed+ Fold.mapM_ (TChan.write output . DeletePage) removed + (delayedUpdatesIn, delayedUpdatesOut) <- Chan.new+ void $ forkIO $ Event.listen sq- ( writeTChanIO output . InsertText . formatPitch )- waitChan- ALSA.startQueue sq+ ( TChan.writeIO output . InsertText . formatPitch )+ ( STM.atomically . mapM_ (TChan.write output)+ =<< Chan.read delayedUpdatesOut )+ waitIn+ ALSA.runSend sq ALSA.startQueue Event.runState $- execute limits program term ( writeTChan output ) sq waitChan-+ execute limits program term delayedUpdatesIn+ ( TChan.writeIO output . Exception ) sq waitOut -execute :: Option.Limits- -> TVar Program- -- ^ current program (GUI might change the contents)- -> TMVar Term -- ^ current term- -> ( GuiUpdate -> STM () ) -- ^ sink for messages (show current term)- -> ALSA.Sequencer SndSeq.DuplexMode -- ^ for playing MIDI events- -> Chan Event.WaitResult- -> MS.StateT Event.State IO ()-execute limits program term output sq waitChan =+execute ::+ Option.Limits+ -> TVar Program+ -- ^ current program (GUI might change the contents)+ -> TMVar Term -- ^ current term+ -> Chan.In [ GuiUpdate ]+ -- ^ sink for time-stamped delayed messages (show current term)+ -> ( Exception.Message -> IO () )+ -- ^ sink for asynchronous warnings (currently feedback from festival)+ -> ALSA.Sequencer SndSeq.DuplexMode -- ^ for playing MIDI events+ -> Chan.Out Event.WaitResult+ -> MS.StateT Event.State IO ()+execute limits program term delayedUpdatesIn sendWarning sq waitChan = forever $ do- (mdur,outputs) <- MW.runWriterT $ do+ {-+ executeStep may call stopQueueLater in case of an exception.+ Thus we must register the visualisation trigger before that event,+ in order to display the exception.+ -}+ void $ Event.runSend sq $+ Event.sendEcho Event.visualizeId (ALSA.latencyNano sq)+ (mdur, updates) <- MW.runWriterT $ do waiting <- lift $ AccM.get Event.stateWaiting when waiting $ writeUpdate ResetDisplay maxEventsSat <- lift $ checkMaxEvents limits- executeStep limits program term- (STM.atomically . output . Exception) sq maxEventsSat- liftIO $ STM.atomically $ mapM_ output outputs+ executeStep limits program term sendWarning sq maxEventsSat+ {-+ This update will take effect+ when the above visualisation trigger event is arrives.+ -}+ lift $ Chan.write delayedUpdatesIn updates Event.wait sq waitChan mdur {-@@ -587,19 +605,24 @@ ALSA.Sequencer SndSeq.DuplexMode -> Bool -> MW.WriterT [ GuiUpdate ]- ( MS.StateT Event.State IO ) ( Maybe Event.Time )-executeStep limits program term writeExcMsg sq maxEventsSat =+ ( MS.StateT Event.State IO ) ( Maybe ALSA.Time )+executeStep limits program term sendWarning sq maxEventsSat = Exception.switchT (\e -> do- liftIO $ ALSA.stopQueue sq- -- writeChan waitChan $ Event.ModeChange Event.SingleStep+-- liftIO $ ALSA.stopQueue sq+ currentTime <- lift $ AccM.get Event.stateTime+ liftIO $ Log.put "executeStep: stopQueueLater"+ newTime <-+ liftIO $ ALSA.runSend sq $ ALSA.stopQueueLater currentTime+ -- Chan.write waitChan $ Event.ModeChange Event.SingleStep writeUpdate $ Exception e writeUpdate $ Running Event.SingleStep {- We have to alter the mode directly,- since the channel is only read when we wait for a duration other than Nothing+ since waitChan is only read when we wait for a duration other than Nothing -} lift $ AccM.set Event.stateWaitMode Event.SingleStep+ lift $ AccM.set Event.stateTime newTime return Nothing) (\(x,s) -> do {-@@ -608,7 +631,7 @@ wait <- Exc.resolveT (fmap (const Nothing) . writeUpdate . Exception) (Exc.mapExceptionalT lift $- Event.play sq writeExcMsg x)+ Event.play sq sendWarning x) waitMode <- lift $ AccM.get Event.stateWaitMode waiting <- lift $ AccM.get Event.stateWaiting@@ -689,16 +712,33 @@ registerMyEvent win io = WXEvent.evtHandlerOnMenuCommand win myEventId io +{- |+The machine writes to this channel+(a textual representation of "current expression")+but sometimes the GUI also controls itself.+-}+forEvent :: TChan.Out a -> WX.Frame f -> (a -> IO ()) -> IO ()+forEvent chan f act = do+ (inC,out) <- Chan.new++ void $ forkIO $ forever $ do+ Chan.write inC =<< STM.atomically (TChan.read chan)+ WXCAL.evtHandlerAddPendingEvent f =<< createMyEvent++ registerMyEvent f $ Chan.read out >>= act+++ {- The order of widget creation is important for cycling through widgets using tabulator key. -}-gui :: Chan Action -- ^ the gui writes here+gui :: Chan.In Action -- ^ the gui writes here -- (if the program text changes due to an edit action)- -> TChan GuiUpdate -- ^ the machine writes here- -- (a textual representation of "current expression")+ -> TChan.In GuiUpdate+ -> (WX.Frame () -> (GuiUpdate -> IO ()) -> IO ()) -> IO ()-gui input output = do+gui input output procEvent = do panels <- newIORef M.empty frameError <- newFrameError@@ -709,12 +749,6 @@ [ text := "live-sequencer", visible := False ] - out <- newChan-- void $ forkIO $ forever $ do- writeChan out =<< STM.atomically (readTChan output)- WXCAL.evtHandlerAddPendingEvent f =<< createMyEvent- p <- WX.panel f [ ] @@ -789,7 +823,7 @@ WX.menuLine execMenu _restartItem <- WX.menuItem execMenu [ text := "Res&tart\tCtrl-T",- on command := writeChan input (Execution Restart),+ on command := Chan.write input (Execution Restart), help := "stop sound and restart program execution with 'main'" ] playTermItem <- WX.menuItem execMenu@@ -806,7 +840,7 @@ "example terms: (merge track) or (flip append track)" ] _stopItem <- WX.menuItem execMenu [ text := "Stop\tCtrl-Space",- on command := writeChan input (Execution Stop),+ on command := Chan.write input (Execution Stop), help := "stop program execution and sound, " ++ "reset term to 'main'" ]@@ -824,7 +858,7 @@ nextStepItem <- WX.menuItem execMenu [ text := "Next step\tCtrl-N", enabled := False,- on command := writeChan input (Execution NextStep),+ on command := Chan.write input (Execution NextStep), help := "perform next step in single step mode" ] @@ -878,7 +912,7 @@ result <- try act case result of Left err ->- writeTChanIO output $ Exception $+ TChan.writeIO output $ Exception $ Module.inoutExceptionMsg moduleName $ Err.ioeGetErrorString err Right () -> return ()@@ -888,7 +922,7 @@ mfilename <- WX.fileOpenDialog f False {- change current directory -} True "Load Haskell program" haskellFilenames "" ""- forM_ mfilename $ writeChan input . Modification . Load+ forM_ mfilename $ Chan.write input . Modification . Load ] set reloadItem [@@ -939,25 +973,25 @@ set newModuleItem [ on command :=- writeChan input $ Modification NewModule+ Chan.write input $ Modification NewModule ] set closeModuleItem [ on command :=- writeChan input . Modification . CloseModule . fst+ Chan.write input . Modification . CloseModule . fst =<< getFromNotebook nb =<< readIORef panels ] set flushModulesItem [ on command :=- writeChan input . Modification . FlushModules . fst+ Chan.write input . Modification . FlushModules . fst =<< getFromNotebook nb =<< readIORef panels ] let refreshProgram (moduleName, pnl) = do s <- get (editor pnl) text pos <- get (editor pnl) cursor- writeChan input $ Modification $ RefreshModule Nothing moduleName s pos+ Chan.write input $ Modification $ RefreshModule Nothing moduleName s pos updateErrorLog frameError $ Seq.filter $ \(Exception.Message _ errorRng _) ->@@ -972,14 +1006,14 @@ set playTermItem [ on command :=- writeChan input . Execution . PlayTerm+ Chan.write input . Execution . PlayTerm =<< uncurry getMarkedExpr . mapSnd editor =<< getFromNotebook nb =<< readIORef panels ] set applyTermItem [ on command :=- writeChan input . Execution . ApplyTerm+ Chan.write input . Execution . ApplyTerm =<< uncurry getMarkedExpr . mapSnd editor =<< getFromNotebook nb =<< readIORef panels ]@@ -988,7 +1022,7 @@ let updateSlowMotionDur = do dur <- readIORef waitDuration- writeChan input $ Execution $ Mode $ Event.SlowMotion dur+ Chan.write input $ Execution $ Mode $ Event.SlowMotion dur slowmoUnit = Time.milliseconds 100 set fasterItem [@@ -1042,13 +1076,13 @@ onActivation realTimeItem $ do activateRealTime- writeChan input $ Execution $ Mode Event.RealTime+ Chan.write input $ Execution $ Mode Event.RealTime onActivation slowMotionItem $ do activateSlowMotion updateSlowMotionDur onActivation singleStepItem $ do activateSingleStep- writeChan input $ Execution $ Mode Event.SingleStep+ Chan.write input $ Execution $ Mode Event.SingleStep splitterWindowSetSashGravity splitter 0.5 let initSplitterPosition = 0 {- equal division of heights -}@@ -1123,8 +1157,7 @@ highlights <- varCreate M.empty - registerMyEvent f $ do- msg <- readChan out+ procEvent f $ \msg -> case msg of CurrentTerm sr -> do get reducerVisibleItem checked >>=@@ -1214,7 +1247,7 @@ then set status [ text := "new " ++ Module.tellName modName ] else- writeTChanIO output $ Exception $+ TChan.writeIO output $ Exception $ Module.inoutExceptionMsg modName $ "Panic: cannot add page for the module" @@ -1233,7 +1266,7 @@ ( M.lookup fromName pnls ) ) $ \(i,pnl) -> do success <- WXCMZ.notebookRemovePage nb i when (not success) $- writeTChanIO output $ Exception $+ TChan.writeIO output $ Exception $ Module.inoutExceptionMsg fromName $ "Panic: cannot remove page for renaming module" let newPnls =@@ -1247,7 +1280,7 @@ RebuildControls ctrls -> Controls.create frameControls ctrls $- writeChan input . Control+ Chan.write input . Control Running mode -> do case mode of@@ -1269,7 +1302,7 @@ pnls <- readIORef panels HTTPGui.update (\contentMVar name newContent pos ->- writeChan input $ Modification $+ Chan.write input $ Modification $ RefreshModule (Just contentMVar) name newContent pos) status (fmap editor pnls) request
src/Option.hs view
@@ -22,6 +22,7 @@ import qualified Utility.NonEmptyList as NEList import Data.Traversable ( forM )+import Data.Bool.HT ( if' ) import Data.List.HT ( chop ) import Data.List ( intercalate ) @@ -31,10 +32,15 @@ importPaths :: [FilePath], connect :: NEList.T Port, sequencerName :: String,+ latency :: Double, limits :: Limits, httpOption :: HTTP.Option } +-- the formatted value might look ugly+defltLatencyStr :: String+defltLatencyStr = "0.05"+ getDeflt :: IO Option getDeflt = do dataDir <- Paths.getDataDir@@ -46,6 +52,7 @@ [ "prelude", "base", "example" ], connect = NEList.singleton (Port "inout" (Just []) (Just [])), sequencerName = "Rewrite-Sequencer",+ latency = read defltLatencyStr, limits = limitsDeflt, httpOption = HTTP.deflt }@@ -133,6 +140,18 @@ return $ flags{sequencerName = str}) ("name of the ALSA sequencer client, default " ++ sequencerName deflt) :+ Opt.Option [] ["latency"]+ (flip ReqArg "SECONDS" $ \str flags ->+ case reads str of+ [(x, "")] ->+ if' (x<0)+ (exitFailureMsg "latency must be non-negative") $+ if' (x>1000)+ (exitFailureMsg "latency is certainly too large") $+ return $ flags{latency = x}+ _ -> exitFailureMsg "latency value must be a number")+ ("delay between evaluation and playing,\ndefault " +++ defltLatencyStr) : map (fmapOptDescr $ \update old -> do newLimits <- update $ limits old return $ old {limits = newLimits})
src/Utility/Concurrent.hs view
@@ -1,9 +1,7 @@ module Utility.Concurrent where -import Control.Concurrent.STM.TChan import Control.Concurrent.STM.TMVar import Control.Monad.STM ( STM )-import qualified Control.Monad.STM as STM import qualified Control.Monad.Trans.Class as MT import qualified Control.Monad.Trans.State as MS@@ -21,10 +19,6 @@ clearTMVar :: TMVar a -> STM () clearTMVar var = void $ tryTakeTMVar var--writeTChanIO :: TChan a -> a -> IO ()-writeTChanIO chan a =- STM.atomically $ writeTChan chan a class Monad m => MonadSTM m where