live-sequencer 0.0.4 → 0.0.5
raw patch · 20 files changed
+407/−649 lines, 20 filesdep ~non-emptydep ~transformers
Dependency ranges changed: non-empty, transformers
Files
- ChangeLog +6/−0
- data/base/Chord.hs +40/−0
- data/base/Chords.hs +0/−40
- data/base/Controller.hs +11/−0
- data/base/Controls.hs +0/−11
- data/base/Maybe.hs +24/−0
- data/example/Band.hs +1/−1
- data/example/BandControlled.hs +2/−2
- data/example/Klingklong.hs +1/−1
- data/example/Sweep.hs +1/−1
- data/example/UD.hs +1/−1
- live-sequencer.cabal +16/−289
- src/Controller.hs +144/−0
- src/ControllerBase.hs +133/−0
- src/Controls.hs +0/−144
- src/ControlsBase.hs +0/−133
- src/GUI.hs +10/−10
- src/Module.hs +8/−8
- src/Option.hs +2/−1
- src/Program.hs +7/−7
+ ChangeLog view
@@ -0,0 +1,6 @@+0.0.5:++* uniform singular names for modules++ data/Controls -> data/Controller+ data/Chords -> data/Chord
+ data/base/Chord.hs view
@@ -0,0 +1,40 @@+module Chord where++import Midi+import Pitch ( Pitch )+++chord ::+ Time -> [Pitch] ->+ [Midi.Event Midi.Message] ;+chord dur =+ mergeMany . map (note dur) ;+++chord3 ::+ Time ->+ Pitch -> Pitch -> Pitch ->+ [Midi.Event Midi.Message] ;+chord3 dur p0 p1 p2 = chord dur [p0, p1, p2] ;++chord4 ::+ Time ->+ Pitch -> Pitch -> Pitch -> Pitch ->+ [Midi.Event Midi.Message] ;+chord4 dur p0 p1 p2 p3 = chord dur [p0, p1, p2, p3] ;+++major, major7, minor, minor7 ::+ Time -> Pitch -> [Midi.Event Midi.Message] ;++major dur base =+ chord4 dur base (base + 4) (base + 7) (base + 12) ;++major7 dur base =+ chord4 dur base (base + 4) (base + 7) (base + 10) ;++minor dur base =+ chord4 dur base (base + 3) (base + 7) (base + 12) ;++minor7 dur base =+ chord4 dur base (base + 3) (base + 7) (base + 10) ;
− data/base/Chords.hs
@@ -1,40 +0,0 @@-module Chords where--import Midi-import Pitch ( Pitch )---chord ::- Time -> [Pitch] ->- [Midi.Event Midi.Message] ;-chord dur =- mergeMany . map (note dur) ;---chord3 ::- Time ->- Pitch -> Pitch -> Pitch ->- [Midi.Event Midi.Message] ;-chord3 dur p0 p1 p2 = chord dur [p0, p1, p2] ;--chord4 ::- Time ->- Pitch -> Pitch -> Pitch -> Pitch ->- [Midi.Event Midi.Message] ;-chord4 dur p0 p1 p2 p3 = chord dur [p0, p1, p2, p3] ;---major, major7, minor, minor7 ::- Time -> Pitch -> [Midi.Event Midi.Message] ;--major dur base =- chord4 dur base (base + 4) (base + 7) (base + 12) ;--major7 dur base =- chord4 dur base (base + 4) (base + 7) (base + 10) ;--minor dur base =- chord4 dur base (base + 3) (base + 7) (base + 12) ;--minor7 dur base =- chord4 dur base (base + 3) (base + 7) (base + 10) ;
+ data/base/Controller.hs view
@@ -0,0 +1,11 @@+module Controller where+{-+Do not alter this module!+The live-sequencer relies on the module content as it is.+-}++checkBox :: String -> Bool -> Bool ;+checkBox _name deflt = deflt ;++slider :: String -> Integer -> Integer -> Integer -> Integer ;+slider _name _lower _upper deflt = deflt ;
− data/base/Controls.hs
@@ -1,11 +0,0 @@-module Controls where-{--Do not alter this module!-The live-sequencer relies on the module content as it is.--}--checkBox :: String -> Bool -> Bool ;-checkBox _name deflt = deflt ;--slider :: String -> Integer -> Integer -> Integer -> Integer ;-slider _name _lower _upper deflt = deflt ;
+ data/base/Maybe.hs view
@@ -0,0 +1,24 @@+module Maybe where++import List (map);+import ListLive (cons);+import Function (id, ($), (.));+import Prelude ();++data Maybe a = Nothing | Just a;+++maybe :: b -> (a -> b) -> Maybe a -> b;+maybe x _ Nothing = x;+maybe _ f (Just a) = f a;++fromMaybe :: a -> Maybe a -> a;+fromMaybe a = maybe a id;++catMaybes :: [Maybe a] -> [a];+catMaybes [] = [];+catMaybes (mx : xs) =+ maybe id cons mx $ catMaybes xs;++mapMaybe :: (a -> Maybe b) -> [a] -> [b];+mapMaybe f = catMaybes . map f;
data/example/Band.hs view
@@ -1,7 +1,7 @@ module Band where import Drum-import Chords+import Chord import Pitch import Midi import List
data/example/BandControlled.hs view
@@ -1,8 +1,8 @@ module BandControlled where -import Controls+import Controller import Drum-import Chords+import Chord import Pitch import Midi import List
data/example/Klingklong.hs view
@@ -1,6 +1,6 @@ module Klingklong where -import Chords+import Chord import Pitch import Midi import List
data/example/Sweep.hs view
@@ -1,6 +1,6 @@ module Sweep where -import Chords+import Chord import Pitch import Midi import List
data/example/UD.hs view
@@ -1,7 +1,7 @@ module UD where import Drum-import Chords+import Chord import Pitch import Midi import List
live-sequencer.cabal view
@@ -1,5 +1,5 @@ Name: live-sequencer-Version: 0.0.4+Version: 0.0.5 Author: Henning Thielemann and Johannes Waldmann Maintainer: Johannes Waldmann <waldmann@imn.htwk-leipzig.de>, Henning Thielemann <haskell@henning-thielemann.de> Category: Sound, Music, GUI@@ -18,282 +18,6 @@ Additionally the state of the interpreter is shown in the form of the current reduced term for educational and debugging purposes.- .- 1. example usage *****- .- The live-sequencer does not make music itself,- its entire task is to control other software or hardware synthesizers.- That is, in order to hear something you need a working MIDI synthesizer- such as the sampling based software synthesizer TiMidity.- You may run TiMidity and the live-sequencer this way:- .- > timidity -iA &- > live-sequencer-gui --connect-to TiMidity Simplesong &- .- This should give you an ongoing stream of notes.- Then change one of the numbers- that appear in the lines like- @qn = 300@- and press CTRL-R for \"reloading\" that module into the interpreter.- This should immediately have an effect,- namely increasing the tempo of the melody.- You may also alter a note name like @c 4@ to @cis 4@, then reload,- then undo the modification and reload, again, after a while.- This is the main idea of changing the song while it is playing.- The way the changes are applied warrants- that the change takes effect when the time comes.- Music is not interrupted and- does not need to be restarted for reacting to changes.- .- The overall task performed by the sequencer- is to lazily evaluate a term called @main@- that is a list of events.- The value of @main@ is a stream of midi events- (@On/Off pitch velocity@, @PgmChange@, @Controller@)- or (@Wait milliseconds@).- You may wrap a MIDI event in a @Channel@ constructor- in order to assign the event to the particular MIDI channel.- If you omit this constructor then the event is put to channel 0.- .- In each step, the head of the @main@ stream gets reduced- to head normal form (with @:@ at the top),- and the first arg of the @:@ gets fully expanded- and it must be a MIDI event.- .- 2. input language *****- .- The used language is syntactically almost a subset of Haskell with- only strict pattern matching and- pattern matching only at the definition level (no case),- no local bindings (no lambda, let, where),- no types (no type inference, type signatures and type declarations are skipped),- and with diet syntax (i.e. drastically reduced syntactic sugar,- like no layout rule, no do syntax, no list comprehension, no operator sections).- .- Semantics is similar to lazy evaluation,- but we have no sharing.- The design goal is that code can be changed- while the program is running.- This implies that evaluation of one expression- may give different results at different times- (e.g., during a live performance,- one changes some chords of a musical theme).- In turn, this implies that we do not store- and share results of evaluations,- hence, we don't have local bindings.- .- You may import and use- the special functions 'Controls.checkBox', 'Controls.slider'- from the "Controls" module.- For every call to these functions a widget is added to the control window- and the state of the widget is the result of the function call.- Technically every change of these widgets- internally adds or updates a rule in the "Controls" module.- The effect is very similar to updating a value definition in a module- and then reloading that module to the interpreter,- but using the widgets is more intuitive.- .- 3. Offline rendering *****- .- In the library interface of this package- we provide the basic Live-Sequencer modules- in order to allow offline rendering of music- that you programmed within the Live-Sequencer.- You may generate a standard MIDI file- using functions from the "Render" module.- To this end load your song module into GHCi and call- .- >YourModule> Render.writeStream "yoursong.mid" yourSong- .- 4. HTTP access *****- .- You may open a browser and view all modules under- <http://localhost:8080/>.- If the user of the GUI inserts comments like this one:- .- >----------------- .- , then it is possible to modify the content below this mark via HTTP.- This way multiple people can participate in the composition process.- The recommended situation is a room- with a data projector and a loudspeaker,- where the conductor explains the functions to the auditory- and the participants can watch the screen and listen to the music.- .- You may choose any other port using the command line option @--http-port@.- If you want to use a system port like the standard HTTP port 80,- we recommend to configure a firewall to redirect the external port 80- to the internal user port.- We discourage from starting the live-sequencer as root user.- You may disable the HTTP server altogether- by compiling with @cabal install -f-httpServer@.- .- 5. Execution modes *****- .- There are three modes of execution- that you can choose from the @Execution@ menu:- .- * Real-time:- This is the mode for musical live performances.- The interpreter waits according to the @Wait@ elements in the main list.- .- * Slow motion:- This mode is for demonstration and debugging.- You can alter the speed using @CTRL-\<@ and @CTRL-\>@.- .- * Single step:- This mode is for demonstration, debugging and as a pause mode,- when the interpreter reaches the end of the main list.- You can trigger evaluation of the next element using @CTRL-N@.- You can perform a single reduction with @CTRL-U@,- which also highlights the rule that will be applied next.- Changes to the program are only respected- when an element is completely reduced and sent via MIDI.- Unfortunately it is currently not possible to undo a step.- .- 6. Editing *****- .- You can change a module name by altering the module identifier- between the @module@ and @where@ keywords- and then triggering module reload.- The same way you can load new modules- by adding import lines and reloading the module.- Alternatively, you may create new modules or close old ones- using functions from the @File@ menu.- .- For composition it is useful to play parts of the music.- You can do this by simply placing the cursor within an identifier- or by marking an expression- and then call @Play term@ from the @Execution@ menu.- This will make the marked expression the current term- and start playing.- .- Once the music is playing you can change it- by altering the module and reload it.- However you may find out- that you cannot do a certain modification this way.- In this case you can mark an expression- that denotes a stream transformation function- and call the @Apply term@ menu item.- This will apply the marked function to the current term.- Useful functions are:- .- * @merge newTrack@ for adding a new track simultaneously.- However, mind the latency!- .- * @flip append newTrack@ for appending some events to the current music.- .- * @dropTime time@ for skipping a part of the music.- However this may skip some @Off@ events and this yields hanging tones.- Additionally you may exceed the number of maximally allowed reductions.- .- * @skipTime time@ for skipping a part of the music.- This one only removes or shortens @Wait@ constructors.- Thus all events are played but you risk exceeding the limit- for playing many events at once.- .- * @compressTime acceleration time@ for accelerating the music for a certain time.- This should circumvent the problems of @dropTime@ and @skipTime@.- .- 7. Limits *****- .- Without some safety belts it would be very easy- to consume all memory or all processing power- by accident or by people who contribute malicious code via HTTP.- Thus we have added some limits.- These have reasonable default values- but you can adjust them to your needs via command line options at startup.- These are the limits you can set:- .- * maximum number of reduction steps per list element:- With this limit you can prevent infinite loops.- .- * term size:- With this limit you can prevent memory leaks.- .- * term depth:- With this limit you can prevent unbalanced expression trees.- Unbalanced trees do not consume more memory than balanced ones,- but they consume considerably more graphical space on pretty-printing.- .- * maximum number of events per time period:- If your song is too fast or does not contain any @Wait@ elements at all,- your machine will run out of processing power.- Thus you can restrict the number of events- generated in a certain period of time.- It is controlled by two options:- @--event-period@ sets the time period in milliseconds- whereas @--max-events-per-period@- sets the maximum number of events within this time period.- In principle you can consider this a ratio- but you cannot simply cancel it.- E.g. both @--event-period=100 --max-events-per-period=15@- and @--event-period=1000 --max-events-per-period=150@- describe the same ratio,- the difference is how liberal is the sequencer- with respect to exceeding the ratio for a short time.- Read the first setting as:- \"For 15 adjacent events,- the duration between the first and the last one must be at least 100ms.\"- That is, if you emit 20 events simultaneously every second,- then the first setting will forbid this,- and the second setting will allow it.- Thus we recommend to first set @--max-events-per-period@- to the number of events that you want to emit simultaneously- and then set @--event-period@ large enough- to match the power of your machine.- .- 8. ALSA *****- .- Using the @--new-out-port@ option- you may add more ALSA MIDI ports.- Every port extends the range of MIDI channels by 16 new logical channels.- That is @Channel 40 ev@ sends an event- to MIDI channel 8 at the second newly added ALSA port- (because 40 = 2*16+8).- Every @--connect-to@ option refers to the latest added port.- Example:- .- > live-sequencer --connect-to Synth0 --new-out-port out1 --connect-to Synth1 --new-out-port out2 --connect-to Synth2- .- You do not need to connect to any synthesizer at startup.- You may connect or disconnect the live-sequencer- to any synthesizer once it is running- using @aconnect@ (command line) or- @kaconnect@, @alsa-patch-bay@, @patchage@ (graphical interfaces).- .- The live-sequencer itself can be controlled to some extent.- You may start the live-sequencer this way- .- > live-sequencer --connect-from YourMidiController- .- or connect to it once it is running.- This enables the following functions:- .- * If you press a key on your MIDI keyboard named YourMidiController,- then the according note name is inserted in the current module.- However, note durations cannot be preserved- and velocities are ignored, as well.- Thus don't expect that the live-sequencer captures complex songs,- this function is just intended as assistance for note input.- .- * You can control execution of the live-sequencer- using MIDI Machine Control SysEx messages.- Some MIDI controller keyboards have transportation buttons- that support those messages.- .- The supported MMC commands are:- .- * RECORD STROBE:- Toggle between receiving and ignoring note input from MIDI keyboard- .- * PLAY: Restart the interpreter- .- * STOP: Halt the interpreter and turn sound off- .- * PAUSE: Toggle between real time and single step mode- .- * FAST FORWARD: Next element in single step mode Build-Type: Simple @@ -313,8 +37,8 @@ data/example/Pattern.hs data/base/Bool.hs- data/base/Chords.hs- data/base/Controls.hs+ data/base/Chord.hs+ data/base/Controller.hs data/base/Drum.hs data/base/Enum.hs data/base/Function.hs@@ -324,6 +48,7 @@ data/base/ListLive.hs data/base/List/Basic.hs data/base/List/Advanced.hs+ data/base/Maybe.hs data/base/Midi.hs data/base/Music.hs data/base/Pitch.hs@@ -333,6 +58,7 @@ data/prelude/Prelude.hs Extra-Source-Files:+ ChangeLog http/enable/HTTPServer.hs http/enable/HTTPServer/GUI.hs http/enable/HTTPServer/Option.hs@@ -345,7 +71,7 @@ Source-Repository this Type: git- Tag: 0.0.4+ Tag: 0.0.5 Location: http://code.haskell.org/~thielema/livesequencer/ Flag gui@@ -372,14 +98,15 @@ Exposed-Modules: Render Bool- Chords- Controls+ Chord+ Controller Drum Enum Function Instrument Integer ListLive+ Maybe Midi Music Pitch@@ -425,7 +152,7 @@ Build-Depends: stm-split >=0.0 && <0.1, concurrent-split >=0.0 && <0.1,- transformers >=0.2.2 && <0.4,+ transformers >=0.2.2 && <0.6, explicit-exception >=0.1.5 && <0.2, parsec >=2.1 && <3.2, pretty >=1.0 && <1.2,@@ -437,7 +164,7 @@ data-accessor >=0.2.1 && <0.3, strict >=0.3.2 && <0.4, utility-ht >=0.0.8 && <0.1,- non-empty >=0.0 && <0.1,+ non-empty >=0.2 && <0.3, containers >=0.3 && <0.6, bytestring >=0.9 && <0.11, process >=1.0 && <1.2,@@ -452,7 +179,7 @@ wxcore >=0.12.1 && <0.14, stm >=2.2 && <2.4, concurrent-split >=0.0 && <0.1,- transformers >=0.2.2 && <0.4,+ transformers >=0.2.2 && <0.6, explicit-exception >=0.1.5 && <0.2, parsec >=2.1 && <3.2, pretty >=1.0 && <1.2,@@ -463,7 +190,7 @@ data-accessor-transformers >=0.2.1 && <0.3, data-accessor >=0.2.1 && <0.3, strict >=0.3.2 && <0.4,- non-empty >=0.0 && <0.1,+ non-empty >=0.2 && <0.3, utility-ht >=0.0.8 && <0.1, containers >=0.3 && <0.6, bytestring >=0.9 && <0.11,@@ -484,8 +211,8 @@ Module Option Option.Utility- Controls- ControlsBase+ Controller+ ControllerBase Program Rewrite Rule@@ -528,7 +255,7 @@ alsa-core >=0.5 && <0.6, unix >=2.4 && <2.7, directory >=1.0 && <1.3,- transformers >=0.2.2 && <0.4,+ transformers >=0.2.2 && <0.6, base >=4.2 && <5 Else Buildable: False
+ src/Controller.hs view
@@ -0,0 +1,144 @@+-- | controllers are widgets that are:+-- * specified in the program text,+-- * displayed in the GUI,+-- * read while executing the program.++module Controller (+ module Controller,+ module ControllerBase,+ ) 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 qualified Control.Monad.Exception.Synchronous as Exc+import qualified Control.Monad.Trans.Writer as MW+import qualified Control.Monad.Trans.Class as MT+import Control.Monad.IO.Class ( liftIO )++import qualified Graphics.UI.WX as WX+import qualified Graphics.UI.WXCore.WxcClassesMZ as WXCMZ+import Graphics.UI.WX.Attributes ( Prop((:=)), set, get )+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 Data.Foldable ( forM_ )+import Control.Functor.HT ( void )+++data Event = Event Name Value+ deriving Show++++moduleName :: Module.Name+moduleName = Module.Name "Controller"++defltIdent :: Term.Term+defltIdent = read "deflt"++changeControllerModule ::+ Program.Program ->+ Event ->+ Exc.Exceptional Exception.Message Program.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+ "cannot find module for controller updates" )+ ( M.lookup moduleName $ Program.modules p0 )++updateValue ::+ Name -> Value -> Values -> Values+updateValue name val vals =+ case val of+ Bool b ->+ vals{boolValues = M.insert name b $ boolValues vals}+ Number x ->+ vals{numberValues = M.insert name x $ numberValues vals}+++controllerRule ::+ Name -> Value -> Rule.Rule+controllerRule name val =+ case val of+ Bool b ->+ Rule.Rule+ ( read "checkBox" )+ [ Term.StringLiteral+ ( Module.nameRange moduleName )+ ( deconsName name ),+ defltIdent ]+ ( Term.Node ( read $ show b ) [] )+ Number x ->+ Rule.Rule+ ( read "slider" )+ [ Term.StringLiteral+ ( Module.nameRange moduleName )+ ( deconsName name ),+ read "lower",+ read "upper",+ defltIdent ]+ ( Term.Number ( Module.nameRange moduleName ) ( fromIntegral x ) )++create ::+ WX.Frame () ->+ Assignments ->+ (Event -> IO ()) ->+ IO ()+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) $+ \ ( name, (_rng, con) ) ->+ case con of+ C.CheckBox val -> do+ cb <- liftIO $ WX.checkBox panel+ [ text := deconsName name , checked := val ]+ liftIO $ set cb+ [ on command := do+ c <- get cb checked+ sink $ Event name $ Bool c+ ]+ MW.tell [ widget cb ]+ C.Slider lower upper val -> do+ sl <- liftIO $ WX.hslider panel False lower upper+ [ selection := val ]+ sp <- liftIO $ WX.spinCtrl panel lower upper+ [ selection := val ]+ liftIO $ set sl+ [ on command := do+ c <- get sl selection+ set sp [ selection := c ]+ sink $ Event name $ Number c+ ]+ liftIO $ set sp+ [ on select := do+ c <- get sp selection+ set sl [ selection := c ]+ sink $ Event name $ Number c+ ]+ MT.lift $ MW.tell [+ WX.row 5 [ WX.hfill $ widget sl , widget sp,+ WX.label (deconsName name) ]+ ]+ set frame [+ layout :=+ container panel $ column 5 $+ WX.hfloatCenter (row 5 cs) : ss,+ WX.outerSize := size+ ]
+ src/ControllerBase.hs view
@@ -0,0 +1,133 @@+{-+This is a part of the Controller module+that is separated in order to prevent an import cycle.+-}+module ControllerBase where++import qualified Exception+import qualified Term+import Term ( Term )++import qualified Data.Map as M++import qualified Control.Monad.Exception.Synchronous as Exc++import qualified Control.Monad.Trans.Class as MT+import qualified Control.Monad.Trans.State as MS+import qualified Data.Traversable as Trav++++data Control =+ CheckBox Bool+ | Slider Int Int Int++data Value = Bool Bool | Number Int+ deriving Show++data Values =+ Values {+ boolValues :: M.Map Name Bool,+ numberValues :: M.Map Name Int+ } deriving Show++newtype Name = Name String+ deriving (Eq, Ord, Show)++deconsName :: Name -> String+deconsName (Name name) = name+++emptyValues :: Values+emptyValues = Values M.empty M.empty++updateValues :: Values -> Assignments -> Assignments+updateValues (Values bools numbers) assigns =+ M.union+ (M.intersectionWith+ (\b (rng, a) -> (rng,+ case a of+ CheckBox _deflt -> CheckBox b+ _ -> a))+ bools assigns) $+ M.union+ (M.intersectionWith+ (\x (rng, a) -> (rng,+ case a of+ Slider lower upper _deflt -> Slider lower upper x+ _ -> a))+ numbers assigns) $+ assigns+++type Assignments = M.Map Name (Term.Range, Control)+++exc :: Term.Range -> String -> Exception.Message+exc rng msg =+ Exception.Message Exception.Parse rng msg++excDuplicate :: Name -> Term.Range -> Exception.Message+excDuplicate name rng =+ exc rng $+ "duplicate controller definition with name "+ ++ deconsName name++union ::+ Assignments ->+ Assignments ->+ Exc.Exceptional Exception.Message Assignments+union m0 m1 =+ let f = fmap Exc.Success+ in Trav.sequenceA $+ M.unionWithKey+ (\name _ a -> do+ (rng, _c) <- a+ Exc.throw $ excDuplicate name rng)+ (f m0) (f m1)++collect ::+ Term -> Exc.Exceptional Exception.Message Assignments+collect topTerm =+ flip MS.execStateT M.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++ ( _pos, term ) <- Term.subterms topTerm+ case Term.viewNode term of+ Just ( "checkBox" , args ) ->+ return $+ case args of+ [ Term.StringLiteral _rng tag, Term.Node deflt [] ] ->+ case reads $ Term.name deflt of+ [(b, "")] ->+ Exc.Success $ (Name tag, (Term.termRange term, CheckBox b))+ _ ->+ Exc.Exception $+ exc (Term.range deflt) $+ "cannot parse Bool value " +++ show (Term.name deflt) ++ " for checkBox"+ _ ->+ Exc.Exception $+ exc (Term.termRange term) "invalid checkBox arguments"+ Just ( "slider" , args ) ->+ return $+ case args of+ [ Term.StringLiteral _rngT tag, lower, upper, deflt ] -> do+ let milliard = 1000000000+ number arg =+ Exception.checkRange+ Exception.Parse 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"+ _ -> []
− src/Controls.hs
@@ -1,144 +0,0 @@--- | controls are widgets that are:--- * specified in the program text,--- * displayed in the GUI,--- * read while executing the program.--module Controls (- module Controls,- module ControlsBase,- ) where--import ControlsBase- ( Name, deconsName, Assignments,- Value (Bool, Number), Values (boolValues, numberValues) )-import qualified ControlsBase as C-import qualified Program-import qualified Module-import qualified Rule-import qualified Term-import qualified Exception--import qualified Control.Monad.Exception.Synchronous as Exc-import qualified Control.Monad.Trans.Writer as MW-import qualified Control.Monad.Trans.Class as MT-import Control.Monad.IO.Class ( liftIO )--import qualified Graphics.UI.WX as WX-import qualified Graphics.UI.WXCore.WxcClassesMZ as WXCMZ-import Graphics.UI.WX.Attributes ( Prop((:=)), set, get )-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 Data.Foldable ( forM_ )-import Control.Functor.HT ( void )---data Event = Event Name Value- deriving Show----moduleName :: Module.Name-moduleName = Module.Name "Controls"--defltIdent :: Term.Term-defltIdent = read "deflt"--changeControllerModule ::- Program.Program ->- Event ->- Exc.Exceptional Exception.Message Program.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- "cannot find module for controller updates" )- ( M.lookup moduleName $ Program.modules p0 )--updateValue ::- Name -> Value -> Values -> Values-updateValue name val vals =- case val of- Bool b ->- vals{boolValues = M.insert name b $ boolValues vals}- Number x ->- vals{numberValues = M.insert name x $ numberValues vals}---controllerRule ::- Name -> Value -> Rule.Rule-controllerRule name val =- case val of- Bool b ->- Rule.Rule- ( read "checkBox" )- [ Term.StringLiteral- ( Module.nameRange moduleName )- ( deconsName name ),- defltIdent ]- ( Term.Node ( read $ show b ) [] )- Number x ->- Rule.Rule- ( read "slider" )- [ Term.StringLiteral- ( Module.nameRange moduleName )- ( deconsName name ),- read "lower",- read "upper",- defltIdent ]- ( Term.Number ( Module.nameRange moduleName ) ( fromIntegral x ) )--create ::- WX.Frame () ->- Assignments ->- (Event -> IO ()) ->- IO ()-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) $- \ ( name, (_rng, con) ) ->- case con of- C.CheckBox val -> do- cb <- liftIO $ WX.checkBox panel- [ text := deconsName name , checked := val ]- liftIO $ set cb- [ on command := do- c <- get cb checked- sink $ Event name $ Bool c- ]- MW.tell [ widget cb ]- C.Slider lower upper val -> do- sl <- liftIO $ WX.hslider panel False lower upper- [ selection := val ]- sp <- liftIO $ WX.spinCtrl panel lower upper- [ selection := val ]- liftIO $ set sl- [ on command := do- c <- get sl selection- set sp [ selection := c ]- sink $ Event name $ Number c- ]- liftIO $ set sp- [ on select := do- c <- get sp selection- set sl [ selection := c ]- sink $ Event name $ Number c- ]- MT.lift $ MW.tell [- WX.row 5 [ WX.hfill $ widget sl , widget sp,- WX.label (deconsName name) ]- ]- set frame [- layout :=- container panel $ column 5 $- WX.hfloatCenter (row 5 cs) : ss,- WX.outerSize := size- ]
− src/ControlsBase.hs
@@ -1,133 +0,0 @@-{--This is a part of the Controls module-that is separated in order to prevent an import cycle.--}-module ControlsBase where--import qualified Exception-import qualified Term-import Term ( Term )--import qualified Data.Map as M--import qualified Control.Monad.Exception.Synchronous as Exc--import qualified Control.Monad.Trans.Class as MT-import qualified Control.Monad.Trans.State as MS-import qualified Data.Traversable as Trav----data Control =- CheckBox Bool- | Slider Int Int Int--data Value = Bool Bool | Number Int- deriving Show--data Values =- Values {- boolValues :: M.Map Name Bool,- numberValues :: M.Map Name Int- } deriving Show--newtype Name = Name String- deriving (Eq, Ord, Show)--deconsName :: Name -> String-deconsName (Name name) = name---emptyValues :: Values-emptyValues = Values M.empty M.empty--updateValues :: Values -> Assignments -> Assignments-updateValues (Values bools numbers) assigns =- M.union- (M.intersectionWith- (\b (rng, a) -> (rng,- case a of- CheckBox _deflt -> CheckBox b- _ -> a))- bools assigns) $- M.union- (M.intersectionWith- (\x (rng, a) -> (rng,- case a of- Slider lower upper _deflt -> Slider lower upper x- _ -> a))- numbers assigns) $- assigns---type Assignments = M.Map Name (Term.Range, Control)---exc :: Term.Range -> String -> Exception.Message-exc rng msg =- Exception.Message Exception.Parse rng msg--excDuplicate :: Name -> Term.Range -> Exception.Message-excDuplicate name rng =- exc rng $- "duplicate controller definition with name "- ++ deconsName name--union ::- Assignments ->- Assignments ->- Exc.Exceptional Exception.Message Assignments-union m0 m1 =- let f = fmap Exc.Success- in Trav.sequenceA $- M.unionWithKey- (\name _ a -> do- (rng, _c) <- a- Exc.throw $ excDuplicate name rng)- (f m0) (f m1)--collect ::- Term -> Exc.Exceptional Exception.Message Assignments-collect topTerm =- flip MS.execStateT M.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-- ( _pos, term ) <- Term.subterms topTerm- case Term.viewNode term of- Just ( "checkBox" , args ) ->- return $- case args of- [ Term.StringLiteral _rng tag, Term.Node deflt [] ] ->- case reads $ Term.name deflt of- [(b, "")] ->- Exc.Success $ (Name tag, (Term.termRange term, CheckBox b))- _ ->- Exc.Exception $- exc (Term.range deflt) $- "cannot parse Bool value " ++- show (Term.name deflt) ++ " for checkBox"- _ ->- Exc.Exception $- exc (Term.termRange term) "invalid checkBox arguments"- Just ( "slider" , args ) ->- return $- case args of- [ Term.StringLiteral _rngT tag, lower, upper, deflt ] -> do- let milliard = 1000000000- number arg =- Exception.checkRange- Exception.Parse 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"- _ -> []
src/GUI.hs view
@@ -45,7 +45,7 @@ import qualified Program import qualified Exception import qualified Module-import qualified Controls+import qualified Controller import qualified Rewrite import qualified Option import qualified Log@@ -195,7 +195,7 @@ data Action = Execution Execution | Modification Modification- | Control Controls.Event+ | Control Controller.Event data Execution = Mode Event.WaitMode | SwitchMode | Restart | Stop |@@ -222,7 +222,7 @@ | InsertPage { _activate :: Bool, _module :: Module.Module } | DeletePage Module.Name | RenamePage Module.Name Module.Name- | RebuildControls Controls.Assignments+ | RebuildControllers Controller.Assignments | InsertText { _insertedText :: String } | StatusLine { _statusLine :: String } | HTTP HTTPGui.GuiUpdate@@ -377,18 +377,18 @@ M.difference ( Program.modules p2 ) ( Program.modules p1 ) -- Refresh must happen after a Rename MW.tell [ Refresh (Module.name m) sourceCode pos,- RebuildControls $ Program.controls p2 ]+ RebuildControllers $ Program.controls p2 ] return p2 registerProgram :: TChan.In GuiUpdate -> Module.Name -> Program -> STM () registerProgram output mainModName p = do TChan.write output $ Register mainModName $ Program.modules p- TChan.write output $ RebuildControls $ Program.controls p+ TChan.write output $ RebuildControllers $ Program.controls p updateProgram :: TVar Program -> TChan.In GuiUpdate -> Program -> STM () updateProgram program output p = do liftSTM $ writeTVar program p- liftSTM $ TChan.write output $ RebuildControls $ Program.controls p+ liftSTM $ TChan.write output $ RebuildControllers $ Program.controls p {-@@ -432,9 +432,9 @@ Log.put $ show event STM.atomically $ exceptionToGUI output $ do p <- lift $ readTVar program- p' <- Exception.lift $ Controls.changeControllerModule p event+ p' <- Exception.lift $ Controller.changeControllerModule p event lift $ writeTVar program p'- -- return $ Controls.getControllerModule p'+ -- return $ Controller.getControllerModule p' -- Log.put $ show m Execution exec ->@@ -1413,8 +1413,8 @@ set status [ text := "renamed " ++ Module.tellName fromName ++ " to " ++ Module.tellName toName ] - RebuildControls ctrls ->- Controls.create frameControls ctrls $+ RebuildControllers ctrls ->+ Controller.create frameControls ctrls $ Chan.write input . Control Running mode -> do
src/Module.hs view
@@ -3,7 +3,7 @@ import IO ( Input, Output, input, output ) import Term ( Term, Identifier, lexer ) import Rule ( Rule )-import qualified ControlsBase as Controls+import qualified ControllerBase as Controller import qualified Type import qualified Term import qualified Rule@@ -145,7 +145,7 @@ reserved lexer "type" l <- input reservedOp lexer "="- r <- input+ r <- Type.parseExpression void $ Token.semi lexer return $ Type { typeLhs = l, typeRhs = r } @@ -252,7 +252,7 @@ , declarations :: [ Declaration ] , functions :: FunctionDeclarations , constructors :: ConstructorDeclarations- , controls :: Controls.Assignments+ , controls :: Controller.Assignments , sourceText :: String , sourceLocation :: FilePath }@@ -355,12 +355,12 @@ Term.Node ident _ <- summands return ident -makeControls ::+makeControllers :: [Declaration] ->- Exc.Exceptional Exception.Message Controls.Assignments-makeControls decls =+ Exc.Exceptional Exception.Message Controller.Assignments+makeControllers decls = flip (foldr- (\r go a -> Controls.collect r >>= Controls.union a >>= go)+ (\r go a -> Controller.collect r >>= Controller.union a >>= go) return) M.empty $ do Module.RuleDeclaration rule <- decls return $ Rule.rhs rule@@ -388,7 +388,7 @@ is <- Parsec.many input ds <- Parsec.many input return $ do- ctrls <- makeControls ds+ ctrls <- makeControllers ds return $ Module { name = m, imports = is, declarations = ds, functions = makeFunctions ds,
src/Option.hs view
@@ -20,6 +20,7 @@ import Control.Monad ( when ) +import qualified Data.NonEmpty.Class as NEClass import qualified Data.NonEmpty as NEList import Data.Traversable ( forM ) import Data.Bool.HT ( if' )@@ -141,7 +142,7 @@ Opt.Option [] ["new-out-port"] (flip ReqArg "PORTNAME" $ \str flags -> return $ flags{connect =- NEList.cons (Port str Nothing (Just [])) $+ NEClass.cons (Port str Nothing (Just [])) $ connect flags}) ("create new ALSA output port and add 16 MIDI channels") : Opt.Option [] ["sequencer-name"]
src/Program.hs view
@@ -6,7 +6,7 @@ import qualified Module import qualified Log import qualified Exception-import qualified ControlsBase as Controls+import qualified ControllerBase as Controller import qualified Control.Monad.Exception.Synchronous as Exc import Control.Monad.Trans.Class ( lift )@@ -30,8 +30,8 @@ { modules :: M.Map Module.Name Module , functions :: Module.FunctionDeclarations , constructors :: Module.ConstructorDeclarations- , controls :: Controls.Assignments- , controlValues :: Controls.Values+ , controls :: Controller.Assignments+ , controlValues :: Controller.Values } -- deriving (Show) @@ -42,7 +42,7 @@ functions = M.empty, constructors = S.empty, controls = M.empty,- controlValues = Controls.emptyValues+ controlValues = Controller.emptyValues } singleton :: Module -> Program@@ -52,7 +52,7 @@ functions = Module.functions m, constructors = Module.constructors m, controls = Module.controls m,- controlValues = Controls.emptyValues+ controlValues = Controller.emptyValues } {- |@@ -72,8 +72,8 @@ unionDecls ( mapFromSet $ Module.constructors m ) ( mapFromSet $ constructors p ) )- ( Controls.union- ( Controls.updateValues+ ( Controller.union+ ( Controller.updateValues ( controlValues p ) ( Module.controls m ) ) ( controls p ) ) ( return $ controlValues p )