diff --git a/http/disable/HTTPServer/GUI.hs b/http/disable/HTTPServer/GUI.hs --- a/http/disable/HTTPServer/GUI.hs +++ b/http/disable/HTTPServer/GUI.hs @@ -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 -> diff --git a/http/enable/HTTPServer/GUI.hs b/http/enable/HTTPServer/GUI.hs --- a/http/enable/HTTPServer/GUI.hs +++ b/http/enable/HTTPServer/GUI.hs @@ -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) -> diff --git a/live-sequencer.cabal b/live-sequencer.cabal --- a/live-sequencer.cabal +++ b/live-sequencer.cabal @@ -1,5 +1,5 @@ Name: live-sequencer -Version: 0.0.2 +Version: 0.0.3 Author: Henning Thielemann and Johannes Waldmann Maintainer: Johannes Waldmann , Henning Thielemann 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, diff --git a/src/ALSA.hs b/src/ALSA.hs --- a/src/ALSA.hs +++ b/src/ALSA.hs @@ -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) + } diff --git a/src/Console.hs b/src/Console.hs --- a/src/Console.hs +++ b/src/Console.hs @@ -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) diff --git a/src/Event.hs b/src/Event.hs --- a/src/Event.hs +++ b/src/Event.hs @@ -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 + } diff --git a/src/GUI.hs b/src/GUI.hs --- a/src/GUI.hs +++ b/src/GUI.hs @@ -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 diff --git a/src/Option.hs b/src/Option.hs --- a/src/Option.hs +++ b/src/Option.hs @@ -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}) diff --git a/src/Utility/Concurrent.hs b/src/Utility/Concurrent.hs --- a/src/Utility/Concurrent.hs +++ b/src/Utility/Concurrent.hs @@ -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