-- module GUI where {- | The program manages a number of threads: GUI: The GUI shall be responsive also if a program is loaded or a term is reduced. Thus the GUI has its own thread. If a GUI element requires a more complicated action, it sends an Action message via then 'input' Chan to the 'machine'. machine: This thread manages loading and parsing of modules as well as the operation mode of the interpreter. It gets most of its messages from the GUI and sends its result as GuiUpdate via the 'output' Chan to the GUI. execute: This runs the interpreter. It reduces expressions and sends according MIDI messages or waits according to Wait events. ALSA: With ALSA we can wait only for all kinds of events at once. Thus this thread receives all incoming messages and distributes them to the right receiver. E.g. NoteOn events are sent to the GUI as text inserts and Echo messages are sent to the 'execute' thread for handling Wait events. HTTPServer: Waits for and responds to incoming HTTP requests. -} import qualified IO import qualified Term import qualified Program import qualified Exception import qualified Module import qualified Controls import qualified Rewrite import qualified Option import qualified Log import Program ( Program, modules ) import Term ( Term, Identifier ) import Utility.Concurrent ( writeTMVar, writeTChanIO ) import Utility.WX ( cursor, editable, notebookSelection ) import qualified HTTPServer.GUI as HTTPGui import qualified Graphics.UI.WX as WX import Graphics.UI.WX.Attributes ( Prop((:=)), set, get ) import Graphics.UI.WX.Classes import Graphics.UI.WX.Controls import Graphics.UI.WX.Events import Graphics.UI.WX.Layout import Graphics.UI.WX.Types ( Color, rgb, fontFixed, Point2(Point), sz, varCreate, varSwap, varUpdate ) import Control.Concurrent ( forkIO ) import Control.Concurrent.MVar import Control.Concurrent.Chan import Control.Concurrent.STM.TChan import Control.Concurrent.STM.TVar import Control.Concurrent.STM.TMVar import Control.Monad.STM ( STM ) import qualified Control.Monad.STM as STM import Data.IORef ( newIORef, readIORef, writeIORef, modifyIORef ) import qualified Graphics.UI.WXCore as WXCore import qualified Graphics.UI.WXCore.WxcClassesAL as WXCAL import qualified Graphics.UI.WXCore.WxcClassesMZ as WXCMZ import Graphics.UI.WXCore.WxcDefs ( wxID_HIGHEST ) import Graphics.UI.WXCore.Events import qualified Event import Foreign.Storable ( peek ) import Foreign.Marshal.Alloc ( alloca ) import qualified ALSA import qualified Sound.ALSA.Sequencer as SndSeq import qualified Sound.MIDI.Message.Channel.Voice as VM import qualified Control.Monad.Trans.State as MS import qualified Control.Monad.Trans.Writer as MW import qualified Control.Monad.Trans.Maybe as MaybeT import qualified Control.Monad.Exception.Synchronous as Exc import Control.Monad.IO.Class ( liftIO ) import Control.Monad.Trans.Class ( lift ) import Control.Monad ( when, liftM2, forever, ) import Control.Functor.HT ( void ) import Data.Foldable ( forM_ ) import qualified Text.ParserCombinators.Parsec as Parsec import qualified Text.ParserCombinators.Parsec.Pos as Pos import qualified Text.ParserCombinators.Parsec.Token as Token import Control.Exception ( bracket, finally, try ) import qualified System.IO as IO import qualified System.IO.Error as Err import qualified System.Exit as Exit import qualified System.FilePath as FilePath import qualified Data.Accessor.Monad.Trans.State as AccM import qualified Data.Accessor.Tuple as AccTuple import qualified Data.Traversable as Trav import qualified Data.Foldable as Fold import qualified Data.Sequence as Seq import qualified Data.Map as M import Data.Maybe ( maybeToList, fromMaybe ) import qualified Data.Char as Char import qualified Data.List as List import Data.Tuple.HT ( fst3 ) import Prelude hiding ( log ) -- | read rules files, should contain definition for "main" main :: IO () main = do IO.hSetBuffering IO.stderr IO.LineBuffering opt <- Option.get (p,ctrls) <- Exc.resolveT (\e -> IO.hPutStrLn IO.stderr (Exception.multilineFromMessage e) >> Exit.exitFailure) $ prepareProgram =<< Program.chase (Option.importPaths opt) (Option.moduleName opt) input <- newChan output <- newTChanIO writeTChanIO output $ Register p ctrls ALSA.withSequencer "Rewrite-Sequencer" $ \sq -> do ALSA.parseAndConnect sq ( Option.connectFrom opt ) ( Option.connectTo opt ) flip finally (ALSA.stopQueue sq) $ WX.start $ do gui input output void $ forkIO $ machine input output (Option.importPaths opt) p sq void $ forkIO $ HTTPGui.run (HTTPGui.methods (writeTChanIO output . HTTP)) (Option.httpOption opt) -- | messages that are sent from GUI to machine data Action = Modification (Maybe (MVar HTTPGui.Feedback)) Module.Name String Int -- ^ MVar of the HTTP server, modulename, sourcetext, position | Execution Execution | NextStep | Control Controls.Event | Load FilePath data Execution = Mode Event.WaitMode | Restart | Stop | PlayTerm String -- | messages that are sent from machine to GUI data GuiUpdate = Term { _steps :: [ Rewrite.Message ], _currentTerm :: String } | Exception { _message :: Exception.Message } | Register Program [(Identifier, Controls.Control)] | Refresh { _moduleName :: Module.Name, _content :: String, _position :: Int } | InsertText { _insertedText :: String } | HTTP HTTPGui.GuiUpdate | Running { _runningMode :: Event.WaitMode } | ResetDisplay exceptionToGUI :: TChan GuiUpdate -> Exc.ExceptionalT Exception.Message STM () -> STM () exceptionToGUI output = Exc.resolveT (writeTChan output . Exception) exceptionToGUIIO :: TChan GuiUpdate -> Exc.ExceptionalT Exception.Message IO () -> IO () exceptionToGUIIO output = Exc.resolveT (writeTChanIO output . Exception) prepareProgram :: (Monad m) => Program -> Exc.ExceptionalT Exception.Message m (Program, [(Identifier, Controls.Control)]) prepareProgram p0 = do let ctrls = Controls.collect p0 p1 <- Exc.ExceptionalT $ return $ Program.add_module (Controls.controller_module ctrls) p0 return (p1, ctrls) formatPitch :: VM.Pitch -> String formatPitch p = let (oct,cls) = divMod (VM.fromPitch p) 12 name = case cls of 00 -> "c" 01 -> "cs" 02 -> "d" 03 -> "ds" 04 -> "e" 05 -> "f" 06 -> "fs" 07 -> "g" 08 -> "gs" 09 -> "a" 10 -> "as" 11 -> "b" _ -> error "pitch class must be a number from 0 to 11" in "note qn (" ++ name ++ " " ++ show (oct-1) ++ ") : " {- TODO: handle the case that the module changed its name (might happen if user changes the text in the editor) -} modifyModule :: TVar Program -> TChan GuiUpdate -> Module.Name -> [Char] -> Int -> Exc.ExceptionalT Exception.Message STM () modifyModule program output moduleName sourceCode pos = do p <- lift $ readTVar program let Just previous = M.lookup moduleName $ modules p m <- Exc.mapExceptionT Program.messageFromParserError $ Exc.fromEitherT $ return $ Parsec.parse (Module.parseUntilEOF (Module.source_location previous) sourceCode) ( Module.deconsName moduleName ) sourceCode lift . writeTVar program =<< (Exc.ExceptionalT $ return $ Program.add_module m p) lift $ writeTChan output $ Refresh moduleName sourceCode pos -- lift $ Log.put "parsed and modified OK" {- This runs concurrently and is fed with changes to the modules by the GUI. It parses them and provides the parsed modules to the execution engine. 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 -- (module name, module contents) -> TChan GuiUpdate -- ^ and writes output to here -- (log message (for highlighting), current term) -> [FilePath] -> Program -- ^ initial program -> ALSA.Sequencer SndSeq.DuplexMode -> IO () machine input output importPaths progInit sq = do program <- newTVarIO progInit let mainName = read "main" term <- newTMVarIO mainName waitChan <- newChan void $ forkIO $ forever $ do action <- readChan input let withMode mode transaction = do writeChan waitChan $ Event.ModeChange mode STM.atomically $ do writeTChan output $ Running mode transaction case action of Control event -> do Log.put $ show event STM.atomically $ exceptionToGUI output $ do p <- lift $ readTVar program p' <- Exc.ExceptionalT $ return $ Controls.change_controller_module p event lift $ writeTVar program p' -- return $ Controls.get_controller_module p' -- Log.put $ show m NextStep -> writeChan waitChan Event.NextStep 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 PlayTerm str -> case Parsec.parse (Parsec.between (Token.whiteSpace Term.lexer) (Parsec.eof) IO.input) "marked range" str of Left msg -> writeTChanIO output . Exception $ Program.messageFromParserError msg Right t -> do ALSA.quietContinueQueue sq withMode Event.RealTime $ writeTMVar term t Modification feedback moduleName sourceCode pos -> do Log.put $ Module.tellName moduleName ++ " has new input\n" ++ sourceCode case feedback of Nothing -> STM.atomically $ exceptionToGUI output $ modifyModule program output moduleName sourceCode pos Just mvar -> do x <- STM.atomically $ fmap (Exc.switch (\e -> (Just $ Exception.multilineFromMessage e, sourceCode)) (\() -> (Nothing, sourceCode))) $ Exc.runExceptionalT $ Exc.catchT (modifyModule program output moduleName sourceCode pos) (\e -> do lift $ writeTChan output $ Exception e Exc.throwT e) putMVar mvar $ Exc.Success x Load filePath -> do Log.put $ "load " ++ filePath ++ " and all its dependencies" exceptionToGUIIO output $ do (p,ctrls) <- prepareProgram =<< Program.load importPaths Program.empty (FilePath.takeBaseName filePath) filePath lift $ do ALSA.stopQueue sq withMode Event.RealTime $ do writeTVar program p writeTMVar term mainName writeTChan output $ Register p ctrls ALSA.continueQueue sq Log.put "chased and parsed OK" void $ forkIO $ Event.listen sq ( writeTChanIO output . InsertText . formatPitch ) waitChan ALSA.startQueue sq flip MS.evalStateT (Event.RealTime, 0) $ execute program term ( writeTChan output ) sq waitChan execute :: 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 program term output sq waitChan = forever $ excSwitchT (\e -> do liftIO $ do ALSA.stopQueue sq -- writeChan waitChan $ Event.ModeChange Event.SingleStep STM.atomically $ do output $ Exception e output $ 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 -} AccM.set AccTuple.first Event.SingleStep Event.wait sq waitChan Nothing) (\x -> do let writeExcMsg = STM.atomically . output . Exception {- exceptions on processing an event are not fatal and we keep running -} Exc.resolveT (liftIO . writeExcMsg) (Event.play sq waitChan writeExcMsg x) case Term.viewNode x of Just ("Wait", _) -> liftIO $ STM.atomically $ output ResetDisplay _ -> return ()) (let mainName = read "main" in Exc.mapExceptionalT (liftIO . STM.atomically) $ flip Exc.catchT (\(pos,msg) -> do lift $ putTMVar term mainName Exc.throwT $ Exception.Message Exception.Term pos msg) $ do t <- lift $ takeTMVar term p <- lift $ readTVar program {- this happens anew at each click since the program text might have changed in the editor -} (s,log) <- Exc.mapExceptionalT (fmap (\(ms,log) -> liftM2 (,) ms (return log)) . MW.runWriterT) $ Rewrite.runEval p (Rewrite.force_head t) {- This way the term will be pretty printed in the GUI thread which may block the GUI thread. However evaluating it here may defer playing notes, which is not better. -} lift $ output . Term log . show $ s case Term.viewNode s of Just (":", [x, xs]) -> do lift $ putTMVar term xs return x Just ("[]", []) -> Exc.throwT (Term.termRange s, "finished.") _ -> Exc.throwT (Term.termRange s, "I do not know how to handle this term: " ++ show s)) -- also available in explicit-exception>=0.1.7 excSwitchT :: (Monad m) => (e -> m b) -> (a -> m b) -> Exc.ExceptionalT e m a -> m b excSwitchT e s m = Exc.switch e s =<< Exc.runExceptionalT m -- | following code taken from http://snipplr.com/view/17538/ myEventId :: Int myEventId = wxID_HIGHEST+100 -- the custom event ID, avoid clash with Graphics.UI.WXCore.Types.varTopId -- | the custom event is registered as a menu event createMyEvent :: IO (WXCore.CommandEvent ()) createMyEvent = WXCAL.commandEventCreate WXCMZ.wxEVT_COMMAND_MENU_SELECTED myEventId registerMyEvent :: WXCore.EvtHandler a -> IO () -> IO () registerMyEvent win io = evtHandlerOnMenuCommand win myEventId io {- The order of widget creation is important for cycling through widgets using tabulator key. -} gui :: Chan 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") -> IO () gui input output = do program <- newIORef Program.empty controls <- newIORef [] panels <- newIORef M.empty let highlighters = fmap ( \ (_pnl,_,h) -> h ) editors = fmap ( \ (_pnl,e,_) -> e ) frameError <- WX.frame [ text := "errors" ] panelError <- WX.panel frameError [ ] errorLog <- WX.listCtrl panelError [ columns := ("Module", AlignLeft, 120) : ("Row", AlignRight, -1) : ("Column", AlignRight, -1) : ("Type", AlignLeft, -1) : ("Description", AlignLeft, 500) : [] ] errorList <- newIORef Seq.empty let updateErrorLog f = do errors <- readIORef errorList let newErrors = f errors writeIORef errorList newErrors set errorLog [ items := map Exception.lineFromMessage $ Fold.toList newErrors ] clearLog <- WX.button panelError [ text := "Clear", on command := updateErrorLog (const Seq.empty) ] frameControls <- WX.frame [ text := "controls" ] f <- WX.frame [ 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 [ ] fileMenu <- WX.menuPane [text := "&File"] let haskellFilenames = [ ("Haskell modules", ["*.hs"]), ("All files", ["*"]) ] loadItem <- WX.menuItem fileMenu [ text := "L&oad and check program ...\tCtrl-O", help := "flush all modules " ++ "and load a new program with all its dependencies" ] reloadItem <- WX.menuItem fileMenu [ text := "&Reload module", help := "reload a module from its original file, " ++ "but do not pass it to the interpreter" ] saveItem <- WX.menuItem fileMenu [ text := "&Save module\tCtrl-S", help := "overwrite original file with current module content" ] saveAsItem <- WX.menuItem fileMenu [ text := "Save module &as ...", help := "save module content to a different or new file " ++ "and make this the new file target" ] WX.menuLine fileMenu quitItem <- WX.menuQuit fileMenu [] execMenu <- WX.menuPane [text := "&Execution"] refreshItem <- WX.menuItem execMenu [ text := "&Refresh\tCtrl-R", help := "parse the edited program and if successful " ++ "replace the executed program" ] WX.menuLine execMenu realTimeItem <- WX.menuItem execMenu [ text := "Real time\tCtrl-1", checkable := True, checked := True, help := "pause according to Wait elements" ] slowMotionItem <- WX.menuItem execMenu [ text := "Slow motion\tCtrl-2", checkable := True, help := "pause between every list element" ] singleStepItem <- WX.menuItem execMenu [ text := "Single step\tCtrl-3", checkable := True, help := "wait for user confirmation after every list element" ] WX.menuLine execMenu _restartItem <- WX.menuItem execMenu [ text := "Res&tart\tCtrl-T", on command := writeChan input (Execution Restart), help := "stop sound and restart program execution with 'main'" ] playTermItem <- WX.menuItem execMenu [ text := "Play term\tCtrl-M", help := "stop sound and restart program execution " ++ "with the marked editor area as current term, " ++ "or use the surrounding identifier if nothing is marked" ] _stopItem <- WX.menuItem execMenu [ text := "Stop\tCtrl-Space", on command := writeChan input (Execution Stop), help := "stop program execution and sound, " ++ "reset term to 'main'" ] WX.menuLine execMenu fasterItem <- WX.menuItem execMenu [ text := "Faster\tCtrl->", enabled := False, help := "decrease pause in slow motion mode" ] slowerItem <- WX.menuItem execMenu [ text := "Slower\tCtrl-<", enabled := False, help := "increase pause in slow motion mode" ] nextStepItem <- WX.menuItem execMenu [ text := "Next step\tCtrl-N", enabled := False, on command := writeChan input NextStep, help := "perform next step in single step mode" ] windowMenu <- WX.menuPane [text := "&Window"] appRunning <- newIORef True let windowMenuItem title win = do itm <- WX.menuItem windowMenu [ text := title, help := "show or hide " ++ title ++ " window", checkable := True, checked := True ] set itm [ on command := do b <- get itm checked set win [ visible := b ] ] set win [ on closing := do run <- readIORef appRunning if run then do set itm [ checked := False ] set win [ visible := False ] -- WXCMZ.closeEventVeto ??? True else propagateEvent ] windowMenuItem "errors" frameError windowMenuItem "controls" frameControls WX.menuLine windowMenu reducerVisibleItem <- WX.menuItem windowMenu [ text := "current term", checkable := True, checked := True, help := "show or hide current term - " ++ "hiding may improve performance drastically" ] nb <- WX.notebook p [ ] reducer <- textCtrl p [ font := fontFixed, editable := False, wrap := WrapNone ] status <- WX.statusField [ text := "Welcome to interactive music composition with Haskell" ] let handleException moduleName act = do result <- try act case result of Left err -> writeTChanIO output $ Exception $ Exception.Message Exception.InOut (Program.dummyRange (Module.deconsName moduleName)) (Err.ioeGetErrorString err) Right () -> return () set loadItem [ on command := do mfilename <- WX.fileOpenDialog f False {- change current directory -} True "Load Haskell program" haskellFilenames "" "" forM_ mfilename $ writeChan input . Load ] set reloadItem [ on command := do index <- get nb notebookSelection (moduleName, (_panel, editor, _highlighter)) <- fmap ( M.elemAt index ) $ readIORef panels prg <- readIORef program let path = Module.source_location $ snd $ M.elemAt index (modules prg) handleException moduleName $ do content <- readFile path set editor [ text := content ] set status [ text := Module.tellName moduleName ++ " reloaded from " ++ path ] ] let getCurrentModule = do index <- get nb notebookSelection (moduleName, (_panel, editor, _highlighter)) <- fmap ( M.elemAt index ) $ readIORef panels content <- get editor text prg <- readIORef program return (Module.source_location $ snd $ M.elemAt index (modules prg), moduleName, content) saveModule (path, moduleName, content) = handleException moduleName $ do -- Log.put path writeFile path content set status [ text := Module.tellName moduleName ++ " saved to " ++ path ] set saveItem [ on command := do saveModule =<< getCurrentModule ] set saveAsItem [ on command := do (filePath, moduleName, content) <- getCurrentModule let (path,file) = FilePath.splitFileName filePath -- print (path,file) mfilename <- WX.fileSaveDialog f False {- change current directory -} True ("Save " ++ Module.tellName moduleName) haskellFilenames path file forM_ mfilename $ \fileName -> do saveModule (fileName, moduleName, content) modifyIORef program $ \prg -> prg { Program.modules = M.adjust (\modu -> modu { Module.source_location = fileName }) moduleName (Program.modules prg) } ] let refreshProgram (moduleName, (_panel, editor, _highlighter)) = do s <- get editor text pos <- get editor cursor writeChan input $ Modification Nothing moduleName s pos updateErrorLog $ Seq.filter $ \(Exception.Message _ errorRng _) -> Module.deconsName moduleName /= Pos.sourceName (Term.start errorRng) set refreshItem [ on command := do refreshProgram =<< getFromNotebook nb =<< readIORef panels -- mapM_ refreshProgram pnls ] set playTermItem [ on command := do (_moduleName, (_panel, editor, _highlighter)) <- getFromNotebook nb =<< readIORef panels marked <- WXCMZ.textCtrlGetStringSelection editor expr <- if null marked then do (i,line) <- textColumnRowFromPos editor =<< get editor cursor content <- WXCMZ.textCtrlGetLineText editor line {- simpler but inefficient content <- get editor text i <- get editor cursor -} case splitAt i content of (prefix,suffix) -> let identLetter c = Char.isAlphaNum c || c == '_' || c == '.' in return $ (reverse $ takeWhile identLetter $ reverse prefix) ++ takeWhile identLetter suffix else return marked writeChan input . Execution . PlayTerm $ expr ] waitDuration <- newIORef 500 let updateSlowMotionDur = do dur <- readIORef waitDuration writeChan input $ Execution $ Mode $ Event.SlowMotion dur set fasterItem [ on command := do modifyIORef waitDuration (\d -> max 100 (d-100)) updateSlowMotionDur d <- readIORef waitDuration set status [ text := "decreased pause to " ++ show d ++ "ms" ] ] set slowerItem [ on command := do modifyIORef waitDuration (100+) updateSlowMotionDur d <- readIORef waitDuration set status [ text := "increased pause to " ++ show d ++ "ms" ] ] let setRealTime b = do set realTimeItem [ checked := b ] setSlowMotion b = do set slowMotionItem [ checked := b ] set fasterItem [ enabled := b ] set slowerItem [ enabled := b ] setSingleStep b = do set singleStepItem [ checked := b ] set nextStepItem [ enabled := b ] onActivation w act = set w [ on command := do b <- get w checked if b then act else set w [checked := True] ] activateRealTime = do setRealTime True setSlowMotion False setSingleStep False activateSlowMotion = do setRealTime False setSlowMotion True setSingleStep False activateSingleStep = do setRealTime False setSlowMotion False setSingleStep True onActivation realTimeItem $ do activateRealTime writeChan input $ Execution $ Mode Event.RealTime onActivation slowMotionItem $ do activateSlowMotion updateSlowMotionDur onActivation singleStepItem $ do activateSingleStep writeChan input $ Execution $ Mode Event.SingleStep set reducerVisibleItem [ on command := do b <- get reducerVisibleItem checked set reducer [ visible := b ] windowReFit reducer ] set f [ layout := container p $ margin 5 $ column 5 [ WX.fill $ tabs nb [] , WX.fill $ widget reducer ] , WX.statusBar := [status] , WX.menuBar := [fileMenu, execMenu, windowMenu] , visible := True , clientSize := sz 1280 720 ] set errorLog [ on listEvent := \ev -> void $ MaybeT.runMaybeT $ do ListItemSelected n <- return ev errors <- liftIO $ readIORef errorList let (Exception.Message typ errorRng _descr) = Seq.index errors n Right moduleIdent <- return $ Parsec.parse IO.input "" $ Pos.sourceName $ Term.start errorRng pnls <- liftIO $ readIORef panels pnl <- MaybeT.MaybeT $ return $ M.lookupIndex moduleIdent pnls liftIO $ set nb [ notebookSelection := pnl ] let activateText textField = do h <- MaybeT.MaybeT $ return $ M.lookup moduleIdent textField i <- liftIO $ textPosFromSourcePos h $ Term.start errorRng j <- liftIO $ textPosFromSourcePos h $ Term.end errorRng liftIO $ set h [ cursor := i ] liftIO $ WXCMZ.textCtrlSetSelection h i j case typ of Exception.Parse -> activateText $ editors pnls Exception.Term -> activateText $ highlighters pnls Exception.InOut -> return () ] set frameError [ layout := container panelError $ margin 5 $ column 5 $ [ WX.fill $ widget errorLog, WX.hfloatLeft $ widget clearLog ] , clientSize := sz 500 300 ] let closeOther = writeIORef appRunning False >> close frameError >> close frameControls set quitItem [ on command := closeOther >> close f] set f [ on closing := closeOther >> propagateEvent {- 'close f' would trigger the closing handler again -} ] focusOn f highlights <- varCreate M.empty registerMyEvent f $ do msg <- readChan out let setColorHighlighters :: M.Map Module.Name [Identifier] -> Int -> Int -> Int -> IO () setColorHighlighters m r g b = do pnls <- readIORef panels set_color nb ( highlighters pnls ) m ( rgb r g b ) case msg of Term steps sr -> do get reducerVisibleItem checked >>= flip when ( set reducer [ text := sr, cursor := 0 ] ) forM_ steps $ \step -> case step of Rewrite.Step target mrule -> do let m = M.fromList $ do t <- target : maybeToList mrule return (Module.Name $ Pos.sourceName $ Term.start $ Term.range t, [t]) void $ varUpdate highlights $ M.unionWith (++) m setColorHighlighters m 0 200 200 Rewrite.Data origin -> do set reducer [ text := sr, cursor := 0 ] let m = M.singleton (Module.Name $ Pos.sourceName $ Term.start $ Term.range origin) [origin] void $ varUpdate highlights $ M.unionWith (++) m setColorHighlighters m 200 200 0 Exception exc -> do itemAppend errorLog $ Exception.lineFromMessage exc modifyIORef errorList (Seq.|> exc) set status [ text := Exception.statusFromMessage exc ] -- update highlighter text field only if parsing was successful Refresh moduleName s pos -> do pnls <- readIORef panels Fold.mapM_ (\h -> set h [ text := s, cursor := pos ]) (M.lookup moduleName $ highlighters pnls) set status [ text := Module.tellName moduleName ++ " reloaded into interpreter" ] InsertText str -> do (_moduleName, (_panel, editor, _highlighter)) <- getFromNotebook nb =<< readIORef panels WXCMZ.textCtrlWriteText editor str set status [ text := "inserted note from external controller" ] Register prg ctrls -> do writeIORef program prg writeIORef controls ctrls void $ WXCMZ.notebookDeleteAllPages nb pnls <- displayModules input frameControls ctrls nb prg writeIORef panels pnls Fold.forM_ (M.mapWithKey (,) $ fmap fst3 pnls) $ \(moduleName,sub) -> WXCMZ.notebookAddPage nb sub (Module.deconsName moduleName) False (-1) updateErrorLog (const Seq.empty) set status [ text := "modules loaded: " ++ (List.intercalate ", " $ map Module.deconsName $ M.keys $ Program.modules prg) ] ResetDisplay -> do previous <- varSwap highlights M.empty setColorHighlighters previous 255 255 255 Running mode -> do case mode of Event.RealTime -> do set status [ text := "interpreter in real-time mode" ] activateRealTime Event.SlowMotion dur -> do set status [ text := ("interpreter in slow-motion mode with pause " ++ show dur ++ "ms") ] activateSlowMotion Event.SingleStep -> do set status [ text := "interpreter in single step mode," ++ " waiting for next step" ] activateSingleStep HTTP request -> HTTPGui.update (\contentMVar name newContent pos -> writeChan input $ Modification (Just contentMVar) name newContent pos) status panels request displayModules :: Chan Action -> WX.Frame c -> [(Identifier, Controls.Control)] -> WXCore.Window b -> Program -> IO (M.Map Module.Name (Panel (), TextCtrl (), TextCtrl ())) displayModules input frameControls ctrls nb prog = do Controls.create frameControls ctrls $ \ e -> writeChan input ( Control e ) Trav.forM (modules prog) $ \ content -> do psub <- panel nb [] editor <- textCtrl psub [ font := fontFixed, wrap := WrapNone ] highlighter <- textCtrlRich psub [ font := fontFixed, wrap := WrapNone, editable := False ] set editor [ text := Module.source_text content ] set highlighter [ text := Module.source_text content ] set psub [ layout := (row 5 $ map WX.fill $ [widget editor, widget highlighter]) ] return (psub, editor, highlighter) getFromNotebook :: Notebook b -> M.Map k a -> IO (k, a) getFromNotebook nb m = fmap (flip M.elemAt m) $ get nb notebookSelection textPosFromSourcePos :: TextCtrl a -> Pos.SourcePos -> IO Int textPosFromSourcePos textArea pos = WXCMZ.textCtrlXYToPosition textArea $ Point (Pos.sourceColumn pos - 1) (Pos.sourceLine pos - 1) textColumnRowFromPos :: TextCtrl a -> Int -> IO (Int, Int) textColumnRowFromPos textArea pos = alloca $ \rowPtr -> alloca $ \columnPtr -> do void $ WXCMZ.textCtrlPositionToXY textArea pos columnPtr rowPtr liftM2 (,) (fmap fromIntegral $ peek columnPtr) (fmap fromIntegral $ peek rowPtr) set_color :: (Ord k) => Notebook a -> M.Map k (TextCtrl a) -> M.Map k [Identifier] -> Color -> IO () set_color nb highlighters positions hicolor = void $ do (p, highlighter) <- getFromNotebook nb highlighters attr <- WXCMZ.textCtrlGetDefaultStyle highlighter bracket (WXCMZ.textAttrGetBackgroundColour attr) (WXCMZ.textAttrSetBackgroundColour attr) $ const $ do WXCMZ.textAttrSetBackgroundColour attr hicolor forM_ (fromMaybe [] $ M.lookup p positions) $ \ ident -> do let rng = Term.range ident from <- textPosFromSourcePos highlighter $ Term.start rng to <- textPosFromSourcePos highlighter $ Term.end rng WXCMZ.textCtrlSetStyle highlighter from to attr