summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorHenningThielemann <>2018-01-12 22:17:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2018-01-12 22:17:00 (GMT)
commit5ae2ef8ca7bbe3f0b8c49051c922088308d35b63 (patch)
tree9803298fef06f1c743210ffefa16b10e433f9019
parent9495280636105543fda49a804d08702dc384c51a (diff)
version 0.0.6.10.0.6.1
-rw-r--r--ChangeLog6
-rw-r--r--Changes.md18
-rw-r--r--README.md13
-rw-r--r--data/example/Introduction.hs121
-rw-r--r--http/enable/HTTPServer.hs4
-rw-r--r--live-sequencer.cabal30
-rw-r--r--src/ALSA.hs2
-rw-r--r--src/Console.hs24
-rw-r--r--src/Controller.hs62
-rw-r--r--src/ControllerBase.hs74
-rw-r--r--src/Event.hs62
-rw-r--r--src/Exception.hs195
-rw-r--r--src/GUI.hs770
-rw-r--r--src/InOut.hs (renamed from src/IO.hs)6
-rw-r--r--src/MPlayer.hs23
-rw-r--r--src/Module.hs249
-rw-r--r--src/ModuleBase.hs60
-rw-r--r--src/Option.hs53
-rw-r--r--src/Program.hs195
-rw-r--r--src/Rewrite.hs117
-rw-r--r--src/Rule.hs37
-rw-r--r--src/SourceText.hs61
-rw-r--r--src/Step.hs27
-rw-r--r--src/Term.hs252
-rw-r--r--src/TermFocus.hs10
-rw-r--r--src/TermParser.hs96
-rw-r--r--src/Time.hs85
-rw-r--r--src/Type.hs44
-rw-r--r--src/Utility/Concurrent.hs4
29 files changed, 1551 insertions, 1149 deletions
diff --git a/ChangeLog b/ChangeLog
deleted file mode 100644
index 7dcb9e6..0000000
--- a/ChangeLog
+++ /dev/null
@@ -1,6 +0,0 @@
-0.0.5:
-
-* uniform singular names for modules
-
- data/Controls -> data/Controller
- data/Chords -> data/Chord
diff --git a/Changes.md b/Changes.md
new file mode 100644
index 0000000..0c2595b
--- /dev/null
+++ b/Changes.md
@@ -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
diff --git a/README.md b/README.md
index 4c04158..ca6e865 100644
--- a/README.md
+++ b/README.md
@@ -231,6 +231,19 @@ These are the limits you can set:
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
diff --git a/data/example/Introduction.hs b/data/example/Introduction.hs
new file mode 100644
index 0000000..a383587
--- /dev/null
+++ b/data/example/Introduction.hs
@@ -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) ) ;
diff --git a/http/enable/HTTPServer.hs b/http/enable/HTTPServer.hs
index d91d68b..7e617b4 100644
--- a/http/enable/HTTPServer.hs
+++ b/http/enable/HTTPServer.hs
@@ -11,7 +11,7 @@ module HTTPServer (
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 @@ parseModuleName modName =
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
diff --git a/live-sequencer.cabal b/live-sequencer.cabal
index a21f6ef..59db186 100644
--- a/live-sequencer.cabal
+++ b/live-sequencer.cabal
@@ -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 @@ Description:
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-Files:
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 @@ Source-Repository head
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 @@ Executable live-sequencer
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 @@ Executable live-sequencer
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 @@ Executable live-sequencer
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 @@ Executable live-sequencer-gui
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 @@ Executable live-sequencer-gui
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 @@ Executable live-sequencer-gui
Other-Modules:
ALSA
Event
- IO
+ InOut
Exception
Module
+ ModuleBase
Option
Option.Utility
Controller
@@ -216,8 +218,9 @@ Executable live-sequencer-gui
Program
Rewrite
Rule
- Step
+ SourceText
Term
+ TermParser
TermFocus
Time
Type
@@ -255,7 +258,6 @@ Executable live-mplayer-control
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
diff --git a/src/ALSA.hs b/src/ALSA.hs
index edcd6e1..94cf9c2 100644
--- a/src/ALSA.hs
+++ b/src/ALSA.hs
@@ -33,7 +33,7 @@ import Control.Monad ( (<=<) )
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 )
diff --git a/src/Console.hs b/src/Console.hs
index e9bba21..c1bd744 100644
--- a/src/Console.hs
+++ b/src/Console.hs
@@ -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.Concurrent.Split.Chan as Chan
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 @@ main = do
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 @@ main = do
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 @@ execute maxRed p sq visIn waitOut =
(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)
diff --git a/src/Controller.hs b/src/Controller.hs
index 76b3796..ba50435 100644
--- a/src/Controller.hs
+++ b/src/Controller.hs
@@ -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.Classes ( text, checked, selection )
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 @@ data Event = Event Name Value
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 @@ create frame controls sink = do
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
diff --git a/src/ControllerBase.hs b/src/ControllerBase.hs
index 0cf9920..aefe7fa 100644
--- a/src/ControllerBase.hs
+++ b/src/ControllerBase.hs
@@ -7,10 +7,12 @@ module ControllerBase where
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 Value = Bool Bool | Number Int
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 @@ deconsName (Name name) = name
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 @@ updateValues (Values bools numbers) assigns =
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 @@ collect topTerm =
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"
_ -> []
diff --git a/src/Event.hs b/src/Event.hs
index 3356361..91f8652 100644
--- a/src/Event.hs
+++ b/src/Event.hs
@@ -83,6 +83,7 @@ module Event where
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 Sound.ALSA.Sequencer as SndSeq
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 qualified Control.Concurrent.Split.Chan as Chan
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 :: WaitMode
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 @@ checkRange ::
(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 ::
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 @@ play sq throwAsync x = case Term.viewNode x of
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 @@ play sq throwAsync x = case Term.viewNode x of
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 @@ play sq throwAsync x = case Term.viewNode x of
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 @@ listen sq noteInput visualize waitChan = do
{- 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
diff --git a/src/Exception.hs b/src/Exception.hs
index b7445c7..f2a7cf9 100644
--- a/src/Exception.hs
+++ b/src/Exception.hs
@@ -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
-
-formatPos :: Type -> Pos.SourcePos -> String
-formatPos typ pos =
- Pos.sourceName pos ++
- (case typ of
- InOut -> ""
- _ ->
- ':' : show (Pos.sourceLine pos) ++
- ':' : show (Pos.sourceColumn pos))
-
-stringFromType :: Type -> String
-stringFromType typ =
+multilineFromMessage (Message typ descr) =
+ case stringsFromType typ of
+ (typeStr, name, mpos) ->
+ typeStr ++ " - " ++
+ formatPos name mpos ++ "\n" ++
+ descr
+
+formatPos :: String -> Maybe (String, String) -> String
+formatPos name mpos =
+ name ++ maybe "" (\(line,column) -> ':':line++':':column) mpos
+
+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
-
-
-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)
+flattenMultiline = List.intercalate "; " . lines
+
+
+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
diff --git a/src/GUI.hs b/src/GUI.hs
index edf630e..a9a27d4 100644
--- a/src/GUI.hs
+++ b/src/GUI.hs
@@ -38,7 +38,7 @@ HTTPServer:
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 Exception
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 @@ import Graphics.UI.WX.Layout
( 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,21 +104,23 @@ import qualified Sound.MIDI.Message.Channel.Voice as VM
import qualified Control.Monad.Trans.State as MS
import qualified Control.Monad.Trans.Writer as MW
-import qualified Control.Monad.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
@@ -125,7 +128,8 @@ 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 @@ main = do
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 @@ data Execution =
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 @@ data GuiUpdate =
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 @@ data GuiUpdate =
| 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)
-
-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
+ ME.resolveT (TChan.writeIO output . Exception)
+
+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 @@ processMidiCommand machineChan guiChan cmd =
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 @@ and blocking access to 'program'
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 @@ modifyModule importPaths program output moduleName sourceCode pos = do
-- 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 @@ modifyModule importPaths program output moduleName sourceCode pos = do
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 @@ machine :: Chan.Out Action -- ^ machine reads program text from here
-- (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 @@ machine input output procMidi limits importPaths progInit sq = do
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 @@ machine input output procMidi limits importPaths progInit sq = do
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 @@ machine input output procMidi limits importPaths progInit sq = do
"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 @@ machine input output procMidi limits importPaths progInit sq = do
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 @@ execute limits program term delayedUpdatesIn sendWarning sq waitChan =
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 @@ executeStep ::
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 @@ executeStep limits program term sendWarning sq maxEventsSat = do
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 @@ executeStep limits program term sendWarning sq maxEventsSat = do
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 @@ executeStep limits program term sendWarning sq maxEventsSat = do
", 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 @@ computeStep ::
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 @@ computeStep limits program term maxEventsSat waitMode = do
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 @@ computeStep limits program term maxEventsSat waitMode = do
-}
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 @@ computeStep limits program term maxEventsSat waitMode = do
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,9 +789,6 @@ splitAtReduction (Rewrite.Term t : ms) = ( [], Just (t, ms ) )
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) =>
@@ -851,17 +835,16 @@ gui :: Chan.In Action -- ^ the gui writes here
-- (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 @@ gui input output procEvent = do
_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 @@ gui input output procEvent = do
[ 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 @@ gui input output procEvent = do
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 sendExceptionInOut moduleName =
+ TChan.writeIO output . Exception .
+ Exception.messageInOutEditor moduleName
+
+ let handleException moduleName act =
+ either
+ (sendExceptionInOut moduleName . Err.ioeGetErrorString)
+ return
+ =<< try act
- 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 ()
+ {-
+ 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 @@ gui input output procEvent = do
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 @@ gui input output procEvent = do
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 @@ gui input output procEvent = do
[ 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 @@ gui input output procEvent = do
\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 @@ gui input output procEvent = do
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 @@ gui input output procEvent = do
, 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 @@ gui input output procEvent = do
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 @@ gui input output procEvent = do
)
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 @@ gui input output procEvent = do
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 @@ gui input output procEvent = do
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 @@ gui input output procEvent = do
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 @@ onErrorSelection r act =
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 @@ updateErrorLog r f = do
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 @@ textCtrlMono parent prop =
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 @@ textCtrlRichMono parent prop =
( 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
-
-textPosFromSourcePos ::
- TextCtrl a -> Pos.SourcePos -> IO Int
-textPosFromSourcePos textArea pos =
- WXCMZ.textCtrlXYToPosition textArea
- $ Point (Pos.sourceColumn pos - 1)
- (Pos.sourceLine pos - 1)
-
-sourcePosFromTextColumnRow ::
- Module.Name -> (Int, Int) -> Pos.SourcePos
-sourcePosFromTextColumnRow (Module.Name name) (col, line) =
- Pos.newPos name (line+1) (col+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)
-
-textRangeFromSelection ::
- TextCtrl a -> IO (Int, Int)
+lookupPlusIndex :: Ord k => k -> Map k a -> Maybe (Int, a)
+lookupPlusIndex name panels =
+ liftM2 (,)
+ ( Map.lookupIndex name panels )
+ ( Map.lookup name panels )
+
+getFromNotebook :: Notebook b -> Map Module.Name a -> IO (Module.Name, a)
+getFromNotebook nb m = flip Map.elemAt m <$> get nb notebookSelection
+
+textPosFromSourcePos :: TextCtrl a -> Source.Position -> IO Int
+textPosFromSourcePos textArea (Source.Position line column) =
+ WXCMZ.textCtrlXYToPosition textArea $
+ Point (column - 1) (line - 1)
+
+sourcePosFromTextColumnRow :: (Int, Int) -> Source.Position
+sourcePosFromTextColumnRow (col, line) =
+ Source.Position (line+1) (col+1)
+
+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 @@ getMarkedExpr modu ed = do
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 @@ getMarkedExpr modu ed = do
(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
diff --git a/src/IO.hs b/src/InOut.hs
index bb56362..8f76c94 100644
--- a/src/IO.hs
+++ b/src/InOut.hs
@@ -1,4 +1,4 @@
-module IO where
+module InOut where
import qualified Text.ParserCombinators.Parsec as Parsec
import Text.PrettyPrint.HughesPJ ( Doc )
@@ -9,9 +9,7 @@ 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 :: (Input a) => prec -> String -> [(a, String)]
parsecReader _p s =
case Parsec.parse ( liftM2 (,) input Parsec.getInput ) "" s of
Left _err -> []
diff --git a/src/MPlayer.hs b/src/MPlayer.hs
index 7b26f70..9840525 100644
--- a/src/MPlayer.hs
+++ b/src/MPlayer.hs
@@ -37,19 +37,21 @@ import Control.Monad.IO.Class (MonadIO, liftIO)
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 @@ main = do
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
diff --git a/src/Module.hs b/src/Module.hs
index cb0859c..a871b83 100644
--- a/src/Module.hs
+++ b/src/Module.hs
@@ -1,22 +1,61 @@
-module Module where
-
-import IO ( Input, Output, input, output )
-import Term ( Term, Identifier, lexer )
+module Module (
+ Name (Name, deconsName), tellName, mainName, noName,
+ Source (..), maybeEditor,
+ Identifier (Identifier, deconsIdentifier),
+ stripIdentifier,
+
+ 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 @@ import Text.PrettyPrint.HughesPJ
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 @@ indent = 4
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 @@ instance Output Import where
]
-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 @@ instance Output TypeSig where
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 @@ instance Output Data where
$$ 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 @@ instance Output Type where
( 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 @@ instance Output Infix where
data Declaration = TypeSignature TypeSig
- | RuleDeclaration Rule
+ | RuleDeclaration (Rule Range)
| TypeDeclaration Type
| DataDeclaration Data
| InfixDeclaration Infix
@@ -238,6 +276,7 @@ instance Output Declaration where
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 @@ instance Output Declaration where
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)
-
-instance Input Name where
- input = fmap Name Term.identifier
-
-instance Output Name where
- output (Name n) = text n
+nameFromIdentifier :: Term.Identifier ModuleRange -> Name
+nameFromIdentifier = extractModuleName . Term.range
-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
+makeFileName :: Name -> Path.RelFile
+makeFileName (Name n) =
+ Path.addExtension (Path.joinPath $ chop ('.'==) n) "hs"
-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 @@ and append the new element otherwise.
-}
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 @@ and prepend the new element otherwise.
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 @@ the caller should provide the source file path and content.
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
diff --git a/src/ModuleBase.hs b/src/ModuleBase.hs
new file mode 100644
index 0000000..106dc7b
--- /dev/null
+++ b/src/ModuleBase.hs
@@ -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
diff --git a/src/Option.hs b/src/Option.hs
index be9db89..4584aae 100644
--- a/src/Option.hs
+++ b/src/Option.hs
@@ -2,7 +2,7 @@ module Option where
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 qualified System.Console.GetOpt as Opt
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 @@ import Data.List.HT ( chop )
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 @@ getDeflt = do
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 @@ data Limits =
maxTermSize, maxTermDepth,
maxReductions,
maxEvents :: Int,
- eventPeriod :: Time.Milliseconds Integer
+ eventPeriod :: Time.Milliseconds Integer,
+ splitWait :: Time.Milliseconds Integer
}
limitsDeflt :: Limits
@@ -81,7 +88,8 @@ limitsDeflt = Limits {
maxTermDepth = 100,
maxReductions = 1000,
maxEvents = 150,
- eventPeriod = Time.milliseconds 1000
+ eventPeriod = Time.seconds 1,
+ splitWait = Time.seconds 1
}
@@ -101,15 +109,18 @@ description deflt =
"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 @@ limitsDescription deflt =
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 @@ get = do
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 {
diff --git a/src/Program.hs b/src/Program.hs
index 5d29313..b0215ed 100644
--- a/src/Program.hs
+++ b/src/Program.hs
@@ -2,32 +2,43 @@ module Program where
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 @@ data Program =
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 @@ add a module
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 @@ addModule m p =
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
diff --git a/src/Rewrite.hs b/src/Rewrite.hs
index 2c6646b..3887d59 100644
--- a/src/Rewrite.hs
+++ b/src/Rewrite.hs
@@ -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 @@ data Context =
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 @@ runEval maxRed p =
-}
-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 @@ forceHead t = do
-- | 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 @@ full x = do
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 @@ top t = ( lift $ tell . (:[]) . Term . TermFocus t =<< asks superTerms ) >> case
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 @@ mapArgs i f =
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 @@ localSuperTerm i done xs =
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 @@ eval i xs
_ -> 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 @@ evalDecls g =
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 @@ appendArguments f xs =
-- 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 @@ matchExpand pat t = case pat of
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 @@ matchExpand pat t = case pat of
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 @@ matchExpandList s i done (x:xs) (y:ys) = do
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
diff --git a/src/Rule.hs b/src/Rule.hs
index c9b44f1..2d3adb5 100644
--- a/src/Rule.hs
+++ b/src/Rule.hs
@@ -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 Show (Rule range) where show = render . output
+instance (ParserRange range) =>
+ Read (Rule range) where readsPrec = parsecReader
-instance Output Rule where
+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 @@ instance Input Rule where
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 }
diff --git a/src/SourceText.hs b/src/SourceText.hs
new file mode 100644
index 0000000..5c3bf24
--- /dev/null
+++ b/src/SourceText.hs
@@ -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)
diff --git a/src/Step.hs b/src/Step.hs
deleted file mode 100644
index 21247a6..0000000
--- a/src/Step.hs
+++ /dev/null
@@ -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 )
diff --git a/src/Term.hs b/src/Term.hs
index a733253..f26aa49 100644
--- a/src/Term.hs
+++ b/src/Term.hs
@@ -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 range =
+ Node (Identifier range) [ Term range ]
+ | Number range Integer
+ | StringLiteral range String
+
+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
-data Term = Node Identifier [ Term ]
- | Number Range Integer
- | StringLiteral Range String
- deriving ( Eq, Ord )
+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
-instance Show Term where show = render . output
-instance Read Term where readsPrec = parsecReader
+variable :: Module.Name -> String -> Term ModuleRange
+variable moduName n = Node (identifier moduName n) []
-mainName :: Term
-mainName = read "main"
+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 @@ and we need the precise range of the literal.
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 @@ parseStringLiteral =
-- (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 @@ parseAtom =
<|> 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 @@ binary (s, assoc) = flip Expr.Infix assoc $ do
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 @@ addList xs [] = xs
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 @@ subterms t = ( [], t ) : case t of
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 @@ peek (Node _f xs) (k : ks) =
[] -> 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
diff --git a/src/TermFocus.hs b/src/TermFocus.hs
index 737acec..8fd9b5b 100644
--- a/src/TermFocus.hs
+++ b/src/TermFocus.hs
@@ -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.HT ( tails )
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 )
diff --git a/src/TermParser.hs b/src/TermParser.hs
new file mode 100644
index 0000000..cdf618d
--- /dev/null
+++ b/src/TermParser.hs
@@ -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
diff --git a/src/Time.hs b/src/Time.hs
index 1e7c832..3c05cc7 100644
--- a/src/Time.hs
+++ b/src/Time.hs
@@ -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,20 +59,17 @@ instance Factor factor => Factor (EM3 factor) where
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 = div1000 . seconds
-milliseconds ::
- (Factor factor, Num a) =>
- a -> Time (EM3 factor) a
-milliseconds =
- 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 =
- mul3 . mul3 . mul3 . seconds
+nanoseconds :: (Factor factor, Num a) => a -> Time (EM3 (EM3 (EM3 factor))) a
+nanoseconds = div1000 . microseconds
pause :: Time Micro Int -> IO ()
@@ -70,42 +78,29 @@ 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"
+class Factor factor =>
+ Format factor where formatUnit :: Const String factor
+instance Format One where formatUnit = Const "s"
-instance Format1 factor => Format (EM3 factor) where
- formatUnit = formatUnit1
+class Factor factor =>
+ Format1 factor where formatUnit1 :: Const String (EM3 factor)
+instance Format1 One where formatUnit1 = Const "ms"
+class Factor factor =>
+ Format2 factor where formatUnit2 :: Const String (EM3 (EM3 factor))
+instance Format2 One where formatUnit2 = Const "us"
-class Format2 factor where
- formatUnit2 :: Time (EM3 (EM3 factor)) a -> String
+class Factor factor =>
+ Format3 factor where formatUnit3 :: Const String (EM3 (EM3 (EM3 factor)))
+instance Format3 One where formatUnit3 = Const "ns"
-instance Format2 One where
- formatUnit2 = const "us"
-
-instance Format2 factor => Format1 (EM3 factor) where
- formatUnit1 = formatUnit2
-
-
-class Format3 factor where
- formatUnit3 :: Time (EM3 (EM3 (EM3 factor))) a -> String
-
-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
diff --git a/src/Type.hs b/src/Type.hs
index 6f99619..bbdcef1 100644
--- a/src/Type.hs
+++ b/src/Type.hs
@@ -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
import Text.ParserCombinators.Parsec.Expr
( Assoc(AssocRight) )
-import Control.Monad.Exception.Synchronous ( Exceptional(Success,Exception) )
import Control.Monad ( liftM2 )
@@ -24,8 +26,8 @@ lexer =
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 @@ operators =
]
-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 @@ 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,_) <- 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
diff --git a/src/Utility/Concurrent.hs b/src/Utility/Concurrent.hs
index fc86749..55786eb 100644
--- a/src/Utility/Concurrent.hs
+++ b/src/Utility/Concurrent.hs
@@ -6,7 +6,7 @@ import Control.Monad.STM ( STM )
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, Monoid w) => MonadSTM (MW.WriterT w m) where
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