live-sequencer 0.0.6 → 0.0.6.1
raw patch · 30 files changed
+1554/−1152 lines, 30 filesdep +pathtypedep −directorydep −filepathdep ~explicit-exception
Dependencies added: pathtype
Dependencies removed: directory, filepath
Dependency ranges changed: explicit-exception
Files
- ChangeLog +0/−6
- Changes.md +18/−0
- README.md +13/−0
- data/example/Introduction.hs +121/−0
- http/enable/HTTPServer.hs +2/−2
- live-sequencer.cabal +16/−14
- src/ALSA.hs +1/−1
- src/Console.hs +13/−11
- src/Controller.hs +31/−31
- src/ControllerBase.hs +34/−40
- src/Event.hs +35/−27
- src/Exception.hs +100/−87
- src/GUI.hs +384/−374
- src/IO.hs +0/−18
- src/InOut.hs +16/−0
- src/MPlayer.hs +14/−9
- src/Module.hs +144/−103
- src/ModuleBase.hs +60/−0
- src/Option.hs +36/−17
- src/Program.hs +113/−82
- src/Rewrite.hs +60/−57
- src/Rule.hs +25/−12
- src/SourceText.hs +61/−0
- src/Step.hs +0/−27
- src/Term.hs +91/−161
- src/TermFocus.hs +6/−4
- src/TermParser.hs +96/−0
- src/Time.hs +40/−45
- src/Type.hs +22/−22
- src/Utility/Concurrent.hs +2/−2
− ChangeLog
@@ -1,6 +0,0 @@-0.0.5:--* uniform singular names for modules-- data/Controls -> data/Controller- data/Chords -> data/Chord
+ Changes.md view
@@ -0,0 +1,18 @@+# Change log for the `live-sequencer` package++## 0.0.6.1:++ * Do not highlight terms anymore if they were from outdated module contents.+ This also avoids warnings by GTK about highlighting invalid text positions.+ Internally solved by using module versions.++## 0.0.6:++ * adapt to wxwidgets-3.0++## 0.0.5:++ * uniform singular names for modules++ data/Controls -> data/Controller+ data/Chords -> data/Chord
README.md view
@@ -231,6 +231,19 @@ and then set `--event-period` large enough to match the power of your machine. +* split wait:+ The interpreter cannot be interrupted if it waits+ in reaction to a `Wait` command.+ The way we implemented the interpreter,+ an overly long `Wait` duration+ will still allow to stop playing music immediately.+ However, if you restart the music you may still meet the interpreter+ while waiting for the end of the wait duration.+ To prevent this situation the interpreter will split a `Wait`+ if its duration is too long.+ The `--split-wait` option allows you to adjust+ the maximum allowed `Wait` duration.+ # ALSA Using the `--new-out-port` option
+ data/example/Introduction.hs view
@@ -0,0 +1,121 @@+module Introduction where++import Instrument+import Midi+import List+import Prelude++-- * basic functions++{-+Send a single MIDI message (and some AllNotesOff).+Verify with 'aseqdump'.+-}+single = Event ( PgmChange acousticGrandPiano ) : [] ;++{-+Press the middle C key.+-}+oneNoteOn = Event ( On 60 64 ) : [] ;++{-+Press the middle C key, wait and release it.+-}+oneNote = Event ( On 60 64 ) : Wait 1000 : Event ( Off 60 64 ) : [] ;++{-+Use functions from the Midi module.+-}+noteWithFunc = noteOn 60 : Wait 1000 : noteOff 60 : [] ;++{-+Use functions from the Pitch module.+-}+noteWithPitch = noteOn (c 4) : Wait 1000 : noteOff (c 4) : [] ;++{-+Play notes one after another.+-}+noteSequence =+ noteOn (c 4) : Wait 1000 : noteOff (c 4) :+ noteOn (e 4) : Wait 1000 : noteOff (e 4) :+ noteOn (g 4) : Wait 1000 : noteOff (g 4) :+ noteOn (c 5) : Wait 1000 : noteOff (c 5) :+ [] ;++{-+Play notes simultaneously.+-}+noteParallel =+ noteOn (c 4) : noteOn (e 4) : noteOn (g 4) : noteOn (c 5) :+ Wait 1000 :+ noteOff (c 4) : noteOff (e 4) : noteOff (g 4) : noteOff (c 5) :+ [] ;+++dur = 1000 ;++{-+Use 'note' function.+-}+noteFunc = noteLazy dur (c 4) ;++{-+Play notes one after another using (++).+-}+noteFuncSequence =+ noteLazy dur (c 4) ++ noteLazy dur (e 4) ;++{-+Repeat a note by append to itself.+-}+noteFuncLoop =+ noteLazy dur (c 4) ++ noteFuncLoop ;++{-+Play notes simultaneously using (=:=).+-}+noteFuncParallel =+ noteLazy dur (c 4) =:= noteLazy dur (e 4) ;++noteFuncSequenceParallel =+ ( noteLazy dur (c 4) ++ noteLazy dur (g 4) )+ =:=+ noteLazy (2*dur) (e 4) ;+++-- * laws++identitySequence = note dur (c 4) ;+leftIdentitySequence = [] ++ note dur (c 4) ;+rightIdentitySequence = note dur (c 4) ++ [] ;++leftAssociativeSequence =+ ( note dur (c 4) ++ note dur (e 4) ) ++ note dur (g 4) ;+rightAssociativeSequence =+ note dur (c 4) ++ ( note dur (e 4) ++ note dur (g 4) ) ;+++identityParallel = note dur (c 4) ;+leftIdentityParallel = [] =:= note dur (c 4) ;+rightIdentityParallel = note dur (c 4) =:= [] ;++leftAssociativeParallel =+ ( note dur (c 4) =:= note dur (e 4) ) =:= note dur (g 4) ;+rightAssociativeParallel =+ note dur (c 4) =:= ( note dur (e 4) =:= note dur (g 4) ) ;++commutative0Parallel =+ note dur (c 4) =:= note dur (e 4) ;+commutative1Parallel =+ note dur (e 4) =:= note dur (c 4) ;++distributive0 =+ ( note dur (c 4) =:= note dur (g 4) )+ +++ ( note dur (e 4) =:= note dur (c 5) ) ;++distributive1 =+ ( note dur (c 4) ++ note dur (e 4) )+ =:=+ ( note dur (g 4) ++ note dur (c 5) ) ;
http/enable/HTTPServer.hs view
@@ -11,7 +11,7 @@ import qualified HTTPServer.Option as Option import qualified Module-import qualified IO+import qualified InOut import qualified Network.Shed.Httpd as HTTPd import qualified Network.CGI as CGI@@ -132,7 +132,7 @@ show) $ Exc.fromEitherT $ return $ Parsec.parse- (Parsec.between (return ()) Parsec.eof IO.input)+ (Parsec.between (return ()) Parsec.eof InOut.input) "" modName formatModuleList :: [Module.Name] -> String
live-sequencer.cabal view
@@ -1,5 +1,5 @@ Name: live-sequencer-Version: 0.0.6+Version: 0.0.6.1 Author: Henning Thielemann and Johannes Waldmann Maintainer: Henning Thielemann <haskell@henning-thielemann.de>, Johannes Waldmann <waldmann@imn.htwk-leipzig.de> Category: Sound, Music, GUI@@ -21,6 +21,7 @@ Build-Type: Simple Data-Files:+ data/example/Introduction.hs data/example/Band.hs data/example/BandControlled.hs data/example/Finite.hs@@ -57,7 +58,7 @@ data/prelude/Prelude.hs Extra-Source-Files:- ChangeLog+ Changes.md README.md http/enable/HTTPServer.hs http/enable/HTTPServer/GUI.hs@@ -70,7 +71,7 @@ Location: https://hub.darcs.net/thielema/livesequencer Source-Repository this- Tag: 0.0.6+ Tag: 0.0.6.1 Type: darcs Location: https://hub.darcs.net/thielema/livesequencer @@ -130,15 +131,17 @@ Other-Modules: ALSA Event- IO+ InOut Module+ ModuleBase Option Option.Utility Program Rewrite Rule- Step+ SourceText Term+ TermParser TermFocus Time Type@@ -153,7 +156,7 @@ stm-split >=0.0 && <0.1, concurrent-split >=0.0 && <0.1, transformers >=0.2.2 && <0.6,- explicit-exception >=0.1.5 && <0.2,+ explicit-exception >=0.1.9 && <0.2, parsec >=2.1 && <3.2, pretty >=1.0 && <1.2, midi-alsa >=0.2 && <0.3,@@ -168,8 +171,7 @@ containers >=0.3 && <0.6, bytestring >=0.9 && <0.11, process >=1.0 && <1.5,- directory >=1.0 && <1.4,- filepath >=1.1 && <1.5,+ pathtype >=0.8.1 && <0.9, base >=4.2 && <5 Executable live-sequencer-gui@@ -180,7 +182,7 @@ stm >=2.2 && <2.5, concurrent-split >=0.0 && <0.1, transformers >=0.2.2 && <0.6,- explicit-exception >=0.1.5 && <0.2,+ explicit-exception >=0.1.9 && <0.2, parsec >=2.1 && <3.2, pretty >=1.0 && <1.2, midi-alsa >=0.2 && <0.3,@@ -195,8 +197,7 @@ containers >=0.3 && <0.6, bytestring >=0.9 && <0.11, process >=1.0 && <1.5,- directory >=1.0 && <1.4,- filepath >=1.1 && <1.5,+ pathtype >=0.8.1 && <0.9, base >=4.2 && <5 Else Buildable: False@@ -206,9 +207,10 @@ Other-Modules: ALSA Event- IO+ InOut Exception Module+ ModuleBase Option Option.Utility Controller@@ -216,8 +218,9 @@ Program Rewrite Rule- Step+ SourceText Term+ TermParser TermFocus Time Type@@ -255,7 +258,6 @@ alsa-seq >=0.6 && <0.7, alsa-core >=0.5 && <0.6, unix >=2.4 && <2.8,- directory >=1.0 && <1.4, transformers >=0.2.2 && <0.6, base >=4.2 && <5 Else
src/ALSA.hs view
@@ -33,7 +33,7 @@ import Control.Applicative ( Applicative ) import Control.Functor.HT ( void ) import qualified Data.Foldable as Fold-import Data.Foldable ( Foldable, forM_, foldMap )+import Data.Foldable ( forM_, foldMap ) import Data.Monoid ( mappend )
src/Console.hs view
@@ -1,13 +1,14 @@ -- module Console where -import Term ( Term )-import Program ( Program ) import qualified Program+import qualified Module import qualified Time import qualified Term import qualified Event import qualified Rewrite import qualified Exception+import Program ( Program )+import SourceText ( ModuleRange ) import qualified Option import qualified ALSA@@ -20,18 +21,18 @@ import qualified Control.Monad.Trans.Writer as MW import qualified Control.Monad.Trans.State as MS+import qualified Control.Monad.Trans.Class as MT import Control.Monad.Exception.Synchronous ( mapExceptionalT, resolveT, throwT ) import Control.Monad.IO.Class ( liftIO )-import Control.Monad.Trans.Class ( lift ) import Control.Monad ( when, (>=>) ) import Control.Functor.HT ( void ) import qualified System.IO as IO import Option.Utility ( exitFailureMsg ) -import Prelude hiding ( log ) +type Term = Term.Term ModuleRange -- | read rules files, start expansion of "main" main :: IO ()@@ -42,7 +43,8 @@ p <- resolveT (exitFailureMsg . Exception.multilineFromMessage) $ Program.chaseMany- (Option.importPaths opt) (Option.moduleNames opt) Program.empty+ (Option.importPaths opt) Module.initVersion+ (Option.moduleNames opt) Program.empty ALSA.withSequencer opt $ \sq -> do (waitIn,waitOut) <- Chan.new (visIn,visOut) <- Chan.new@@ -51,7 +53,7 @@ Event.runState $ execute (Option.maxReductions $ Option.limits opt)- p sq visIn waitOut Term.mainName+ p sq visIn waitOut Term.main writeExcMsg :: Exception.Message -> IO () writeExcMsg = putStrLn . Exception.statusFromMessage@@ -71,18 +73,18 @@ (MW.runWriterT >=> \(ms,_log) -> {- liftIO (mapM_ print log) >> -} return ms) $ Rewrite.runEval maxRed p (Rewrite.forceHead t)- lift $ liftIO $ Chan.write visIn s- lift $ void $ Event.runSend sq$+ MT.lift $ liftIO $ Chan.write visIn s+ MT.lift $ void $ Event.runSend sq$ Event.sendEcho Event.visualizeId $ ALSA.latencyNano sq case Term.viewNode s of Just (":", [x, xs]) -> do- mdur <- lift $ resolveT+ mdur <- MT.lift $ resolveT (liftIO . fmap (const Nothing) . writeExcMsg) (Event.play sq writeExcMsg x)- lift $ Event.wait sq waitOut mdur+ MT.lift $ Event.wait sq waitOut mdur go xs Just ("[]", []) ->- lift $ liftIO $+ MT.lift $ liftIO $ Time.pause $ ALSA.latencyMicro sq {- says: operation not permitted SeqEvent.syncOutputQueue (ALSA.handle sq)
src/Controller.hs view
@@ -4,21 +4,25 @@ -- * read while executing the program. module Controller (- module Controller,- module ControllerBase,+ Assignments,+ Event,+ create,+ changeControllerModule, ) where -import ControllerBase- ( Name, deconsName, Assignments,- Value (Bool, Number), Values (boolValues, numberValues) ) import qualified ControllerBase as C import qualified Program import qualified Module import qualified Rule import qualified Term import qualified Exception+import ControllerBase+ ( Name, deconsName, Assignments,+ Value (Bool, Number), Values (boolValues, numberValues) )+import Program (Program)+import SourceText ( ModuleRange, emptyModuleRange ) -import qualified Control.Monad.Exception.Synchronous as Exc+import qualified Control.Monad.Exception.Synchronous as ME import qualified Control.Monad.Trans.Writer as MW import qualified Control.Monad.Trans.Class as MT import Control.Monad.IO.Class ( liftIO )@@ -30,7 +34,7 @@ import Graphics.UI.WX.Events ( on, command, select ) import Graphics.UI.WX.Layout ( layout, container, row, column, widget ) -import qualified Data.Map as M+import qualified Data.Map as Map import Data.Foldable ( forM_ ) import Control.Functor.HT ( void )@@ -44,55 +48,51 @@ moduleName :: Module.Name moduleName = Module.Name "Controller" -defltIdent :: Term.Term-defltIdent = read "deflt"+defltIdent :: Term.Term ModuleRange+defltIdent = Term.variable moduleName "deflt" -changeControllerModule ::- Program.Program ->- Event ->- Exc.Exceptional Exception.Message Program.Program+changeControllerModule :: Program -> Event -> Exception.Monad Program changeControllerModule p0 (Event name val) = fmap (\p -> p{Program.controlValues = updateValue name val $ Program.controlValues p}) . flip Program.replaceModule p0 . Module.addRule ( controllerRule name val ) =<<- Exc.fromMaybe- ( Module.inoutExceptionMsg moduleName+ ME.fromMaybe+ ( Exception.messageInOutEditor moduleName "cannot find module for controller updates" )- ( M.lookup moduleName $ Program.modules p0 )+ ( Map.lookup moduleName $ Program.modules p0 ) -updateValue ::- Name -> Value -> Values -> Values+updateValue :: Name -> Value -> Values -> Values updateValue name val vals = case val of Bool b ->- vals{boolValues = M.insert name b $ boolValues vals}+ vals{boolValues = Map.insert name b $ boolValues vals} Number x ->- vals{numberValues = M.insert name x $ numberValues vals}+ vals{numberValues = Map.insert name x $ numberValues vals} -controllerRule ::- Name -> Value -> Rule.Rule+controllerRule :: Name -> Value -> Rule.Rule ModuleRange controllerRule name val = case val of Bool b -> Rule.Rule- ( read "checkBox" )+ ( Term.identifier moduleName "checkBox" ) [ Term.StringLiteral- ( Module.nameRange moduleName )+ ( emptyModuleRange moduleName ) ( deconsName name ), defltIdent ]- ( Term.Node ( read $ show b ) [] )+ ( Term.variable moduleName $ show b ) Number x -> Rule.Rule- ( read "slider" )+ ( Term.identifier moduleName "slider" ) [ Term.StringLiteral- ( Module.nameRange moduleName )+ ( emptyModuleRange moduleName ) ( deconsName name ),- read "lower",- read "upper",+ Term.variable moduleName "lower",+ Term.variable moduleName "upper", defltIdent ]- ( Term.Number ( Module.nameRange moduleName ) ( fromIntegral x ) )+ ( Term.Number ( emptyModuleRange moduleName )+ ( fromIntegral x ) ) create :: WX.Frame () ->@@ -103,7 +103,7 @@ size <- WX.get frame WX.outerSize void $ WXCMZ.windowDestroyChildren frame panel <- WX.panel frame []- (cs,ss) <- MW.runWriterT $ MW.execWriterT $ forM_ (M.toList controls) $+ (cs,ss) <- MW.runWriterT $ MW.execWriterT $ forM_ (Map.toList controls) $ \ ( name, (_rng, con) ) -> case con of C.CheckBox val -> do
src/ControllerBase.hs view
@@ -7,10 +7,12 @@ import qualified Exception import qualified Term import Term ( Term )+import SourceText ( ModuleRange ) -import qualified Data.Map as M+import qualified Data.Map as Map+import Data.Map ( Map ) -import qualified Control.Monad.Exception.Synchronous as Exc+import qualified Control.Monad.Exception.Synchronous as ME import qualified Control.Monad.Trans.Class as MT import qualified Control.Monad.Trans.State as MS@@ -27,8 +29,8 @@ data Values = Values {- boolValues :: M.Map Name Bool,- numberValues :: M.Map Name Int+ boolValues :: Map Name Bool,+ numberValues :: Map Name Int } deriving Show newtype Name = Name String@@ -39,19 +41,19 @@ emptyValues :: Values-emptyValues = Values M.empty M.empty+emptyValues = Values Map.empty Map.empty updateValues :: Values -> Assignments -> Assignments updateValues (Values bools numbers) assigns =- M.union- (M.intersectionWith+ Map.union+ (Map.intersectionWith (\b (rng, a) -> (rng, case a of CheckBox _deflt -> CheckBox b _ -> a)) bools assigns) $- M.union- (M.intersectionWith+ Map.union+ (Map.intersectionWith (\x (rng, a) -> (rng, case a of Slider lower upper _deflt -> Slider lower upper x@@ -60,60 +62,54 @@ assigns -type Assignments = M.Map Name (Term.Range, Control)+type Assignments = Map Name (ModuleRange, Control) -exc :: Term.Range -> String -> Exception.Message-exc rng msg =- Exception.Message Exception.Parse rng msg+exc :: Term ModuleRange -> String -> ME.Exceptional Exception.Message a+exc t = ME.Exception . Exception.messageParseModuleRange (Term.termRange t) -excDuplicate :: Name -> Term.Range -> Exception.Message+excDuplicate :: Name -> ModuleRange -> Exception.Message excDuplicate name rng =- exc rng $+ Exception.messageParseModuleRange rng $ "duplicate controller definition with name " ++ deconsName name -union ::- Assignments ->- Assignments ->- Exc.Exceptional Exception.Message Assignments+union :: Assignments -> Assignments -> Exception.Monad Assignments union m0 m1 =- let f = fmap Exc.Success+ let f = fmap ME.Success in Trav.sequenceA $- M.unionWithKey+ Map.unionWithKey (\name _ a -> do (rng, _c) <- a- Exc.throw $ excDuplicate name rng)+ ME.throw $ excDuplicate name rng) (f m0) (f m1) -collect ::- Term -> Exc.Exceptional Exception.Message Assignments+collect :: Term ModuleRange -> Exception.Monad Assignments collect topTerm =- flip MS.execStateT M.empty $+ flip MS.execStateT Map.empty $ mapM_ (\ea -> do (name, rc@(rng, _ctrl)) <- MT.lift ea- MT.lift . Exc.assert (excDuplicate name rng)- =<< MS.gets (not . M.member name)- MS.modify (M.insert name rc)) $ do+ MT.lift . ME.assert (excDuplicate name rng)+ =<< MS.gets (Map.notMember name)+ MS.modify (Map.insert name rc)) $ do ( _pos, term ) <- Term.subterms topTerm case Term.viewNode term of Just ( "checkBox" , args ) -> return $ case args of- [ Term.StringLiteral _rng tag, Term.Node deflt [] ] ->+ [ Term.StringLiteral _rng tag,+ defltTerm@(Term.Node deflt []) ] -> case reads $ Term.name deflt of [(b, "")] ->- Exc.Success $ (Name tag, (Term.termRange term, CheckBox b))+ ME.Success+ (Name tag, (Term.termRange term, CheckBox b)) _ ->- Exc.Exception $- exc (Term.range deflt) $+ exc defltTerm $ "cannot parse Bool value " ++ show (Term.name deflt) ++ " for checkBox"- _ ->- Exc.Exception $- exc (Term.termRange term) "invalid checkBox arguments"+ _ -> exc term "invalid checkBox arguments" Just ( "slider" , args ) -> return $ case args of@@ -121,13 +117,11 @@ let milliard = 1000000000 number arg = Exception.checkRange- Exception.Parse arg id id- (-milliard) milliard+ Exception.messageParseModuleRange+ arg id id (-milliard) milliard l <- number "lower slider bound" lower u <- number "upper slider bound" upper x <- number "default slider value" deflt return (Name tag, (Term.termRange term, Slider l u x))- _ ->- Exc.Exception $- exc (Term.termRange term) "invalid slider arguments"+ _ -> exc term "invalid slider arguments" _ -> []
src/Event.hs view
@@ -83,6 +83,7 @@ import Term ( Term(Number, StringLiteral), termRange ) import ALSA ( Sequencer(handle), Time )+import SourceText ( ModuleRange ) import qualified Term import qualified ALSA import qualified Time@@ -102,8 +103,9 @@ import qualified Control.Monad.Trans.State as MS import qualified Control.Monad.Trans.Class as MT-import qualified Control.Monad.Exception.Asynchronous as ExcA-import Control.Monad.Exception.Synchronous ( ExceptionalT, throwT )+import qualified Control.Monad.Exception.Asynchronous as MEA+import qualified Control.Monad.Exception.Synchronous as ME+import Control.Monad.Exception.Synchronous ( throwT ) import Control.Monad.IO.Class ( MonadIO, liftIO ) import Control.Monad ( when, forever ) import Control.Functor.HT ( void )@@ -130,6 +132,8 @@ import Control.Concurrent ( forkIO ) +type RTerm = Term ModuleRange+ data WaitMode = RealTime | SlowMotion (Time.Milliseconds Integer) | SingleStep Continue deriving (Eq, Show)@@ -148,16 +152,12 @@ singleStep = SingleStep NextElement -termException ::- (Monad m) =>- Term -> String -> ExceptionalT Exception.Message m a+termException :: (Monad m) => RTerm -> String -> Exception.MonadT m a termException s msg =- throwT $- Exception.Message Exception.Term- (termRange s) (msg ++ " " ++ show s)+ throwT $ Exception.messageTerm (termRange s) (msg ++ " " ++ show s) -runIO :: (MonadIO m) => IO a -> ExceptionalT Exception.Message m a+runIO :: (MonadIO m) => IO a -> Exception.MonadT m a runIO action = MT.lift $ liftIO action @@ -165,20 +165,20 @@ (Bounded a, Monad m) => String -> (Int -> a) -> (a -> Int) -> a -> a ->- Term ->- ExceptionalT Exception.Message m a+ RTerm ->+ Exception.MonadT m a checkRange typ fromInt toInt minb maxb =- Exception.lift .- Exception.checkRange Exception.Term typ fromInt toInt minb maxb+ ME.liftT .+ Exception.checkRange Exception.messageTerm typ fromInt toInt minb maxb checkRangeAuto :: (Bounded a, Monad m) => String -> (Int -> a) -> (a -> Int) ->- Term ->- ExceptionalT Exception.Message m a+ RTerm ->+ Exception.MonadT m a checkRangeAuto typ fromInt0 toInt0 =- Exception.lift .- Exception.checkRangeAuto Exception.Term typ fromInt0 toInt0+ ME.liftT .+ Exception.checkRangeAuto Exception.messageTerm typ fromInt0 toInt0 data State =@@ -215,11 +215,20 @@ runSend sq = MS.mapStateT (ALSA.runSend sq) +splitWait :: Time.Milliseconds Integer -> RTerm -> RTerm+splitWait (Time.Time maxWait)+ t@(Term.Node consId [Term.Node waitId [Number nrng n], xs]) =+ if Term.name consId == ":" && Term.name waitId == "Wait" && n>maxWait+ then Term.Node consId [Term.Node waitId [Number nrng maxWait],+ Term.Node consId [Term.Node waitId [Number nrng (n-maxWait)], xs]]+ else t+splitWait _ t = t+ play :: Sequencer SndSeq.DuplexMode -> (Exception.Message -> IO ()) ->- Term ->- ExceptionalT Exception.Message (MS.StateT State IO) (Maybe Time)+ RTerm ->+ Exception.MonadT (MS.StateT State IO) (Maybe Time) play sq throwAsync x = case Term.viewNode x of Just ("Wait", [Number _ n]) -> do when (n<0) $ termException x $@@ -227,10 +236,9 @@ MT.lift $ AccM.set stateWaiting True return $ Just $ Time.milliseconds n - Just ( "Say", [StringLiteral rng arg] ) ->+ Just ("Say", [StringLiteral rng arg]) -> MT.lift $ (AccM.set stateWaiting False >>) $ liftIO $ do- let cmd = unwords- [ "echo", show arg, "|", "festival", "--tts" ]+ let cmd = unwords [ "echo", show arg, "|", "festival", "--tts" ] Log.put cmd void $ forkIO $ do Time.pause $ ALSA.latencyMicro sq@@ -244,10 +252,10 @@ Exit.ExitSuccess -> when (not (null errText)) $ throwAsync $- Exception.Message Exception.Term rng ("warning: " ++ errText)+ Exception.messageTerm rng ("warning: " ++ errText) Exit.ExitFailure _ -> throwAsync $- Exception.Message Exception.Term rng errText+ Exception.messageTerm rng errText return Nothing @@ -264,8 +272,8 @@ processChannelMsg :: Sequencer SndSeq.DuplexMode ->- (Port.T, CM.Channel) -> Term ->- ExceptionalT Exception.Message (MS.StateT State IO) (Maybe Time)+ (Port.T, CM.Channel) -> RTerm ->+ Exception.MonadT (MS.StateT State IO) (Maybe Time) processChannelMsg sq chanPort@(port, chan) body = do MT.lift $ AccM.set stateWaiting False let checkVelocity =@@ -458,7 +466,7 @@ {- FIXME: How to cope with the device id? -} case B.unpack msg of 0xF0 : 0x7F : 0x00 : 0x06 : cmds ->- forM_ (ExcA.result $ fst $+ forM_ (MEA.result $ fst $ MMC.runParser MMC.getCommands cmds) $ \cmd -> case cmd of MMC.RecordStrobe -> modifyIORef recording not
src/Exception.hs view
@@ -1,136 +1,149 @@ module Exception where import qualified Term-import Term ( Term, Range(Range) )+import qualified SourceText as Source+import qualified ModuleBase as Module+import Term ( Term )+import SourceText ( Range(Range), ModuleRange(ModuleRange) ) -import qualified Control.Monad.Exception.Synchronous as Exc+import qualified Control.Monad.Exception.Synchronous as ME import qualified Text.ParserCombinators.Parsec.Error as PErr import qualified Text.ParserCombinators.Parsec.Pos as Pos-import qualified Text.ParserCombinators.Parsec as Parsec import qualified Data.List as List +import Data.Maybe ( Maybe (Just, Nothing), maybe ) import Data.Bool.HT ( if' ) +import Prelude (+ String, Bounded, Int, Show, show, ($), (.), (++),+ maxBound, minBound,+ (<), fromInteger, fromIntegral,+ head, lines,+ return,+ ) -data Message = Message Type Range String++data Message = Message Type String -- deriving (Show) -data Type = Parse | Term | InOut- deriving (Show, Eq, Ord, Enum)+data Type = Parse Module.Source Range | Term ModuleRange | InOut Module.Source+ deriving (Show) +type Monad = ME.Exceptional Message+type MonadT = ME.ExceptionalT Message++messageParse :: Module.Source -> Range -> String -> Message+messageParse name = Message . Parse name++messageParseModuleRange :: ModuleRange -> String -> Exception.Message+messageParseModuleRange (ModuleRange modu _ rng) =+ messageParse (Module.Editor modu) rng++messageTerm :: ModuleRange -> String -> Message+messageTerm = Message . Term++messageInOut :: Module.Source -> String -> Message+messageInOut = Message . InOut++messageInOutEditor :: Module.Name -> String -> Exception.Message+messageInOutEditor = messageInOut . Module.Editor++ lineFromMessage :: Message -> [String]-lineFromMessage (Message typ (Range pos _) descr) =- Pos.sourceName pos :- show (Pos.sourceLine pos) : show (Pos.sourceColumn pos) :- stringFromType typ :- head (lines descr) :- []+lineFromMessage (Message typ descr) =+ case stringsFromType typ of+ (typeStr, name, mpos) ->+ name :+ maybe ["",""] (\(line,column) -> [line,column]) mpos +++ typeStr :+ head (lines descr) :+ [] statusFromMessage :: Message -> String-statusFromMessage (Message typ (Range pos _) descr) =- stringFromType typ ++ " - " ++- formatPos typ pos ++ " - " ++- flattenMultiline descr+statusFromMessage (Message typ descr) =+ case stringsFromType typ of+ (typeStr, name, mpos) ->+ typeStr ++ " - " +++ formatPos name mpos ++ " - " +++ flattenMultiline descr multilineFromMessage :: Message -> String-multilineFromMessage (Message typ (Range pos _) descr) =- stringFromType typ ++ " - " ++- formatPos typ pos ++ "\n" ++- descr+multilineFromMessage (Message typ descr) =+ case stringsFromType typ of+ (typeStr, name, mpos) ->+ typeStr ++ " - " +++ formatPos name mpos ++ "\n" +++ descr -formatPos :: Type -> Pos.SourcePos -> String-formatPos typ pos =- Pos.sourceName pos ++- (case typ of- InOut -> ""- _ ->- ':' : show (Pos.sourceLine pos) ++- ':' : show (Pos.sourceColumn pos))+formatPos :: String -> Maybe (String, String) -> String+formatPos name mpos =+ name ++ maybe "" (\(line,column) -> ':':line++':':column) mpos -stringFromType :: Type -> String-stringFromType typ =+stringsFromType :: Type -> (String, String, Maybe (String, String))+stringsFromType typ = case typ of- Parse -> "parse error"- Term -> "term error"- InOut -> "in/out error"+ Parse name rng ->+ ("parse error", Module.formatSource name,+ Just $ stringFromRange rng)+ Term (ModuleRange name _ rng) ->+ ("term error", Module.deconsName name, Just $ stringFromRange rng)+ InOut name ->+ ("in/out error", Module.formatSource name, Nothing) +stringFromRange :: Range -> (String, String)+stringFromRange (Range (Source.Position line column) _) =+ (show line, show column)+ flattenMultiline :: String -> String-flattenMultiline =- List.intercalate "; " . lines+flattenMultiline = List.intercalate "; " . lines -toParsec :: Message -> Parsec.Parser a-toParsec (Message _ rng msg) = do- Parsec.setPosition $ Term.start rng- fail msg--messageFromParserError :: PErr.ParseError -> Message-messageFromParserError err = Message- Parse- (let p = PErr.errorPos err- in Range p (Pos.updatePosChar p ' '))- (removeLeadingNewline $- PErr.showErrorMessages- "or" "unknown parse error"- "expecting" "unexpected" "end of input" $- PErr.errorMessages err)+messageFromParserError :: Module.Source -> PErr.ParseError -> Message+messageFromParserError source err =+ let p = PErr.errorPos err+ in messageParse source+ (Source.consRange p (Pos.updatePosChar p ' '))+ (removeLeadingNewline $+ PErr.showErrorMessages+ "or" "unknown parse error"+ "expecting" "unexpected" "end of input" $+ PErr.errorMessages err) removeLeadingNewline :: String -> String removeLeadingNewline ('\n':str) = str removeLeadingNewline str = str -dummyRange :: String -> Range-dummyRange f =- let pos = Pos.initialPos f- in Range pos pos -- checkRange :: (Bounded a) =>- Type ->+ (range -> String -> Message) -> String -> (Int -> a) -> (a -> Int) -> a -> a ->- Term ->- Exc.Exceptional Message a-checkRange excType typ fromInt toInt minb maxb (Term.Number rng x) =+ Term range ->+ Exception.Monad a+checkRange makeMsg typ fromInt toInt minb maxb (Term.Number rng x) = if' (x < fromIntegral (toInt minb))- (Exc.throw $ Message excType rng $+ (ME.throw $ makeMsg rng $ typ ++ " argument " ++ show x ++ " is less than minimum value " ++ show (toInt minb)) $ if' (fromIntegral (toInt maxb) < x)- (Exc.throw $ Message excType rng $- typ ++ " argument " ++ show x ++- " is greater than maximum value " ++ show (toInt maxb)) $+ (ME.throw $ makeMsg rng $+ typ ++ " argument " ++ show x +++ " is greater than maximum value " ++ show (toInt maxb)) $ return $ fromInt $ fromInteger x-checkRange excType typ _ _ _ _ t =- Exc.throw $- Message excType- (Term.termRange t) (typ ++ " argument is not a number")+checkRange makeMsg typ _ _ _ _ t =+ ME.throw $+ makeMsg (Term.termRange t) (typ ++ " argument is not a number") checkRangeAuto :: (Bounded a) =>- Type ->+ (range -> String -> Message) -> String -> (Int -> a) -> (a -> Int) ->- Term ->- Exc.Exceptional Message a-checkRangeAuto excType typ fromInt0 toInt0 =- checkRange excType typ fromInt0 toInt0 minBound maxBound------ also available in explicit-exception>=0.1.7-switchT ::- (Monad m) =>- (e -> m b) -> (a -> m b) ->- Exc.ExceptionalT e m a -> m b-switchT e s m = Exc.switch e s =<< Exc.runExceptionalT m--lift ::- (Monad m) =>- Exc.Exceptional e a -> Exc.ExceptionalT e m a-lift = Exc.ExceptionalT . return+ Term range ->+ Exception.Monad a+checkRangeAuto makeMsg typ fromInt0 toInt0 =+ checkRange makeMsg typ fromInt0 toInt0 minBound maxBound
src/GUI.hs view
@@ -38,7 +38,7 @@ Waits for and responds to incoming HTTP requests. -} -import qualified IO+import qualified InOut import qualified TermFocus import qualified Term import qualified Time@@ -47,11 +47,12 @@ import qualified Module import qualified Controller import qualified Rewrite+import qualified SourceText as Source import qualified Option import qualified Log import Program ( Program ) import TermFocus ( TermFocus )-import Term ( Term, Identifier )+import TermParser ( lexer ) import Option.Utility ( exitFailureMsg ) import Utility.WX ( cursor, editable, notebookSelection, splitterWindowSetSashGravity ) @@ -71,7 +72,7 @@ ( widget, container, layout, margin ) import Graphics.UI.WX.Types ( Color, rgb, fontFixed, Point2(Point), sz,- varCreate, varSwap, varUpdate )+ varCreate, varGet, varSet, varSwap, varUpdate ) import Control.Concurrent ( forkIO ) import qualified Control.Concurrent.Split.MVar as MVar import qualified Control.Concurrent.Split.Chan as Chan@@ -103,29 +104,32 @@ import qualified Control.Monad.Trans.State as MS import qualified Control.Monad.Trans.Writer as MW-import qualified Control.Monad.Exception.Synchronous as Exc+import qualified Control.Monad.Trans.Class as MT+import qualified Control.Monad.Exception.Synchronous as ME import Control.Monad.IO.Class ( liftIO )-import Control.Monad.Trans.Class ( lift ) import Control.Monad ( when, liftM, liftM2, forever )+import Control.Applicative ( (<$>) ) import Control.Functor.HT ( void ) import Data.Foldable ( forM_ )-import Data.Traversable ( forM )+import Data.Traversable ( forM, traverse ) 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.FilePath as FilePath +import qualified System.Path.IO as PathIO+import qualified System.Path as Path+ import qualified Data.Accessor.Monad.Trans.State as AccM import qualified Data.Accessor.Basic as Acc import qualified Data.Accessor.Tuple as AccTuple import qualified Data.Foldable as Fold import qualified Data.Sequence as Seq-import qualified Data.Map as M+import qualified Data.Map as Map+import Data.Map ( Map ) import qualified Data.Monoid as Mn @@ -145,42 +149,23 @@ opt <- Option.get (mainMod, p) <-- Exc.resolveT (exitFailureMsg . Exception.multilineFromMessage) $- case Option.moduleNames opt of- [] ->- return $- let name = Module.Name "Main"- in (name, Program.singleton $ Module.empty name)- names@(mainModName:_) ->- {-- If a file is not found, we setup an empty module.- If a file exists but contains parse errors- then we abort loading.- -}- fmap ((,) mainModName) $- flip MS.execStateT Program.empty $- mapM_- (\name -> do- epath <-- lift $ lift $ Exc.tryT $- Program.chaseFile (Option.importPaths opt)- (Module.makeFileName name)- case epath of- Exc.Success path -> do- voidStateT $- Program.load (Option.importPaths opt)- (Module.deconsName name) path- Exc.Exception _ ->- voidStateT $ Exception.lift .- Program.addModule (Module.empty name))- names+ ME.resolveT (exitFailureMsg . Exception.multilineFromMessage) $ do+ (names, p) <-+ Program.loadMany (Option.importPaths opt)+ Module.initVersion (Option.moduleNames opt)+ return $+ case names of+ [] -> (Module.mainName,+ Program.singleton $ Module.empty Module.mainName)+ mainModName:_ -> (mainModName, p) (guiIn,guiOut) <- Chan.new (machineIn,machineOut) <- TChan.newIO STM.atomically $ registerProgram machineIn mainMod p- ALSA.withSequencer opt $ \sq -> do+ ALSA.withSequencer opt $ \sq -> flip finally (ALSA.runSend sq ALSA.stopQueue) $ WX.start $ do- gui guiIn machineIn (forEvent machineOut)+ gui guiIn machineIn+ (forEvent machineOut) (Module.nextVersion Module.initVersion) void $ forkIO $ machine guiOut machineIn (processMidiCommand guiIn machineIn)@@ -203,12 +188,12 @@ PlayTerm MarkedText | ApplyTerm MarkedText data Modification =- Load FilePath+ Load Module.Version Path.AbsFile | NewModule | CloseModule Module.Name | FlushModules Module.Name- | RefreshModule (Maybe (MVar.In HTTPGui.Feedback)) Module.Name String Int- -- ^ MVar of the HTTP server, modulename, sourcetext, position+ | RefreshModule (Maybe (MVar.In HTTPGui.Feedback)) Module.Name Module.Version String Int+ -- ^ MVar of the HTTP server, module name, module version, sourcetext, position -- | messages that are sent from machine to GUI@@ -216,9 +201,10 @@ ReductionSteps { _steps :: [ Rewrite.Source ] } | CurrentTerm { _range :: (Int, Int), _currentTerm :: String } | Exception { _message :: Exception.Message }- | Register { _mainModName :: Module.Name, _modules :: M.Map Module.Name Module.Module }- | Refresh { _moduleName :: Module.Name, _content :: String, _position :: Int }- | SelectPage Module.Name ( Maybe Term.Range )+ | Register { _mainModName :: Module.Name, _modules :: Map Module.Name Module.Module }+ | Refresh { _moduleName :: Module.Name, _version :: Module.Version,+ _content :: String, _position :: Int }+ | PopupIdentifier Identifier | InsertPage { _activate :: Bool, _module :: Module.Module } | DeletePage Module.Name | RenamePage Module.Name Module.Name@@ -229,45 +215,40 @@ | Running { _runningMode :: Event.WaitMode } | ResetDisplay +type Term = Term.Term Source.ModuleRange+type Identifier = Term.Identifier Source.ModuleRange+ -- | the messages describe the steps towards the stateTerm-data State = State { stateMessages :: Maybe [ Rewrite.Message ], stateTerm :: Term }+data State =+ State {+ stateMessages :: Maybe [ Rewrite.Message ],+ stateTerm :: Term+ } initialState :: State-initialState = State Nothing Term.mainName+initialState = State Nothing Term.main stateFromTerm :: Term -> State stateFromTerm t = State Nothing t -exceptionToGUI ::- TChan.In GuiUpdate ->- Exc.ExceptionalT Exception.Message STM () ->- STM ()+exceptionToGUI :: TChan.In GuiUpdate -> Exception.MonadT STM () -> STM () exceptionToGUI output =- Exc.resolveT (TChan.write output . Exception)+ ME.resolveT (TChan.write output . Exception) -exceptionToGUIIO ::- TChan.In GuiUpdate ->- Exc.ExceptionalT Exception.Message IO () ->- IO ()+exceptionToGUIIO :: TChan.In GuiUpdate -> Exception.MonadT IO () -> IO () exceptionToGUIIO output =- Exc.resolveT (TChan.writeIO output . Exception)+ ME.resolveT (TChan.writeIO output . Exception) -parseTerm ::- (Monad m, IO.Input a) =>- MarkedText -> Exc.ExceptionalT Exception.Message m a-parseTerm (MarkedText pos str) =- case Parsec.parse- (Parsec.setPosition pos- >>- Parsec.between- (Token.whiteSpace Term.lexer)- Parsec.eof- IO.input)- "" str of- Left msg ->- Exc.throwT $ Exception.messageFromParserError msg- Right t -> return t+parseTerm :: (Monad m, InOut.Input a) => MarkedText -> Exception.MonadT m a+parseTerm (MarkedText modu pos str) =+ ME.mapExceptionT (Exception.messageFromParserError (Module.Editor modu)) $+ ME.liftT $ ME.fromEither $+ Parsec.parse+ (Parsec.setPosition (Source.makeParsecPos modu pos)+ >>+ Parsec.between (Token.whiteSpace lexer) Parsec.eof InOut.input)+ "" str processMidiCommand ::@@ -278,11 +259,12 @@ Event.NoteInput p -> TChan.writeIO guiChan . InsertText . formatPitch $ p Event.Transportation trans ->+ Chan.write machineChan $ Execution $ case trans of- Event.Play -> Chan.write machineChan $ Execution Restart- Event.Stop -> Chan.write machineChan $ Execution Stop- Event.Pause -> Chan.write machineChan $ Execution SwitchMode- Event.Forward -> Chan.write machineChan $ Execution $ NextStep Event.NextElement+ Event.Play -> Restart+ Event.Stop -> Stop+ Event.Pause -> SwitchMode+ Event.Forward -> NextStep Event.NextElement formatPitch :: VM.Pitch -> String formatPitch p =@@ -316,16 +298,17 @@ would block the read access by the interpreter. -} modifyModule ::- [ FilePath ] ->+ [ Path.AbsDir ] -> TVar Program -> TChan.In GuiUpdate -> Module.Name ->+ Module.Version -> String -> Int -> IO (Maybe Exception.Message)-modifyModule importPaths program output moduleName sourceCode pos = do+modifyModule importPaths program output moduleName vers sourceCode pos = do p <- readTVarIO program- Exception.switchT+ ME.switchT (\e -> do TChan.writeIO output $ Exception e return $ Just e)@@ -336,16 +319,17 @@ -- Log.put "parsed and modified OK" return Nothing) $ do let exception =- Exception.Message Exception.Parse (Module.nameRange moduleName)+ Exception.messageParse+ (Module.Editor moduleName) Source.emptyRange previous <-- case M.lookup moduleName $ Program.modules p of- Nothing ->- Exc.throwT $ exception $- Module.tellName moduleName ++ " does no longer exist"- Just m -> return m+ ME.liftT $+ ME.fromMaybe+ (exception $+ Module.tellName moduleName ++ " does no longer exist") $+ Map.lookup moduleName $ Program.modules p m <-- Exception.lift $ Module.parse- (Module.deconsName moduleName)+ ME.liftT $ Module.parse vers+ (Just moduleName) (Module.sourceLocation previous) sourceCode {- My first thought was that renaming of modules@@ -361,22 +345,22 @@ MW.runWriterT $ do p1 <- if' (moduleName == Module.name m)- (lift $ Exception.lift $ Program.replaceModule m p) $+ (MT.lift $ ME.liftT $ Program.replaceModule m p) $ if' allowRename (do- lift $ Exc.assertT+ MT.lift $ ME.assertT (exception $ Module.tellName (Module.name m) ++ " already exists")- (not $ M.member (Module.name m) $ Program.modules p)+ (Map.notMember (Module.name m) $ Program.modules p) MW.tell [ RenamePage moduleName (Module.name m) ]- lift $ Exception.lift $ Program.addModule m $+ MT.lift $ ME.liftT $ Program.addModule m $ Program.removeModule moduleName p) $- (lift $ Exc.throwT $ exception+ (MT.lift $ ME.throwT $ exception "module name does not match page name and renaming is disallowed")- p2 <- lift $ Program.chaseImports importPaths m p1- MW.tell $ map (InsertPage False) $ M.elems $- M.difference ( Program.modules p2 ) ( Program.modules p1 )+ p2 <- MT.lift $ Program.chaseImports importPaths vers m p1+ MW.tell $ map (InsertPage False) $ Map.elems $+ Map.difference ( Program.modules p2 ) ( Program.modules p1 ) -- Refresh must happen after a Rename- MW.tell [ Refresh (Module.name m) sourceCode pos,+ MW.tell [ Refresh (Module.name m) vers sourceCode pos, RebuildControllers $ Program.controls p2 ] return p2 @@ -404,7 +388,7 @@ -- (log message (for highlighting), current term) -> (Event.Command -> IO ()) -> Option.Limits- -> [FilePath]+ -> [ Path.AbsDir ] -> Program -- ^ initial program -> ALSA.Sequencer SndSeq.DuplexMode -> IO ()@@ -431,9 +415,9 @@ Control event -> do Log.put $ show event STM.atomically $ exceptionToGUI output $ do- p <- lift $ readTVar program- p' <- Exception.lift $ Controller.changeControllerModule p event- lift $ writeTVar program p'+ p <- MT.lift $ readTVar program+ p' <- ME.liftT $ Controller.changeControllerModule p event+ MT.lift $ writeTVar program p' -- return $ Controller.getControllerModule p' -- Log.put $ show m @@ -452,14 +436,15 @@ NextStep cont -> Chan.write waitIn $ Event.NextStep cont PlayTerm txt -> exceptionToGUIIO output $ do t <- parseTerm txt- lift $ withMode Event.RealTime+ MT.lift $ withMode Event.RealTime Event.forwardQuietContinueQueue- (writeTMVar term $ stateFromTerm t)+ (writeTMVar term $ stateFromTerm $+ fmap Source.setRangeNoVersion t) ApplyTerm txt -> exceptionToGUIIO output $ do fterm <- parseTerm txt- case fterm of+ case fmap Source.setRangeNoVersion fterm of Term.Node f xs ->- lift $ STM.atomically $ do+ MT.lift $ STM.atomically $ do t0 <- readTMVar term let t1 = Term.Node f (xs ++ [stateTerm t0]) writeTMVar term $ stateFromTerm t1@@ -469,41 +454,41 @@ "applied function term " ++ show (markedString txt) _ ->- Exc.throwT .- Exception.Message Exception.Parse (Term.termRange fterm) $+ ME.throwT .+ Exception.messageParse+ (Module.Editor $ markedModuleName txt)+ (Term.termRange fterm) $ "tried to apply the non-function term " ++ show (markedString txt) Modification modi -> case modi of- RefreshModule feedback moduleName sourceCode pos -> do+ RefreshModule feedback moduleName vers sourceCode pos -> do Log.put $ Module.tellName moduleName ++ " has new input\n" ++ sourceCode- case feedback of- Nothing ->- void $- modifyModule importPaths program output moduleName sourceCode pos- Just mvar -> do- x <- modifyModule importPaths program output moduleName sourceCode pos- MVar.put mvar $ Exc.Success+ x <- modifyModule importPaths program output+ moduleName vers sourceCode pos+ forM_ feedback $ \mvar ->+ MVar.put mvar $+ ME.Success (fmap Exception.multilineFromMessage x, sourceCode) - Load filePath -> do+ Load vers filePath -> do Log.put $- "load " ++ filePath ++ " and all its dependencies"+ "load " ++ Path.toString filePath +++ " and all its dependencies" exceptionToGUIIO output $ do- let stem = FilePath.takeBaseName filePath p <-- Program.load importPaths stem filePath- Program.empty- lift $ do+ Program.load importPaths+ vers filePath Program.empty+ MT.lift $ do withMode Event.RealTime Event.forwardQuietContinueQueue $ do- writeTVar program p+ writeTVar program (snd p) writeTMVar term initialState- registerProgram output (Module.Name stem) p+ uncurry (registerProgram output) p Log.put "chased and parsed OK" NewModule ->@@ -511,36 +496,36 @@ prg <- readTVar program let modName = head $- filter (not . flip M.member (Program.modules prg)) $+ filter (flip Map.notMember (Program.modules prg)) $ map (Module.Name . ("New"++)) $ "" : map show (iterate (1+) (1::Integer)) modu = Module.empty modName case Program.addModule modu prg of- Exc.Exception e ->+ ME.Exception e -> error ("new module has no declarations and thus should not lead to conflicts with existing modules - " ++ Exception.statusFromMessage e)- Exc.Success newPrg ->+ ME.Success newPrg -> liftSTM $ updateProgram program output newPrg liftSTM $ TChan.write output $ InsertPage True modu CloseModule modName -> STM.atomically $ exceptionToGUI output $- Exc.mapExceptionT- (Module.inoutExceptionMsg modName .+ ME.mapExceptionT+ (Exception.messageInOutEditor modName . ("cannot close module: " ++)) $ do prg <- liftSTM $ readTVar program let modules = Program.modules prg importingModules =- M.keys $- M.filter (elem modName . map Module.source .+ Map.keys $+ Map.filter (elem modName . map Module.source . Module.imports) $- M.delete modName modules- flip Exc.assertT (null importingModules) $+ Map.delete modName modules+ flip ME.assertT (null importingModules) $ "it is still imported by " ++ formatModuleList importingModules- flip Exc.assertT (M.member modName modules) $+ flip ME.assertT (Map.member modName modules) $ "it does not exist"- flip Exc.assertT (M.size modules > 1) $+ flip ME.assertT (Map.size modules > 1) $ "there must remain at least one module" liftSTM $ updateProgram program output $ Program.removeModule modName prg@@ -587,15 +572,15 @@ void $ Event.runSend sq $ Event.sendEcho Event.visualizeId (ALSA.latencyNano sq) (mdur, updates) <- MW.runWriterT $ do- waiting <- lift $ AccM.get Event.stateWaiting+ waiting <- MT.lift $ AccM.get Event.stateWaiting when waiting $ writeUpdate ResetDisplay- maxEventsSat <- lift $ checkMaxEvents limits+ maxEventsSat <- MT.lift $ checkMaxEvents limits executeStep limits program term sendWarning sq maxEventsSat {- This update will take effect when the above visualisation trigger event arrives. -}- lift $ Chan.write delayedUpdatesIn updates+ MT.lift $ Chan.write delayedUpdatesIn updates Event.wait sq waitChan mdur {-@@ -638,11 +623,11 @@ MW.WriterT [ GuiUpdate ] ( MS.StateT Event.State IO ) ( Maybe ALSA.Time ) executeStep limits program term sendWarning sq maxEventsSat = do- waitMode <- lift $ AccM.get Event.stateWaitMode- Exception.switchT+ waitMode <- MT.lift $ AccM.get Event.stateWaitMode+ ME.switchT (\e -> do -- liftIO $ ALSA.stopQueue sq- currentTime <- lift $ AccM.get Event.stateTime+ currentTime <- MT.lift $ AccM.get Event.stateTime liftIO $ Log.put "executeStep: stopQueueLater" newTime <- liftIO $ ALSA.runSend sq $ ALSA.stopQueueLater currentTime@@ -653,8 +638,8 @@ We have to alter the mode directly, 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+ MT.lift $ AccM.set Event.stateWaitMode Event.singleStep+ MT.lift $ AccM.set Event.stateTime newTime return Nothing) (\(mx,s) -> do {-@@ -664,12 +649,12 @@ case mx of Nothing -> return Nothing Just x ->- Exc.resolveT+ ME.resolveT (fmap (const Nothing) . writeUpdate . Exception)- (Exc.mapExceptionalT lift $+ (ME.mapExceptionalT MT.lift $ Event.play sq sendWarning x) - waiting <- lift $ AccM.get Event.stateWaiting+ waiting <- MT.lift $ AccM.get Event.stateWaiting {- This way the term will be pretty printed in the GUI thread which may block the GUI thread.@@ -684,11 +669,11 @@ ", term depth: " ++ ( show $ length $ Term.breadths s ) -} return wait)- (Exc.mapExceptionalT (MW.mapWriterT (liftIO . STM.atomically)) $- flip Exc.catchT (\(pos,msg) -> do+ (ME.mapExceptionalT (MW.mapWriterT (liftIO . STM.atomically)) $+ ME.catchT (computeStep limits program term maxEventsSat waitMode) $+ \(pos,msg) -> do liftSTM $ putTMVar term initialState- Exc.throwT $ Exception.Message Exception.Term pos msg) $- computeStep limits program term maxEventsSat waitMode)+ ME.throwT $ Exception.messageTerm pos msg) computeStep ::@@ -698,8 +683,8 @@ TMVar State -> Bool -> Event.WaitMode ->- Exc.ExceptionalT- (Term.Range, String)+ ME.ExceptionalT+ (Source.ModuleRange, String) (MW.WriterT [GuiUpdate] m) (Maybe Term, TermFocus) computeStep limits program term maxEventsSat waitMode = do@@ -707,13 +692,19 @@ p <- liftSTM $ readTVar program {- this happens anew at each click since the program text might have changed in the editor -}- Exc.assertT+ ME.assertT (Term.termRange $ stateTerm t, "too many events in a too short period") maxEventsSat - let forceHead =- Exc.mapExceptionalT- (liftM (\(ms,msgs) -> fmap ((,) msgs) ms) .+ let forceHead ::+ (Monad m) =>+ ME.ExceptionalT (Source.ModuleRange, String)+ (MW.WriterT [GuiUpdate] m) ([Rewrite.Message], Term)+ forceHead =+ ME.mapExceptionalT+ (liftM (\(ms,msgs) ->+ (,) msgs . Event.splitWait (Option.splitWait limits)+ <$> ms) . MW.runWriterT) $ Rewrite.runEval (Option.maxReductions limits) p@@ -746,11 +737,7 @@ -} x@(_, _, mst) <- nextReduction case do {st <- maybeToList mst; Rewrite.AttemptRule r <- fst $ splitAtReduction $ fst st; return r} of- (f : _) ->- lift $ writeUpdate $- SelectPage- (Module.nameFromIdentifier f)- (Just $ Term.range f)+ (f : _) -> MT.lift $ writeUpdate $ PopupIdentifier f _ -> return () return x _ -> do@@ -766,30 +753,30 @@ case mst of Nothing -> do let s = TermFocus.subTerm focusedTerm- Exc.assertT+ ME.assertT (Term.termRange s, "term size exceeds limit " ++ show (Option.maxTermSize limits)) (null $ drop (Option.maxTermSize limits) $ Term.subterms s)- Exc.assertT+ ME.assertT (Term.termRange s, "term depth exceeds limit " ++ show (Option.maxTermDepth limits)) (null $ drop (Option.maxTermDepth limits) $ Term.breadths s)- lift $ writeUpdate $ ReductionSteps steps+ MT.lift $ writeUpdate $ ReductionSteps steps case Term.viewNode s of Just (":", [x, xs]) -> do liftSTM $ putTMVar term $ stateFromTerm xs return (Just x) Just ("[]", []) -> do- lift $ writeUpdate $ uncurry CurrentTerm $+ MT.lift $ writeUpdate $ uncurry CurrentTerm $ TermFocus.format $ TermFocus.fromTerm s- Exc.throwT (Term.termRange s, "finished.")+ ME.throwT (Term.termRange s, "finished.") _ -> do- lift $ writeUpdate $ uncurry CurrentTerm $+ MT.lift $ writeUpdate $ uncurry CurrentTerm $ TermFocus.format $ TermFocus.fromTerm s- Exc.throwT (Term.termRange s,+ ME.throwT (Term.termRange s, "I do not know how to handle this term: " ++ show s) Just (msgs, nt) -> do- lift $ writeUpdate $ ReductionSteps steps+ MT.lift $ writeUpdate $ ReductionSteps steps liftSTM $ putTMVar term $ State (Just msgs) nt return Nothing @@ -802,10 +789,7 @@ splitAtReduction (Rewrite.Source s : ms) = mapFst (s:) $ splitAtReduction ms -voidStateT :: (Monad m) => (s -> m s) -> MS.StateT s m ()-voidStateT f = MS.StateT $ liftM ((,) ()) . f - writeUpdate :: (Monad m) => GuiUpdate -> MW.WriterT [GuiUpdate] m ()@@ -851,17 +835,16 @@ -- (if the program text changes due to an edit action) -> TChan.In GuiUpdate -> (WX.Frame () -> (GuiUpdate -> IO ()) -> IO ())+ -> Module.Version -> IO ()-gui input output procEvent = do- panels <- newIORef M.empty+gui input output procEvent initVersion = do+ panels <- newIORef Map.empty frameError <- newFrameError frameControls <- WX.frame [ text := "controls" ] - f <- WX.frame- [ text := "live-sequencer", visible := False- ]+ f <- WX.frame [ text := "live-sequencer", visible := False ] p <- WX.panel f [ ] @@ -938,8 +921,7 @@ _restartItem <- WX.menuItem execMenu [ text := "Res&tart\tCtrl-T", on command := Chan.write input (Execution Restart),- help :=- "stop sound and restart program execution with 'main'" ]+ help := "stop sound and restart program execution with 'main'" ] playTermItem <- WX.menuItem execMenu [ text := "Play term\tCtrl-M", help :=@@ -969,20 +951,21 @@ [ text := "Slower\tCtrl-<", enabled := False, help := "increase pause in slow motion mode" ]+ let sendNextStep = Chan.write input . Execution . NextStep nextElemItem <- WX.menuItem execMenu [ text := "Next element\tCtrl-N", enabled := False,- on command := Chan.write input (Execution $ NextStep Event.NextElement),+ on command := sendNextStep Event.NextElement, help := "compute next list element in single step mode" ] nextRedItem <- WX.menuItem execMenu [ text := "Next reduction\tCtrl-Shift-N", enabled := False,- on command := Chan.write input (Execution $ NextStep Event.NextReduction),+ on command := sendNextStep Event.NextReduction, help := "compute next reduction in single step mode" ] nextShowItem <- WX.menuItem execMenu [ text := "Next reduction and highlight rule\tCtrl-U", enabled := False,- on command := Chan.write input (Execution $ NextStep Event.NextReductionShow),+ on command := sendNextStep Event.NextReductionShow, help := "compute next reduction in single step mode " ++ "and highlight currently processed rule" ] @@ -1024,54 +1007,79 @@ splitter <- WX.splitterWindow p [] nb <- WX.notebook splitter [ ]+ let getCurrentPanel = getFromNotebook nb =<< readIORef panels+ let selectNotebook i = set nb [ notebookSelection := i ] reducer <- textCtrlMono splitter [ editable := False ] status <- WX.statusField [ text := "Welcome to interactive music composition with Haskell" ]+ let setStatus msg = set status [ text := msg ] - let handleException moduleName act = do- result <- try act- case result of- Left err ->- TChan.writeIO output $ Exception $- Module.inoutExceptionMsg moduleName $- Err.ioeGetErrorString err- Right () -> return ()+ let sendExceptionInOut moduleName =+ TChan.writeIO output . Exception .+ Exception.messageInOutEditor moduleName + let handleException moduleName act =+ either+ (sendExceptionInOut moduleName . Err.ioeGetErrorString)+ return+ =<< try act++ {-+ We need a global version for correct handling of two scenarios:+ 1. A module is deleted and later a new module with the same name is added, again.+ Now consider identifiers in the current term that refer to the old module.+ We must not follow these references anymore+ even if the module is re-added with the same name.+ With per-module versions we would have to store the versions+ even after removal of the module.+ 2. A module is renamed.+ The version would have to be adapted to the last version number+ of a possibly already deleted module+ and we have to maintain the version of the old module name.++ Nonetheless, multiple modules can get the same version+ if they are loaded as imports of a module.+ -}+ nextVersion <- flip varUpdate Module.nextVersion <$> varCreate initVersion+ set loadItem [ on command := do mfilename <- WX.fileOpenDialog f False {- change current directory -} True "Load Haskell program" haskellFilenames "" ""- forM_ mfilename $ Chan.write input . Modification . Load+ forM_ mfilename $ \filename -> do+ vers <- nextVersion+ Chan.write input . Modification . Load vers . Path.file+ $ filename ] set reloadItem [ on command := do- (moduleName, pnl) <-- getFromNotebook nb =<< readIORef panels+ (moduleName, pnl) <- getCurrentPanel let path = sourceLocation pnl handleException moduleName $ do- content <- readFile path+ content <- PathIO.readFile path set (editor pnl) [ text := content ]- set status [- text := Module.tellName moduleName ++ " reloaded from " ++ path ]+ setStatus $+ Module.tellName moduleName ++ " reloaded from " +++ Path.toString path ] let getCurrentModule = do- (moduleName, pnl) <-- getFromNotebook nb =<< readIORef panels+ (moduleName, pnl) <- getCurrentPanel content <- get (editor pnl) text return (sourceLocation pnl, moduleName, content) saveModule (path, moduleName, content) = handleException moduleName $ do -- Log.put path- writeFile path content- set status [- text := Module.tellName moduleName ++ " saved to " ++ path ]+ PathIO.writeFile path content+ setStatus $+ Module.tellName moduleName +++ " saved to " ++ Path.toString path set saveItem [ on command := do@@ -1080,15 +1088,17 @@ set saveAsItem [ on command := do (filePath, moduleName, content) <- getCurrentModule- let (path,file) = FilePath.splitFileName filePath+ let (path,file) = Path.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+ mfilename <-+ WX.fileSaveDialog+ f False {- change current directory -} True+ ("Save " ++ Module.tellName moduleName)+ haskellFilenames (Path.toString path) (Path.toString file)+ forM_ (fmap Path.file mfilename) $ \fileName -> do saveModule (fileName, moduleName, content) modifyIORef panels $- M.adjust+ Map.adjust (\pnl -> pnl { sourceLocation = fileName }) moduleName ]@@ -1102,28 +1112,35 @@ set closeModuleItem [ on command := Chan.write input . Modification . CloseModule . fst- =<< getFromNotebook nb =<< readIORef panels+ =<< getCurrentPanel ] set flushModulesItem [ on command := Chan.write input . Modification . FlushModules . fst- =<< getFromNotebook nb =<< readIORef panels+ =<< getCurrentPanel ] let refreshProgram (moduleName, pnl) = do+ vers <- nextVersion s <- get (editor pnl) text pos <- get (editor pnl) cursor- Chan.write input $ Modification $ RefreshModule Nothing moduleName s pos+ Chan.write input $ Modification $+ RefreshModule Nothing moduleName vers s pos updateErrorLog frameError $ Seq.filter $- \(Exception.Message _ errorRng _) ->- Module.deconsName moduleName /=- Pos.sourceName (Term.start errorRng)+ \(Exception.Message typ _) ->+ case typ of+ Exception.Parse source _ ->+ Just moduleName /= Module.maybeEditor source+ Exception.Term errorRng ->+ moduleName /= Source.extractModuleName errorRng+ Exception.InOut source ->+ Just moduleName /= Module.maybeEditor source set refreshItem [ on command := do- refreshProgram =<< getFromNotebook nb =<< readIORef panels+ refreshProgram =<< getCurrentPanel -- mapM_ refreshProgram pnls ] @@ -1131,15 +1148,13 @@ [ on command := Chan.write input . Execution . PlayTerm =<< uncurry getMarkedExpr . mapSnd editor- =<< getFromNotebook nb- =<< readIORef panels ]+ =<< getCurrentPanel ] set applyTermItem [ on command := Chan.write input . Execution . ApplyTerm =<< uncurry getMarkedExpr . mapSnd editor- =<< getFromNotebook nb- =<< readIORef panels ]+ =<< getCurrentPanel ] waitDuration <- newIORef $ Time.milliseconds 500 @@ -1154,16 +1169,16 @@ \d -> max slowmoUnit (Time.sub d slowmoUnit) updateSlowMotionDur d <- readIORef waitDuration- set status [ text :=- "decreased pause to " ++ Time.format d ] ]+ setStatus $ "decreased pause to " ++ Time.format d+ ] set slowerItem [ on command := do modifyIORef waitDuration $ Mn.mappend slowmoUnit updateSlowMotionDur d <- readIORef waitDuration- set status [ text :=- "increased pause to " ++ Time.format d ] ]+ setStatus $ "increased pause to " ++ Time.format d+ ] let setRealTime b = do set realTimeItem [ checked := b ]@@ -1234,7 +1249,7 @@ Maybe this is a race condition. -} do- pnl <- displayModule nb (Module.empty $ Module.Name "Dummy")+ pnl <- createPanel nb (Module.empty $ Module.Name "Dummy") void $ WXCMZ.notebookAddPage nb (panel pnl) "Dummy" True (-1) set f [@@ -1250,23 +1265,23 @@ , clientSize := sz 1280 720 ] - onErrorSelection frameError $ \(Exception.Message typ errorRng _descr) -> do- let moduleIdent =- Module.Name $- Pos.sourceName $ Term.start errorRng+ onErrorSelection frameError $ \(Exception.Message typ _descr) -> do pnls <- readIORef panels- forM_ (liftM2 (,)- (M.lookupIndex moduleIdent pnls)- (M.lookup moduleIdent pnls)) $- \ (i,pnl) -> do- set nb [ notebookSelection := i ]- case typ of- Exception.Parse ->- flip markText errorRng $ editor pnl- Exception.Term ->- flip markText errorRng $ highlighter pnl- Exception.InOut ->- return ()+ case typ of+ Exception.Parse source errorRng ->+ forM_ (Module.maybeEditor source) $ \name ->+ forM_ (lookupPlusIndex name pnls) $ \(i,pnl) -> do+ selectNotebook i+ markText (editor pnl) errorRng+ Exception.Term (Source.ModuleRange name vers errorRng) ->+ forM_ (lookupPlusIndex name pnls) $ \(i,pnl) -> do+ selectNotebook i+ pnlVersion <- varGet $ moduleVersion pnl+ when (Module.equalVersion pnlVersion vers) $+ markText (highlighter pnl) errorRng+ Exception.InOut source ->+ forM_ (Module.maybeEditor source) $ \name ->+ forM_ (Map.lookupIndex name pnls) selectNotebook let closeOther = writeIORef appRunning False >>@@ -1277,7 +1292,12 @@ focusOn f - highlights <- varCreate M.empty+ highlights <- varCreate Map.empty+ let versionedHighlighters =+ traverse+ (\pnl ->+ (,) (highlighter pnl) <$> varGet (moduleVersion pnl))+ =<< readIORef panels procEvent f $ \msg -> case msg of@@ -1289,15 +1309,14 @@ ) ReductionSteps steps -> do- hls <- fmap (fmap highlighter) $ readIORef panels- visibleModule <- fmap fst $ getFromNotebook nb hls- let highlight ::- Int -> Int -> Int -> [Identifier] -> IO ()+ hls <- versionedHighlighters+ visibleModule <- fst <$> getFromNotebook nb hls+ let highlight :: Int -> Int -> Int -> [Identifier] -> IO () highlight r g b idents = do- let m = M.fromListWith (++) $+ let m = Map.fromListWith (++) $ filter ((visibleModule==) . fst) $ map (\ident -> (Module.nameFromIdentifier ident, [ident])) idents- void $ varUpdate highlights $ M.unionWith (++) $ m+ void $ varUpdate highlights $ Map.unionWith (++) m setColor hls ( rgb r g b ) m let prep step =@@ -1315,36 +1334,36 @@ highlight 200 200 0 origins ResetDisplay -> do- hls <- fmap (fmap highlighter) $ readIORef panels+ hls <- versionedHighlighters setColor hls WXCore.white- =<< varSwap highlights M.empty+ =<< varSwap highlights Map.empty Exception exc -> do addToErrorLog frameError exc- set status [ text := Exception.statusFromMessage exc ]+ setStatus $ Exception.statusFromMessage exc -- update highlighter text field only if parsing was successful- Refresh moduleName s pos -> do+ Refresh moduleName vers s pos -> do pnls <- readIORef panels Fold.mapM_- (\pnl -> set (highlighter pnl) [ text := s, cursor := pos ])- (M.lookup moduleName pnls)- set status [ text :=- Module.tellName moduleName ++ " reloaded into interpreter" ]+ (\pnl -> do+ varSet (moduleVersion pnl) (Just vers)+ set (highlighter pnl) [ text := s, cursor := pos ])+ (Map.lookup moduleName pnls)+ setStatus $+ Module.tellName moduleName ++ " reloaded into interpreter" InsertText str -> do- pnl <- fmap snd $ getFromNotebook nb =<< readIORef panels+ pnl <- snd <$> getCurrentPanel WXCMZ.textCtrlWriteText (editor pnl) str- set status [ text :=- "inserted note from external controller" ]+ setStatus "inserted note from external controller" - StatusLine str -> do- set status [ text := str ]+ StatusLine str -> setStatus str Register mainModName mods -> do void $ WXCMZ.notebookDeleteAllPages nb (writeIORef panels =<<) $ forM mods $ \modu -> do- pnl <- displayModule nb modu+ pnl <- createPanel nb modu void $ WXCMZ.notebookAddPage nb (panel pnl) (Module.deconsName $ Module.name modu) (Module.name modu == mainModName) (-1)@@ -1352,66 +1371,60 @@ updateErrorLog frameError (const Seq.empty) - set status [ text :=- "modules loaded: " ++ formatModuleList ( M.keys mods ) ]+ setStatus $+ "modules loaded: " ++ formatModuleList ( Map.keys mods ) - SelectPage modName mrng -> do+ PopupIdentifier ident -> do+ let Source.ModuleRange name vers rng = Term.range ident pnls <- readIORef panels- forM_ (liftM2 (,)- (M.lookupIndex modName pnls)- (M.lookup modName pnls)) $- \ (i,pnl) -> do- set nb [ notebookSelection := i ]- Fold.mapM_ ( markText ( highlighter pnl ) ) mrng+ forM_ (lookupPlusIndex name pnls) $ \ (i,pnl) -> do+ selectNotebook i+ pnlVersion <- varGet $ moduleVersion pnl+ when (Module.equalVersion pnlVersion vers) $+ markText ( highlighter pnl ) rng InsertPage act modu -> do pnls <- readIORef panels- pnl <- displayModule nb modu+ pnl <- createPanel nb modu let modName = Module.name modu- newPnls = M.insert modName pnl pnls+ newPnls = Map.insert modName pnl pnls writeIORef panels newPnls success <- WXCMZ.notebookInsertPage nb- (M.findIndex modName newPnls) (panel pnl)+ (Map.findIndex modName newPnls) (panel pnl) (Module.deconsName modName) act (-1) {- FIXME: if the page cannot be added, we get an inconsistency - how to solve that? -} if success- then- set status [ text := "new " ++ Module.tellName modName ]+ then setStatus $ "new " ++ Module.tellName modName else- TChan.writeIO output $ Exception $- Module.inoutExceptionMsg modName $+ sendExceptionInOut modName $ "Panic: cannot add page for the module" DeletePage modName -> do pnls <- readIORef panels- forM_ ( M.lookupIndex modName pnls ) $+ forM_ ( Map.lookupIndex modName pnls ) $ WXCMZ.notebookDeletePage nb- writeIORef panels $ M.delete modName pnls- set status [ text := "closed " ++ Module.tellName modName ]+ writeIORef panels $ Map.delete modName pnls+ setStatus $ "closed " ++ Module.tellName modName RenamePage fromName toName -> do pnls <- readIORef panels- forM_- ( liftM2 (,)- ( M.lookupIndex fromName pnls )- ( M.lookup fromName pnls ) ) $ \(i,pnl) -> do+ forM_ ( lookupPlusIndex fromName pnls ) $ \(i,pnl) -> do success <- WXCMZ.notebookRemovePage nb i when (not success) $- TChan.writeIO output $ Exception $- Module.inoutExceptionMsg fromName $+ sendExceptionInOut fromName $ "Panic: cannot remove page for renaming module" let newPnls =- M.insert toName pnl $ M.delete fromName pnls+ Map.insert toName pnl $ Map.delete fromName pnls writeIORef panels newPnls- forM_ ( M.lookupIndex toName newPnls ) $ \j ->+ forM_ ( Map.lookupIndex toName newPnls ) $ \j -> WXCMZ.notebookInsertPage nb j (panel pnl) (Module.deconsName toName) True (-1)- set status [ text := "renamed " ++ Module.tellName fromName ++- " to " ++ Module.tellName toName ]+ setStatus $ "renamed " ++ Module.tellName fromName +++ " to " ++ Module.tellName toName RebuildControllers ctrls -> Controller.create frameControls ctrls $@@ -1420,25 +1433,27 @@ Running mode -> do case mode of Event.RealTime -> do- set status [ text := "interpreter in real-time mode" ]+ setStatus "interpreter in real-time mode" activateRealTime Event.SlowMotion dur -> do- set status [ text :=- ("interpreter in slow-motion mode with pause " ++- Time.format dur) ]+ setStatus $+ "interpreter in slow-motion mode with pause " +++ Time.format dur activateSlowMotion Event.SingleStep _ -> do- set status [ text :=+ setStatus $ "interpreter in single step mode," ++- " waiting for next step" ]+ " waiting for next step" activateSingleStep HTTP request -> do pnls <- readIORef panels HTTPGui.update- (\contentMVar name newContent pos ->+ (\contentMVar name newContent pos -> do+ vers <- nextVersion Chan.write input $ Modification $- RefreshModule (Just contentMVar) name newContent pos)+ RefreshModule (Just contentMVar) name vers+ newContent pos) status (fmap editor pnls) request @@ -1503,7 +1518,7 @@ case ev of WXEvent.ListItemSelected n -> do errors <- readIORef (errorList r)- let msg@(Exception.Message _typ _errorRng descr) =+ let msg@(Exception.Message _type descr) = Seq.index errors n set (errorText r) [ text := descr ] act msg@@ -1518,48 +1533,50 @@ errors <- readIORef (errorList r) let newErrors = f errors writeIORef (errorList r) newErrors- set (errorLog r) [ items :=- map Exception.lineFromMessage $ Fold.toList newErrors ]+ set (errorLog r)+ [ items := map Exception.lineFromMessage $ Fold.toList newErrors ] -addToErrorLog ::- FrameError -> Exception.Message -> IO ()+addToErrorLog :: FrameError -> Exception.Message -> IO () addToErrorLog r exc = do itemAppend (errorLog r) $ Exception.lineFromMessage exc modifyIORef (errorList r) (Seq.|> exc) -markText :: TextCtrl a -> Term.Range -> IO ()+markText :: TextCtrl a -> Source.Range -> IO () markText textCtrl rng = do (i,j) <- textRangeFromRange textCtrl rng set textCtrl [ cursor := i ] WXCMZ.textCtrlSetSelection textCtrl i j +{-|+'moduleVersion' should be a member variable of the 'highlighter'+but we cannot attach data to a widget.+-} data Panel = Panel { panel :: WX.SplitterWindow (), editor, highlighter :: WX.TextCtrl (),- sourceLocation :: FilePath+ moduleVersion :: WX.Var (Maybe Module.Version),+ sourceLocation :: Path.AbsFile } -displayModule ::- WXCore.Window b ->- Module.Module ->- IO Panel-displayModule nb modu = do+createPanel :: WXCore.Window b -> Module.Module -> IO Panel+createPanel nb modu = do psub <- WX.splitterWindow nb [] splitterWindowSetSashGravity psub 0.5 ed <- textCtrlMono psub [] hl <- textCtrlRichMono psub [ editable := False ] set ed [ text := Module.sourceText modu ] set hl [ text := Module.sourceText modu ]+ vers <- varCreate $ Module.version modu void $ WXCMZ.splitterWindowSplitVertically psub ed hl 0 {- set psub [ layout := WX.vsplit psub 5 0 (WX.fill $ widget ed) (WX.fill $ widget hl) ] -}- return $ Panel psub ed hl $ Module.sourceLocation modu+ return $ Panel psub ed hl vers $ Module.sourceLocation modu textCtrlMono ::@@ -1572,8 +1589,7 @@ WX.textCtrl parent $ ( font := fontFixed ) : ( wrap := WrapNone ) : prop -textCtrlRichMono ::- WXCore.Window a -> [Prop (TextCtrl ())] -> IO (TextCtrl ())+textCtrlRichMono :: WXCore.Window a -> [Prop (TextCtrl ())] -> IO (TextCtrl ()) textCtrlRichMono parent prop = {- WX.textCtrlEx parent@@ -1583,87 +1599,82 @@ ( font := fontFixed ) : ( wrap := WrapNone ) : prop -getFromNotebook ::- Notebook b -> M.Map Module.Name a -> IO (Module.Name, a)-getFromNotebook nb m =- fmap (flip M.elemAt m) $ get nb notebookSelection+lookupPlusIndex :: Ord k => k -> Map k a -> Maybe (Int, a)+lookupPlusIndex name panels =+ liftM2 (,)+ ( Map.lookupIndex name panels )+ ( Map.lookup name panels ) -textPosFromSourcePos ::- TextCtrl a -> Pos.SourcePos -> IO Int-textPosFromSourcePos textArea pos =- WXCMZ.textCtrlXYToPosition textArea- $ Point (Pos.sourceColumn pos - 1)- (Pos.sourceLine pos - 1)+getFromNotebook :: Notebook b -> Map Module.Name a -> IO (Module.Name, a)+getFromNotebook nb m = flip Map.elemAt m <$> get nb notebookSelection -sourcePosFromTextColumnRow ::- Module.Name -> (Int, Int) -> Pos.SourcePos-sourcePosFromTextColumnRow (Module.Name name) (col, line) =- Pos.newPos name (line+1) (col+1)+textPosFromSourcePos :: TextCtrl a -> Source.Position -> IO Int+textPosFromSourcePos textArea (Source.Position line column) =+ WXCMZ.textCtrlXYToPosition textArea $+ Point (column - 1) (line - 1) -textRangeFromRange ::- TextCtrl a -> Term.Range -> IO (Int, Int)-textRangeFromRange textArea rng = do- from <- textPosFromSourcePos textArea $ Term.start rng- to <- textPosFromSourcePos textArea $ Term.end rng- return (from, to)+sourcePosFromTextColumnRow :: (Int, Int) -> Source.Position+sourcePosFromTextColumnRow (col, line) =+ Source.Position (line+1) (col+1) -textRangeFromSelection ::- TextCtrl a -> IO (Int, Int)+textRangeFromRange :: TextCtrl a -> Source.Range -> IO (Int, Int)+textRangeFromRange textArea rng =+ liftM2 (,)+ (textPosFromSourcePos textArea $ Source.start rng)+ (textPosFromSourcePos textArea $ Source.stop rng)++textRangeFromSelection :: TextCtrl a -> IO (Int, Int) textRangeFromSelection textArea = alloca $ \fromPtr -> alloca $ \toPtr -> do void $ WXCMZ.textCtrlGetSelection textArea fromPtr toPtr liftM2 (,)- (fmap fromIntegral $ peek (fromPtr :: Ptr C.CInt))- (fmap fromIntegral $ peek (toPtr :: Ptr C.CInt))+ (fromIntegral <$> peek (fromPtr :: Ptr C.CInt))+ (fromIntegral <$> peek (toPtr :: Ptr C.CInt)) -textColumnRowFromPos ::- TextCtrl a -> Int -> IO (Int, Int)+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)+ (fromIntegral <$> peek columnPtr)+ (fromIntegral <$> peek rowPtr) -setColor ::- (Ord k) =>- M.Map k (TextCtrl a) ->- Color ->- M.Map k [Identifier] ->- IO ()-setColor highlighters hicolor positions = do- forM_ (M.intersectionWith (,) highlighters positions) $- \(hl, idents) -> do- attr <- WXCMZ.textCtrlGetDefaultStyle hl- bracket- (WXCMZ.textAttrGetBackgroundColour attr)- (WXCMZ.textAttrSetBackgroundColour attr) $ const $ do- WXCMZ.textAttrSetBackgroundColour attr hicolor- forM_ idents $ \ ident -> do- (from, to) <-- textRangeFromRange hl $ Term.range ident- WXCMZ.textCtrlSetStyle hl from to attr -setColorCurrentTerm ::- TextCtrl a ->- Color ->- (Int, Int)->- IO ()-setColorCurrentTerm reducer hicolor (from, to) = do- attr <- WXCMZ.textCtrlGetDefaultStyle reducer+withBackgroundColour ::+ TextCtrl b -> Color -> (WXCore.TextAttr () -> IO a) -> IO a+withBackgroundColour textField hicolor act = do+ attr <- WXCMZ.textCtrlGetDefaultStyle textField bracket (WXCMZ.textAttrGetBackgroundColour attr)- (WXCMZ.textAttrSetBackgroundColour attr) $ const $ do- WXCMZ.textAttrSetBackgroundColour attr hicolor- void $ WXCMZ.textCtrlSetStyle reducer from to attr- return ()+ (WXCMZ.textAttrSetBackgroundColour attr) $ const $+ WXCMZ.textAttrSetBackgroundColour attr hicolor >> act attr +setColor ::+ (Ord k) =>+ Map k (TextCtrl a, Maybe Module.Version) ->+ Color -> Map k [Identifier] -> IO ()+setColor highlighters hicolor positions =+ forM_ (Map.intersectionWith (,) highlighters positions) $+ \((hl,moduVers), idents) ->+ withBackgroundColour hl hicolor $ \attr ->+ forM_ idents $ \ ident -> do+ let Source.ModuleRange _ vers rng = Term.range ident+ when (Module.equalVersion moduVers vers) $ do+ (from, to) <- textRangeFromRange hl rng+ void $ WXCMZ.textCtrlSetStyle hl from to attr +setColorCurrentTerm :: TextCtrl a -> Color -> (Int, Int)-> IO ()+setColorCurrentTerm reducer hicolor (from, to) =+ withBackgroundColour reducer hicolor $+ void . WXCMZ.textCtrlSetStyle reducer from to++ data MarkedText = MarkedText {- _markedPosition :: Pos.SourcePos,+ markedModuleName :: Module.Name,+ _markedPosition :: Source.Position, markedString :: String } @@ -1672,8 +1683,7 @@ marked <- WXCMZ.textCtrlGetStringSelection ed if null marked then do- (i,line) <-- textColumnRowFromPos ed =<< get ed cursor+ (i,line) <- textColumnRowFromPos ed =<< get ed cursor content <- WXCMZ.textCtrlGetLineText ed line {- simpler but inefficient content <- get ed text@@ -1683,12 +1693,12 @@ (prefix,suffix) -> let identLetter c = Char.isAlphaNum c || c == '_' || c == '.' in return $- MarkedText- (sourcePosFromTextColumnRow modu (i - length prefix, line))+ MarkedText modu+ (sourcePosFromTextColumnRow (i - length prefix, line)) ((reverse $ takeWhile identLetter $ reverse prefix) ++ takeWhile identLetter suffix) else do (from, _to) <- textRangeFromSelection ed pos <- textColumnRowFromPos ed from- return $ MarkedText (sourcePosFromTextColumnRow modu pos) marked+ return $ MarkedText modu (sourcePosFromTextColumnRow pos) marked
− src/IO.hs
@@ -1,18 +0,0 @@-module IO where--import qualified Text.ParserCombinators.Parsec as Parsec-import Text.PrettyPrint.HughesPJ ( Doc )--import Control.Monad ( liftM2 )---class Input a where input :: Parsec.Parser a-class Output a where output :: a -> Doc--parsecReader ::- (Input a) =>- t -> String -> [(a, String)]-parsecReader _p s =- case Parsec.parse ( liftM2 (,) input Parsec.getInput ) "" s of- Left _err -> []- Right (x,t) -> [(x,t)]
+ src/InOut.hs view
@@ -0,0 +1,16 @@+module InOut where++import qualified Text.ParserCombinators.Parsec as Parsec+import Text.PrettyPrint.HughesPJ ( Doc )++import Control.Monad ( liftM2 )+++class Input a where input :: Parsec.Parser a+class Output a where output :: a -> Doc++parsecReader :: (Input a) => prec -> String -> [(a, String)]+parsecReader _p s =+ case Parsec.parse ( liftM2 (,) input Parsec.getInput ) "" s of+ Left _err -> []+ Right (x,t) -> [(x,t)]
src/MPlayer.hs view
@@ -37,19 +37,21 @@ import Control.Monad (when, forever, ) import Data.Foldable (forM_, ) -import qualified System.Directory as Dir import qualified System.Posix.Files as File-import qualified System.IO as IO import qualified System.Environment as Env import qualified Control.Exception as Exc +import qualified System.Path.Directory as Dir+import qualified System.Path.IO as IO+import qualified System.Path as Path+ import qualified Text.Printf as Printf import Option.Utility (exitFailureMsg) -defltPipeName :: FilePath-defltPipeName = "/tmp/mppipe"+defltPipeName :: Path.AbsRelFile+defltPipeName = Path.file "/tmp/mppipe" seqName :: String seqName = "MPlayer control"@@ -71,20 +73,23 @@ args <- Env.getArgs case args of _:_:_ -> exitFailureMsg "too many arguments"- [pipeName] -> process pipeName+ [pipeName] ->+ case Path.parse pipeName of+ Right pipePath -> process pipePath+ Left msg -> exitFailureMsg msg [] -> Exc.bracket_- (File.createNamedPipe defltPipeName 0o644 >>- putStrLn ("Created pipe: " ++ defltPipeName))+ (File.createNamedPipe (Path.toString defltPipeName) 0o644 >>+ putStrLn ("Created pipe: " ++ Path.toString defltPipeName)) (Dir.removeFile defltPipeName) (process defltPipeName) -process :: FilePath -> IO ()+process :: Path.AbsRelFile -> IO () process pipeName = (do pipe <- IO.openFile pipeName IO.WriteMode IO.hSetBuffering pipe IO.LineBuffering putStrLn $ "Start MPlayer like this:"- putStrLn $ "mplayer -input file=" ++ pipeName+ putStrLn $ "mplayer -input file=" ++ Path.toString pipeName putStrLn "" SndSeq.with SndSeq.defaultName SndSeq.Block $ \h -> do
src/Module.hs view
@@ -1,22 +1,61 @@-module Module where+module Module (+ Name (Name, deconsName), tellName, mainName, noName,+ Source (..), maybeEditor,+ Identifier (Identifier, deconsIdentifier),+ stripIdentifier, -import IO ( Input, Output, input, output )-import Term ( Term, Identifier, lexer )+ Module,+ name,+ version,+ sourceText,+ sourceLocation,+ constructors,+ controls,+ functions,+ imports,+ source,++ FunctionDeclarations,+ ConstructorDeclarations,++ Version(Version),+ noVersion,+ initVersion,+ nextVersion,+ equalVersion,++ empty,+ addRule,++ nameFromIdentifier,+ makeFileName,+ parse,+ ) where++import ModuleBase ( Name(Name, deconsName), tellName, mainName, noName,+ Version(Version),+ noVersion, initVersion, nextVersion, equalVersion,+ Source(File, Editor), maybeEditor, formatSource )+import InOut ( Input, Output, input, output )+import Term ( Term )+import TermParser ( lexer ) import Rule ( Rule )+import SourceText+ ( ModuleRange, Range,+ extractModuleName, extractModuleRange, setRangeSourceName ) import qualified ControllerBase as Controller import qualified Type import qualified Term import qualified Rule import qualified Exception-import qualified Control.Monad.Exception.Synchronous as Exc+import qualified Control.Monad.Exception.Synchronous as ME -import qualified Data.Set as S-import qualified Data.Map as M+import qualified Data.Map as Map+import Data.Map ( Map ) import Data.Maybe ( mapMaybe ) import qualified Text.ParserCombinators.Parsec as Parsec-import qualified Text.ParserCombinators.Parsec.Pos as Pos import qualified Text.ParserCombinators.Parsec.Token as Token import Text.ParserCombinators.Parsec ( (<|>) ) import Text.ParserCombinators.Parsec.Token ( reserved, reservedOp )@@ -28,9 +67,11 @@ render, text, comma, vcat, parens ) import qualified Data.Char as Char -import qualified System.FilePath as FP+import qualified System.Path as Path import Data.List.HT ( chop )+import Data.Eq.HT ( equating ) +import Control.Applicative ( (<$>) ) import Control.Functor.HT ( void ) @@ -40,12 +81,11 @@ data Import = Import { qualified :: Bool , source :: Name- , rename :: Maybe Identifier+ , rename :: Maybe Name } -- deriving (Show) -parsePortList ::- Parsec.GenParser Char () [Identifier]+parsePortList :: Parsec.Parser [Term.Identifier Range] parsePortList = Token.parens lexer $ flip Parsec.sepEndBy (Token.comma lexer) $ (do ident <- input@@ -86,13 +126,11 @@ ] -data TypeSig = TypeSig [Identifier] [Term] Term+data TypeSig = TypeSig [Term.Identifier Range] [Term Range] (Term Range) deriving (Show) -parseIdentList :: Parsec.CharParser () [Identifier]-parseIdentList =- Token.commaSep lexer- (input <|> Term.parenOperator)+parseIdentList :: Parsec.CharParser () [Term.Identifier Range]+parseIdentList = Token.commaSep lexer (input <|> Term.parenOperator) instance Input TypeSig where input = do@@ -116,8 +154,8 @@ output typeExpr <+> text ";"]) -data Data = Data { dataLhs :: Term- , dataRhs :: [ Term ]+data Data = Data { dataLhs :: Term Range+ , dataRhs :: [ Term Range ] } deriving (Show) @@ -135,8 +173,8 @@ $$ hsep ( punctuate ( text "|" ) $ map output ( dataRhs d ) ) <+> text ";" -data Type = Type { typeLhs :: Term- , typeRhs :: Term+data Type = Type { typeLhs :: Term Range+ , typeRhs :: Term Range } deriving (Show) @@ -157,7 +195,7 @@ ( output ( typeRhs d ) <+> text ";" ) -data Infix = Infix Assoc Int [ Identifier ]+data Infix = Infix Assoc Int [ Term.Identifier Range ] showAssoc :: Assoc -> String showAssoc AssocLeft = "AssocLeft"@@ -206,7 +244,7 @@ data Declaration = TypeSignature TypeSig- | RuleDeclaration Rule+ | RuleDeclaration (Rule Range) | TypeDeclaration Type | DataDeclaration Data | InfixDeclaration Infix@@ -238,6 +276,7 @@ RuleDeclaration d -> output d InfixDeclaration d -> output d + -- | on module parsing: -- identifiers contain information on their source location. -- their sourceName (as used by Parsec) is the "show"@@ -248,79 +287,68 @@ data Module = Module { name :: Name+ , version :: Maybe Version , imports :: [ Import ] , declarations :: [ Declaration ] , functions :: FunctionDeclarations , constructors :: ConstructorDeclarations , controls :: Controller.Assignments , sourceText :: String- , sourceLocation :: FilePath+ , sourceLocation :: Path.AbsFile } -newtype Name = Name {deconsName :: String}- deriving (Eq, Ord)+nameFromIdentifier :: Term.Identifier ModuleRange -> Name+nameFromIdentifier = extractModuleName . Term.range -instance Input Name where- input = fmap Name Term.identifier+makeFileName :: Name -> Path.RelFile+makeFileName (Name n) =+ Path.addExtension (Path.joinPath $ chop ('.'==) n) "hs" -instance Output Name where- output (Name n) = text n -tellName :: Name -> String-tellName (Name n) = "module " ++ n--nameFromIdentifier :: Identifier -> Name-nameFromIdentifier =- Name . Pos.sourceName . Term.start . Term.range--{- |-Make a dummy Range if only the module name is known.--}-nameRange :: Name -> Term.Range-nameRange (Name n) = Exception.dummyRange n--inoutExceptionMsg :: Module.Name -> String -> Exception.Message-inoutExceptionMsg moduleName msg =- Exception.Message Exception.InOut (Module.nameRange moduleName) msg--makeFileName :: Name -> FilePath-makeFileName (Name n) =- FP.addExtension (FP.joinPath $ chop ('.'==) n) "hs"+newtype Identifier = Identifier { deconsIdentifier :: String }+ deriving (Eq, Ord) +stripIdentifier :: Term.Identifier range -> Identifier+stripIdentifier = Identifier . Term.name -type FunctionDeclarations = M.Map Identifier [Rule]-type ConstructorDeclarations = S.Set Identifier+type FunctionDeclarations =+ Map Identifier (Term.Identifier ModuleRange, [Rule ModuleRange])+type ConstructorDeclarations =+ Map Identifier (Term.Identifier ModuleRange) empty :: Name -> Module empty moduleName = Module { name = moduleName,+ version = noVersion, imports = [], sourceText = show $ outputModuleHead moduleName,- sourceLocation = "/dev/null",- functions = M.empty,- constructors = S.empty,- controls = M.empty,+ sourceLocation = Path.file "/dev/null",+ functions = Map.empty,+ constructors = Map.empty,+ controls = Map.empty, declarations = [] } -- | add, or replace (if rule with exact same lhs is already present)-addRule :: Rule -> Module -> Module+addRule :: Rule ModuleRange -> Module -> Module addRule rule@(Rule.Rule ident params _rhs) m =+ let matchParams ps = Term.equatingList Term.match ps . Rule.parameters+ in m { declarations = revUpdate (\d -> case d of RuleDeclaration r' ->- ident == Rule.name r' &&- params == Rule.parameters r'+ equating Term.name (extractModuleRange <$> ident) (Rule.name r') &&+ matchParams (map (fmap extractModuleRange) params) r' _ -> False)- (RuleDeclaration rule) $+ (RuleDeclaration (extractModuleRange <$> rule)) $ declarations m, functions =- M.insertWith- (\_ -> revUpdate ((params ==) . Rule.parameters) rule)- ident [rule] $+ Map.insertWith+ (\_ -> (,) ident . revUpdate (matchParams params) rule . snd)+ (stripIdentifier ident) (ident, [rule]) $ functions m } {- |@@ -329,7 +357,7 @@ -} update :: (a -> Bool) -> a -> [a] -> [a] update matches x xs =- let ( pre, post ) = span ( not . matches ) xs+ let ( pre, post ) = break matches xs in pre ++ x : drop 1 post {- |@@ -339,32 +367,56 @@ revUpdate :: (a -> Bool) -> a -> [a] -> [a] revUpdate p x = reverse . update p x . reverse -makeFunctions ::- [Declaration] -> M.Map Identifier [Rule]-makeFunctions =- M.fromListWith (flip (++)) .+makeFunctions :: Name -> Version -> [Declaration] -> FunctionDeclarations+makeFunctions srcName vers =+ Map.fromListWith (\(nm,xs) (_,ys) -> (nm, ys++xs)) . mapMaybe (\decl -> case decl of- RuleDeclaration rule -> Just (Rule.name rule, [rule])+ RuleDeclaration rule -> Just $+ let nm = Rule.name rule+ in (stripIdentifier nm,+ (setRangeSourceName srcName vers <$> nm,+ [setRangeSourceName srcName vers <$> rule])) _ -> Nothing) -makeConstructors ::- [Declaration] -> S.Set Identifier-makeConstructors decls = S.fromList $ do+makeConstructors :: Name -> Version -> [Declaration] -> ConstructorDeclarations+makeConstructors srcName vers decls = Map.fromList $ do DataDeclaration (Data {dataRhs = summands}) <- decls Term.Node ident _ <- summands- return ident+ return (stripIdentifier ident, setRangeSourceName srcName vers <$> ident) makeControllers ::- [Declaration] ->- Exc.Exceptional Exception.Message Controller.Assignments-makeControllers decls =+ Name -> Version -> [Declaration] -> Exception.Monad Controller.Assignments+makeControllers srcName vers decls = flip (foldr (\r go a -> Controller.collect r >>= Controller.union a >>= go)- return) M.empty $ do+ return) Map.empty $ do Module.RuleDeclaration rule <- decls- return $ Rule.rhs rule+ return $ setRangeSourceName srcName vers <$> Rule.rhs rule +{- |+Replace source names in all identifiers.+We can only do this after parsing+because if a parse error happens, module renaming will be skipped+and thus parse errors must refer+to the old module name or to the file name.+-}+fromDeclarations ::+ Path.AbsFile -> String ->+ Name -> Version -> [Import] -> [Declaration] ->+ Controller.Assignments -> Module+fromDeclarations srcLoc srcText moduleName vers imps decls ctrls =+ Module {+ name = moduleName,+ version = Just vers,+ imports = imps,+ declarations = decls,+ functions = makeFunctions moduleName vers decls,+ constructors = makeConstructors moduleName vers decls,+ controls = ctrls,+ sourceText = srcText,+ sourceLocation = srcLoc+ } {- We do not define the instance Input Module,@@ -374,40 +426,29 @@ instance Input Module where input = do -}-parser ::- FilePath -> String ->- Parsec.GenParser Char ()- (Exc.Exceptional Exception.Message Module)-parser srcLoc srcText = do- m <- Parsec.option (Name "Main") $ do+parser :: Parsec.Parser (Name, [Import], [Declaration])+parser = do+ m <- Parsec.option mainName $ do reserved lexer "module" m <- input- void $ Parsec.optionMaybe $ parsePortList+ void $ Parsec.optionMaybe parsePortList reserved lexer "where" return m is <- Parsec.many input ds <- Parsec.many input- return $ do- ctrls <- makeControllers ds- return $ Module {- name = m, imports = is, declarations = ds,- functions = makeFunctions ds,- constructors = makeConstructors ds,- controls = ctrls,- sourceText = srcText,- sourceLocation = srcLoc- }+ Parsec.eof+ return (m,is,ds) parse ::- String -> FilePath -> String ->- Exc.Exceptional Exception.Message Module-parse srcName srcLoc srcText =- let parserUntilEOF = do- m <- parser srcLoc srcText- Parsec.eof- return m- in either (Exc.Exception . Exception.messageFromParserError) id $- Parsec.parse parserUntilEOF srcName srcText+ Version -> Maybe Name -> Path.AbsFile -> String -> Exception.Monad Module+parse vers srcName srcLoc srcText =+ let src = maybe (File srcLoc) Editor srcName+ in either+ (ME.Exception . Exception.messageFromParserError src)+ (\(m,is,ds) ->+ fromDeclarations srcLoc srcText m vers is ds+ <$> makeControllers m vers ds) $+ Parsec.parse parser (formatSource src) srcText
+ src/ModuleBase.hs view
@@ -0,0 +1,60 @@+module ModuleBase where++import TermParser ( lexer )+import InOut ( Input, Output, input, output )++import qualified Text.ParserCombinators.Parsec.Token as Token+import Text.PrettyPrint.HughesPJ ( text )++import qualified System.Path as Path++import Control.Applicative ( liftA2, (<$>) )++import qualified Data.Foldable as Fold+++newtype Name = Name {deconsName :: String}+ deriving (Eq, Ord, Show)++instance Input Name where+ input = Name <$> Token.identifier lexer++instance Output Name where+ output (Name n) = text n++mainName :: Name+mainName = Name "Main"++noName :: Name+noName = Name ""++tellName :: Name -> String+tellName (Name n) = "module " ++ n+++newtype Version = Version Integer+ deriving (Eq, Ord, Show)++noVersion :: Maybe Version+noVersion = Nothing++initVersion :: Version+initVersion = Version 0++nextVersion :: Version -> Version+nextVersion (Version k) = Version (k+1)++equalVersion :: Maybe Version -> Maybe Version -> Bool+equalVersion u v = Fold.or $ liftA2 (==) u v+++data Source = File Path.AbsFile | Editor Name+ deriving (Show)++maybeEditor :: Source -> Maybe Name+maybeEditor (File _) = Nothing+maybeEditor (Editor name) = Just name++formatSource :: Source -> String+formatSource (File path) = Path.toString path+formatSource (Editor name) = deconsName name
src/Option.hs view
@@ -2,7 +2,7 @@ import qualified Module import qualified Time-import qualified IO+import qualified InOut import Option.Utility ( exitFailureMsg, fmapOptDescr, parseNumber ) import qualified HTTPServer.Option as HTTP @@ -13,9 +13,11 @@ import System.Console.GetOpt (getOpt, usageInfo, ArgDescr(NoArg, ReqArg), ) import System.Environment (getArgs, getProgName, )-import System.FilePath ( (</>), searchPathSeparator, isSearchPathSeparator, ) -import System.Directory ( getCurrentDirectory )+import qualified System.Path as Path+import System.Path.Directory ( getCurrentDirectory )+import System.Path ( (</>), searchPathSeparator, isSearchPathSeparator, )+ import qualified System.Exit as Exit import Control.Monad ( when )@@ -29,7 +31,8 @@ data Option = Option { moduleNames :: [Module.Name],- importPaths :: [FilePath],+ rawImportPaths :: [Path.AbsRelDir],+ importPaths :: [Path.AbsDir], connect :: NEList.T [] Port, sequencerName :: String, latency :: Double,@@ -48,9 +51,12 @@ return $ Option { moduleNames = [],- importPaths =- curDir :- map ((dataDir </>) . ("data" </>))+ importPaths = error "import paths not converted to absolute paths",+ rawImportPaths =+ Path.toAbsRel curDir :+ map+ ((Path.absRel dataDir </>) . (Path.dir "data" </>) .+ Path.dir) [ "prelude", "base", "example" ], connect = NEList.singleton (Port "inout" (Just []) (Just [])), sequencerName = "Rewrite-Sequencer",@@ -72,7 +78,8 @@ maxTermSize, maxTermDepth, maxReductions, maxEvents :: Int,- eventPeriod :: Time.Milliseconds Integer+ eventPeriod :: Time.Milliseconds Integer,+ splitWait :: Time.Milliseconds Integer } limitsDeflt :: Limits@@ -81,7 +88,8 @@ maxTermDepth = 100, maxReductions = 1000, maxEvents = 150,- eventPeriod = Time.milliseconds 1000+ eventPeriod = Time.seconds 1,+ splitWait = Time.seconds 1 } @@ -101,15 +109,18 @@ "show options" : Opt.Option ['i'] ["import-paths"] (flip ReqArg "PATHS" $ \str flags ->- return $ flags{importPaths =- if null str- then []- else chop isSearchPathSeparator str ++ importPaths flags- })+ if null str+ then return $ flags{rawImportPaths = []}+ else+ case mapM Path.parse $ chop isSearchPathSeparator str of+ Right paths ->+ return $ flags{rawImportPaths =+ paths ++ rawImportPaths flags}+ Left msg -> exitFailureMsg $ "--import-paths: " ++ msg) ("if empty: clear import paths\n" ++ "otherwise: add colon separated import paths,\n" ++ "default: " ++- (case importPaths deflt of+ (case map Path.toString $ rawImportPaths deflt of [] -> "" x:xs -> unlines $ x : map ((" "++) . (searchPathSeparator:)) xs)) : Opt.Option ['p'] ["connect-to"]@@ -204,6 +215,12 @@ parseNumber "event period" (\n -> 0<n && n<1000000000) "positive 30 bit" str) ("period for limitting adjacent events, default " ++ Time.format (eventPeriod deflt)) :+ Opt.Option [] ["split-wait"]+ (flip ReqArg "MILLISECONDS" $ \str flags ->+ fmap (\p -> flags{splitWait = Time.milliseconds p}) $+ parseNumber "wait duration" (\n -> 0<n && n<1000000000) "positive 30 bit" str)+ ("maximum atomic wait, default " +++ Time.format (splitWait deflt)) : [] @@ -218,12 +235,14 @@ dir <- getCurrentDirectory parsedOpts <-- fmap (\o -> o { importPaths = map (dir </>) $ importPaths o } ) $+ fmap (\o -> o {+ importPaths = map (Path.dynamicMakeAbsolute dir) $ rawImportPaths o+ } ) $ foldl (>>=) (return deflt) opts names <- forM files $ \modu ->- case Parsec.parse IO.input modu modu of+ case Parsec.parse InOut.input modu modu of Right name -> return name Left _ -> exitFailureMsg $ show modu ++ " is not a module name" return $ parsedOpts {
src/Program.hs view
@@ -2,32 +2,43 @@ import Term ( Identifier ) import Module ( Module )+import SourceText ( ModuleRange ) import qualified Term import qualified Module import qualified Log import qualified Exception import qualified ControllerBase as Controller -import qualified Control.Monad.Exception.Synchronous as Exc-import Control.Monad.Trans.Class ( lift )+import qualified Control.Monad.Exception.Synchronous as ME+import qualified Control.Monad.Trans.State as MS+import qualified Control.Monad.Trans.Class as MT+import Control.Applicative ( (<$>) ) -import qualified Control.Exception as ExcBase+import qualified Control.Exception as Exc import qualified System.IO.Strict as StrictIO-import System.Directory ( doesFileExist )-import System.FilePath ( (</>) ) import qualified System.IO.Error as Err +import qualified System.Path.PartClass as PartClass+import qualified System.Path as Path+import System.Path.Directory ( doesFileExist )+import System.Path ( (</>) )+ import qualified Data.Foldable as Fold import qualified Data.Traversable as Trav-import qualified Data.Map as M-import qualified Data.Set as S+import qualified Data.Map as Map+import qualified Data.Set as Set+import Data.Map ( Map )+import Data.Set ( Set )+import Data.Tuple.HT ( mapSnd )++import qualified Control.Functor.HT as FuncHT import Control.Monad ( foldM, liftM4 ) data Program = Program- { modules :: M.Map Module.Name Module+ { modules :: Map Module.Name Module , functions :: Module.FunctionDeclarations , constructors :: Module.ConstructorDeclarations , controls :: Controller.Assignments@@ -38,17 +49,17 @@ empty :: Program empty = Program {- modules = M.empty,- functions = M.empty,- constructors = S.empty,- controls = M.empty,+ modules = Map.empty,+ functions = Map.empty,+ constructors = Map.empty,+ controls = Map.empty, controlValues = Controller.emptyValues } singleton :: Module -> Program singleton m = Program {- modules = M.singleton (Module.name m) m,+ modules = Map.singleton (Module.name m) m, functions = Module.functions m, constructors = Module.constructors m, controls = Module.controls m,@@ -61,17 +72,15 @@ The module must not be present in the program, otherwise this function returns an invalid 'Program'. -}-addModule ::- Module -> Program ->- Exc.Exceptional Exception.Message Program+addModule :: Module -> Program -> Exception.Monad Program addModule m p = liftM4- ( Program ( M.insert ( Module.name m ) m ( modules p ) ) )+ ( Program ( Map.insert ( Module.name m ) m ( modules p ) ) ) ( unionDecls ( Module.functions m ) ( functions p ) )- ( fmap M.keysSet $+ ( Map.map fst <$> unionDecls- ( mapFromSet $ Module.constructors m )- ( mapFromSet $ constructors p ) )+ ( flip (,) () <$> Module.constructors m )+ ( flip (,) () <$> constructors p ) ) ( Controller.union ( Controller.updateValues ( controlValues p ) ( Module.controls m ) )@@ -81,118 +90,140 @@ removeModule :: Module.Name -> Program -> Program removeModule nm p =- case M.lookup nm $ modules p of+ case Map.lookup nm $ modules p of Nothing -> p Just m -> Program {- modules = M.delete nm $ modules p,- functions = M.difference ( functions p ) ( Module.functions m ),+ modules = Map.delete nm $ modules p,+ functions = Map.difference ( functions p ) ( Module.functions m ), constructors =- S.difference ( constructors p ) ( Module.constructors m ),- controls = M.difference ( controls p ) ( Module.controls m ),+ Map.difference ( constructors p ) ( Module.constructors m ),+ controls = Map.difference ( controls p ) ( Module.controls m ), controlValues = controlValues p } -replaceModule ::- Module -> Program ->- Exc.Exceptional Exception.Message Program+replaceModule :: Module -> Program -> Exception.Monad Program replaceModule m p = addModule m $ removeModule (Module.name m) p -mapFromSet :: Ord a => S.Set a -> M.Map a ()-mapFromSet =- M.fromAscList . map (flip (,) ()) . S.toAscList- unionDecls ::- M.Map Identifier a ->- M.Map Identifier a ->- Exc.Exceptional Exception.Message ( M.Map Identifier a )+ Map Module.Identifier (Identifier ModuleRange, a) ->+ Map Module.Identifier (Identifier ModuleRange, a) ->+ Exception.Monad ( Map Module.Identifier (Identifier ModuleRange, a) ) unionDecls m0 m1 =- let f = M.mapWithKey (\nm rs -> (nm, Exc.Success rs))- in Trav.sequenceA . fmap snd $- M.unionWith (\(n0,_) (n1,_) ->+ let f = fmap (mapSnd ME.Success)+ in+ Trav.traverse (FuncHT.mapSnd id) $+ Map.unionWith+ (\(n0,_) (n1,_) -> (n0,- Exc.Exception $ Exception.Message Exception.Parse- (Term.range n0)+ ME.Exception $+ Exception.messageParseModuleRange (Term.range n0) ("duplicate definition of " ++ show n0 ++ " in " ++ (Module.deconsName $ Module.nameFromIdentifier n0) ++ " and " ++ (Module.deconsName $ Module.nameFromIdentifier n1)))) (f m0) (f m1) -minimize :: Module.Name -> Program -> (S.Set Module.Name, Program)+minimize :: Module.Name -> Program -> (Set Module.Name, Program) minimize seed p = let trace modName ms =- if S.member modName ms- then foldl (flip trace) (S.delete modName ms) $+ if Set.member modName ms+ then foldl (flip trace) (Set.delete modName ms) $ maybe [] (map Module.source . Module.imports) $- M.lookup modName (modules p)+ Map.lookup modName (modules p) else ms- removed = trace seed $ M.keysSet $ modules p+ removed = trace seed $ Map.keysSet $ modules p in (removed, Fold.foldl (flip removeModule) p removed) -- | load from disk, with import chasing chase ::- [ FilePath ] -> Module.Name ->- Exc.ExceptionalT Exception.Message IO Program-chase dirs n =- chaser dirs empty n+ [ Path.AbsDir ] -> Module.Version ->+ Module.Name -> Exception.MonadT IO Program+chase dirs vers n =+ chaser dirs vers empty n chaser ::- [ FilePath ] -> Program -> Module.Name ->- Exc.ExceptionalT Exception.Message IO Program-chaser dirs p n = do- lift $ Log.put $ "chasing " ++ Module.tellName n- case M.lookup n ( modules p ) of- Just _ -> lift $ do+ [ Path.AbsDir ] -> Module.Version ->+ Program -> Module.Name -> Exception.MonadT IO Program+chaser dirs vers p n = do+ MT.lift $ Log.put $ "chasing " ++ Module.tellName n+ case Map.lookup n ( modules p ) of+ Just _ -> MT.lift $ do Log.put $ "module is already loaded" return p Nothing -> do path <- chaseFile dirs ( Module.makeFileName n )- load dirs ( Module.deconsName n ) path p+ snd <$> load dirs vers path p chaseMany ::- [ FilePath ] -> [ Module.Name ] -> Program ->- Exc.ExceptionalT Exception.Message IO Program-chaseMany dirs names p =- foldM ( chaser dirs ) p names+ [ Path.AbsDir ] -> Module.Version ->+ [ Module.Name ] -> Program -> Exception.MonadT IO Program+chaseMany dirs vers names p =+ foldM ( chaser dirs vers ) p names chaseImports ::- [ FilePath ] -> Module.Module -> Program ->- Exc.ExceptionalT Exception.Message IO Program-chaseImports dirs =- chaseMany dirs . map Module.source . Module.imports+ [ Path.AbsDir ] -> Module.Version ->+ Module.Module -> Program -> Exception.MonadT IO Program+chaseImports dirs vers =+ chaseMany dirs vers . map Module.source . Module.imports load ::- [ FilePath ] -> String -> FilePath -> Program ->- Exc.ExceptionalT Exception.Message IO Program-load dirs n ff p = do+ [ Path.AbsDir ] -> Module.Version -> Path.AbsFile -> Program ->+ Exception.MonadT IO (Module.Name, Program)+load dirs vers ff p = do content <-- Exc.mapExceptionT- (\e -> Exception.Message- Exception.InOut (Exception.dummyRange ff) (Err.ioeGetErrorString e)) $- Exc.fromEitherT $ ExcBase.try $ StrictIO.readFile ff- m <- Exception.lift $ Module.parse n ff content- lift $ Log.put $ show m- chaseImports dirs m =<< Exception.lift ( addModule m p )+ ME.mapExceptionT+ (\e ->+ Exception.messageInOut+ (Module.File ff)+ (Err.ioeGetErrorString e)) $+ ME.fromEitherT $ Exc.try $ StrictIO.readFile $ Path.toString ff+ m <- ME.liftT $ Module.parse vers Nothing ff content+ MT.lift $ Log.put $ show m+ fmap ((,) (Module.name m)) $+ chaseImports dirs vers m =<< ME.liftT ( addModule m p ) +{- |+If a file is not found, we setup an empty module.+If a file exists but contains parse errors then we abort loading.+-}+loadMany ::+ [ Path.AbsDir ] -> Module.Version -> [ Module.Name ] ->+ Exception.MonadT IO ([Module.Name], Program)+loadMany dirs vers =+ flip MS.runStateT empty .+ mapM+ (\name -> do+ epath <-+ MT.lift $ MT.lift $ ME.tryT $+ chaseFile dirs $ Module.makeFileName name+ MS.StateT $+ case epath of+ ME.Success path -> load dirs vers path+ ME.Exception _ ->+ fmap ((,) name) . ME.liftT .+ addModule (Module.empty name))++ -- | look for file, trying to append its name to the directories in the path, -- in turn. Will fail if file is not found. chaseFile ::- [FilePath] -> FilePath ->- Exc.ExceptionalT Exception.Message IO FilePath+ (PartClass.AbsRel ar) =>+ [ Path.Dir ar ] -> Path.RelFile -> Exception.MonadT IO (Path.File ar) chaseFile dirs f = foldr (\dir go -> do let ff = dir </> f- e <- lift $ doesFileExist ff+ e <- MT.lift $ doesFileExist ff if e- then lift $ do- Log.put $ unwords [ "found at location", ff ]+ then MT.lift $ do+ Log.put $ "found at location " ++ Path.toString ff return ff else go)- (Exc.throwT $ Exception.Message Exception.InOut- (Exception.dummyRange f)- (unwords [ "module", "not", "found:", f ]))+ (ME.throwT $+ Exception.messageInOut+ (Module.Editor Module.noName)+ ("module not found: " ++ Path.toString f)) dirs
src/Rewrite.hs view
@@ -1,33 +1,38 @@ module Rewrite where -import Term ( Term(Node, Number, StringLiteral),- Identifier(Identifier, range, name), Range, termRange )+import Term ( Term(Node, Number, StringLiteral), range, name, termRange ) import TermFocus ( TermFocus(TermFocus), SuperTerm ) import Program ( Program )+import SourceText ( ModuleRange ) import qualified Program+import qualified Module import qualified TermFocus import qualified Term import qualified Rule import qualified Control.Monad.Trans.Writer as MW import qualified Control.Monad.Trans.RWS as MRWS+import qualified Control.Monad.Trans.Class as MT import Control.Monad.Trans.RWS ( RWS, asks, tell, get, put )-import Control.Monad.Trans.Class ( lift ) import Control.Monad.Exception.Synchronous ( Exceptional(Exception,Success), ExceptionalT, mapExceptionalT, throwT, assertT )-import qualified Data.Map as M-import qualified Data.Set as S+import qualified Data.Map as Map import qualified Data.Traversable as Trav+import Data.Map ( Map ) import Data.Monoid ( Monoid ) import Data.Maybe.HT ( toMaybe ) import Data.Tuple.HT ( mapSnd ) import Data.List ( intercalate )+import Data.Eq.HT ( equating ) -- import Debug.Trace ( trace ) +type RTerm = Term.Term ModuleRange+type Identifier = Term.Identifier ModuleRange+ data Message = Term { term :: TermFocus } | Source { source :: Source }@@ -50,13 +55,13 @@ type Count = Int type Evaluator =- ExceptionalT (Range, String) ( RWS Context [ Message ] Count )+ ExceptionalT (ModuleRange, String) ( RWS Context [ Message ] Count ) runEval :: (Monad m) => Count -> Program -> Evaluator a ->- ExceptionalT (Range, String) ( MW.WriterT [ Message ] m ) a+ ExceptionalT (ModuleRange, String) ( MW.WriterT [ Message ] m ) a runEval maxRed p = -- in transformers-0.3 you can write MW.writer instead of MW.WriterT . return mapExceptionalT (\evl ->@@ -69,15 +74,14 @@ -} -exception :: Range -> String -> Evaluator a-exception rng msg =- throwT $ (rng, msg)+exception :: ModuleRange -> String -> Evaluator a+exception rng msg = throwT (rng, msg) -- | force head of stream: -- evaluate until we have Cons or Nil at root, -- then evaluate first argument of Cons fully.-forceHead :: Term -> Evaluator Term+forceHead :: RTerm -> Evaluator RTerm forceHead t = do t' <- top t case t' of@@ -91,7 +95,7 @@ -- | force full evaluation -- (result has only constructors and numbers)-full :: Term -> Evaluator Term+full :: RTerm -> Evaluator RTerm full x = do x' <- top x case x' of@@ -100,8 +104,8 @@ StringLiteral _ _ -> return x' -- | evaluate until root symbol is constructor.-top :: Term -> Evaluator Term-top t = ( lift $ tell . (:[]) . Term . TermFocus t =<< asks superTerms ) >> case t of+top :: RTerm -> Evaluator RTerm+top t = ( MT.lift $ tell . (:[]) . Term . TermFocus t =<< asks superTerms ) >> case t of Number {} -> return t StringLiteral {} -> return t Node f xs ->@@ -109,7 +113,7 @@ then return t else eval f xs >>= top -mapArgs :: Identifier -> (Term -> Evaluator Term) -> [Term] -> Evaluator [Term]+mapArgs :: Identifier -> (RTerm -> Evaluator RTerm) -> [RTerm] -> Evaluator [RTerm] mapArgs i f = let go _ [] = return [] go done (x:xs) = do@@ -120,8 +124,8 @@ localSuperTerm :: (Monad m, Monoid w) => Identifier ->- [Term] ->- [Term] ->+ [RTerm] ->+ [RTerm] -> ExceptionalT e (MRWS.RWST Context w s m) b -> ExceptionalT e (MRWS.RWST Context w s m) b localSuperTerm i done xs =@@ -131,23 +135,22 @@ superTerms ctx})) -- | do one reduction step at the root-eval ::- Identifier -> [Term] -> Evaluator Term+eval :: Identifier -> [RTerm] -> Evaluator RTerm eval i xs | name i `elem` [ "compare", "<", "-", "+", "*", "div", "mod" ] = do ys <- mapArgs i top xs- lift $ tell $ [ Source $ Step { target = i } ]+ MT.lift $ tell $ [ Source $ Step { target = i } ] case ys of [ Number _ a, Number _ b] -> case name i of -- FIXME: handling of positions is dubious "<" -> return $- Node ( Identifier { name = show (a < b)+ Node ( Term.Identifier { name = show (a < b) , range = range i } ) [] "compare" -> return $- Node ( Identifier { name = show (compare a b)+ Node ( Term.Identifier { name = show (compare a b) , range = range i } ) [] "-" -> return $ Number (range i) $ a - b "+" -> return $ Number (range i) $ a + b@@ -159,30 +162,31 @@ _ -> exception (range i) $ "wrong number of arguments" eval g ys = do- funcs <- lift $ asks ( Program.functions . program )- case M.lookup g funcs of+ funcs <- MT.lift $ asks ( Program.functions . program )+ case Map.lookup (Module.stripIdentifier g) funcs of Nothing -> exception (range g) $ unwords [ "unknown function", show $ Node g ys ]- Just rules ->- evalDecls g rules ys+ Just (_name, rules) -> evalDecls g rules ys evalDecls ::- Identifier -> [ Rule.Rule ] -> [Term] -> Evaluator Term+ Identifier -> [ Rule.Rule ModuleRange ] -> [RTerm] -> Evaluator RTerm evalDecls g = foldr (\(Rule.Rule f xs rhs) go ys -> do- lift $ tell [ Source $ AttemptRule f ]- (m, ys') <- matchExpandList M.empty g [] xs ys+ MT.lift $ tell [ Source $ AttemptRule f ]+ (m, ys') <- matchExpandList Map.empty g [] xs ys case m of Nothing -> go ys' Just (substitions, additionalArgs) -> do- conss <- lift $ asks ( Program.constructors . program )- lift $ tell $ map Source $+ conss <- MT.lift $ asks ( Program.constructors . program )+ MT.lift $ tell $ map Source $ Step g : Rule f :- ( map Data $ S.toList $ S.intersection conss $- S.fromList $ foldr constructors [] xs )+ ( map Data $ Map.elems $+ Map.intersectionWith const conss $ Map.fromList $+ map (flip (,) ()) $ map Module.stripIdentifier $+ foldr constructors [] xs ) rhs' <- apply substitions rhs appendArguments rhs' additionalArgs) (\ys ->@@ -190,14 +194,14 @@ unwords [ "no matching pattern for function", show g, "and arguments", show ys ]) -constructors :: Term -> [Identifier] -> [Identifier]+constructors :: RTerm -> [Identifier] -> [Identifier] constructors (Node f xs) acc = if Term.isConstructor f then f : foldr constructors acc xs else acc constructors _ acc = acc -appendArguments :: Term -> [Term] -> Evaluator Term+appendArguments :: RTerm -> [RTerm] -> Evaluator RTerm appendArguments f xs = case Term.appendArguments f xs of Success t -> return t@@ -208,20 +212,19 @@ -- do some reductions if they are necessary to decide about the match. -- return the reduced term in the second result component. matchExpand ::- Term -> Term ->- Evaluator ( Maybe (M.Map Identifier Term) , Term )+ RTerm -> RTerm -> Evaluator ( Maybe (Map Module.Identifier RTerm) , RTerm ) matchExpand pat t = case pat of Node f [] | Term.isVariable f ->- return ( Just $ M.singleton f t , t )+ return ( Just $ Map.singleton (Module.stripIdentifier f) t , t ) Node f xs | Term.isConstructor f -> do t' <- top t case t' of Node g ys ->- if f /= g- then return ( Nothing, t' )- else do- ( m, ys' ) <- matchExpandList M.empty g [] xs ys+ if equating name f g+ then do+ ( m, ys' ) <- matchExpandList Map.empty g [] xs ys return ( fmap fst m, Node f ys' )+ else return ( Nothing, t' ) _ -> exception (termRange t') $ "constructor pattern matched against non-constructor term: " ++ show t'@@ -232,7 +235,7 @@ t' <- top t case t' of Number _ b ->- return ( toMaybe (a==b) M.empty, t' )+ return ( toMaybe (a==b) Map.empty, t' ) _ -> exception (termRange t') $ "number pattern matched against non-number term: " ++ show t'@@ -240,19 +243,19 @@ t' <- top t case t' of StringLiteral _ b ->- return ( toMaybe (a==b) M.empty, t' )+ return ( toMaybe (a==b) Map.empty, t' ) _ -> exception (termRange t') $ "string pattern matched against non-string term: " ++ show t' matchExpandList ::- M.Map Identifier Term ->+ Map Module.Identifier RTerm -> Identifier ->- [Term] ->- [Term] ->- [Term] ->- Evaluator (Maybe (M.Map Identifier Term, [Term]), [Term])+ [RTerm] ->+ [RTerm] ->+ [RTerm] ->+ Evaluator (Maybe (Map Module.Identifier RTerm, [RTerm]), [RTerm]) matchExpandList s _ _ [] ys = return ( Just (s,ys), ys ) matchExpandList s i done (x:xs) (y:ys) = do (m, y') <- localSuperTerm i done ys $ matchExpand x y@@ -262,29 +265,29 @@ Just s' -> do s'' <- case MW.runWriter $ Trav.sequenceA $- M.unionWithKey (\var t _ -> MW.tell [var] >> t)+ Map.unionWithKey (\var t _ -> MW.tell [var] >> t) (fmap return s) (fmap return s') of (un, []) -> return un (_, vars) -> exception (termRange y') $ "variables bound more than once in pattern: " ++- intercalate ", " (map name vars)+ intercalate ", " (map Module.deconsIdentifier vars) matchExpandList s'' i (y':done) xs ys matchExpandList _ _ _ (x:_) _ = exception (termRange x) "too few arguments" -apply :: M.Map Identifier Term -> Term -> Evaluator Term+apply :: Map Module.Identifier RTerm -> RTerm -> Evaluator RTerm apply m t = checkMaxReductions (termRange t) >> case t of Node f xs -> do ys <- mapM ( apply m ) xs- case M.lookup f m of+ case Map.lookup (Module.stripIdentifier f) m of Nothing -> return $ Node f ys Just t' -> appendArguments t' ys _ -> return t -checkMaxReductions :: Range -> Evaluator ()+checkMaxReductions :: ModuleRange -> Evaluator () checkMaxReductions rng = do- maxCount <- lift $ asks maxReductions- count <- lift get+ maxCount <- MT.lift $ asks maxReductions+ count <- MT.lift get assertT (rng, "number of reductions exceeds limit " ++ show maxCount) $ count < maxCount- lift $ put $ succ count+ MT.lift $ put $ succ count
src/Rule.hs view
@@ -1,27 +1,40 @@ module Rule where -import IO ( Input(input), Output(output), parsecReader )-import Term ( Term(Node), Identifier )+import qualified TermParser import qualified Term+import InOut ( Input(input), Output(output), parsecReader )+import Term ( Term(Node), Identifier )+import SourceText ( ParserRange ) import Text.PrettyPrint.HughesPJ ( fsep, render, text ) +import Control.Applicative ( (<$>) ) -data Rule = Rule- { name :: Identifier- , parameters :: [ Term ]- , rhs :: Term++data Rule range = Rule+ { name :: Identifier range+ , parameters :: [ Term range ]+ , rhs :: Term range } -instance Show Rule where show = render . output-instance Read Rule where readsPrec = parsecReader+instance Functor Rule where+ fmap f r =+ Rule {+ name = f <$> name r,+ parameters = map (f <$>) $ parameters r,+ rhs = f <$> rhs r+ } -instance Output Rule where+instance Show (Rule range) where show = render . output+instance (ParserRange range) =>+ Read (Rule range) where readsPrec = parsecReader++instance Output (Rule range) where output r = fsep [ output ( Node (name r) (parameters r) ), text "=", output ( rhs r ), text ";" ] -instance Input Rule where+instance (ParserRange range) => Input (Rule range) where input = do t <- input (nm, ps) <-@@ -31,7 +44,7 @@ then return (nm, args) else fail $ show nm ++ " is not a function identifier" _ -> fail $ "the term " ++ show t ++ " is not a valid left-hand side of a rule"- Term.symbol "="+ TermParser.symbol "=" r <- input- Term.symbol ";"+ TermParser.symbol ";" return $ Rule { name = nm, parameters = ps, rhs = r }
+ src/SourceText.hs view
@@ -0,0 +1,61 @@+module SourceText where++import qualified ModuleBase as Module++import qualified Text.ParserCombinators.Parsec.Pos as ParsecPos+import Text.ParserCombinators.Parsec ( CharParser, getPosition )+++data Position = Position !Int !Int+ deriving (Eq, Ord, Show)++initialPos :: Position+initialPos = Position 1 1++parsecPos :: ParsecPos.SourcePos -> Position+parsecPos pos =+ Position (ParsecPos.sourceLine pos) (ParsecPos.sourceColumn pos)++makeParsecPos :: Module.Name -> Position -> ParsecPos.SourcePos+makeParsecPos (Module.Name modu) (Position line column) =+ ParsecPos.newPos modu line column+++data Range = Range { start, stop :: Position }+ deriving (Eq, Ord, Show)++data ModuleRange = ModuleRange Module.Name (Maybe Module.Version) Range+ deriving (Eq, Ord, Show)++emptyRange :: Range+emptyRange = Range initialPos initialPos++emptyModuleRange :: Module.Name -> ModuleRange+emptyModuleRange name = ModuleRange name Module.noVersion emptyRange++extractModuleName :: ModuleRange -> Module.Name+extractModuleName (ModuleRange n _ _) = n++extractModuleRange :: ModuleRange -> Range+extractModuleRange (ModuleRange _ _ rng) = rng++setRangeNoVersion :: Range -> ModuleRange+setRangeNoVersion = ModuleRange Module.noName Module.noVersion++setRangeSourceName :: Module.Name -> Module.Version -> Range -> ModuleRange+setRangeSourceName name vers = ModuleRange name (Just vers)+++class ParserRange range where+ consRange :: ParsecPos.SourcePos -> ParsecPos.SourcePos -> range++instance ParserRange Range where+ consRange from to = Range (parsecPos from) (parsecPos to)+++ranged :: (ParserRange range) => CharParser st a -> CharParser st (range, a)+ranged p = do+ from <- getPosition+ x <- p+ to <- getPosition+ return (consRange from to, x)
− src/Step.hs
@@ -1,27 +0,0 @@-module Step where--import Term-import Rule--import qualified Data.Map as M-import Control.Monad ( forM, mzero )---- | pattern must be linear-match :: [ Identifier ] -- ^ list of variables in pattern- -> Term -- ^ pattern- -> Term -- ^ term to match- -> Maybe ( M.Map Identifier Term )-match vs p t = case p of- Number {} | p == t -> return $ M.empty- Node v [] | v `elem` vs -> return $ M.fromList [ (v, t) ]- Node f xs -> case t of- Node g ys | f == g && length xs == length ys -> do- ms <- forM ( zip xs ys ) $ \ (x,y) -> match vs x y- return $ M.unionsWith ( error "non-linear pattern" ) ms- _ -> mzero---rootStep :: Rule -> Term -> Maybe Term-rootStep r t = do- m <- match ( vars r ) ( lhs r ) t- return $ apply m ( rhs r )
src/Term.hs view
@@ -1,188 +1,122 @@ module Term where -import IO ( Input, Output, input, output, parsecReader )+import qualified ModuleBase as Module+import qualified TermParser as Parser+import TermParser+ ( lexer, symbol, operators,+ operatorSymbols, operatorStart, operatorLetter )+import SourceText+ ( ModuleRange(ModuleRange), emptyRange,+ ParserRange, consRange, ranged )+import InOut ( Input, Output, input, output ) import qualified Text.ParserCombinators.Parsec.Token as T-import qualified Text.ParserCombinators.Parsec.Language as L import qualified Text.ParserCombinators.Parsec.Expr as Expr import qualified Text.ParserCombinators.Parsec as Parsec-import Text.ParserCombinators.Parsec- ( CharParser, Parser, getPosition, (<|>), (<?>), )-import Text.ParserCombinators.Parsec.Pos- ( SourcePos, )-import Text.ParserCombinators.Parsec.Expr- ( Assoc(AssocLeft, AssocRight, AssocNone) )+import Text.ParserCombinators.Parsec.Expr ( Assoc )+import Text.ParserCombinators.Parsec ( Parser, getPosition, (<|>), (<?>), ) import Text.PrettyPrint.HughesPJ ( Doc, (<+>), fsep, parens, render, text ) -import qualified Data.Set as S-import Control.Monad.Exception.Synchronous ( Exceptional(Success,Exception) )+import qualified Control.Monad.Exception.Synchronous as ME+import Control.Monad.Exception.Synchronous ( Exceptional(Exception) ) import Control.Monad ( liftM2, mzero )-import Control.Functor.HT ( void )+import Control.Applicative ( (<$>) ) import Data.Char (isUpper, isLower)--- import Data.Eq.HT (equating)-import Data.Ord (comparing) -data Range = Range { start :: SourcePos , end :: SourcePos }- deriving (Eq, Ord, Show)+data Identifier range = Identifier { range :: range, name :: String } -data Identifier =- Identifier { range :: Range, name :: String }+instance Functor Identifier where+ fmap f (Identifier rng idname) = Identifier (f rng) idname -instance Eq Identifier where--- FIXME: this is ignoring the module.--- for a complete implementation, we'd need fully qualified names- i == j = name i == name j--- (==) = equating name+identifier :: Module.Name -> String -> Identifier ModuleRange+identifier moduName =+ Identifier (ModuleRange moduName Module.noVersion emptyRange) -instance Ord Identifier where- compare = comparing name -isConstructor :: Identifier -> Bool+isConstructor :: Identifier range -> Bool isConstructor i = case name i of c:_ -> c == '[' || c == ':' || isUpper c _ -> error "isConstructor: identifier must be non-empty" -isVariable :: Identifier -> Bool+isVariable :: Identifier range -> Bool isVariable i = case name i of c:_ -> isLower c || elem c ('_':operatorSymbols) _ -> error "isVariable: identifier must be non-empty" -lexer :: T.TokenParser st-lexer =- T.makeTokenParser $ L.emptyDef {- L.commentStart = "{-",- L.commentEnd = "-}",- L.commentLine = "--",- L.nestedComments = True,- L.identStart = identifierStart,- L.identLetter = identifierLetter,- L.opStart = operatorStart,- L.opLetter = operatorLetter,- L.caseSensitive = True,- L.reservedNames = [ "module", "where", "import", "qualified"- , "as", "data", "class", "instance", "case", "of"- , "infix", "infixl", "infixr" ],- L.reservedOpNames = [ "=", "::", "|" ]- }----- FIXME: this should be read from a file (Prelude.hs).--- but then we need a parser that correctly handles fixity information--- on-the-fly.--- A simplified solution could be:--- Allow fixity definitions only between import and the first declaration.--- With this restriction we could parse the preamble first--- and then start with a fresh parser for the module body.--- For now, we hard-code Prelude's fixities:-{----infixr 9 .-infixr 8 ^, ^^, **-infixl 7 *, /, `quot`, `rem`, `div`, `mod`-infixl 6 +, ----- The (:) operator is built-in syntax, and cannot legally be given--- a fixity declaration; but its fixity is given by:--- infixr 5 :--infix 4 ==, /=, <, <=, >=, >-infixr 3 &&-infixr 2 ||-infixl 1 >>, >>=-infixr 1 =<<-infixr 0 $, $!, `seq`--}--operators :: [[([Char], Assoc)]]-operators =- [ [ ( ".", AssocRight ), ( "!!", AssocLeft ) ]- , [ ( "^", AssocRight) ]- , [ ( "*", AssocLeft), ("/", AssocLeft), ("%", AssocLeft), ("+:+", AssocRight) ]- , [ ( "+", AssocLeft), ("-", AssocLeft), ("=:=", AssocRight) ]- , [ ( ":", AssocRight ), ( "++", AssocRight ) ]- , map ( \ s -> (s, AssocNone) ) [ "==", "/=", "<", "<=", ">=", ">" ]- , [ ( "&&", AssocRight ) ]- , [ ( "||", AssocRight ) ]- , [ ( "$", AssocRight ) ]- ]--identifierStart, identifierLetter :: CharParser st Char-identifierStart = Parsec.letter <|> Parsec.char '_'---- FIXME: check the distinction between '.' in qualified names, and as operator-identifierLetter =- Parsec.alphaNum <|> Parsec.char '_' <|> Parsec.char '.'--identifierCore :: Parser String-identifierCore =- liftM2 (:) identifierStart (Parsec.many identifierLetter)--identifier :: Parser String-identifier = T.identifier lexer--parenOperator :: Parser Identifier+parenOperator :: (ParserRange range) => Parser (Identifier range) parenOperator = T.parens lexer $ T.lexeme lexer $ fmap (uncurry Identifier) $ ranged $ liftM2 (:) operatorStart (Parsec.many operatorLetter) -infixOperator :: Parser Identifier+infixOperator :: (ParserRange range) => Parser (Identifier range) infixOperator = T.lexeme lexer $ fmap (uncurry Identifier) $ ranged $- Parsec.between (Parsec.char '`') (Parsec.char '`') identifierCore+ Parsec.between (Parsec.char '`') (Parsec.char '`') Parser.identifier <|> liftM2 (:) operatorStart (Parsec.many operatorLetter) -symbol :: String -> Parser ()-symbol = void . T.symbol lexer -ranged :: CharParser st a -> CharParser st (Range, a)-ranged p = do- from <- getPosition- x <- p- to <- getPosition- return $ (Range from to, x)---instance Input Identifier where+instance (ParserRange range) => Input (Identifier range) where input = T.lexeme lexer $- fmap (uncurry Identifier) $ ranged identifierCore+ fmap (uncurry Identifier) $ ranged Parser.identifier -instance Output Identifier where+instance Output (Identifier range) where output i = text $ name i -instance Show Identifier where show = render . output-instance Read Identifier where readsPrec = parsecReader+instance Show (Identifier range) where show = render . output -data Term = Node Identifier [ Term ]- | Number Range Integer- | StringLiteral Range String- deriving ( Eq, Ord )+data Term range =+ Node (Identifier range) [ Term range ]+ | Number range Integer+ | StringLiteral range String -instance Show Term where show = render . output-instance Read Term where readsPrec = parsecReader+instance Show (Term range) where show = render . output +match :: Term range -> Term range -> Bool+match (Node x xs) (Node y ys) = name x == name y && equatingList match xs ys+match (Number _rngx x) (Number _rngy y) = x==y+match (StringLiteral _rngx x) (StringLiteral _rngy y) = x==y+match _ _ = False -mainName :: Term-mainName = read "main"+equatingList :: (a -> a -> Bool) -> [a] -> [a] -> Bool+equatingList eq =+ let go (x:xs) (y:ys) = eq x y && go xs ys+ go [] [] = True+ go _ _ = False+ in go +variable :: Module.Name -> String -> Term ModuleRange+variable moduName n = Node (identifier moduName n) []++main :: Term ModuleRange+main = variable Module.mainName "main"++ {- | simplifies case analysis -}-viewNode :: Term -> Maybe (String, [Term])+viewNode :: Term range -> Maybe (String, [Term range]) viewNode (Node f xs) = Just (Term.name f, xs) viewNode _ = Nothing -appendArguments :: Term -> [Term] -> Exceptional String Term++liftMonadFail :: (Monad m) => Exceptional String a -> m a+liftMonadFail = ME.switch fail return++{- |+This function allows us to handle @((f) a) b@ equivalently to @f a b@+in any circumstance, i.e. parsing and rewriting.+-}+appendArguments :: Term range -> [Term range] -> Exceptional String (Term range) appendArguments g ys = case (g, ys) of (Node f xs, _) -> return $ Node f $ xs ++ ys@@ -199,7 +133,7 @@ However this implementation is very simplistic, since T.stringChar is not exported. -}-parseStringLiteral :: Parsec.GenParser Char st String+parseStringLiteral :: Parsec.Parser String parseStringLiteral = flip (<?>) "literal string" $ -- fmap catMaybes $@@ -210,7 +144,7 @@ -- (Parsec.many (T.stringChar lexer)) -parseAtom :: Parser Term+parseAtom :: (ParserRange range) => Parser (Term range) parseAtom = (T.lexeme lexer $ fmap (uncurry Number) $ ranged (fmap read $ Parsec.many1 Parsec.digit))@@ -221,27 +155,20 @@ <|> bracketedList <|> fmap (flip Node []) input -parse :: Parser Term-parse = do- t <- liftM2 appendArguments parseAtom $ Parsec.many parseAtom- case t of- Success t' -> return t'- Exception e -> fail e+parse :: (ParserRange range) => Parser (Term range)+parse =+ liftMonadFail =<<+ liftM2 appendArguments parseAtom (Parsec.many parseAtom) -instance Input Term where+instance (ParserRange range) => Input (Term range) where input = Expr.buildExpressionParser table parse -operatorStart, operatorLetter :: CharParser st Char-operatorStart = Parsec.oneOf operatorSymbols-operatorLetter = Parsec.oneOf operatorSymbols -operatorSymbols :: [Char]-operatorSymbols = ":!#$%&*+./<=>?@\\^|-~"--table :: Expr.OperatorTable Char st Term+table :: (ParserRange range) => Expr.OperatorTable Char st (Term range) table = map ( map binary ) operators -binary :: (String, Assoc) -> Expr.Operator Char st Term+binary ::+ (ParserRange range) => (String, Assoc) -> Expr.Operator Char st (Term range) binary (s, assoc) = flip Expr.Infix assoc $ do rng <- Parsec.try $ T.lexeme lexer $ do (rng,_) <- ranged $ Parsec.string s@@ -250,44 +177,52 @@ return $ \ l r -> Node ( Identifier { name = s, range = rng } ) [ l, r ] -bracketedList :: Parser Term+bracketedList :: (ParserRange range) => Parser (Term range) bracketedList = do (r,_) <- ranged $ symbol "[" insideBracketedList r -insideBracketedList :: Range -> Parser Term+insideBracketedList :: (ParserRange range) => range -> Parser (Term range) insideBracketedList rng = do (r,_) <- ranged $ symbol "]" return $ Node ( Identifier { name = "[]", range = r } ) [] <|> do x <- input q <- getPosition xs <- do symbol "]" ; r <- getPosition- return $ Node ( Identifier { name = "[]", range = Range q r } ) []+ return $ Node+ ( Identifier { name = "[]", range = consRange q r } ) [] <|> do symbol "," ; r <- getPosition- insideBracketedList $ Range q r+ insideBracketedList $ consRange q r return $ Node ( Identifier { name = ":", range = rng } ) [ x, xs ] -instance Output Term where+instance Output (Term range) where output t = case t of Number _ n -> text $ show n StringLiteral _ s -> text $ show s Node f args -> output f <+> fsep ( map protected args ) -protected :: Term -> Doc+protected :: Term range -> Doc protected t = case t of Node _f (_:_) -> parens $ output t _ -> output t -termRange :: Term -> Range+termRange :: Term range -> range termRange (Node i _) = range i termRange (Number rng _) = rng termRange (StringLiteral rng _) = rng +instance Functor Term where+ fmap f t =+ case t of+ Node i ts -> Node (f <$> i) (map (fmap f) ts)+ Number rng n -> Number (f rng) n+ StringLiteral rng str -> StringLiteral (f rng) str+ {- | compute the number of nodes in the same depth -}-breadths :: Term -> [ Int ]+breadths :: Term range -> [ Int ] breadths t = 1 : case t of Node _f xs -> foldl addList [] $ map breadths xs _ -> []@@ -300,7 +235,7 @@ type Position = [ Int ] -subterms :: Term -> [ (Position, Term) ]+subterms :: Term range -> [ (Position, Term range) ] subterms t = ( [], t ) : case t of Node _f xs -> do (k, x) <- zip [ 0.. ] xs@@ -308,12 +243,7 @@ return (k : p, s) _ -> [] -signature :: Term -> S.Set Identifier-signature t = S.fromList $ do- (_p, Node f _xs) <- subterms t- return f--peek :: Term -> Position -> Maybe Term+peek :: Term range -> Position -> Maybe (Term range) peek t [] = return t peek (Node _f xs) (k : ks) = case drop k xs of@@ -321,7 +251,7 @@ [] -> mzero peek _ _ = mzero -poke :: Term -> Position -> Term -> Maybe Term+poke :: Term range -> Position -> Term range -> Maybe (Term range) poke _t [] s = return s poke (Node f xs) (k : ks) s = case splitAt k xs of
src/TermFocus.hs view
@@ -1,8 +1,8 @@ module TermFocus where import qualified Term-import Term ( Term, Identifier )-import IO ( Output, output )+import SourceText ( ModuleRange )+import InOut ( Output, output ) import Text.PrettyPrint.HughesPJ ( Doc, (<+>), fsep, parens, render, text ) @@ -11,8 +11,10 @@ import Data.List ( isPrefixOf ) -data TermFocus =- TermFocus { subTerm :: Term, superTerms :: [ SuperTerm ] }+type Term = Term.Term ModuleRange+type Identifier = Term.Identifier ModuleRange++data TermFocus = TermFocus { subTerm :: Term, superTerms :: [ SuperTerm ] } deriving (Show) data SuperTerm = Node Identifier ( List Term )
+ src/TermParser.hs view
@@ -0,0 +1,96 @@+module TermParser where++import qualified Text.ParserCombinators.Parsec.Token as T+import qualified Text.ParserCombinators.Parsec.Language as L+import qualified Text.ParserCombinators.Parsec as Parsec+import Text.ParserCombinators.Parsec ( CharParser, Parser, (<|>) )+import Text.ParserCombinators.Parsec.Expr+ ( Assoc(AssocLeft, AssocRight, AssocNone) )++import Control.Monad ( liftM2 )+import Control.Functor.HT ( void )++++lexer :: T.TokenParser st+lexer =+ T.makeTokenParser $ L.emptyDef {+ L.commentStart = "{-",+ L.commentEnd = "-}",+ L.commentLine = "--",+ L.nestedComments = True,+ L.identStart = identifierStart,+ L.identLetter = identifierLetter,+ L.opStart = operatorStart,+ L.opLetter = operatorLetter,+ L.caseSensitive = True,+ L.reservedNames = [ "module", "where", "import", "qualified"+ , "as", "data", "class", "instance", "case", "of"+ , "infix", "infixl", "infixr" ],+ L.reservedOpNames = [ "=", "::", "|" ]+ }++++{-+FIXME: This should be read from a file (Prelude.hs).+But then we need a parser that correctly handles fixity information on-the-fly.+A simplified solution could be:+Allow fixity definitions only between import and the first declaration.+With this restriction we could parse the preamble first+and then start with a fresh parser for the module body.+For now, we hard-code Prelude's fixities:+++infixr 9 .+infixr 8 ^, ^^, **+infixl 7 *, /, `quot`, `rem`, `div`, `mod`+infixl 6 +, -++-- The (:) operator is built-in syntax, and cannot legally be given+-- a fixity declaration; but its fixity is given by:+-- infixr 5 :++infix 4 ==, /=, <, <=, >=, >+infixr 3 &&+infixr 2 ||+infixl 1 >>, >>=+infixr 1 =<<+infixr 0 $, $!, `seq`+-}++operators :: [[([Char], Assoc)]]+operators =+ [ [ ( ".", AssocRight ), ( "!!", AssocLeft ) ]+ , [ ( "^", AssocRight) ]+ , [ ( "*", AssocLeft), ("/", AssocLeft), ("%", AssocLeft), ("+:+", AssocRight) ]+ , [ ( "+", AssocLeft), ("-", AssocLeft), ("=:=", AssocRight) ]+ , [ ( ":", AssocRight ), ( "++", AssocRight ) ]+ , map ( \ s -> (s, AssocNone) ) [ "==", "/=", "<", "<=", ">=", ">" ]+ , [ ( "&&", AssocRight ) ]+ , [ ( "||", AssocRight ) ]+ , [ ( "$", AssocRight ) ]+ ]++identifierStart, identifierLetter :: CharParser st Char+identifierStart = Parsec.letter <|> Parsec.char '_'++-- FIXME: check the distinction between '.' in qualified names, and as operator+identifierLetter =+ Parsec.alphaNum <|> Parsec.char '_' <|> Parsec.char '.'++identifier :: Parser String+identifier =+ liftM2 (:) identifierStart (Parsec.many identifierLetter)+++operatorStart, operatorLetter :: CharParser st Char+operatorStart = Parsec.oneOf operatorSymbols+operatorLetter = Parsec.oneOf operatorSymbols++operatorSymbols :: [Char]+operatorSymbols = ":!#$%&*+./<=>?@\\^|-~"+++symbol :: String -> Parser ()+symbol = void . T.symbol lexer
src/Time.hs view
@@ -1,8 +1,19 @@ {-# LANGUAGE EmptyDataDecls #-} {- | Similar to "Data.Fixed" -}-module Time where+module Time (+ Time(Time),+ sub, up,+ Seconds, seconds,+ Milliseconds, milliseconds,+ Microseconds, microseconds,+ Nanoseconds, nanoseconds,+ pause,+ format,+ ) where import Control.Concurrent ( threadDelay )+import Control.Applicative ( Const (Const, getConst) )+ import qualified Data.Monoid as Mn @@ -48,64 +59,48 @@ seconds = up . seconds -mul3 :: Time factor a -> Time (EM3 factor) a-mul3 (Time t) = Time t+div1000 :: Time factor a -> Time (EM3 factor) a+div1000 (Time t) = Time t -milliseconds ::- (Factor factor, Num a) =>- a -> Time (EM3 factor) a-milliseconds =- mul3 . seconds+milliseconds :: (Factor factor, Num a) => a -> Time (EM3 factor) a+milliseconds = div1000 . seconds -nanoseconds ::- (Factor factor, Num a) =>- a -> Time (EM3 (EM3 (EM3 factor))) a-nanoseconds =- mul3 . mul3 . mul3 . seconds+microseconds :: (Factor factor, Num a) => a -> Time (EM3 (EM3 factor)) a+microseconds = div1000 . milliseconds +nanoseconds :: (Factor factor, Num a) => a -> Time (EM3 (EM3 (EM3 factor))) a+nanoseconds = div1000 . microseconds + pause :: Time Micro Int -> IO () pause (Time t) = threadDelay t -- | we check by the types whether we can format the time value or not-class Format factor where- formatUnit :: Time factor a -> String--instance Format One where- formatUnit = const "s"---class Format1 factor where- formatUnit1 :: Time (EM3 factor) a -> String--instance Format1 One where- formatUnit1 = const "ms"--instance Format1 factor => Format (EM3 factor) where- formatUnit = formatUnit1---class Format2 factor where- formatUnit2 :: Time (EM3 (EM3 factor)) a -> String--instance Format2 One where- formatUnit2 = const "us"--instance Format2 factor => Format1 (EM3 factor) where- formatUnit1 = formatUnit2+class Factor factor =>+ Format factor where formatUnit :: Const String factor+instance Format One where formatUnit = Const "s" +class Factor factor =>+ Format1 factor where formatUnit1 :: Const String (EM3 factor)+instance Format1 One where formatUnit1 = Const "ms" -class Format3 factor where- formatUnit3 :: Time (EM3 (EM3 (EM3 factor))) a -> String+class Factor factor =>+ Format2 factor where formatUnit2 :: Const String (EM3 (EM3 factor))+instance Format2 One where formatUnit2 = Const "us" -instance Format3 One where- formatUnit3 = const "ns"+class Factor factor =>+ Format3 factor where formatUnit3 :: Const String (EM3 (EM3 (EM3 factor)))+instance Format3 One where formatUnit3 = Const "ns" -instance Format3 factor => Format2 (EM3 factor) where- formatUnit2 = formatUnit3+instance Format1 factor => Format (EM3 factor) where formatUnit = formatUnit1+instance Format2 factor => Format1 (EM3 factor) where formatUnit1 = formatUnit2+instance Format3 factor => Format2 (EM3 factor) where formatUnit2 = formatUnit3 format :: (Format factor, Show a) => Time factor a -> String-format time@(Time t) = show t ++ formatUnit time+format time@(Time t) = show t ++ getConst (formatUnitFromTime time)++formatUnitFromTime :: (Format factor) => Time factor a -> Const String factor+formatUnitFromTime = const formatUnit
src/Type.hs view
@@ -1,8 +1,11 @@ module Type where +import qualified TermParser as Parser import qualified Term-import Term ( Term(Node), Identifier(Identifier) )-import IO ( Input, input )+import qualified SourceText as Source+import Term ( Term(Node), Identifier(Identifier), liftMonadFail )+import SourceText ( ParserRange )+import InOut ( input ) import qualified Text.ParserCombinators.Parsec.Token as T import qualified Text.ParserCombinators.Parsec.Language as L@@ -13,7 +16,6 @@ import Text.ParserCombinators.Parsec.Expr ( Assoc(AssocRight) ) -import Control.Monad.Exception.Synchronous ( Exceptional(Success,Exception) ) import Control.Monad ( liftM2 ) @@ -24,8 +26,8 @@ L.commentEnd = "-}", L.commentLine = "--", L.nestedComments = True,- L.identStart = Term.identifierStart,- L.identLetter = Term.identifierLetter,+ L.identStart = Parser.identifierStart,+ L.identLetter = Parser.identifierLetter, L.opStart = operatorStart, L.opLetter = operatorLetter, L.caseSensitive = True,@@ -41,25 +43,23 @@ ] -parseBracket :: Parser Term+parseBracket :: (ParserRange range) => Parser (Term range) parseBracket = T.lexeme lexer $ do (rng,term) <-- Term.ranged $+ Source.ranged $ Parsec.between (T.symbol lexer "[") (Parsec.char ']') parseExpression return (Node (Identifier { Term.name = "[]", Term.range = rng }) [term]) -parseAtom :: Parser Term+parseAtom :: (ParserRange range) => Parser (Term range) parseAtom = T.parens lexer parseExpression <|> parseBracket <|> fmap (flip Node []) input -parseApply :: Parser Term-parseApply = do- t <- liftM2 Term.appendArguments parseAtom $ Parsec.many parseAtom- case t of- Success t' -> return t'- Exception e -> fail e+parseApply :: (ParserRange range) => Parser (Term range)+parseApply =+ liftMonadFail =<<+ liftM2 Term.appendArguments parseAtom (Parsec.many parseAtom) operatorStart, operatorLetter :: CharParser st Char@@ -69,26 +69,26 @@ operatorSymbols :: [Char] operatorSymbols = ":->" -table :: Expr.OperatorTable Char st Term+table :: (ParserRange range) => Expr.OperatorTable Char st (Term range) table = map ( map binary ) operators -binary :: (String, Assoc) -> Expr.Operator Char st Term+binary ::+ (ParserRange range) =>+ (String, Assoc) -> Expr.Operator Char st (Term range) binary (s, assoc) = flip Expr.Infix assoc $ do rng <- Parsec.try $ T.lexeme lexer $ do- (rng,_) <- Term.ranged $ Parsec.string s+ (rng,_) <- Source.ranged $ Parsec.string s Parsec.notFollowedBy operatorLetter <?> ("end of " ++ show s) return rng return $ \ l r -> Node ( Identifier { Term.name = s, Term.range = rng } ) [ l, r ] -parseContext :: Parsec.GenParser Char () [Term]+parseContext :: (ParserRange range) => Parsec.Parser [Term range] parseContext = do- constraints <-- T.parens lexer $- T.commaSep lexer input+ constraints <- T.parens lexer $ T.commaSep lexer input T.reservedOp lexer "=>" return constraints -parseExpression :: Parsec.GenParser Char () Term+parseExpression :: (ParserRange range) => Parsec.Parser (Term range) parseExpression = Expr.buildExpressionParser table parseApply
src/Utility/Concurrent.hs view
@@ -6,7 +6,7 @@ import qualified Control.Monad.Trans.Class as MT import qualified Control.Monad.Trans.State as MS import qualified Control.Monad.Trans.Writer as MW-import qualified Control.Monad.Exception.Synchronous as Exc+import qualified Control.Monad.Exception.Synchronous as ME import Data.Monoid ( Monoid ) import Control.Functor.HT ( void )@@ -33,5 +33,5 @@ instance MonadSTM m => MonadSTM (MS.StateT s m) where liftSTM = MT.lift . liftSTM -instance MonadSTM m => MonadSTM (Exc.ExceptionalT e m) where+instance MonadSTM m => MonadSTM (ME.ExceptionalT e m) where liftSTM = MT.lift . liftSTM