live-sequencer 0.0 → 0.0.1
raw patch · 70 files changed
+4690/−3170 lines, 70 files
Files
- data/Band.hs +0/−34
- data/Bool.hs +0/−24
- data/Chords.hs +0/−41
- data/CrossSum.hs +0/−62
- data/DeBruijn.hs +0/−49
- data/Drum.hs +0/−76
- data/Fibonacci.hs +0/−48
- data/Finite.hs +0/−18
- data/Function.hs +0/−34
- data/Instrument.hs +0/−135
- data/Integer.hs +0/−5
- data/Klingklong.hs +0/−261
- data/List.hs +0/−141
- data/ListLive.hs +0/−114
- data/Midi.hs +0/−153
- data/Music.hs +0/−100
- data/Pattern.hs +0/−38
- data/Pitch.hs +0/−38
- data/Render.hs +0/−82
- data/Simplesong.hs +0/−20
- data/Sweep.hs +0/−39
- data/Tuple.hs +0/−9
- data/UD.hs +0/−62
- data/base/Bool.hs +27/−0
- data/base/Chords.hs +41/−0
- data/base/Controls.hs +11/−0
- data/base/Drum.hs +76/−0
- data/base/Function.hs +36/−0
- data/base/Instrument.hs +135/−0
- data/base/Integer.hs +5/−0
- data/base/List.hs +141/−0
- data/base/ListLive.hs +114/−0
- data/base/Midi.hs +221/−0
- data/base/Music.hs +100/−0
- data/base/Pitch.hs +41/−0
- data/base/Render.hs +82/−0
- data/base/Tuple.hs +9/−0
- data/example/Band.hs +34/−0
- data/example/BandControlled.hs +43/−0
- data/example/CrossSum.hs +62/−0
- data/example/DeBruijn.hs +49/−0
- data/example/Fibonacci.hs +48/−0
- data/example/Finite.hs +18/−0
- data/example/Klingklong.hs +261/−0
- data/example/Pattern.hs +38/−0
- data/example/Simplesong.hs +20/−0
- data/example/Sweep.hs +39/−0
- data/example/UD.hs +62/−0
- http/disable/HTTPServer/GUI.hs +1/−4
- http/enable/HTTPServer/GUI.hs +7/−12
- live-sequencer.cabal +290/−82
- src/ALSA.hs +45/−32
- src/Console.hs +25/−20
- src/Controls.hs +104/−69
- src/ControlsBase.hs +133/−0
- src/Event.hs +111/−93
- src/Exception.hs +94/−8
- src/GUI.hs +1475/−1046
- src/IO.hs +2/−2
- src/Module.hs +147/−59
- src/Option.hs +125/−21
- src/Program.hs +122/−70
- src/Rewrite.hs +81/−46
- src/Rule.hs +2/−2
- src/Step.hs +2/−4
- src/Term.hs +37/−17
- src/Time.hs +110/−0
- src/Utility/Concurrent.hs +22/−0
- src/Utility/NonEmptyList.hs +39/−0
- src/Utility/WX.hs +3/−0
− data/Band.hs
@@ -1,34 +0,0 @@-module Band where--import Drum-import Chords-import Pitch-import Midi-import List-import Prelude ( (*) ) ;--main, chords, drums :: [Event (Channel Message)] ;-main = merge ( cycle chords ) ( cycle drums ) ;--en, qn, hn, wn :: Time ;-en = 100 ;-qn = 2 * en ;-hn = 2 * qn ;-wn = 2 * hn ;--chords =- channel 0 ( concat- [ quad ( major qn (c 4) )- , quad ( minor qn (a 4) )- , quad ( major qn (f 4) )- , quad ( major7 qn (g 4) )- ] ) ;--drums =- drumChannel ( concat- [ emphasize 16 ( drum bassDrum1 hn )- , quad ( drum acousticSnare en )- ] ) ;--quad :: [a] -> [a] ;-quad x = concat [ x, x, x, x ] ;
− data/Bool.hs
@@ -1,24 +0,0 @@-module Bool where--ifThenElse :: Bool -> a -> a -> a ;-ifThenElse True y _ = y ;-ifThenElse False _ n = n ;---not :: Bool -> Bool ;-not False = True ;-not True = False ;---infixr 3 && ;--(&&) :: Bool -> Bool -> Bool ;-False && _ = False ;-True && x = x ;---infixr 2 || ;--(||) :: Bool -> Bool -> Bool ;-True || _ = True ;-False || x = x ;
− data/Chords.hs
@@ -1,41 +0,0 @@-module Chords where--import Midi--chord3 ::- Integer ->- Integer -> Integer -> Integer ->- [Midi.Event Midi.Message] ;-chord3 dur p0 p1 p2 =- mergeMany [- note dur p0,- note dur p1,- note dur p2- ] ;--chord4 ::- Integer ->- Integer -> Integer -> Integer -> Integer ->- [Midi.Event Midi.Message] ;-chord4 dur p0 p1 p2 p3 =- mergeMany [- note dur p0,- note dur p1,- note dur p2,- note dur p3- ] ;--major, major7, minor, minor7 ::- Integer -> Integer -> [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/CrossSum.hs
@@ -1,62 +0,0 @@-module CrossSum where--import Midi ;-import ListLive ;-import List ;-import Pitch ;-import Function ;-import Prelude ( Integer, fromInteger, (+), mod, div, succ ) ;---main :: [ Event (Channel Message) ] ;-main =- channel 0 $- concatMap (note qn . makePitch) $- modCrossSums 4 ;--makePitch :: Integer -> Pitch ;-makePitch 0 = c 4 ;-makePitch 1 = e 4 ;-makePitch 2 = g 4 ;-makePitch _ = c 5 ;----- * explicit base conversion--modCrossSums :: Integer -> [Integer] ;-modCrossSums n =- map (foldl (modAdd n) 0 . toBase n) $- iterateInteger succ 0 ;--toBase :: Integer -> Integer -> [Integer] ;-toBase _n 0 = [] ;-toBase n x = mod x n : toBase n (div x n) ;----- * recursion on lists--modCrossSumsList :: Integer -> [Integer] ;-modCrossSumsList n =- 0 : extList n [0] ;--extList :: Integer -> [Integer] -> [Integer] ;-extList n y =- applyStrictListList (extList2 n) $ map (incList n y) $- take (fromInteger n) $ iterateInteger succ 0 ;--extList2 :: Integer -> [[Integer]] -> [Integer] ;-extList2 n z =- concat (tail z) ++ extList n (concat z) ;--incList :: Integer -> [Integer] -> Integer -> [Integer] ;-incList m ys x = map (modAdd m x) ys ;----- * auxiliary--modAdd :: Integer -> Integer -> Integer -> Integer ;-modAdd m x y = mod (x+y) m ;---qn :: Integer ;-qn = 150 ;
− data/DeBruijn.hs
@@ -1,49 +0,0 @@-module DeBruijn where--import Midi ;-import ListLive ;-import List ;-import Pitch ;-import Bool ;-import Integer ;-import Prelude ( Integer, fromInteger, fromIntegral, ($), (.), (+), (-), (<), mod ) ;---main :: [ Event (Channel Message) ] ;-main =- channel 0 $- concatMap (note qn . makePitch) $- cycle $ deBruijnSequence 4 2 ;--makePitch :: Integer -> Pitch ;-makePitch 0 = c 4 ;-makePitch 1 = e 4 ;-makePitch 2 = g 4 ;-makePitch _ = c 5 ;----- * De Bruijn sequence generation based on lists--nextLyndonWord :: Integer -> Integer -> [Integer] -> [Integer] ;-nextLyndonWord n k =- foldr (checkLyndonElement n) [] . take (fromInteger k) . cycle ;--checkLyndonElement :: Integer -> Integer -> [Integer] -> [Integer] ;-checkLyndonElement n x [] = ifThenElse (x<n-1) [x+1] [] ;-checkLyndonElement _ x xs = x:xs ;--deBruijnSequence :: Integer -> Integer -> [Integer] ;-deBruijnSequence n k =- concat $- filter (isZero . mod k . fromIntegral . length) $- takeWhile (not . null) $- iterateIntegerList (nextLyndonWord n k) [0] ;----- Another efficient approach might be encoding the Lyndon words as integers.----- * auxiliary--qn :: Integer ;-qn = 150 ;
− data/Drum.hs
@@ -1,76 +0,0 @@-module Drum where--import Midi ( Event, Time, Message, Channel, note, channel )---type Drum = Integer ;--drum :: Drum -> Time -> [Event Message] ;-drum kind dur = note dur kind ;--drumChannel :: [Event a] -> [Event (Channel a)] ;-drumChannel = channel 9 ;--acousticBassDrum, bassDrum1, sideStick, acousticSnare, - handClap, electricSnare, lowFloorTom, closedHiHat, - highFloorTom, pedalHiHat, lowTom, openHiHat, - lowMidTom, hiMidTom, crashCymbal1, highTom, - rideCymbal1, chineseCymbal, rideBell, tambourine, - splashCymbal, cowbell, crashCymbal2, vibraslap, - rideCymbal2, hiBongo, lowBongo, muteHiConga, - openHiConga, lowConga, highTimbale, lowTimbale, - highAgogo, lowAgogo, cabasa, maracas, - shortWhistle, longWhistle, shortGuiro, longGuiro, - claves, hiWoodBlock, lowWoodBlock, muteCuica, - openCuica, muteTriangle, openTriangle :: Drum ;----- general MIDI drum aliases--acousticBassDrum = 35 ;-bassDrum1 = 36 ;-sideStick = 37 ;-acousticSnare = 38 ;-handClap = 39 ;-electricSnare = 40 ;-lowFloorTom = 41 ;-closedHiHat = 42 ;-highFloorTom = 43 ;-pedalHiHat = 44 ;-lowTom = 45 ;-openHiHat = 46 ;-lowMidTom = 47 ;-hiMidTom = 48 ;-crashCymbal1 = 49 ;-highTom = 50 ;-rideCymbal1 = 51 ;-chineseCymbal = 52 ;-rideBell = 53 ;-tambourine = 54 ;-splashCymbal = 55 ;-cowbell = 56 ;-crashCymbal2 = 57 ;-vibraslap = 58 ;-rideCymbal2 = 59 ;-hiBongo = 60 ;-lowBongo = 61 ;-muteHiConga = 62 ;-openHiConga = 63 ;-lowConga = 64 ;-highTimbale = 65 ;-lowTimbale = 66 ;-highAgogo = 67 ;-lowAgogo = 68 ;-cabasa = 69 ;-maracas = 70 ;-shortWhistle = 71 ;-longWhistle = 72 ;-shortGuiro = 73 ;-longGuiro = 74 ;-claves = 75 ;-hiWoodBlock = 76 ;-lowWoodBlock = 77 ;-muteCuica = 78 ;-openCuica = 79 ;-muteTriangle = 80 ;-openTriangle = 81 ;
− data/Fibonacci.hs
@@ -1,48 +0,0 @@-module Fibonacci where--import Midi ;-import List ;-import Pitch ;-import Function ;-import Prelude ( Integer, (*), (+), mod ) ;---main :: [ Event (Channel Message) ] ;-main =- channel 0 $- concatMap (note qn . makePitch) $- modFibonacci3 4 1 1 0 ;--makePitch :: Integer -> Pitch ;-makePitch 0 = c 4 ;-makePitch 1 = e 4 ;-makePitch 2 = g 4 ;-makePitch _ = c 5 ;----- * Solution of linear difference equation in modulo arithmetic--modFibonacci :: Integer -> Integer -> Integer -> [Integer] ;-modFibonacci n c0 c1 = modFibonacciRec n c0 c1 0 1 ;--modFibonacciRec ::- Integer -> Integer -> Integer ->- Integer -> Integer -> [Integer] ;-modFibonacciRec n c0 c1 x0 x1 =- x0 : applyStrict (modFibonacciRec n c0 c1 x1) (mod (x0*c0+x1*c1) n) ;---modFibonacci3 :: Integer -> Integer -> Integer -> Integer -> [Integer] ;-modFibonacci3 n c0 c1 c2 = modFibonacci3Rec n c0 c1 c2 0 0 1 ;--modFibonacci3Rec ::- Integer -> Integer -> Integer -> Integer ->- Integer -> Integer -> Integer -> [Integer] ;-modFibonacci3Rec n c0 c1 c2 x0 x1 x2 =- x0 : applyStrict (modFibonacci3Rec n c0 c1 c2 x1 x2) (mod (x0*c0+x1*c1+x2*c2) n) ;----- * auxiliary--qn :: Integer ;-qn = 150 ;
− data/Finite.hs
@@ -1,18 +0,0 @@-module Finite where--import Pitch-import Midi-import List-import Prelude ( (*), ($) )---main, voice :: [Event (Channel Message)] ;-main = voice ;--qn, hn :: Time ;-qn = 600 ;-hn = 2 * qn ;--voice =- channel 0 $- program 0 ++ note qn (c 4) ++ note hn (ds 4) ++ note qn (gs 4) ;
− data/Function.hs
@@ -1,34 +0,0 @@-module Function where---infixr 9 . ;--(.) :: (b -> c) -> (a -> b) -> a -> c ;-(f . g) x = f (g x) ;--infixr 0 $ ;--($) :: (a -> b) -> a -> b ;-f $ x = f x ;---- $!-applyStrict :: (Integer -> a) -> (Integer -> a) ;-applyStrict f 0 = f 0 ;-applyStrict f x = f x ;---flip :: (b -> a -> c) -> a -> b -> c ;-flip f x y = f y x ;--id :: a -> a ;-id x = x ;--nest :: Int -> (a -> a) -> a -> a ;-nest 0 _ x = x ;-nest n f x = nest (n-1) f (f x) ;--const :: a -> b -> a ;-const a _ = a ;--fix :: (a -> a) -> a ;-fix f = f (fix f) ;
− data/Instrument.hs
@@ -1,135 +0,0 @@-module Instrument where--type Instrument = Integer ;---acousticGrandPiano , brightAcousticPiano ,- electricGrandPiano , honkyTonk ,- electricPiano1 , electricPiano2 ,- harpsichord , clavinet ,- celesta , glockenspiel ,- musicBox , vibraphone ,- marimba , xylophone ,- tubularBells , dulcimer ,- drawbarOrgan , percussiveOrgan ,- rockOrgan , churchOrgan ,- reedOrgan , accordion ,- harmonica , tangoAccordian ,- acousticGuitarNylon , acousticGuitarSteel ,- electricGuitarJazz , electricGuitarClean ,- electricGuitarMuted , overdrivenGuitar ,- distortionGuitar , guitarHarmonics ,- acousticBass , electricBassFinger ,- electricBassPick , fretlessBass ,- slapBass1 , slapBass2 ,- synthBass1 , synthBass2 ,- violin , viola ,- cello , contrabass ,- tremoloStrings , pizzicatoStrings ,- orchestralHarp , timpani ,- stringEnsemble1 , stringEnsemble2 ,- synthStrings1 , synthStrings2 ,- choirAahs , voiceOohs ,- synthVoice , orchestraHit ,- trumpet , trombone ,- tuba , mutedTrumpet ,- frenchHorn , brassSection ,- synthBrass1 , synthBrass2 ,- sopranoSax , altoSax ,- tenorSax , baritoneSax ,- oboe , englishHorn ,- bassoon , clarinet ,- piccolo , flute ,- recorder , panFlute ,- blownBottle , skakuhachi ,- whistle , ocarina ,- lead1Square , lead2Sawtooth ,- lead3Calliope , lead4Chiff ,- lead5Charang , lead6Voice ,- lead7Fifths , lead8BassLead ,- pad1NewAge , pad2Warm ,- pad3Polysynth , pad4Choir ,- pad5Bowed , pad6Metallic ,- pad7Halo , pad8Sweep ,- fX1Rain , fX2Soundtrack ,- fX3Crystal , fX4Atmosphere ,- fX5Brightness , fX6Goblins ,- fX7Echoes , fX8SciFi ,- sitar , banjo ,- shamisen , koto ,- kalimba , bagpipe ,- fiddle , shanai ,- tinkleBell , agogo ,- steelDrums , woodblock ,- taikoDrum , melodicTom ,- synthDrum , reverseCymbal ,- guitarFretNoise , breathNoise ,- seashore , birdTweet ,- telephoneRing , helicopter ,- applause , gunshot :: Instrument ;---acousticGrandPiano = 0 ; brightAcousticPiano = 1 ;-electricGrandPiano = 2 ; honkyTonk = 3 ;-electricPiano1 = 4 ; electricPiano2 = 5 ;-harpsichord = 6 ; clavinet = 7 ;-celesta = 8 ; glockenspiel = 9 ;-musicBox = 10 ; vibraphone = 11 ;-marimba = 12 ; xylophone = 13 ;-tubularBells = 14 ; dulcimer = 15 ;-drawbarOrgan = 16 ; percussiveOrgan = 17 ;-rockOrgan = 18 ; churchOrgan = 19 ;-reedOrgan = 20 ; accordion = 21 ;-harmonica = 22 ; tangoAccordian = 23 ;-acousticGuitarNylon = 24 ; acousticGuitarSteel = 25 ;-electricGuitarJazz = 26 ; electricGuitarClean = 27 ;-electricGuitarMuted = 28 ; overdrivenGuitar = 29 ;-distortionGuitar = 30 ; guitarHarmonics = 31 ;-acousticBass = 32 ; electricBassFinger = 33 ;-electricBassPick = 34 ; fretlessBass = 35 ;-slapBass1 = 36 ; slapBass2 = 37 ;-synthBass1 = 38 ; synthBass2 = 39 ;-violin = 40 ; viola = 41 ;-cello = 42 ; contrabass = 43 ;-tremoloStrings = 44 ; pizzicatoStrings = 45 ;-orchestralHarp = 46 ; timpani = 47 ;-stringEnsemble1 = 48 ; stringEnsemble2 = 49 ;-synthStrings1 = 50 ; synthStrings2 = 51 ;-choirAahs = 52 ; voiceOohs = 53 ;-synthVoice = 54 ; orchestraHit = 55 ;-trumpet = 56 ; trombone = 57 ;-tuba = 58 ; mutedTrumpet = 59 ;-frenchHorn = 60 ; brassSection = 61 ;-synthBrass1 = 62 ; synthBrass2 = 63 ;-sopranoSax = 64 ; altoSax = 65 ;-tenorSax = 66 ; baritoneSax = 67 ;-oboe = 68 ; englishHorn = 69 ;-bassoon = 70 ; clarinet = 71 ;-piccolo = 72 ; flute = 73 ;-recorder = 74 ; panFlute = 75 ;-blownBottle = 76 ; skakuhachi = 77 ;-whistle = 78 ; ocarina = 79 ;-lead1Square = 80 ; lead2Sawtooth = 81 ;-lead3Calliope = 82 ; lead4Chiff = 83 ;-lead5Charang = 84 ; lead6Voice = 85 ;-lead7Fifths = 86 ; lead8BassLead = 87 ;-pad1NewAge = 88 ; pad2Warm = 89 ;-pad3Polysynth = 90 ; pad4Choir = 91 ;-pad5Bowed = 92 ; pad6Metallic = 93 ;-pad7Halo = 94 ; pad8Sweep = 95 ;-fX1Rain = 96 ; fX2Soundtrack = 97 ;-fX3Crystal = 98 ; fX4Atmosphere = 99 ;-fX5Brightness = 100 ; fX6Goblins = 101 ;-fX7Echoes = 102 ; fX8SciFi = 103 ;-sitar = 104 ; banjo = 105 ;-shamisen = 106 ; koto = 107 ;-kalimba = 108 ; bagpipe = 109 ;-fiddle = 110 ; shanai = 111 ;-tinkleBell = 112 ; agogo = 113 ;-steelDrums = 114 ; woodblock = 115 ;-taikoDrum = 116 ; melodicTom = 117 ;-synthDrum = 118 ; reverseCymbal = 119 ;-guitarFretNoise = 120 ; breathNoise = 121 ;-seashore = 122 ; birdTweet = 123 ;-telephoneRing = 124 ; helicopter = 125 ;-applause = 126 ; gunshot = 127 ;
− data/Integer.hs
@@ -1,5 +0,0 @@-module Integer where--isZero :: Integer -> Bool ;-isZero 0 = True ;-isZero _ = False ;
− data/Klingklong.hs
@@ -1,261 +0,0 @@-module Klingklong where--import Chords-import Pitch-import Midi-import List-import Prelude ( Integer, (*), (+), (-) )---main :: [Midi.Event (Midi.Channel Midi.Message)] ;-main = [] ;----- * patterns--loop0, loop0_1, loop1, loop2a, loop2b- :: [Midi.Event (Midi.Channel Midi.Message)] ;-loop0 = patternChannel ( note qn (c 4) ) ++ loop0 ;--loop0_1 =- patternChannel (- ping ++ note qn (c 4)- ) ++ loop0_1 ;---pattern1, pattern2a, pattern2b, pattern3a, pattern3b- :: [Midi.Event (Midi.Channel Midi.Message)] ;-pattern1 = patternChannel ( concat [- note qn (e 4), note qn (c 4),- note qn (e 4), note qn (c 4),- note qn (g 4), note en (f 4), note en (e 4),- note en (d 4), note en (e 4), note en (f 4),- note en (d 4) ] ) ;--pattern2 :: [Midi.Event Midi.Message] ;-pattern2 = concat [- note qn (e 4), note qn (a 4),- note qn (e 4), note qn (a 4),- note qn (a 4), note en (b 4), note en (c 5),- note en (d 5), note en (c 5), note en (b 4) ] ;--pattern2a =- patternChannel ( pattern2 ++ note en (a 4) ) ;--pattern2b =- patternChannel ( pattern2 ++ note en (g 4) ) ;---pattern3a = patternChannel ( concat [- note qn (e 4), note qn (c 4),- note qn (e 4), note qn (c 4),- note qn (g 4), note en (f 4), note en (e 4),- note en (d 4), note en (e 4), note en (f 4),- note en (d 4) ] ) ;--pattern3b = patternChannel ( concat [- note qn (e 4), note qn (c 4),- note qn (e 4), note qn (c 4),- note qn (e 4), note en (d 4), note en (c 4),- note en (d 4), note en (e 4), note en (d 4),- note en (c 4) ] ) ;---loop1 = pattern1 ++ loop1 ;--loop2a = pattern2a ++ loop2a ;--loop2b = pattern2b ++ loop1 ;----- * pad--padSimple, pad1, pad2, pad3,- bass3, bassLoop,- sweep, loop1p,- pad3loop, loop3sweep, bassPad,- pattern1Bass, pattern1BassPadShort,- pattern1BassPad, pattern2BassPad, pattern3BassPad- :: [Midi.Event (Midi.Channel Midi.Message)] ;---padSimple = padChannel ( concat [- pad,- controller volumeCC 90, controller brightnessCC 60,- chord4 wn2 (c 4) (e 4) (g 4) (c 5) ] ) ;--pad1 = padChannel ( concat [- pad,- controller volumeCC 90,- chord4 wn2 (c 4) (e 4) (g 4) (c 5),- chord4 wn2 (c 4) (d 4) (g 4) (c 5),- chord4 wn2 (c 4) (f 4) (a 4) (c 5),- chord4 wn2 (c 4) (e 4) (g 4) (c 5) ] ) ;--pad2 = padChannel ( concat [- pad,- controller volumeCC 90,- chord4 wn2 (c 4) (e 4) (a 4) (c 5),- chord4 wn2 (b 3) (e 4) (g 4) (b 4),- chord4 wn2 (c 4) (e 4) (a 4) (c 5),- chord4 wn2 (a 3) (c 4) (f 4) (a 4),-- chord4 wn2 (c 4) (e 4) (a 4) (c 5),- chord4 wn2 (b 3) (e 4) (g 4) (b 4),- chord4 wn2 (c 4) (e 4) (a 4) (c 5),- chord4 dwn (a 3) (c 4) (f 4) (a 4),- chord4 hn (b 3) (d 4) (g 4) (b 4) ] ) ;--pad3 = padChannel ( concat [- pad,- controller volumeCC 90, controller brightnessCC 70,- chord4 wn2 (c 4) (f 4) (a 4) (c 5),- chord4 wn2 (e 4) (a 4) (c 5) (e 5),- chord4 wn2 (d 4) (g 4) (b 4) (d 5),- chord4 wn2 (d 4) (fs 4) (a 4) (d 5) ] ) ;----- * bass--bassControl :: [Midi.Event Midi.Message] ;-bassControl =- controlCurve en brightnessCC- (take 64 (cycle [0,31,62,93,124] ) ) ;--bassNote :: Pitch -> [Midi.Event (Midi.Channel Midi.Message)] ;-bassNote p = bassChannel ( concat [- bass,- controller volumeCC 100,- merge ( note (4*2*wn) p ) bassControl ] ) ;--bass3 = bassChannel ( concat [- bass,- controller volumeCC 100,- merge ( concat [ note wn2 (f 2), note wn2 (f 2),- note wn2 (g 2), note wn2 (a 2) ] )- bassControl ] ) ;--bassLoop =- bassNote (c 2) ++ bassLoop ;----- * sweep--sweep =- padChannel ( controlCurve en brightnessCC triangle) ;--triangle :: [Integer] ;-triangle = rampUp 0 ++ rampDown 124 ;--rampUp, rampDown :: Integer -> [Integer] ;-rampUp 124 = [] ;-rampUp n = n : rampUp (n+4) ;--rampDown 0 = [] ;-rampDown n = n : rampDown (n-4) ;----- * complex--loop1p = merge pattern1 pad1 ++ loop1p ;--pad3loop =- merge ( quadAlt pattern3a pattern3b ) pad3- ++- loop1 ;--loop3sweep =- merge pad3 sweep ++ loop3sweep ;--bassPad =- merge pad1 (bassNote (c 2) )- ++- bassPad ;--pattern1Bass =- merge ( quad pattern1 ) (bassNote (c 2) )- ++- pattern1Bass ;--pattern1BassPadShort =- mergeMany [- quad pattern1,- bassNote (c 2),- pad1, sweep- ]- ++- pattern1BassPadShort ;--pattern1BassPad =- double ( mergeMany [- quad pattern1,- bassNote (c 2),- pad1, sweep ] )- ++- pattern2BassPad ;--pattern2BassPad =- mergeMany [- quad pattern2a ++ quadAlt pattern2a pattern2b,- double (bassNote (a 1)),- pad2, double sweep- ]- ++- pattern1BassPad ;--pattern3BassPad =- mergeMany [- quadAlt pattern3a pattern3b,- bass3, pad3, sweep- ]- ++- pattern1BassPad ;----- * concatenation--double :: [a] -> [a] ;-double x = concat [ x, x ] ;--quad :: [a] -> [a] ;-quad x = concat [ x, x, x, x ] ;--quadAlt :: [a] -> [a] -> [a] ;-quadAlt x y = concat [ x, x, x, y] ;----- * durations--en, qn, hn, wn, dwn, wn2 :: Midi.Time ;--en = 170 ;-qn = 2 * en ;-hn = 2 * qn ;-wn = 2 * hn ; dwn = wn + hn ;-wn2 = 2 * wn ;----- * MIDI program--ping, slap, pad, bass :: [Midi.Event Midi.Message] ;-ping = program 0 ;-slap = program 2 ;-pad = program 4 ;-bass = program 9 ;----- * MIDI channels--soloChannel, patternChannel, padChannel, bassChannel- :: [Midi.Event a] -> [Midi.Event (Midi.Channel a)] ;-soloChannel xs = channel 0 xs ;-patternChannel xs = channel 1 xs ;-padChannel xs = channel 2 xs ;-bassChannel xs = channel 3 xs ;----- * MIDI controllers--volumeCC, brightnessCC :: Midi.Controller ;-volumeCC = 7 ;-brightnessCC = 70 ;
− data/List.hs
@@ -1,141 +0,0 @@-module List (- map,- zipWith,- foldr,- foldl,- length,- sum,- add,- scanl,- scanr,- reverse,- replicate,- repeat,- cycle,- iterate,- (++),- concat,- concatMap,- head,- tail,- null,- (!!),- take,- drop,- filter,- takeWhile,- ) where--import ListLive-import Function-import Bool-import Prelude ( (-), (+), Num, Int, Bool(False,True), error )---map :: (a -> b) -> [a] -> [b] ;-map _ [] = [] ;-map f (x : xs) = f x : map f xs ;--zipWith :: (a -> b -> c) -> [a] -> [b] -> [c] ;-zipWith f (x : xs) (y : ys) =- f x y : zipWith f xs ys ;-zipWith _f _xs _ys = [] ;--foldr :: (b -> a -> a) -> a -> [b] -> a ;-foldr _ a [] = a ;-foldr f a (x : xs) = f x ( foldr f a xs ) ;--foldl :: (b -> a -> b) -> b -> [a] -> b ;-foldl _ a [] = a ;-foldl f a (x : xs) = foldl f (f a x) xs ;--length :: [a] -> Int ;-length = sumInteger . map (const 1) ;--sum :: (Num a) => [a] -> a ;-sum = foldl add 0 ;--add :: (Num a) => a -> a -> a ;-add x y = x + y ;---scanl :: (a -> b -> a) -> a -> [b] -> [a] ;-scanl _ a [] = [a] ;-scanl f a (x : xs) = a : scanl f (f a x) xs ;--scanr :: (b -> a -> a) -> a -> [b] -> [a] ;-scanr _ a [] = [a] ;-scanr f a (x : xs) = scanrAux f x (scanr f a xs) ;--scanrAux :: (b -> a -> a) -> b -> [a] -> [a] ;-scanrAux f x ys = f x (head ys) : ys ;---reverse :: [a] -> [a] ;-reverse = foldl (flip cons) [] ;--replicate :: Int -> a -> [a] ;-replicate n x = take n ( repeat x ) ;--repeat :: a -> [a] ;-repeat s = s : repeat s ;--cycle :: [a] -> [a] ;-cycle s = s ++ cycle s ;--iterate :: (a -> a) -> a -> [a] ;-iterate f x = x : iterate f (f x) ;---(++) :: [a] -> [a] -> [a] ;-xs ++ ys = foldr cons ys xs ;--concat :: [[a]] -> [a] ;-concat = foldr append [];--concatMap :: (a -> [b]) -> [a] -> [b] ;-concatMap f = concat . map f ;--head :: [a] -> a ;-head (x:_) = x ;-head [] = error "head: empty list" ;--tail :: [a] -> [a] ;-tail (_:xs) = xs ;-tail [] = error "tail: empty list" ;--null :: [a] -> Bool ;-null [] = True ;-null _ = False ;--(!!) :: [a] -> Int -> a ;-(x:_) !! 0 = x ;-(_:xs) !! n = xs !! (n-1) ;-[] !! _ = error "!!: index too large" ;--take :: Int -> [a] -> [a] ;-take n xs = foldr takeElem (const []) xs n ;--takeElem :: a -> (Int -> [a]) -> Int -> [a] ;-takeElem _ _go 0 = [] ;-takeElem x go m = x : go (m-1) ;--drop :: Int -> [b] -> [b] ;-drop 0 xs = xs ;-drop _ [] = [] ;-drop n (_ : xs) = drop (n-1) xs ;---filter :: (a -> Bool) -> [a] -> [a] ;-filter p =- foldr (filterElem p) [] ;--filterElem :: (a -> Bool) -> a -> [a] -> [a] ;-filterElem p x xs = ifThenElse (p x) (x:xs) xs ;--takeWhile :: (a -> Bool) -> [a] -> [a] ;-takeWhile p =- foldr (takeWhileElem p) [] ;--takeWhileElem :: (a -> Bool) -> a -> [a] -> [a] ;-takeWhileElem p x xs = ifThenElse (p x) (x:xs) [] ;
− data/ListLive.hs
@@ -1,114 +0,0 @@-module ListLive (- cons,- append,- splitAt,- afterEach,- dropWhileRev,-- sumInteger,- iterateInteger,- iterateIntegerList,- applyStrictList,- applyStrictListList,- ) where--import Tuple-import Function-import Bool-import Prelude ( (-), (+), Num, Int, Integer, Integral, Bool, foldr, null, reverse )---cons :: a -> [a] -> [a] ;-cons x xs = x : xs ;--append :: [a] -> [a] -> [a] ;-append = flip ( foldr cons ) ;---{--This does not work well and fails for infinite lists,-because consFirst matches strictly on Pair.--}-splitAt :: Int -> [a] -> Tuple.Pair [a] [a] ;-splitAt 0 xs = Pair [] xs ;-splitAt _ [] = Pair [] [] ;-splitAt n (x : xs) = consFirst x ( splitAt (n-1) xs ) ;--consFirst :: a -> Tuple.Pair [a] [a] -> Tuple.Pair [a] [a] ;-consFirst x p = Pair (x : fst p) (snd p) ;---afterEach :: a -> [a] -> [a] ;-afterEach _y [] = [] ;-afterEach y (x : xs) = x : y : afterEach y xs ;---dropWhileRev :: (a -> Bool) -> [a] -> [a] ;-dropWhileRev p =- foldr (dropWhileRevElem p) [] ;--dropWhileRevElem :: (a -> Bool) -> a -> [a] -> [a] ;-dropWhileRevElem p x xs = ifThenElse (p x && null xs) [] (x:xs) ;----- * functions that are somehow strict---- | constant space usage in contrast to 'sum'-sumInteger :: (Integral a) => [a] -> a ;-sumInteger = sumIntegerAux 0 ;--sumIntegerAux :: (Integral a) => a -> [a] -> a ;-sumIntegerAux 0 [] = 0 ;-sumIntegerAux s [] = s ;-sumIntegerAux s (x:xs) = sumIntegerAux (s+x) xs ;----- | constant space usage in contrast to 'iterate'-iterateInteger, iterateIntegerAux ::- (Integer -> Integer) -> Integer -> [Integer] ;-iterateInteger f = applyStrict (iterateIntegerAux f) ;-iterateIntegerAux f x = x : iterateInteger f (f x) ;--iterateIntegerList, iterateIntegerListAux ::- ([Integer] -> [Integer]) -> [Integer] -> [[Integer]] ;-iterateIntegerList f = applyStrictList (iterateIntegerListAux f) ;-iterateIntegerListAux f x = x : iterateIntegerList f (f x) ;--{- even stricter: it always updates the accumulator, also if the updated value is not needed because the list is aborted earlier-iterateInteger, iterateIntegerAux0 ::- (Integer -> Integer) -> Integer -> [Integer] ;-iterateIntegerAux1 ::- (Integer -> Integer) -> Integer -> Integer -> [Integer] ;-iterateInteger f = applyStrict (iterateIntegerAux0 f) ;-iterateIntegerAux0 f x = applyStrict (iterateIntegerAux1 f x) (f x) ;-iterateIntegerAux1 f x fx = x : iterateInteger f fx ;--}--{- too strict for DeBruijn-iterateIntegerList, iterateIntegerListAux0 ::- ([Integer] -> [Integer]) -> [Integer] -> [[Integer]] ;-iterateIntegerListAux1 ::- ([Integer] -> [Integer]) -> [Integer] -> [Integer] -> [[Integer]] ;-iterateIntegerList f = applyStrictList (iterateIntegerListAux0 f) ;-iterateIntegerListAux0 f x = applyStrictList (iterateIntegerListAux1 f x) (f x) ;-iterateIntegerListAux1 f x fx = x : iterateIntegerList f fx ;--}----applyStrictList :: ([Integer] -> a) -> ([Integer] -> a) ;-applyStrictList f xs = applyStrictListAux f [] (reverse xs) ;--applyStrictListAux :: ([Integer] -> a) -> [Integer] -> ([Integer] -> a) ;-applyStrictListAux f ys [] = f ys ;-applyStrictListAux f ys (0:xs) = applyStrictListAux f (0:ys) xs ;-applyStrictListAux f ys (x:xs) = applyStrictListAux f (x:ys) xs ;---applyStrictListList :: ([[Integer]] -> a) -> ([[Integer]] -> a) ;-applyStrictListList f xs = applyStrictListListAux f [] (reverse xs) ;--applyStrictListListAux :: ([[Integer]] -> a) -> [[Integer]] -> ([[Integer]] -> a) ;-applyStrictListListAux f ys [] = f ys ;-applyStrictListListAux f ys (x:xs) =- applyStrictList (applyStrictListListAux f . flip cons ys) x xs ;
− data/Midi.hs
@@ -1,153 +0,0 @@-module Midi (- Time,- Velocity,- Program,- Controller,- Chan,- Event(Wait, Say, Event),- Channel(Channel),- Message(PgmChange, Controller, On, Off),-- note,- rest,- program,- controller,- channel,- transpose, transposeEvent,- controlCurve,- normalVelocity,- emphasize,-- (+:+),- merge, (=:=),- mergeWait,- mergeMany,- ) where--import Function-import Pitch ( Pitch )---type Time = Integer ;-type Velocity = Integer ;-type Program = Integer ;-type Controller = Integer ;-type Chan = Integer ;--data Event a = Wait Time | Say String | Event a ;--data Channel a = Channel Integer a ;--data Message =- PgmChange Program- | Controller Controller Integer- | On Pitch Velocity- | Off Pitch Velocity ;--{- |-This function is strict in the pitch-and thus asserts that the pitch for NoteOn and NoteOff-are evaluated at the same time to the same value.-This way we assert that a pressed note-will be released later.--}-note :: Time -> Pitch -> [Event Message] ;-note duration = applyStrict (noteLazy duration) ;--noteLazy :: Time -> Pitch -> [Event Message] ;-noteLazy duration pitch =- [ Event (On pitch normalVelocity)- , Wait duration- , Event (Off pitch normalVelocity)- ] ;--rest :: Time -> [Event a] ;-rest duration =- [ Wait duration ] ;--program :: Program -> [Event Message] ;-program n =- [ Event ( PgmChange n ) ] ;--controller :: Controller -> Integer -> [Event Message] ;-controller cc x =- [ Event ( Controller cc x ) ] ;--channel :: Chan -> [Event a] -> [Event (Channel a)] ;-channel chan = map ( channelEvent chan ) ;--channelEvent :: Chan -> Event a -> Event (Channel a) ;-channelEvent chan (Event event) = Event (Channel chan event) ;-channelEvent _chan (Wait duration) = Wait duration ;-channelEvent _chan (Say text) = Say text ;---transpose :: Integer -> [Event Message] -> [Event Message] ;-transpose d = map ( transposeEvent d ) ;--transposeEvent :: Integer -> Event Message -> Event Message ;-transposeEvent d (Event (On pitch velocity)) = Event (On (pitch+d) velocity) ;-transposeEvent d (Event (Off pitch velocity)) = Event (Off (pitch+d) velocity) ;-transposeEvent _d event = event ;---controlCurve :: Time -> Controller -> [Integer] -> [Event Message] ;-controlCurve _d _cc [] = [] ;-controlCurve d cc (x : xs) =- Event (Controller cc x) : Wait d : controlCurve d cc xs ;--normalVelocity :: Velocity ;-normalVelocity = 64 ;--emphasize :: Integer -> [Event Message] -> [Event Message] ;-emphasize v = map ( emphasizeEvent v ) ;--{--We only alter the start velocity.-In most cases NoteOff velocity is the normal velocity-and this is handled more efficiently by the MIDI message encoding.--}-emphasizeEvent :: Integer -> Event Message -> Event Message ;-emphasizeEvent v (Event (On pitch velocity)) = Event (On pitch (velocity+v)) ;-emphasizeEvent _v event = event ;---infixr 7 +:+ ; {- like multiplication -}-infixr 6 =:= ; {- like addition -}--(+:+) :: [Midi.Event a] -> [Midi.Event a] -> [Midi.Event a] ;-xs +:+ ys = xs ++ ys ;--merge, (=:=) :: [Midi.Event a] -> [Midi.Event a] -> [Midi.Event a] ;-xs =:= ys = merge xs ys ;--merge (Wait a : xs) (Wait b : ys) =- mergeWait (a<b) (a-b) a xs b ys ;-merge (Wait a : xs) (y : ys) =- y : merge (Wait a : xs) ys ;-merge (x : xs) ys = x : merge xs ys ;-merge [] ys = ys ;--{--This looks a bit cumbersome,-but it is necessary for avoiding stacks of unevaluated subtractions.-We use or abuse the way of how the interpreter performs pattern matching.-By matching against 0 we force the evaluation of the difference d.-The evaluated difference is hold throughout the matching of all patterns.-It is important that the match against 0 is really performed-and is not shadowed by a failing preceding match, say, against the result of (a<b).--}-mergeWait ::- Bool -> Midi.Time ->- Midi.Time -> [Midi.Event a] ->- Midi.Time -> [Midi.Event a] ->- [Midi.Event a] ;-mergeWait _eq 0 a xs _b ys =- Wait a : merge xs ys ;-mergeWait True d a xs _b ys =- Wait a : merge xs (Wait (negate d) : ys) ;-mergeWait False d _a xs b ys =- Wait b : merge (Wait d : xs) ys ;--mergeMany :: [[Midi.Event a]] -> [Midi.Event a] ;-mergeMany = foldl merge [] ;
− data/Music.hs
@@ -1,100 +0,0 @@-module Music where--import Midi ( Event(Wait, Event, Say), Message, Channel(Channel),- note, transposeEvent, mergeMany )-import ListLive ( afterEach )-import List ( map, replicate, repeat, concat )-import Prelude ( (*), div, (.), ($), negate, Int, Integer, Integral, String )---c, cf, cs, df, d, ds, ef, e, es, ff, f, fs,- gf, g, gs, af, a, as, bf, b, bs ::- Music (Event Message) ;--quarter :: Integer ;-quarter = 240 ;--p :: Music (Event a) ;-p = Atom ( Wait quarter ) ;--c = Seq $ map Atom $ note quarter 36 ;-cf = down 1 c ; cs = up 1 c ;-df = cs ; d = up 2 c ; ds = up 3 c ;-ef = ds ; e = up 4 c ; es = f ;-ff = e ; f = up 5 c ; fs = up 6 c ;-gf = fs ; g = up 7 c ; gs = up 8 c ;-af = gs ; a = up 9 c ; as = up 10 c ;-bf = as ; b = up 11 c ; bs = up 12 c ;--slow, speed :: Integer -> Music (Event a) -> Music (Event a) ;--slowdown, speedup :: (Integral a) => a -> a -> a ;--slow k = wmap ( slowdown k ) ; slowdown k w = w * k ;-speed k = wmap ( speedup k ) ; speedup k w = div w k ;--up, down ::- Integer ->- Music (Event Message) ->- Music (Event Message) ;-up dif s = tr dif s ; down dif s = tr ( negate dif ) s ;--chan ::- Integer ->- Music (Event a) ->- Music (Event (Midi.Channel a)) ;-chan cn = emap ( Channel cn ) ;--tr ::- Integer ->- Music (Event Message) ->- Music (Event Message) ;-tr dif = amap ( transposeEvent dif ) ;--says :: [String] -> Music (Event a) ;-says ws = Seq ( afterEach p ( map (Atom . Say) ws ) ) ;--major, minor, minor7 ::- Music (Event Message) -> Music (Event Message) ;-major s = Par [ s, up 4 s, up 7 s ] ;-minor s = Par [ s, up 3 s, up 7 s ] ;-minor7 s = Par [ s, up 3 s, up 7 s, up 11 s ] ;--times :: Int -> Music a -> Music a ;-times k s = Seq ( replicate k s ) ;--emap :: (a -> b) -> Music (Event a) -> Music (Event b) ;-emap fn ( Atom ( Event ev ) ) = Atom ( Event ( fn ev ) ) ;-emap _ ( Atom ( Wait w ) ) = Atom ( Wait w ) ;-emap _ ( Atom ( Say s ) ) = Atom ( Say s ) ;-emap fn ( Par xs ) = Par ( map ( emap fn ) xs );-emap fn ( Seq xs ) = Seq ( map ( emap fn ) xs );--wmap ::- (Integer -> Integer) ->- Music (Event a) -> Music (Event a) ;-wmap _ ( Atom ( Event ev ) ) = Atom ( Event ev ) ;-wmap fn ( Atom ( Wait w ) ) = Atom ( Wait ( fn w ) ) ;-wmap _ ( Atom ( Say s ) ) = Atom ( Say s ) ;-wmap fn ( Par xs ) = Par ( map ( wmap fn ) xs );-wmap fn ( Seq xs ) = Seq ( map ( wmap fn ) xs );--amap :: (a -> b) -> Music a -> Music b ;-amap fn ( Atom atom ) = Atom ( fn atom ) ;-amap fn ( Par xs ) = Par ( map ( amap fn ) xs );-amap fn ( Seq xs ) = Seq ( map ( amap fn ) xs );---forever :: Music a -> Music a ;-forever s = Seq ( repeat s ) ;--data Music a =- Atom a- | Par [Music a]- | Seq [Music a] ;---play :: Music (Event a) -> [Event a] ;-play (Par xs) = mergeMany ( map play xs ) ;-play (Seq xs) = concat ( map play xs ) ;-play (Atom atom) = [ atom ] ;
− data/Pattern.hs
@@ -1,38 +0,0 @@-module Pattern where--import Pitch-import Midi-import List-import Prelude ( Int, (*), ($) )---main, voice :: [Event (Channel Message)] ;-main = voice ;--en, qn, hn :: Time ;-en = 200 ;-qn = 2 * en ;-hn = 2 * qn ;--harmonies :: [[Pitch]] ;-harmonies =- [ c 4, e 4, g 4, c 5 ] :- [ d 4, f 4, a 4, c 5 ] :- [ b 3, d 4, g 4, b 4 ] :- [ c 4, e 4, g 4, c 5 ] :- [];--pattern :: [ Int ] ;-pattern = [0, 1, 2, 1, 2, 3, 2, 1] ;--voice =- channel 0 (program 0 ++- concatMap ( note en ) (- zipWith index- ( concatMap ( replicate 8 ) $- cycle harmonies )- ( cycle pattern )- ) ) ;--index :: [a] -> Int -> a ;-index xs n = xs !! n ;
− data/Pitch.hs
@@ -1,38 +0,0 @@-module Pitch where--type Pitch = Integer ;-type Octave = Integer ;-type Class = Integer ;--{- cf.-http://en.wikipedia.org/wiki/Scientific_pitch_notation-http://en.wikipedia.org/wiki/MIDI_Tuning_Standard--}-pitch :: Class -> Octave -> Pitch ;-pitch cls octave = cls + (octave+1)*12 ;--cb, db, eb, fb, gb, ab, bb :: Class ;--c, cis, ces, cs, cf,- d, dis, des, ds, df,- e, eis, ees, es, ef,- f, fis, fes, fs, ff,- g, gis, ges, gs, gf,- a, ais, aes, as, af,- b, bis, bes, bs, bf :: Octave -> Pitch ;--cb = 0 ; c = pitch cb ; cis = cs ; ces = cf ;-db = 2 ; d = pitch db ; dis = ds ; des = df ;-eb = 4 ; e = pitch eb ; eis = es ; ees = ef ;-fb = 5 ; f = pitch fb ; fis = fs ; fes = ff ;-gb = 7 ; g = pitch gb ; gis = gs ; ges = gf ;-ab = 9 ; a = pitch ab ; ais = as ; aes = af ;-bb = 11 ; b = pitch bb ; bis = bs ; bes = bf ;--cs = pitch (cb+1) ; cf = pitch (cb-1) ;-ds = pitch (db+1) ; df = pitch (db-1) ;-es = pitch (eb+1) ; ef = pitch (eb-1) ;-fs = pitch (fb+1) ; ff = pitch (fb-1) ;-gs = pitch (gb+1) ; gf = pitch (gb-1) ;-as = pitch (ab+1) ; af = pitch (ab-1) ;-bs = pitch (bb+1) ; bf = pitch (bb-1) ;
− data/Render.hs
@@ -1,82 +0,0 @@-module Render where--import qualified Midi--import qualified Sound.MIDI.File as MidiFile-import qualified Sound.MIDI.File.Event as FileEvent-import qualified Sound.MIDI.File.Save as Save-import qualified Sound.MIDI.File.Event.Meta as MetaEvent-import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg-import qualified Sound.MIDI.Message.Channel as ChannelMsg--import qualified Data.EventList.Relative.TimeBody as EventList-import qualified Numeric.NonNegative.Wrapper as NonNeg--import Data.Monoid (mempty, mappend, )---class Message msg where- makeMessage :: msg -> ChannelMsg.Body--class ChannelMessage msg where- makeChannelMessage :: msg -> ChannelMsg.T--instance ChannelMessage Midi.Message where- makeChannelMessage =- ChannelMsg.Cons (ChannelMsg.toChannel 0) . makeMessage--instance Message Midi.Message where- makeMessage msg =- ChannelMsg.Voice $- case msg of- Midi.On pitch velocity ->- VoiceMsg.NoteOn- (VoiceMsg.toPitch $ fromInteger pitch)- (VoiceMsg.toVelocity $ fromInteger velocity)- Midi.Off pitch velocity ->- VoiceMsg.NoteOff- (VoiceMsg.toPitch $ fromInteger pitch)- (VoiceMsg.toVelocity $ fromInteger velocity)- Midi.PgmChange pgm ->- VoiceMsg.ProgramChange- (VoiceMsg.toProgram $ fromInteger pgm)- Midi.Controller ctrl value ->- VoiceMsg.Control- (VoiceMsg.toController $ fromInteger ctrl)- (fromInteger value)--instance Message msg => ChannelMessage (Midi.Channel msg) where- makeChannelMessage (Midi.Channel chan msg) =- ChannelMsg.Cons (ChannelMsg.toChannel $ fromInteger chan) $- makeMessage msg---trackFromStream ::- (ChannelMessage msg) => [Midi.Event msg] -> MidiFile.Track-trackFromStream evs =- foldr- (\ev go time ->- case ev of- Midi.Wait pause ->- go (mappend time $- NonNeg.fromNumberMsg "Render.trackFromStream: Wait" pause)- Midi.Say str ->- EventList.cons time (FileEvent.MetaEvent $ MetaEvent.Lyric str) $- go 0- Midi.Event msg ->- EventList.cons time (FileEvent.MIDIEvent $ makeChannelMessage msg) $- go 0)- (\ _time -> EventList.empty) evs mempty--fileFromStream ::- (ChannelMessage msg) => [Midi.Event msg] -> MidiFile.T-fileFromStream =- MidiFile.Cons MidiFile.Mixed (MidiFile.Ticks 500) .- (:[]) .- -- EventList.cons 0 (MetaEvent.SetTempo 500000) .- trackFromStream--writeStream ::- (ChannelMessage msg) => FilePath -> [Midi.Event msg] -> IO ()-writeStream path =- Save.toFile path . fileFromStream
− data/Simplesong.hs
@@ -1,20 +0,0 @@-module Simplesong where--import Pitch-import Midi-import List-import Prelude ( (*) )---main, voice1, voice2 :: [Event (Channel Message)] ;-main = cycle ( merge voice1 voice2 ) ;--qn, hn :: Time ;-qn = 600 ;-hn = 2 * qn ;--voice1 =- channel 0 (concat [ program 0 , note qn (c 4) , note hn (ds 4) , note qn (gs 4) ] ) ;--voice2 =- channel 1 (concat [ program 1 , note hn (gs 5) , note hn (as 5) ] ) ;
− data/Sweep.hs
@@ -1,39 +0,0 @@-module Sweep where--import Chords-import Pitch-import Midi-import List-import Prelude ( Integer, (+), (-) )--main :: [Event (Channel Message)] ;-main = channel 0 ( merge control voice ) ;--wn :: Time ;-wn = 2000 ;--voice, control :: [Event Message] ;-voice =- program 4- ++- cycle- ( concat [- chord4 wn (c 4) (e 4) (g 4) (c 5),- chord4 wn (b 3) (e 4) (g 4) (b 4),- chord4 wn (c 4) (f 4) (a 4) (c 5)- ] ) ;--cutoff :: Midi.Controller ;-cutoff = 70 ;--control = controlCurve 50 cutoff ( cycle triangle ) ;--triangle :: [ Integer ] ;-triangle = rampUp 0 ++ rampDown 127 ;--rampUp, rampDown :: Integer -> [ Integer ] ;-rampUp 127 = [] ;-rampUp n = n : rampUp (n+1) ;--rampDown 0 = [] ;-rampDown n = n : rampDown (n-1) ;
− data/Tuple.hs
@@ -1,9 +0,0 @@-module Tuple where--data Pair a b = Pair a b ;--fst :: Pair a b -> a ;-fst ( Pair a _ ) = a ;--snd :: Pair a b -> b ;-snd ( Pair _ b ) = b ;
− data/UD.hs
@@ -1,62 +0,0 @@-module UD where--import Drum-import Chords-import Pitch-import Midi-import List-import Prelude ( (*) )---main, song, mel, drums :: [Event (Channel Message)] ;-main = cycle song =:= cycle drums ;--en, qn, hn, wn :: Time ;-en = 100 ;-qn = 2*en ;-hn = 2*qn ;-wn = 2*hn ;--song = concat- [ merge part1 mel, part2, part3 ] ;--mel = channel 3 ( concat- [ note hn (c 4)- , note hn (f 4), note hn (e 4), note hn (c 4) ] ) ;--part1, part2, part3 :: [Event (Channel Message)] ;-part1 = twice ( channel 0 ( concat- [ quad ( major qn (c 4) )- , quad ( major qn (c 4) )- , quad ( major qn (c 4) )- , concat [ major qn (c 4)- , major qn (g 4)- , major qn (g 4)- , major qn (g 4)- ]- ] ) ) ;--part2 = twice ( channel 0 ( concat- [ twice ( quad ( minor qn (d 4) ) )- , quad ( major qn (f 4) )- , twice ( minor qn (e 4) )- , twice ( minor qn (d 4) )- , quad ( quad ( major qn (c 4) ) )- ] ) ) ;--part3 = [] ;--twice, quad :: [a] -> [a] ;-quad x = concat [ x, x, x, x ] ;-twice x = concat [ x, x];---bass, snare :: Time -> [Event Message] ;-bass dur = emphasize 36 (drum bassDrum1 dur) ;-snare dur = emphasize 16 (drum electricSnare dur) ;--drums = drumChannel ( concat- [ concat ( concat ( replicate 3- [ bass hn, snare hn ] ) )- , concat [ bass qn, snare hn, snare qn ]- ] ) ;
+ data/base/Bool.hs view
@@ -0,0 +1,27 @@+module Bool where++import Prelude ( Bool(True, False) )+++ifThenElse :: Bool -> a -> a -> a ;+ifThenElse True y _ = y ;+ifThenElse False _ n = n ;+++not :: Bool -> Bool ;+not False = True ;+not True = False ;+++infixr 3 && ;++(&&) :: Bool -> Bool -> Bool ;+False && _ = False ;+True && x = x ;+++infixr 2 || ;++(||) :: Bool -> Bool -> Bool ;+True || _ = True ;+False || x = x ;
+ data/base/Chords.hs view
@@ -0,0 +1,41 @@+module Chords where++import Midi++chord3 ::+ Integer ->+ Integer -> Integer -> Integer ->+ [Midi.Event Midi.Message] ;+chord3 dur p0 p1 p2 =+ mergeMany [+ note dur p0,+ note dur p1,+ note dur p2+ ] ;++chord4 ::+ Integer ->+ Integer -> Integer -> Integer -> Integer ->+ [Midi.Event Midi.Message] ;+chord4 dur p0 p1 p2 p3 =+ mergeMany [+ note dur p0,+ note dur p1,+ note dur p2,+ note dur p3+ ] ;++major, major7, minor, minor7 ::+ Integer -> Integer -> [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/Controls.hs view
@@ -0,0 +1,11 @@+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/Drum.hs view
@@ -0,0 +1,76 @@+module Drum where++import Midi ( Event, Time, Message, Channel, note, channel )+++type Drum = Integer ;++drum :: Drum -> Time -> [Event Message] ;+drum kind dur = note dur kind ;++drumChannel :: [Event a] -> [Event (Channel a)] ;+drumChannel = channel 9 ;++acousticBassDrum, bassDrum1, sideStick, acousticSnare, + handClap, electricSnare, lowFloorTom, closedHiHat, + highFloorTom, pedalHiHat, lowTom, openHiHat, + lowMidTom, hiMidTom, crashCymbal1, highTom, + rideCymbal1, chineseCymbal, rideBell, tambourine, + splashCymbal, cowbell, crashCymbal2, vibraslap, + rideCymbal2, hiBongo, lowBongo, muteHiConga, + openHiConga, lowConga, highTimbale, lowTimbale, + highAgogo, lowAgogo, cabasa, maracas, + shortWhistle, longWhistle, shortGuiro, longGuiro, + claves, hiWoodBlock, lowWoodBlock, muteCuica, + openCuica, muteTriangle, openTriangle :: Drum ;+++-- general MIDI drum aliases++acousticBassDrum = 35 ;+bassDrum1 = 36 ;+sideStick = 37 ;+acousticSnare = 38 ;+handClap = 39 ;+electricSnare = 40 ;+lowFloorTom = 41 ;+closedHiHat = 42 ;+highFloorTom = 43 ;+pedalHiHat = 44 ;+lowTom = 45 ;+openHiHat = 46 ;+lowMidTom = 47 ;+hiMidTom = 48 ;+crashCymbal1 = 49 ;+highTom = 50 ;+rideCymbal1 = 51 ;+chineseCymbal = 52 ;+rideBell = 53 ;+tambourine = 54 ;+splashCymbal = 55 ;+cowbell = 56 ;+crashCymbal2 = 57 ;+vibraslap = 58 ;+rideCymbal2 = 59 ;+hiBongo = 60 ;+lowBongo = 61 ;+muteHiConga = 62 ;+openHiConga = 63 ;+lowConga = 64 ;+highTimbale = 65 ;+lowTimbale = 66 ;+highAgogo = 67 ;+lowAgogo = 68 ;+cabasa = 69 ;+maracas = 70 ;+shortWhistle = 71 ;+longWhistle = 72 ;+shortGuiro = 73 ;+longGuiro = 74 ;+claves = 75 ;+hiWoodBlock = 76 ;+lowWoodBlock = 77 ;+muteCuica = 78 ;+openCuica = 79 ;+muteTriangle = 80 ;+openTriangle = 81 ;
+ data/base/Function.hs view
@@ -0,0 +1,36 @@+module Function where++import Prelude ( Integer, Int, (-) )+++infixr 9 . ;++(.) :: (b -> c) -> (a -> b) -> a -> c ;+(f . g) x = f (g x) ;++infixr 0 $ ;++($) :: (a -> b) -> a -> b ;+f $ x = f x ;++-- $!+applyStrict :: (Integer -> a) -> (Integer -> a) ;+applyStrict f 0 = f 0 ;+applyStrict f x = f x ;+++flip :: (b -> a -> c) -> a -> b -> c ;+flip f x y = f y x ;++id :: a -> a ;+id x = x ;++nest :: Int -> (a -> a) -> a -> a ;+nest 0 _ x = x ;+nest n f x = nest (n-1) f (f x) ;++const :: a -> b -> a ;+const a _ = a ;++fix :: (a -> a) -> a ;+fix f = f (fix f) ;
+ data/base/Instrument.hs view
@@ -0,0 +1,135 @@+module Instrument where++type Instrument = Integer ;+++acousticGrandPiano , brightAcousticPiano ,+ electricGrandPiano , honkyTonk ,+ electricPiano1 , electricPiano2 ,+ harpsichord , clavinet ,+ celesta , glockenspiel ,+ musicBox , vibraphone ,+ marimba , xylophone ,+ tubularBells , dulcimer ,+ drawbarOrgan , percussiveOrgan ,+ rockOrgan , churchOrgan ,+ reedOrgan , accordion ,+ harmonica , tangoAccordian ,+ acousticGuitarNylon , acousticGuitarSteel ,+ electricGuitarJazz , electricGuitarClean ,+ electricGuitarMuted , overdrivenGuitar ,+ distortionGuitar , guitarHarmonics ,+ acousticBass , electricBassFinger ,+ electricBassPick , fretlessBass ,+ slapBass1 , slapBass2 ,+ synthBass1 , synthBass2 ,+ violin , viola ,+ cello , contrabass ,+ tremoloStrings , pizzicatoStrings ,+ orchestralHarp , timpani ,+ stringEnsemble1 , stringEnsemble2 ,+ synthStrings1 , synthStrings2 ,+ choirAahs , voiceOohs ,+ synthVoice , orchestraHit ,+ trumpet , trombone ,+ tuba , mutedTrumpet ,+ frenchHorn , brassSection ,+ synthBrass1 , synthBrass2 ,+ sopranoSax , altoSax ,+ tenorSax , baritoneSax ,+ oboe , englishHorn ,+ bassoon , clarinet ,+ piccolo , flute ,+ recorder , panFlute ,+ blownBottle , skakuhachi ,+ whistle , ocarina ,+ lead1Square , lead2Sawtooth ,+ lead3Calliope , lead4Chiff ,+ lead5Charang , lead6Voice ,+ lead7Fifths , lead8BassLead ,+ pad1NewAge , pad2Warm ,+ pad3Polysynth , pad4Choir ,+ pad5Bowed , pad6Metallic ,+ pad7Halo , pad8Sweep ,+ fX1Rain , fX2Soundtrack ,+ fX3Crystal , fX4Atmosphere ,+ fX5Brightness , fX6Goblins ,+ fX7Echoes , fX8SciFi ,+ sitar , banjo ,+ shamisen , koto ,+ kalimba , bagpipe ,+ fiddle , shanai ,+ tinkleBell , agogo ,+ steelDrums , woodblock ,+ taikoDrum , melodicTom ,+ synthDrum , reverseCymbal ,+ guitarFretNoise , breathNoise ,+ seashore , birdTweet ,+ telephoneRing , helicopter ,+ applause , gunshot :: Instrument ;+++acousticGrandPiano = 0 ; brightAcousticPiano = 1 ;+electricGrandPiano = 2 ; honkyTonk = 3 ;+electricPiano1 = 4 ; electricPiano2 = 5 ;+harpsichord = 6 ; clavinet = 7 ;+celesta = 8 ; glockenspiel = 9 ;+musicBox = 10 ; vibraphone = 11 ;+marimba = 12 ; xylophone = 13 ;+tubularBells = 14 ; dulcimer = 15 ;+drawbarOrgan = 16 ; percussiveOrgan = 17 ;+rockOrgan = 18 ; churchOrgan = 19 ;+reedOrgan = 20 ; accordion = 21 ;+harmonica = 22 ; tangoAccordian = 23 ;+acousticGuitarNylon = 24 ; acousticGuitarSteel = 25 ;+electricGuitarJazz = 26 ; electricGuitarClean = 27 ;+electricGuitarMuted = 28 ; overdrivenGuitar = 29 ;+distortionGuitar = 30 ; guitarHarmonics = 31 ;+acousticBass = 32 ; electricBassFinger = 33 ;+electricBassPick = 34 ; fretlessBass = 35 ;+slapBass1 = 36 ; slapBass2 = 37 ;+synthBass1 = 38 ; synthBass2 = 39 ;+violin = 40 ; viola = 41 ;+cello = 42 ; contrabass = 43 ;+tremoloStrings = 44 ; pizzicatoStrings = 45 ;+orchestralHarp = 46 ; timpani = 47 ;+stringEnsemble1 = 48 ; stringEnsemble2 = 49 ;+synthStrings1 = 50 ; synthStrings2 = 51 ;+choirAahs = 52 ; voiceOohs = 53 ;+synthVoice = 54 ; orchestraHit = 55 ;+trumpet = 56 ; trombone = 57 ;+tuba = 58 ; mutedTrumpet = 59 ;+frenchHorn = 60 ; brassSection = 61 ;+synthBrass1 = 62 ; synthBrass2 = 63 ;+sopranoSax = 64 ; altoSax = 65 ;+tenorSax = 66 ; baritoneSax = 67 ;+oboe = 68 ; englishHorn = 69 ;+bassoon = 70 ; clarinet = 71 ;+piccolo = 72 ; flute = 73 ;+recorder = 74 ; panFlute = 75 ;+blownBottle = 76 ; skakuhachi = 77 ;+whistle = 78 ; ocarina = 79 ;+lead1Square = 80 ; lead2Sawtooth = 81 ;+lead3Calliope = 82 ; lead4Chiff = 83 ;+lead5Charang = 84 ; lead6Voice = 85 ;+lead7Fifths = 86 ; lead8BassLead = 87 ;+pad1NewAge = 88 ; pad2Warm = 89 ;+pad3Polysynth = 90 ; pad4Choir = 91 ;+pad5Bowed = 92 ; pad6Metallic = 93 ;+pad7Halo = 94 ; pad8Sweep = 95 ;+fX1Rain = 96 ; fX2Soundtrack = 97 ;+fX3Crystal = 98 ; fX4Atmosphere = 99 ;+fX5Brightness = 100 ; fX6Goblins = 101 ;+fX7Echoes = 102 ; fX8SciFi = 103 ;+sitar = 104 ; banjo = 105 ;+shamisen = 106 ; koto = 107 ;+kalimba = 108 ; bagpipe = 109 ;+fiddle = 110 ; shanai = 111 ;+tinkleBell = 112 ; agogo = 113 ;+steelDrums = 114 ; woodblock = 115 ;+taikoDrum = 116 ; melodicTom = 117 ;+synthDrum = 118 ; reverseCymbal = 119 ;+guitarFretNoise = 120 ; breathNoise = 121 ;+seashore = 122 ; birdTweet = 123 ;+telephoneRing = 124 ; helicopter = 125 ;+applause = 126 ; gunshot = 127 ;
+ data/base/Integer.hs view
@@ -0,0 +1,5 @@+module Integer where++isZero :: Integer -> Bool ;+isZero 0 = True ;+isZero _ = False ;
+ data/base/List.hs view
@@ -0,0 +1,141 @@+module List (+ map,+ zipWith,+ foldr,+ foldl,+ length,+ sum,+ add,+ scanl,+ scanr,+ reverse,+ replicate,+ repeat,+ cycle,+ iterate,+ (++),+ concat,+ concatMap,+ head,+ tail,+ null,+ (!!),+ take,+ drop,+ filter,+ takeWhile,+ ) where++import ListLive+import Function+import Bool+import Prelude ( (-), (+), Num, Int, Bool(False,True), error )+++map :: (a -> b) -> [a] -> [b] ;+map _ [] = [] ;+map f (x : xs) = f x : map f xs ;++zipWith :: (a -> b -> c) -> [a] -> [b] -> [c] ;+zipWith f (x : xs) (y : ys) =+ f x y : zipWith f xs ys ;+zipWith _f _xs _ys = [] ;++foldr :: (b -> a -> a) -> a -> [b] -> a ;+foldr _ a [] = a ;+foldr f a (x : xs) = f x ( foldr f a xs ) ;++foldl :: (b -> a -> b) -> b -> [a] -> b ;+foldl _ a [] = a ;+foldl f a (x : xs) = foldl f (f a x) xs ;++length :: [a] -> Int ;+length = sumInteger . map (const 1) ;++sum :: (Num a) => [a] -> a ;+sum = foldl add 0 ;++add :: (Num a) => a -> a -> a ;+add x y = x + y ;+++scanl :: (a -> b -> a) -> a -> [b] -> [a] ;+scanl _ a [] = [a] ;+scanl f a (x : xs) = a : scanl f (f a x) xs ;++scanr :: (b -> a -> a) -> a -> [b] -> [a] ;+scanr _ a [] = [a] ;+scanr f a (x : xs) = scanrAux f x (scanr f a xs) ;++scanrAux :: (b -> a -> a) -> b -> [a] -> [a] ;+scanrAux f x ys = f x (head ys) : ys ;+++reverse :: [a] -> [a] ;+reverse = foldl (flip cons) [] ;++replicate :: Int -> a -> [a] ;+replicate n x = take n ( repeat x ) ;++repeat :: a -> [a] ;+repeat s = s : repeat s ;++cycle :: [a] -> [a] ;+cycle s = s ++ cycle s ;++iterate :: (a -> a) -> a -> [a] ;+iterate f x = x : iterate f (f x) ;+++(++) :: [a] -> [a] -> [a] ;+xs ++ ys = foldr cons ys xs ;++concat :: [[a]] -> [a] ;+concat = foldr append [];++concatMap :: (a -> [b]) -> [a] -> [b] ;+concatMap f = concat . map f ;++head :: [a] -> a ;+head (x:_) = x ;+head [] = error "head: empty list" ;++tail :: [a] -> [a] ;+tail (_:xs) = xs ;+tail [] = error "tail: empty list" ;++null :: [a] -> Bool ;+null [] = True ;+null _ = False ;++(!!) :: [a] -> Int -> a ;+(x:_) !! 0 = x ;+(_:xs) !! n = xs !! (n-1) ;+[] !! _ = error "!!: index too large" ;++take :: Int -> [a] -> [a] ;+take n xs = foldr takeElem (const []) xs n ;++takeElem :: a -> (Int -> [a]) -> Int -> [a] ;+takeElem _ _go 0 = [] ;+takeElem x go m = x : go (m-1) ;++drop :: Int -> [b] -> [b] ;+drop 0 xs = xs ;+drop _ [] = [] ;+drop n (_ : xs) = drop (n-1) xs ;+++filter :: (a -> Bool) -> [a] -> [a] ;+filter p =+ foldr (filterElem p) [] ;++filterElem :: (a -> Bool) -> a -> [a] -> [a] ;+filterElem p x xs = ifThenElse (p x) (x:xs) xs ;++takeWhile :: (a -> Bool) -> [a] -> [a] ;+takeWhile p =+ foldr (takeWhileElem p) [] ;++takeWhileElem :: (a -> Bool) -> a -> [a] -> [a] ;+takeWhileElem p x xs = ifThenElse (p x) (x:xs) [] ;
+ data/base/ListLive.hs view
@@ -0,0 +1,114 @@+module ListLive (+ cons,+ append,+ splitAt,+ afterEach,+ dropWhileRev,++ sumInteger,+ iterateInteger,+ iterateIntegerList,+ applyStrictList,+ applyStrictListList,+ ) where++import Tuple+import Function+import Bool+import Prelude ( (-), (+), Num, Int, Integer, Integral, Bool, foldr, null, reverse )+++cons :: a -> [a] -> [a] ;+cons x xs = x : xs ;++append :: [a] -> [a] -> [a] ;+append = flip ( foldr cons ) ;+++{-+This does not work well and fails for infinite lists,+because consFirst matches strictly on Pair.+-}+splitAt :: Int -> [a] -> Tuple.Pair [a] [a] ;+splitAt 0 xs = Pair [] xs ;+splitAt _ [] = Pair [] [] ;+splitAt n (x : xs) = consFirst x ( splitAt (n-1) xs ) ;++consFirst :: a -> Tuple.Pair [a] [a] -> Tuple.Pair [a] [a] ;+consFirst x p = Pair (x : fst p) (snd p) ;+++afterEach :: a -> [a] -> [a] ;+afterEach _y [] = [] ;+afterEach y (x : xs) = x : y : afterEach y xs ;+++dropWhileRev :: (a -> Bool) -> [a] -> [a] ;+dropWhileRev p =+ foldr (dropWhileRevElem p) [] ;++dropWhileRevElem :: (a -> Bool) -> a -> [a] -> [a] ;+dropWhileRevElem p x xs = ifThenElse (p x && null xs) [] (x:xs) ;+++-- * functions that are somehow strict++-- | constant space usage in contrast to 'sum'+sumInteger :: (Integral a) => [a] -> a ;+sumInteger = sumIntegerAux 0 ;++sumIntegerAux :: (Integral a) => a -> [a] -> a ;+sumIntegerAux 0 [] = 0 ;+sumIntegerAux s [] = s ;+sumIntegerAux s (x:xs) = sumIntegerAux (s+x) xs ;+++-- | constant space usage in contrast to 'iterate'+iterateInteger, iterateIntegerAux ::+ (Integer -> Integer) -> Integer -> [Integer] ;+iterateInteger f = applyStrict (iterateIntegerAux f) ;+iterateIntegerAux f x = x : iterateInteger f (f x) ;++iterateIntegerList, iterateIntegerListAux ::+ ([Integer] -> [Integer]) -> [Integer] -> [[Integer]] ;+iterateIntegerList f = applyStrictList (iterateIntegerListAux f) ;+iterateIntegerListAux f x = x : iterateIntegerList f (f x) ;++{- even stricter: it always updates the accumulator, also if the updated value is not needed because the list is aborted earlier+iterateInteger, iterateIntegerAux0 ::+ (Integer -> Integer) -> Integer -> [Integer] ;+iterateIntegerAux1 ::+ (Integer -> Integer) -> Integer -> Integer -> [Integer] ;+iterateInteger f = applyStrict (iterateIntegerAux0 f) ;+iterateIntegerAux0 f x = applyStrict (iterateIntegerAux1 f x) (f x) ;+iterateIntegerAux1 f x fx = x : iterateInteger f fx ;+-}++{- too strict for DeBruijn+iterateIntegerList, iterateIntegerListAux0 ::+ ([Integer] -> [Integer]) -> [Integer] -> [[Integer]] ;+iterateIntegerListAux1 ::+ ([Integer] -> [Integer]) -> [Integer] -> [Integer] -> [[Integer]] ;+iterateIntegerList f = applyStrictList (iterateIntegerListAux0 f) ;+iterateIntegerListAux0 f x = applyStrictList (iterateIntegerListAux1 f x) (f x) ;+iterateIntegerListAux1 f x fx = x : iterateIntegerList f fx ;+-}++++applyStrictList :: ([Integer] -> a) -> ([Integer] -> a) ;+applyStrictList f xs = applyStrictListAux f [] (reverse xs) ;++applyStrictListAux :: ([Integer] -> a) -> [Integer] -> ([Integer] -> a) ;+applyStrictListAux f ys [] = f ys ;+applyStrictListAux f ys (0:xs) = applyStrictListAux f (0:ys) xs ;+applyStrictListAux f ys (x:xs) = applyStrictListAux f (x:ys) xs ;+++applyStrictListList :: ([[Integer]] -> a) -> ([[Integer]] -> a) ;+applyStrictListList f xs = applyStrictListListAux f [] (reverse xs) ;++applyStrictListListAux :: ([[Integer]] -> a) -> [[Integer]] -> ([[Integer]] -> a) ;+applyStrictListListAux f ys [] = f ys ;+applyStrictListListAux f ys (x:xs) =+ applyStrictList (applyStrictListListAux f . flip cons ys) x xs ;
+ data/base/Midi.hs view
@@ -0,0 +1,221 @@+module Midi (+ Time,+ Velocity,+ Program,+ Controller,+ Chan,+ Event(Wait, Say, Event),+ Channel(Channel),+ Message(PgmChange, Controller, On, Off),++ note,+ rest,+ program,+ controller,+ channel,+ transpose, transposeEvent,+ controlCurve,+ normalVelocity,+ emphasize,++ takeTime,+ dropTime,+ skipTime,+ compressTime,++ (+:+),+ merge, (=:=),+ mergeWait,+ mergeMany,+ ) where++import Function+import Pitch ( Pitch )+import Bool ( ifThenElse )+++type Time = Integer ;+type Velocity = Integer ;+type Program = Integer ;+type Controller = Integer ;+type Chan = Integer ;++data Event a = Wait Time | Say String | Event a ;++data Channel a = Channel Integer a ;++data Message =+ PgmChange Program+ | Controller Controller Integer+ | On Pitch Velocity+ | Off Pitch Velocity ;++{- |+This function is strict in the pitch+and thus asserts that the pitch for NoteOn and NoteOff+are evaluated at the same time to the same value.+This way we assert that a pressed note+will be released later.+-}+note :: Time -> Pitch -> [Event Message] ;+note duration = applyStrict (noteLazy duration) ;++noteLazy :: Time -> Pitch -> [Event Message] ;+noteLazy duration pitch =+ [ Event (On pitch normalVelocity)+ , Wait duration+ , Event (Off pitch normalVelocity)+ ] ;++rest :: Time -> [Event a] ;+rest duration =+ [ Wait duration ] ;++program :: Program -> [Event Message] ;+program n =+ [ Event ( PgmChange n ) ] ;++controller :: Controller -> Integer -> [Event Message] ;+controller cc x =+ [ Event ( Controller cc x ) ] ;++channel :: Chan -> [Event a] -> [Event (Channel a)] ;+channel chan = map ( channelEvent chan ) ;++channelEvent :: Chan -> Event a -> Event (Channel a) ;+channelEvent chan (Event event) = Event (Channel chan event) ;+channelEvent _chan (Wait duration) = Wait duration ;+channelEvent _chan (Say text) = Say text ;+++transpose :: Integer -> [Event Message] -> [Event Message] ;+transpose d = map ( transposeEvent d ) ;++transposeEvent :: Integer -> Event Message -> Event Message ;+transposeEvent d (Event (On pitch velocity)) = Event (On (pitch+d) velocity) ;+transposeEvent d (Event (Off pitch velocity)) = Event (Off (pitch+d) velocity) ;+transposeEvent _d event = event ;+++controlCurve :: Time -> Controller -> [Integer] -> [Event Message] ;+controlCurve _d _cc [] = [] ;+controlCurve d cc (x : xs) =+ Event (Controller cc x) : Wait d : controlCurve d cc xs ;++normalVelocity :: Velocity ;+normalVelocity = 64 ;++emphasize :: Integer -> [Event Message] -> [Event Message] ;+emphasize v = map ( emphasizeEvent v ) ;++{-+We only alter the start velocity.+In most cases NoteOff velocity is the normal velocity+and this is handled more efficiently by the MIDI message encoding.+-}+emphasizeEvent :: Integer -> Event Message -> Event Message ;+emphasizeEvent v (Event (On pitch velocity)) = Event (On pitch (velocity+v)) ;+emphasizeEvent _v event = event ;+++takeTime :: Time -> [Event a] -> [Event a] ;+takeTime _ [] = [] ;+takeTime t ( Wait x : xs ) =+ ifThenElse (t<x)+ [ Wait t ]+ ( Wait x : applyStrict takeTime (t-x) xs ) ;+takeTime t ( ev : xs ) =+ ev : takeTime t xs ;+++dropTime :: Time -> [Event a] -> [Event a] ;+dropTime = applyStrict dropTimeAux ;++dropTimeAux :: Time -> [Event a] -> [Event a] ;+dropTimeAux _ [] = [] ;+dropTimeAux t ( Wait x : xs ) =+ ifThenElse (t<x)+ ( applyStrict consWait (x-t) xs )+ ( applyStrict dropTimeAux (t-x) xs ) ;+dropTimeAux t ( _ : xs ) = dropTimeAux t xs ;+++{- |+Like 'dropTime' but does not simply remove events but play them at once.+This way all tones are correctly stopped and started,+however you risk the 'too many events in a too short period' exception.+-}+skipTime :: Time -> [Event a] -> [Event a] ;+skipTime = applyStrict skipTimeAux ;++skipTimeAux :: Time -> [Event a] -> [Event a] ;+skipTimeAux _ [] = [] ;+skipTimeAux t ( Wait x : xs ) =+ ifThenElse (t<x)+ ( applyStrict consWait (x-t) xs )+ ( applyStrict skipTimeAux (t-x) xs ) ;+skipTimeAux t ( ev : xs ) = ev : skipTimeAux t xs ;+++{- |+Do not simply remove events but play them at once.+This way all tones are correctly stopped and started,+however you risk the 'too many events in a too short period' exception.+-}+compressTime :: Integer -> Time -> [Event a] -> [Event a] ;+compressTime k = applyStrict (applyStrict compressTimeAux k) ;++compressTimeAux :: Integer -> Time -> [Event a] -> [Event a] ;+compressTimeAux _ _ [] = [] ;+compressTimeAux k t ( Wait x : xs ) =+ ifThenElse (t<x)+ ( applyStrict consWait (div t k + (x-t)) xs )+ ( applyStrict consWait (div x k)+ ( applyStrict (compressTimeAux k) (t-x) xs ) ) ;+compressTimeAux k t ( ev : xs ) = ev : compressTimeAux k t xs ;+++consWait :: Time -> [Event a] -> [Event a] ;+consWait t xs = Wait t : xs ;++++infixr 7 +:+ ; {- like multiplication -}+infixr 6 =:= ; {- like addition -}++(+:+) :: [Event a] -> [Event a] -> [Event a] ;+xs +:+ ys = xs ++ ys ;++merge, (=:=) :: [Event a] -> [Event a] -> [Event a] ;+xs =:= ys = merge xs ys ;++merge (Wait a : xs) (Wait b : ys) =+ mergeWait (a<b) (a-b) a xs b ys ;+merge (Wait a : xs) (y : ys) =+ y : merge (Wait a : xs) ys ;+merge (x : xs) ys = x : merge xs ys ;+merge [] ys = ys ;++{-+This looks a bit cumbersome,+but it is necessary for avoiding stacks of unevaluated subtractions.+We use or abuse the way of how the interpreter performs pattern matching.+By matching against 0 we force the evaluation of the difference d.+The evaluated difference is hold throughout the matching of all patterns.+It is important that the match against 0 is really performed+and is not shadowed by a failing preceding match, say, against the result of (a<b).+-}+mergeWait ::+ Bool -> Time ->+ Time -> [Event a] ->+ Time -> [Event a] ->+ [Event a] ;+mergeWait _eq 0 a xs _b ys =+ Wait a : merge xs ys ;+mergeWait True d a xs _b ys =+ Wait a : merge xs (Wait (negate d) : ys) ;+mergeWait False d _a xs b ys =+ Wait b : merge (Wait d : xs) ys ;++mergeMany :: [[Event a]] -> [Event a] ;+mergeMany = foldl merge [] ;
+ data/base/Music.hs view
@@ -0,0 +1,100 @@+module Music where++import Midi ( Event(Wait, Event, Say), Message, Channel(Channel),+ note, transposeEvent, mergeMany )+import ListLive ( afterEach )+import List ( map, replicate, repeat, concat )+import Prelude ( (*), div, (.), ($), negate, Int, Integer, Integral, String )+++c, cf, cs, df, d, ds, ef, e, es, ff, f, fs,+ gf, g, gs, af, a, as, bf, b, bs ::+ Music (Event Message) ;++quarter :: Integer ;+quarter = 240 ;++p :: Music (Event a) ;+p = Atom ( Wait quarter ) ;++c = Seq $ map Atom $ note quarter 36 ;+cf = down 1 c ; cs = up 1 c ;+df = cs ; d = up 2 c ; ds = up 3 c ;+ef = ds ; e = up 4 c ; es = f ;+ff = e ; f = up 5 c ; fs = up 6 c ;+gf = fs ; g = up 7 c ; gs = up 8 c ;+af = gs ; a = up 9 c ; as = up 10 c ;+bf = as ; b = up 11 c ; bs = up 12 c ;++slow, speed :: Integer -> Music (Event a) -> Music (Event a) ;++slowdown, speedup :: (Integral a) => a -> a -> a ;++slow k = wmap ( slowdown k ) ; slowdown k w = w * k ;+speed k = wmap ( speedup k ) ; speedup k w = div w k ;++up, down ::+ Integer ->+ Music (Event Message) ->+ Music (Event Message) ;+up dif s = tr dif s ; down dif s = tr ( negate dif ) s ;++chan ::+ Integer ->+ Music (Event a) ->+ Music (Event (Midi.Channel a)) ;+chan cn = emap ( Channel cn ) ;++tr ::+ Integer ->+ Music (Event Message) ->+ Music (Event Message) ;+tr dif = amap ( transposeEvent dif ) ;++says :: [String] -> Music (Event a) ;+says ws = Seq ( afterEach p ( map (Atom . Say) ws ) ) ;++major, minor, minor7 ::+ Music (Event Message) -> Music (Event Message) ;+major s = Par [ s, up 4 s, up 7 s ] ;+minor s = Par [ s, up 3 s, up 7 s ] ;+minor7 s = Par [ s, up 3 s, up 7 s, up 11 s ] ;++times :: Int -> Music a -> Music a ;+times k s = Seq ( replicate k s ) ;++emap :: (a -> b) -> Music (Event a) -> Music (Event b) ;+emap fn ( Atom ( Event ev ) ) = Atom ( Event ( fn ev ) ) ;+emap _ ( Atom ( Wait w ) ) = Atom ( Wait w ) ;+emap _ ( Atom ( Say s ) ) = Atom ( Say s ) ;+emap fn ( Par xs ) = Par ( map ( emap fn ) xs );+emap fn ( Seq xs ) = Seq ( map ( emap fn ) xs );++wmap ::+ (Integer -> Integer) ->+ Music (Event a) -> Music (Event a) ;+wmap _ ( Atom ( Event ev ) ) = Atom ( Event ev ) ;+wmap fn ( Atom ( Wait w ) ) = Atom ( Wait ( fn w ) ) ;+wmap _ ( Atom ( Say s ) ) = Atom ( Say s ) ;+wmap fn ( Par xs ) = Par ( map ( wmap fn ) xs );+wmap fn ( Seq xs ) = Seq ( map ( wmap fn ) xs );++amap :: (a -> b) -> Music a -> Music b ;+amap fn ( Atom atom ) = Atom ( fn atom ) ;+amap fn ( Par xs ) = Par ( map ( amap fn ) xs );+amap fn ( Seq xs ) = Seq ( map ( amap fn ) xs );+++forever :: Music a -> Music a ;+forever s = Seq ( repeat s ) ;++data Music a =+ Atom a+ | Par [Music a]+ | Seq [Music a] ;+++play :: Music (Event a) -> [Event a] ;+play (Par xs) = mergeMany ( map play xs ) ;+play (Seq xs) = concat ( map play xs ) ;+play (Atom atom) = [ atom ] ;
+ data/base/Pitch.hs view
@@ -0,0 +1,41 @@+module Pitch where++import Prelude ( Integer, (+), (-), (*) )+++type Pitch = Integer ;+type Octave = Integer ;+type Class = Integer ;++{- cf.+http://en.wikipedia.org/wiki/Scientific_pitch_notation+http://en.wikipedia.org/wiki/MIDI_Tuning_Standard+-}+pitch :: Class -> Octave -> Pitch ;+pitch cls octave = cls + (octave+1)*12 ;++cb, db, eb, fb, gb, ab, bb :: Class ;++c, cis, ces, cs, cf,+ d, dis, des, ds, df,+ e, eis, ees, es, ef,+ f, fis, fes, fs, ff,+ g, gis, ges, gs, gf,+ a, ais, aes, as, af,+ b, bis, bes, bs, bf :: Octave -> Pitch ;++cb = 0 ; c = pitch cb ; cis = cs ; ces = cf ;+db = 2 ; d = pitch db ; dis = ds ; des = df ;+eb = 4 ; e = pitch eb ; eis = es ; ees = ef ;+fb = 5 ; f = pitch fb ; fis = fs ; fes = ff ;+gb = 7 ; g = pitch gb ; gis = gs ; ges = gf ;+ab = 9 ; a = pitch ab ; ais = as ; aes = af ;+bb = 11 ; b = pitch bb ; bis = bs ; bes = bf ;++cs = pitch (cb+1) ; cf = pitch (cb-1) ;+ds = pitch (db+1) ; df = pitch (db-1) ;+es = pitch (eb+1) ; ef = pitch (eb-1) ;+fs = pitch (fb+1) ; ff = pitch (fb-1) ;+gs = pitch (gb+1) ; gf = pitch (gb-1) ;+as = pitch (ab+1) ; af = pitch (ab-1) ;+bs = pitch (bb+1) ; bf = pitch (bb-1) ;
+ data/base/Render.hs view
@@ -0,0 +1,82 @@+module Render where++import qualified Midi++import qualified Sound.MIDI.File as MidiFile+import qualified Sound.MIDI.File.Event as FileEvent+import qualified Sound.MIDI.File.Save as Save+import qualified Sound.MIDI.File.Event.Meta as MetaEvent+import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg+import qualified Sound.MIDI.Message.Channel as ChannelMsg++import qualified Data.EventList.Relative.TimeBody as EventList+import qualified Numeric.NonNegative.Wrapper as NonNeg++import Data.Monoid (mempty, mappend, )+++class Message msg where+ makeMessage :: msg -> ChannelMsg.Body++class ChannelMessage msg where+ makeChannelMessage :: msg -> ChannelMsg.T++instance ChannelMessage Midi.Message where+ makeChannelMessage =+ ChannelMsg.Cons (ChannelMsg.toChannel 0) . makeMessage++instance Message Midi.Message where+ makeMessage msg =+ ChannelMsg.Voice $+ case msg of+ Midi.On pitch velocity ->+ VoiceMsg.NoteOn+ (VoiceMsg.toPitch $ fromInteger pitch)+ (VoiceMsg.toVelocity $ fromInteger velocity)+ Midi.Off pitch velocity ->+ VoiceMsg.NoteOff+ (VoiceMsg.toPitch $ fromInteger pitch)+ (VoiceMsg.toVelocity $ fromInteger velocity)+ Midi.PgmChange pgm ->+ VoiceMsg.ProgramChange+ (VoiceMsg.toProgram $ fromInteger pgm)+ Midi.Controller ctrl value ->+ VoiceMsg.Control+ (VoiceMsg.toController $ fromInteger ctrl)+ (fromInteger value)++instance Message msg => ChannelMessage (Midi.Channel msg) where+ makeChannelMessage (Midi.Channel chan msg) =+ ChannelMsg.Cons (ChannelMsg.toChannel $ fromInteger chan) $+ makeMessage msg+++trackFromStream ::+ (ChannelMessage msg) => [Midi.Event msg] -> MidiFile.Track+trackFromStream evs =+ foldr+ (\ev go time ->+ case ev of+ Midi.Wait pause ->+ go (mappend time $+ NonNeg.fromNumberMsg "Render.trackFromStream: Wait" pause)+ Midi.Say str ->+ EventList.cons time (FileEvent.MetaEvent $ MetaEvent.Lyric str) $+ go 0+ Midi.Event msg ->+ EventList.cons time (FileEvent.MIDIEvent $ makeChannelMessage msg) $+ go 0)+ (\ _time -> EventList.empty) evs mempty++fileFromStream ::+ (ChannelMessage msg) => [Midi.Event msg] -> MidiFile.T+fileFromStream =+ MidiFile.Cons MidiFile.Mixed (MidiFile.Ticks 500) .+ (:[]) .+ -- EventList.cons 0 (MetaEvent.SetTempo 500000) .+ trackFromStream++writeStream ::+ (ChannelMessage msg) => FilePath -> [Midi.Event msg] -> IO ()+writeStream path =+ Save.toFile path . fileFromStream
+ data/base/Tuple.hs view
@@ -0,0 +1,9 @@+module Tuple where++data Pair a b = Pair a b ;++fst :: Pair a b -> a ;+fst ( Pair a _ ) = a ;++snd :: Pair a b -> b ;+snd ( Pair _ b ) = b ;
+ data/example/Band.hs view
@@ -0,0 +1,34 @@+module Band where++import Drum+import Chords+import Pitch+import Midi+import List+import Prelude ( (*) ) ;++main, chords, drums :: [Event (Channel Message)] ;+main = merge ( cycle chords ) ( cycle drums ) ;++en, qn, hn, wn :: Time ;+en = 100 ;+qn = 2 * en ;+hn = 2 * qn ;+wn = 2 * hn ;++chords =+ channel 0 ( concat+ [ quad ( major qn (c 4) )+ , quad ( minor qn (a 4) )+ , quad ( major qn (f 4) )+ , quad ( major7 qn (g 4) )+ ] ) ;++drums =+ drumChannel ( concat+ [ emphasize 16 ( drum bassDrum1 hn )+ , quad ( drum acousticSnare en )+ ] ) ;++quad :: [a] -> [a] ;+quad x = concat [ x, x, x, x ] ;
+ data/example/BandControlled.hs view
@@ -0,0 +1,43 @@+module BandControlled where++import Controls+import Drum+import Chords+import Pitch+import Midi+import List+import Bool+import Prelude ( (*), Bool(False, True) )++main, chords, drums :: [Event (Channel Message)] ;+main = merge ( cycle chords ) ( cycle drums ) ;++en, qn, hn :: Time ;+en = slider "tempo" 50 150 100 ;+qn = 2 * en ;+hn = 2 * qn ;++chords =+ channel 0 ( concat+ [ quad ( major qn (c 4) )+ , quad ( minor qn (a 4) )+ , quad ( major qn (f 4) )+ , quad ( major7 qn (g 4) )+ ] ) ;++quad :: [a] -> [a] ;+quad x = concat [x,x,x,x] ;++drums =+ drumChannel ( concat+ [ emphasize 16 ( drum bassDrum1 hn )+ , concat [ optDrum ( checkBox "B5" True ) acousticSnare en+ , optDrum ( checkBox "B6" False ) acousticSnare en+ , optDrum ( checkBox "B7" False ) acousticSnare en+ , optDrum ( checkBox "B8" True ) acousticSnare en+ ]+ ] ) ;++optDrum :: Bool -> Drum -> Time -> [Event Message] ;+optDrum sel drm dur =+ ifThenElse sel ( drum drm dur ) ( rest dur ) ;
+ data/example/CrossSum.hs view
@@ -0,0 +1,62 @@+module CrossSum where++import Midi ;+import ListLive ;+import List ;+import Pitch ;+import Function ;+import Prelude ( Integer, fromInteger, (+), mod, div, succ ) ;+++main :: [ Event (Channel Message) ] ;+main =+ channel 0 $+ concatMap (note qn . makePitch) $+ modCrossSums 4 ;++makePitch :: Integer -> Pitch ;+makePitch 0 = c 4 ;+makePitch 1 = e 4 ;+makePitch 2 = g 4 ;+makePitch _ = c 5 ;+++-- * explicit base conversion++modCrossSums :: Integer -> [Integer] ;+modCrossSums n =+ map (foldl (modAdd n) 0 . toBase n) $+ iterateInteger succ 0 ;++toBase :: Integer -> Integer -> [Integer] ;+toBase _n 0 = [] ;+toBase n x = mod x n : toBase n (div x n) ;+++-- * recursion on lists++modCrossSumsList :: Integer -> [Integer] ;+modCrossSumsList n =+ 0 : extList n [0] ;++extList :: Integer -> [Integer] -> [Integer] ;+extList n y =+ applyStrictListList (extList2 n) $ map (incList n y) $+ take (fromInteger n) $ iterateInteger succ 0 ;++extList2 :: Integer -> [[Integer]] -> [Integer] ;+extList2 n z =+ concat (tail z) ++ extList n (concat z) ;++incList :: Integer -> [Integer] -> Integer -> [Integer] ;+incList m ys x = map (modAdd m x) ys ;+++-- * auxiliary++modAdd :: Integer -> Integer -> Integer -> Integer ;+modAdd m x y = mod (x+y) m ;+++qn :: Integer ;+qn = 150 ;
+ data/example/DeBruijn.hs view
@@ -0,0 +1,49 @@+module DeBruijn where++import Midi ;+import ListLive ;+import List ;+import Pitch ;+import Bool ;+import Integer ;+import Prelude ( Integer, fromInteger, fromIntegral, ($), (.), (+), (-), (<), mod ) ;+++main :: [ Event (Channel Message) ] ;+main =+ channel 0 $+ concatMap (note qn . makePitch) $+ cycle $ deBruijnSequence 4 2 ;++makePitch :: Integer -> Pitch ;+makePitch 0 = c 4 ;+makePitch 1 = e 4 ;+makePitch 2 = g 4 ;+makePitch _ = c 5 ;+++-- * De Bruijn sequence generation based on lists++nextLyndonWord :: Integer -> Integer -> [Integer] -> [Integer] ;+nextLyndonWord n k =+ foldr (checkLyndonElement n) [] . take (fromInteger k) . cycle ;++checkLyndonElement :: Integer -> Integer -> [Integer] -> [Integer] ;+checkLyndonElement n x [] = ifThenElse (x<n-1) [x+1] [] ;+checkLyndonElement _ x xs = x:xs ;++deBruijnSequence :: Integer -> Integer -> [Integer] ;+deBruijnSequence n k =+ concat $+ filter (isZero . mod k . fromIntegral . length) $+ takeWhile (not . null) $+ iterateIntegerList (nextLyndonWord n k) [0] ;+++-- Another efficient approach might be encoding the Lyndon words as integers.+++-- * auxiliary++qn :: Integer ;+qn = 150 ;
+ data/example/Fibonacci.hs view
@@ -0,0 +1,48 @@+module Fibonacci where++import Midi ;+import List ;+import Pitch ;+import Function ;+import Prelude ( Integer, (*), (+), mod ) ;+++main :: [ Event (Channel Message) ] ;+main =+ channel 0 $+ concatMap (note qn . makePitch) $+ modFibonacci3 4 1 1 0 ;++makePitch :: Integer -> Pitch ;+makePitch 0 = c 4 ;+makePitch 1 = e 4 ;+makePitch 2 = g 4 ;+makePitch _ = c 5 ;+++-- * Solution of linear difference equation in modulo arithmetic++modFibonacci :: Integer -> Integer -> Integer -> [Integer] ;+modFibonacci n c0 c1 = modFibonacciRec n c0 c1 0 1 ;++modFibonacciRec ::+ Integer -> Integer -> Integer ->+ Integer -> Integer -> [Integer] ;+modFibonacciRec n c0 c1 x0 x1 =+ x0 : applyStrict (modFibonacciRec n c0 c1 x1) (mod (x0*c0+x1*c1) n) ;+++modFibonacci3 :: Integer -> Integer -> Integer -> Integer -> [Integer] ;+modFibonacci3 n c0 c1 c2 = modFibonacci3Rec n c0 c1 c2 0 0 1 ;++modFibonacci3Rec ::+ Integer -> Integer -> Integer -> Integer ->+ Integer -> Integer -> Integer -> [Integer] ;+modFibonacci3Rec n c0 c1 c2 x0 x1 x2 =+ x0 : applyStrict (modFibonacci3Rec n c0 c1 c2 x1 x2) (mod (x0*c0+x1*c1+x2*c2) n) ;+++-- * auxiliary++qn :: Integer ;+qn = 150 ;
+ data/example/Finite.hs view
@@ -0,0 +1,18 @@+module Finite where++import Pitch+import Midi+import List+import Prelude ( (*), ($) )+++main, voice :: [Event (Channel Message)] ;+main = voice ;++qn, hn :: Time ;+qn = 600 ;+hn = 2 * qn ;++voice =+ channel 0 $+ program 0 ++ note qn (c 4) ++ note hn (ds 4) ++ note qn (gs 4) ;
+ data/example/Klingklong.hs view
@@ -0,0 +1,261 @@+module Klingklong where++import Chords+import Pitch+import Midi+import List+import Prelude ( Integer, (*), (+), (-) )+++main :: [Midi.Event (Midi.Channel Midi.Message)] ;+main = [] ;+++-- * patterns++loop0, loop0_1, loop1, loop2a, loop2b+ :: [Midi.Event (Midi.Channel Midi.Message)] ;+loop0 = patternChannel ( note qn (c 4) ) ++ loop0 ;++loop0_1 =+ patternChannel (+ ping ++ note qn (c 4)+ ) ++ loop0_1 ;+++pattern1, pattern2a, pattern2b, pattern3a, pattern3b+ :: [Midi.Event (Midi.Channel Midi.Message)] ;+pattern1 = patternChannel ( concat [+ note qn (e 4), note qn (c 4),+ note qn (e 4), note qn (c 4),+ note qn (g 4), note en (f 4), note en (e 4),+ note en (d 4), note en (e 4), note en (f 4),+ note en (d 4) ] ) ;++pattern2 :: [Midi.Event Midi.Message] ;+pattern2 = concat [+ note qn (e 4), note qn (a 4),+ note qn (e 4), note qn (a 4),+ note qn (a 4), note en (b 4), note en (c 5),+ note en (d 5), note en (c 5), note en (b 4) ] ;++pattern2a =+ patternChannel ( pattern2 ++ note en (a 4) ) ;++pattern2b =+ patternChannel ( pattern2 ++ note en (g 4) ) ;+++pattern3a = patternChannel ( concat [+ note qn (e 4), note qn (c 4),+ note qn (e 4), note qn (c 4),+ note qn (g 4), note en (f 4), note en (e 4),+ note en (d 4), note en (e 4), note en (f 4),+ note en (d 4) ] ) ;++pattern3b = patternChannel ( concat [+ note qn (e 4), note qn (c 4),+ note qn (e 4), note qn (c 4),+ note qn (e 4), note en (d 4), note en (c 4),+ note en (d 4), note en (e 4), note en (d 4),+ note en (c 4) ] ) ;+++loop1 = pattern1 ++ loop1 ;++loop2a = pattern2a ++ loop2a ;++loop2b = pattern2b ++ loop1 ;+++-- * pad++padSimple, pad1, pad2, pad3,+ bass3, bassLoop,+ sweep, loop1p,+ pad3loop, loop3sweep, bassPad,+ pattern1Bass, pattern1BassPadShort,+ pattern1BassPad, pattern2BassPad, pattern3BassPad+ :: [Midi.Event (Midi.Channel Midi.Message)] ;+++padSimple = padChannel ( concat [+ pad,+ controller volumeCC 90, controller brightnessCC 60,+ chord4 wn2 (c 4) (e 4) (g 4) (c 5) ] ) ;++pad1 = padChannel ( concat [+ pad,+ controller volumeCC 90,+ chord4 wn2 (c 4) (e 4) (g 4) (c 5),+ chord4 wn2 (c 4) (d 4) (g 4) (c 5),+ chord4 wn2 (c 4) (f 4) (a 4) (c 5),+ chord4 wn2 (c 4) (e 4) (g 4) (c 5) ] ) ;++pad2 = padChannel ( concat [+ pad,+ controller volumeCC 90,+ chord4 wn2 (c 4) (e 4) (a 4) (c 5),+ chord4 wn2 (b 3) (e 4) (g 4) (b 4),+ chord4 wn2 (c 4) (e 4) (a 4) (c 5),+ chord4 wn2 (a 3) (c 4) (f 4) (a 4),++ chord4 wn2 (c 4) (e 4) (a 4) (c 5),+ chord4 wn2 (b 3) (e 4) (g 4) (b 4),+ chord4 wn2 (c 4) (e 4) (a 4) (c 5),+ chord4 dwn (a 3) (c 4) (f 4) (a 4),+ chord4 hn (b 3) (d 4) (g 4) (b 4) ] ) ;++pad3 = padChannel ( concat [+ pad,+ controller volumeCC 90, controller brightnessCC 70,+ chord4 wn2 (c 4) (f 4) (a 4) (c 5),+ chord4 wn2 (e 4) (a 4) (c 5) (e 5),+ chord4 wn2 (d 4) (g 4) (b 4) (d 5),+ chord4 wn2 (d 4) (fs 4) (a 4) (d 5) ] ) ;+++-- * bass++bassControl :: [Midi.Event Midi.Message] ;+bassControl =+ controlCurve en brightnessCC+ (take 64 (cycle [0,31,62,93,124] ) ) ;++bassNote :: Pitch -> [Midi.Event (Midi.Channel Midi.Message)] ;+bassNote p = bassChannel ( concat [+ bass,+ controller volumeCC 100,+ merge ( note (4*2*wn) p ) bassControl ] ) ;++bass3 = bassChannel ( concat [+ bass,+ controller volumeCC 100,+ merge ( concat [ note wn2 (f 2), note wn2 (f 2),+ note wn2 (g 2), note wn2 (a 2) ] )+ bassControl ] ) ;++bassLoop =+ bassNote (c 2) ++ bassLoop ;+++-- * sweep++sweep =+ padChannel ( controlCurve en brightnessCC triangle) ;++triangle :: [Integer] ;+triangle = rampUp 0 ++ rampDown 124 ;++rampUp, rampDown :: Integer -> [Integer] ;+rampUp 124 = [] ;+rampUp n = n : rampUp (n+4) ;++rampDown 0 = [] ;+rampDown n = n : rampDown (n-4) ;+++-- * complex++loop1p = merge pattern1 pad1 ++ loop1p ;++pad3loop =+ merge ( quadAlt pattern3a pattern3b ) pad3+ +++ loop1 ;++loop3sweep =+ merge pad3 sweep ++ loop3sweep ;++bassPad =+ merge pad1 (bassNote (c 2) )+ +++ bassPad ;++pattern1Bass =+ merge ( quad pattern1 ) (bassNote (c 2) )+ +++ pattern1Bass ;++pattern1BassPadShort =+ mergeMany [+ quad pattern1,+ bassNote (c 2),+ pad1, sweep+ ]+ +++ pattern1BassPadShort ;++pattern1BassPad =+ double ( mergeMany [+ quad pattern1,+ bassNote (c 2),+ pad1, sweep ] )+ +++ pattern2BassPad ;++pattern2BassPad =+ mergeMany [+ quad pattern2a ++ quadAlt pattern2a pattern2b,+ double (bassNote (a 1)),+ pad2, double sweep+ ]+ +++ pattern1BassPad ;++pattern3BassPad =+ mergeMany [+ quadAlt pattern3a pattern3b,+ bass3, pad3, sweep+ ]+ +++ pattern1BassPad ;+++-- * concatenation++double :: [a] -> [a] ;+double x = concat [ x, x ] ;++quad :: [a] -> [a] ;+quad x = concat [ x, x, x, x ] ;++quadAlt :: [a] -> [a] -> [a] ;+quadAlt x y = concat [ x, x, x, y] ;+++-- * durations++en, qn, hn, wn, dwn, wn2 :: Midi.Time ;++en = 170 ;+qn = 2 * en ;+hn = 2 * qn ;+wn = 2 * hn ; dwn = wn + hn ;+wn2 = 2 * wn ;+++-- * MIDI program++ping, slap, pad, bass :: [Midi.Event Midi.Message] ;+ping = program 0 ;+slap = program 2 ;+pad = program 4 ;+bass = program 9 ;+++-- * MIDI channels++soloChannel, patternChannel, padChannel, bassChannel+ :: [Midi.Event a] -> [Midi.Event (Midi.Channel a)] ;+soloChannel xs = channel 0 xs ;+patternChannel xs = channel 1 xs ;+padChannel xs = channel 2 xs ;+bassChannel xs = channel 3 xs ;+++-- * MIDI controllers++volumeCC, brightnessCC :: Midi.Controller ;+volumeCC = 7 ;+brightnessCC = 70 ;
+ data/example/Pattern.hs view
@@ -0,0 +1,38 @@+module Pattern where++import Pitch+import Midi+import List+import Prelude ( Int, (*), ($) )+++main, voice :: [Event (Channel Message)] ;+main = voice ;++en, qn, hn :: Time ;+en = 200 ;+qn = 2 * en ;+hn = 2 * qn ;++harmonies :: [[Pitch]] ;+harmonies =+ [ c 4, e 4, g 4, c 5 ] :+ [ d 4, f 4, a 4, c 5 ] :+ [ b 3, d 4, g 4, b 4 ] :+ [ c 4, e 4, g 4, c 5 ] :+ [];++pattern :: [ Int ] ;+pattern = [0, 1, 2, 1, 2, 3, 2, 1] ;++voice =+ channel 0 (program 0 +++ concatMap ( note en ) (+ zipWith index+ ( concatMap ( replicate 8 ) $+ cycle harmonies )+ ( cycle pattern )+ ) ) ;++index :: [a] -> Int -> a ;+index xs n = xs !! n ;
+ data/example/Simplesong.hs view
@@ -0,0 +1,20 @@+module Simplesong where++import Pitch+import Midi+import List+import Prelude ( (*) )+++main, voice1, voice2 :: [Event (Channel Message)] ;+main = cycle ( merge voice1 voice2 ) ;++qn, hn :: Time ;+qn = 600 ;+hn = 2 * qn ;++voice1 =+ channel 0 (concat [ program 0 , note qn (c 4) , note hn (ds 4) , note qn (gs 4) ] ) ;++voice2 =+ channel 1 (concat [ program 1 , note hn (gs 5) , note hn (as 5) ] ) ;
+ data/example/Sweep.hs view
@@ -0,0 +1,39 @@+module Sweep where++import Chords+import Pitch+import Midi+import List+import Prelude ( Integer, (+), (-) )++main :: [Event (Channel Message)] ;+main = channel 0 ( merge control voice ) ;++wn :: Time ;+wn = 2000 ;++voice, control :: [Event Message] ;+voice =+ program 4+ +++ cycle+ ( concat [+ chord4 wn (c 4) (e 4) (g 4) (c 5),+ chord4 wn (b 3) (e 4) (g 4) (b 4),+ chord4 wn (c 4) (f 4) (a 4) (c 5)+ ] ) ;++cutoff :: Midi.Controller ;+cutoff = 70 ;++control = controlCurve 50 cutoff ( cycle triangle ) ;++triangle :: [ Integer ] ;+triangle = rampUp 0 ++ rampDown 127 ;++rampUp, rampDown :: Integer -> [ Integer ] ;+rampUp 127 = [] ;+rampUp n = n : rampUp (n+1) ;++rampDown 0 = [] ;+rampDown n = n : rampDown (n-1) ;
+ data/example/UD.hs view
@@ -0,0 +1,62 @@+module UD where++import Drum+import Chords+import Pitch+import Midi+import List+import Prelude ( (*) )+++main, song, mel, drums :: [Event (Channel Message)] ;+main = cycle song =:= cycle drums ;++en, qn, hn, wn :: Time ;+en = 100 ;+qn = 2*en ;+hn = 2*qn ;+wn = 2*hn ;++song = concat+ [ merge part1 mel, part2, part3 ] ;++mel = channel 3 ( concat+ [ note hn (c 4)+ , note hn (f 4), note hn (e 4), note hn (c 4) ] ) ;++part1, part2, part3 :: [Event (Channel Message)] ;+part1 = twice ( channel 0 ( concat+ [ quad ( major qn (c 4) )+ , quad ( major qn (c 4) )+ , quad ( major qn (c 4) )+ , concat [ major qn (c 4)+ , major qn (g 4)+ , major qn (g 4)+ , major qn (g 4)+ ]+ ] ) ) ;++part2 = twice ( channel 0 ( concat+ [ twice ( quad ( minor qn (d 4) ) )+ , quad ( major qn (f 4) )+ , twice ( minor qn (e 4) )+ , twice ( minor qn (d 4) )+ , quad ( quad ( major qn (c 4) ) )+ ] ) ) ;++part3 = [] ;++twice, quad :: [a] -> [a] ;+quad x = concat [ x, x, x, x ] ;+twice x = concat [ x, x];+++bass, snare :: Time -> [Event Message] ;+bass dur = emphasize 36 (drum bassDrum1 dur) ;+snare dur = emphasize 16 (drum electricSnare dur) ;++drums = drumChannel ( concat+ [ concat ( concat ( replicate 3+ [ bass hn, snare hn ] ) )+ , concat [ bass qn, snare hn, snare qn ]+ ] ) ;
http/disable/HTTPServer/GUI.hs view
@@ -11,11 +11,8 @@ import qualified Module import qualified Graphics.UI.WX as WX-import Graphics.UI.WX.Controls ( TextCtrl ) import Control.Concurrent.MVar -import Data.IORef ( IORef )- import qualified Control.Monad.Exception.Synchronous as Exc import qualified Data.Map as M@@ -40,7 +37,7 @@ update :: (MVar Feedback -> Module.Name -> String -> Int -> IO ()) -> WX.StatusField ->- IORef (M.Map Module.Name (a, TextCtrl b, c)) ->+ M.Map Module.Name (WX.TextCtrl ()) -> GuiUpdate -> IO () update _input _status _panels _req = return ()
http/enable/HTTPServer/GUI.hs view
@@ -13,12 +13,9 @@ import qualified Graphics.UI.WX as WX import Graphics.UI.WX.Attributes ( Prop((:=)), set, get )-import Graphics.UI.WX.Classes-import Graphics.UI.WX.Controls+import Graphics.UI.WX.Classes ( text ) import Control.Concurrent.MVar -import Data.IORef ( IORef, readIORef )- import qualified Control.Monad.Exception.Synchronous as Exc import Control.Monad.Trans.Class ( lift ) @@ -58,27 +55,25 @@ update :: (MVar Feedback -> Module.Name -> String -> Int -> IO ()) -> WX.StatusField ->- IORef (M.Map Module.Name (a, TextCtrl b, c)) ->+ M.Map Module.Name (WX.TextCtrl ()) -> GuiUpdate -> IO ()-update input status panels req =+update input status editors req = case req of GetModuleList modList ->- putMVar modList . M.keys =<< readIORef panels+ putMVar modList . M.keys $ editors GetModuleContent name content -> (putMVar content =<<) $ Exc.runExceptionalT $ do- pnls <- lift $ readIORef panels- (_,editor,_) <- getModule pnls name+ editor <- getModule editors name lift $ set status [ text := Module.tellName name ++ " downloaded by web client" ] lift $ get editor text UpdateModuleContent name content contentMVar -> do result <- Exc.runExceptionalT $ do- pnls <- lift $ readIORef panels- (_,editor,_) <-- case M.lookup name pnls of+ editor <-+ case M.lookup name editors of Nothing -> Exc.throwT (Module.tellName name ++ " no longer available.",
live-sequencer.cabal view
@@ -1,13 +1,14 @@-Name: live-sequencer-Version: 0.0-Author: Henning Thielemann and Johannes Waldmann-Maintainer: Johannes Waldmann <waldmann@imn.htwk-leipzig.de>, Henning Thielemann <haskell@henning-thielemann.de>-Category: Sound, Music, GUI-License: GPL-License-file: LICENSE+Name: live-sequencer+Version: 0.0.1+Author: Henning Thielemann and Johannes Waldmann+Maintainer: Johannes Waldmann <waldmann@imn.htwk-leipzig.de>, Henning Thielemann <haskell@henning-thielemann.de>+Category: Sound, Music, GUI+License: GPL+License-file: LICENSE Cabal-Version: >= 1.6-Tested-With: GHC==6.12.3, GHC==7.2.1-Synopsis: Live coding of MIDI music+Tested-With: GHC==6.12.3, GHC==7.2.1+Homepage: http://www.haskell.org/haskellwiki/Live-Sequencer+Synopsis: Live coding of MIDI music Description: An editor shows a textual description of music (like Haskore), an interpreter computes and emits a stream of MIDI events,@@ -15,72 +16,262 @@ . 1. example usage ***** .- @- timidity -iA &- ./live-sequencer-gui --connect-to TiMidity Stream &- @+ 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: .- this should give you an ongoing stream- of notes+ > timidity -iA &+ > live-sequencer-gui --connect-to TiMidity Simplesong & .- then change one of the numbers+ This should give you an ongoing stream of notes.+ Then change one of the numbers that appear in the lines like- @mid = note 300 (c 4)@+ @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. .- and press CTRL-R for \"reloading\" that module into the interpreter- this should immediately have an effect- (change pitch and duration of some of the notes)+ 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. . 2. input language ***** .- language is Haskell with+ The used language is 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) .- semantics is similar to lazy evaluation,- but we have no sharing,- the value of @main@ is a stream of midi events- (@On/Off pitch velocity@)- or (@Wait milliseconds@)- .- in each step, the head of the stream gets reduced+ Semantics is similar to lazy evaluation,+ but we have no sharing.+ 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. .- In the library interface we provide the basic Live-Sequencer modules- in order to allow offline rendering of Live-Sequencer music.+ 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@.+ 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). Build-Type: Simple Data-Files:- data/prelude/Prelude.hs- data/Band.hs- data/Finite.hs- data/Klingklong.hs- data/Simplesong.hs- data/Sweep.hs- data/UD.hs- data/CrossSum.hs- data/Fibonacci.hs- data/DeBruijn.hs+ data/example/Band.hs+ data/example/BandControlled.hs+ data/example/Finite.hs+ data/example/Klingklong.hs+ data/example/Simplesong.hs+ data/example/Sweep.hs+ data/example/UD.hs+ data/example/CrossSum.hs+ data/example/Fibonacci.hs+ data/example/DeBruijn.hs+ data/example/Pattern.hs - data/Bool.hs- data/Chords.hs- data/Drum.hs- data/Function.hs- data/Instrument.hs- data/Integer.hs- data/List.hs- data/ListLive.hs- data/Midi.hs- data/Music.hs- data/Pattern.hs- data/Pitch.hs- data/Render.hs- data/Tuple.hs+ data/base/Bool.hs+ data/base/Chords.hs+ data/base/Controls.hs+ data/base/Drum.hs+ data/base/Function.hs+ data/base/Instrument.hs+ data/base/Integer.hs+ data/base/List.hs+ data/base/ListLive.hs+ data/base/Midi.hs+ data/base/Music.hs+ data/base/Pitch.hs+ data/base/Render.hs+ data/base/Tuple.hs + data/prelude/Prelude.hs+ Extra-Source-Files: http/enable/HTTPServer.hs http/enable/HTTPServer/GUI.hs@@ -97,13 +288,17 @@ Tag: 0.0 Location: http://code.haskell.org/~thielema/livesequencer/ +Flag gui+ Description: Build the wxWidgets GUI for the sequencer+ Default: True+ Flag httpServer Description: Enable access to modules via a web browser Default: True Library- Hs-Source-Dirs: data+ Hs-Source-Dirs: data/base, data/example GHC-Options: -Wall Build-Depends: -- for Render@@ -114,6 +309,7 @@ Render Bool Chords+ Controls Drum Function Instrument@@ -147,12 +343,16 @@ Rule Step Term+ Time Type Log Paths_live_sequencer+ Utility.NonEmptyList Other-Modules: Lilypond GHC-Options: -Wall -threaded+ If impl(ghc>=7.0)+ GHC-Options: -fwarn-unused-do-bind -fwarn-missing-import-lists Build-Depends: transformers >=0.2.2 && <0.3, explicit-exception >=0.1.5 && <0.2,@@ -173,12 +373,35 @@ base >=4.2 && <5 Executable live-sequencer-gui+ If flag(gui)+ Build-Depends:+ wx >=0.12.1 && <0.13,+ wxcore >=0.12.1 && <0.13,+ stm >=2.2 && <2.3,+ transformers >=0.2.2 && <0.3,+ explicit-exception >=0.1.5 && <0.2,+ parsec >=2.1 && <3.2,+ pretty >=1.0 && <1.2,+ midi-alsa >=0.1.1 && <0.2,+ midi >=0.1.5 && <0.2,+ alsa-seq >=0.5 && <0.6,+ alsa-core >=0.5 && <0.6,+ data-accessor-transformers >=0.2.1 && <0.3,+ data-accessor >=0.2.1 && <0.3,+ strict >=0.3.2 && <0.4,+ utility-ht >=0.0.8 && <0.1,+ containers >=0.3 && <0.5,+ process >=1.0 && <1.2,+ directory >=1.0 && <1.2,+ filepath >=1.1 && <1.4,+ base >=4.2 && <5+ Else+ Buildable: False+ Hs-Source-Dirs: src Main-is: GUI.hs Other-Modules: ALSA- Utility.Concurrent- Utility.WX Event IO Exception@@ -186,43 +409,24 @@ Option Option.Utility Controls+ ControlsBase Program Rewrite Rule Step Term+ Time Type Log Paths_live_sequencer+ Utility.NonEmptyList+ Utility.Concurrent+ Utility.WX+ GHC-Options: -threaded -Wall If impl(ghc>=7.0) GHC-Options: -fwarn-tabs -fwarn-incomplete-uni-patterns- Build-Depends:- wx >=0.12.1 && <0.13,- wxcore >=0.12.1 && <0.13,- stm >=2.2 && <2.3,- transformers >=0.2.2 && <0.3,- explicit-exception >=0.1.5 && <0.2,- parsec >=2.1 && <3.2,- pretty >=1.0 && <1.2,- midi-alsa >=0.1.1 && <0.2,- midi >=0.1.5 && <0.2,- alsa-seq >=0.5 && <0.6,- alsa-core >=0.5 && <0.6,- data-accessor-transformers >=0.2.1 && <0.3,- data-accessor >=0.2.1 && <0.3,- strict >=0.3.2 && <0.4,- utility-ht >=0.0.8 && <0.1,- containers >=0.3 && <0.5,- process >=1.0 && <1.2,- directory >=1.0 && <1.2,- filepath >=1.1 && <1.4,- base >=4.2 && <5 - Other-Modules:- HTTPServer.Option- HTTPServer.GUI- If flag(httpServer) Hs-Source-Dirs: http/enable Other-Modules:@@ -234,3 +438,7 @@ html >=1.0 && <1.1 Else Hs-Source-Dirs: http/disable++ Other-Modules:+ HTTPServer.Option+ HTTPServer.GUI
src/ALSA.hs view
@@ -1,5 +1,7 @@ module ALSA where +import qualified Option+ import qualified Sound.ALSA.Sequencer.Address as Addr import qualified Sound.ALSA.Sequencer.Client as Client import qualified Sound.ALSA.Sequencer.Port as Port@@ -13,27 +15,34 @@ import qualified System.IO as IO -import Data.Foldable ( forM_ )+import qualified Data.Sequence as Seq+import qualified Utility.NonEmptyList as NEList++import Control.Monad.IO.Class ( liftIO )+import Control.Monad.Trans.Cont ( ContT(ContT), runContT, mapContT ) import Control.Monad ( (<=<) ) import Control.Functor.HT ( void )+import Data.Foldable ( Foldable, forM_, foldMap )+import Data.Monoid ( mappend ) data Sequencer mode = Sequencer { handle :: SndSeq.T mode, publicPort, privatePort :: Port.T,+ ports :: Seq.Seq Port.T, queue :: Queue.T } sendEvent :: (SndSeq.AllowOutput mode) =>- Sequencer mode -> Event.Data -> IO ()-sendEvent sq ev = do+ Sequencer mode -> Port.T -> Event.Data -> IO ()+sendEvent sq port ev = do c <- Client.getId (handle sq) void $ Event.outputDirect (handle sq) $- Event.simple (Addr.Cons c (publicPort sq)) ev+ Event.simple (Addr.Cons c port) ev queueControl :: Sequencer mode -> Event.QueueEv -> IO ()@@ -101,34 +110,38 @@ parseAndConnect :: (SndSeq.AllowInput mode, SndSeq.AllowOutput mode) =>- Sequencer mode ->- Maybe String -> Maybe String -> IO ()-parseAndConnect sq from to = do- forM_ from- (SndSeq.connectFrom (handle sq) (publicPort sq)- <=<- Addr.parse (handle sq))- forM_ to- (SndSeq.connectTo (handle sq) (publicPort sq)- <=<- Addr.parse (handle sq))+ SndSeq.T mode ->+ Option.Port -> ContT () IO Port.T+parseAndConnect h (Option.Port name from to) = do+ let caps =+ mappend+ (foldMap (const $ Port.caps [Port.capWrite, Port.capSubsWrite]) from)+ (foldMap (const $ Port.caps [Port.capRead, Port.capSubsRead]) to)+ p <- ContT $+ Port.withSimple h name caps+ (Port.types [Port.typeMidiGeneric, Port.typeSoftware, + Port.typeApplication])+ liftIO $ forM_ from $ mapM_ (SndSeq.connectFrom h p <=< Addr.parse h)+ liftIO $ forM_ to $ mapM_ (SndSeq.connectTo h p <=< Addr.parse h)+ return p withSequencer ::- (SndSeq.OpenMode mode) =>- String -> (Sequencer mode -> IO ()) -> IO ()-withSequencer name act =- flip AlsaExc.catch- (\e -> IO.hPutStrLn IO.stderr $ "alsa_exception: " ++ AlsaExc.show e) $ do- SndSeq.with SndSeq.defaultName SndSeq.Block $ \h -> do- Client.setName h name- Port.withSimple h "inout"- (Port.caps [Port.capRead, Port.capSubsRead,- Port.capWrite, Port.capSubsWrite])- (Port.types [Port.typeMidiGeneric, Port.typeSoftware, - Port.typeApplication]) $ \ public -> do- Port.withSimple h "echo"- (Port.caps [Port.capRead, Port.capWrite])- (Port.types [Port.typeSpecific]) $ \ private -> do- Queue.with h $ \q -> do- act $ Sequencer h public private q+ (SndSeq.AllowInput mode, SndSeq.AllowOutput mode) =>+ Option.Option -> (Sequencer mode -> IO ()) -> IO ()+withSequencer opt@(Option.Option { Option.connect = NEList.Cons firstPort otherPorts } ) =+ runContT $+ mapContT (flip AlsaExc.catch+ (\e -> IO.hPutStrLn IO.stderr $ "alsa_exception: " ++ AlsaExc.show e)) $ do+ h <- ContT $ SndSeq.with SndSeq.defaultName SndSeq.Block+ liftIO $ Client.setName h $ Option.sequencerName opt+ public <- parseAndConnect h firstPort+ ps <-+ fmap ((public Seq.<|) . Seq.fromList) $+ mapM (parseAndConnect h) otherPorts+ private <- ContT $+ Port.withSimple h "echo"+ (Port.caps [Port.capRead, Port.capWrite])+ (Port.types [Port.typeSpecific])+ q <- ContT $ Queue.with h+ return $ Sequencer h public private ps q
src/Console.hs view
@@ -1,7 +1,9 @@ -- module Console where -import Term-import Program ( Program (..), chase )+import Term ( Term )+import Program ( Program )+import qualified Program+import qualified Term import qualified Event import qualified Rewrite import qualified Exception@@ -12,7 +14,7 @@ import qualified Sound.ALSA.Sequencer as SndSeq import Control.Concurrent ( forkIO )-import Control.Concurrent.Chan+import Control.Concurrent.Chan ( Chan, newChan ) import qualified Control.Monad.Trans.Writer as MW import qualified Control.Monad.Trans.State as MS@@ -20,11 +22,11 @@ ( mapExceptionalT, resolveT, throwT ) import Control.Monad.IO.Class ( liftIO ) import Control.Monad.Trans.Class ( lift )-import Control.Monad ( forM_, (>=>) )+import Control.Monad ( when, forM_, (>=>) ) import Control.Functor.HT ( void ) import qualified System.IO as IO-import qualified System.Exit as Exit+import Option.Utility ( exitFailureMsg ) import Prelude hiding ( log ) @@ -33,46 +35,49 @@ main :: IO () main = do opt <- Option.get+ when (null $ Option.moduleNames opt) $+ exitFailureMsg "no module specified" p <-- resolveT (\e ->- IO.hPutStrLn IO.stderr (Exception.statusFromMessage e) >>- Exit.exitFailure) $- Program.chase (Option.importPaths opt) $ Option.moduleName opt- ALSA.withSequencer "Rewrite-Sequencer" $ \sq -> do+ resolveT (exitFailureMsg . Exception.multilineFromMessage) $+ Program.chaseMany+ (Option.importPaths opt) (Option.moduleNames opt) Program.empty+ ALSA.withSequencer opt $ \sq -> do waitChan <- newChan void $ forkIO $ Event.listen sq print waitChan- ALSA.parseAndConnect sq- ( Option.connectFrom opt ) ( Option.connectTo opt ) ALSA.startQueue sq- flip MS.evalStateT (Event.RealTime, 0) $- execute p sq waitChan ( read "main" )+ Event.runState $+ execute+ (Option.maxReductions $ Option.limits opt)+ p sq waitChan Term.mainName writeExcMsg :: Exception.Message -> IO () writeExcMsg = putStrLn . Exception.statusFromMessage execute ::+ Rewrite.Count -> Program -> ALSA.Sequencer SndSeq.DuplexMode -> Chan Event.WaitResult -> Term -> MS.StateT Event.State IO ()-execute p sq waitChan =+execute maxRed p sq waitChan = let go t = do s <- mapExceptionalT (MW.runWriterT >=> \(ms,log) -> forM_ log (liftIO . print) >> return ms) $- Rewrite.runEval p (Rewrite.force_head t)+ Rewrite.runEval maxRed p (Rewrite.forceHead t) lift $ liftIO $ print s case Term.viewNode s of Just ("[]", []) -> return () Just (":", [x, xs]) -> do- lift $ resolveT- (liftIO . writeExcMsg)- (Event.play sq waitChan writeExcMsg x)+ mdur <- lift $ resolveT+ (liftIO . fmap (const Nothing) . writeExcMsg)+ (Event.play sq writeExcMsg x)+ lift $ Event.wait sq waitChan mdur go xs _ -> throwT- (termRange s,+ (Term.termRange s, "do not know how to handle term\n" ++ show s) in resolveT (\(pos, msg) ->
src/Controls.hs view
@@ -3,8 +3,15 @@ -- * displayed in the GUI, -- * read while executing the program. -module Controls where+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@@ -12,98 +19,126 @@ 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-import Graphics.UI.WX.Events-import Graphics.UI.WX.Layout ( layout, container, row, widget )+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 Control.Monad ( forM )++import Data.Foldable ( forM_ ) import Control.Functor.HT ( void ) -data Event = EventBool Term.Identifier Bool+data Event = Event Name Value deriving Show -data Control = CheckBox Bool moduleName :: Module.Name moduleName = Module.Name "Controls" -get_controller_module :: Program.Program -> Module.Module-get_controller_module p =- let Just m = M.lookup moduleName $ Program.modules p- in m+defltIdent :: Term.Term+defltIdent = read "deflt" -change_controller_module ::+changeControllerModule :: Program.Program ->- Controls.Event ->+ Event -> Exc.Exceptional Exception.Message Program.Program-change_controller_module p event = case event of- EventBool name val ->- flip Program.add_module p $- Module.add_rule ( controller_rule name val ) $- get_controller_module p+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 ) -controller_rule ::- Show a =>- Term.Identifier -> a -> Rule.Rule-controller_rule name val =- Rule.Rule- ( read "checkBox" )- [ Term.Node name [], read "deflt" ]- ( Term.Node ( read $ show val ) [] )+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} -controller_module :: [(Term.Identifier, Control)] -> Module.Module-controller_module controls =- let decls = do- ( name, CheckBox deflt ) <- controls- return $ Module.Rule_Declaration- $ controller_rule name deflt- m = Module.Module { Module.name = moduleName- , Module.imports = []- , Module.source_text = show m- , Module.source_location = "/dev/null"- , Module.functions =- Module.make_functions decls- , Module.declarations = decls- }- in m +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 b ->- [(Term.Identifier, Control)] ->- (Controls.Event -> IO ()) ->+ 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 []- ws <- forM controls $ \ ( name, con ) ->- case con of- CheckBox val -> do- cb <- WX.checkBox panel- [ text := Term.name name , checked := val ]- set cb- [ on command := do- c <- get cb checked- sink $ EventBool name c- ]- return $ widget cb- set frame [ layout := container panel $ row 5 ws ]---collect :: Program.Program -> [ ( Term.Identifier, Control ) ]-collect p = do- ( _mod, contents ) <- M.toList $ Program.modules p- Module.Rule_Declaration rule <- Module.declarations contents- ( _pos, term ) <- Term.subterms $ Rule.rhs rule- case Term.viewNode term of- Just ( "checkBox" , [ Term.Node tag [], Term.Node val [] ] ) ->- return ( tag- , CheckBox $ read ( Term.name val )- )- _ -> []+ (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 view
@@ -0,0 +1,133 @@+{-+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/Event.hs view
@@ -1,7 +1,10 @@ module Event where -import Term+import Term ( Term(Number, StringLiteral), termRange ) import ALSA ( Sequencer(handle, queue, privatePort), sendEvent )+import qualified Term+import qualified ALSA+import qualified Time import qualified Exception import qualified Log @@ -23,25 +26,28 @@ import Control.Monad ( when, forever ) import Control.Functor.HT ( void ) +import Data.Monoid ( mempty, mappend )+ import qualified System.Process as Proc import qualified System.Exit as Exit import qualified System.IO.Strict as StrictIO import qualified System.IO as IO import qualified Data.Accessor.Monad.Trans.State as AccM-import qualified Data.Accessor.Tuple as AccTuple+import qualified Data.Accessor.Basic as Acc import Data.Accessor.Basic ((^.), ) +import qualified Data.Sequence as Seq import Data.Maybe ( isJust )-import Data.Bool.HT ( if' ) import Control.Concurrent.Chan ( Chan, readChan, writeChan )-import Control.Concurrent ( forkIO {- threadDelay -} )+import Control.Concurrent ( forkIO ) -type Time = Integer -data WaitMode = RealTime | SlowMotion Time | SingleStep+type Time = Time.Nanoseconds Integer++data WaitMode = RealTime | SlowMotion (Time.Milliseconds Integer) | SingleStep deriving (Eq, Show) data WaitResult =@@ -51,74 +57,79 @@ termException :: (Monad m) =>- String -> Term -> ExceptionalT Exception.Message m ()-termException msg s =+ Term -> String -> ExceptionalT Exception.Message m a+termException s msg = throwT $ Exception.Message Exception.Term (termRange s) (msg ++ " " ++ show s) -runIO :: (MonadIO m) => IO () -> ExceptionalT Exception.Message m ()+runIO :: (MonadIO m) => IO a -> ExceptionalT Exception.Message m a runIO action = MT.lift $ liftIO action -{--FIXME:-minBound for Velocity is zero.-This is not very helpful, because zero velocity is treated as NoteOff.--}-withRangeCheck ::++checkRange :: (Bounded a, Monad m) => String -> (Int -> a) -> (a -> Int) ->+ a -> a -> Term ->- (a -> ExceptionalT Exception.Message m ()) ->- ExceptionalT Exception.Message m ()-withRangeCheck typ fromInt0 toInt0 (Number rng x) =- let aux ::- (Monad m) =>- (Int -> a) -> (a -> Int) ->- a -> a ->- (a -> ExceptionalT Exception.Message m ()) ->- ExceptionalT Exception.Message m ()- aux fromInt toInt minb maxb f =- if' (x < fromIntegral (toInt minb))- (throwT $ Exception.Message Exception.Term rng $- typ ++ " argument " ++ show x ++- " is less than minimum value " ++ show (toInt minb)) $- if' (fromIntegral (toInt maxb) < x)- (throwT $ Exception.Message Exception.Term rng $- typ ++ " argument " ++ show x ++- " is greater than maximum value " ++ show (toInt maxb)) $- f (fromInt $ fromInteger x)- in aux fromInt0 toInt0 minBound maxBound-withRangeCheck typ _ _ t =- \ _f ->- throwT $- Exception.Message Exception.Term- (termRange t) (typ ++ " argument is not a number")+ ExceptionalT Exception.Message m a+checkRange typ fromInt toInt minb maxb =+ Exception.lift .+ Exception.checkRange Exception.Term typ fromInt toInt minb maxb +checkRangeAuto ::+ (Bounded a, Monad m) =>+ String -> (Int -> a) -> (a -> Int) ->+ Term ->+ ExceptionalT Exception.Message m a+checkRangeAuto typ fromInt0 toInt0 =+ Exception.lift .+ Exception.checkRangeAuto Exception.Term typ fromInt0 toInt0 -newtype ControllerValue = ControllerValue {fromControllerValue :: Int}- deriving (Eq, Ord, Show) -instance Bounded ControllerValue where- minBound = ControllerValue 0- maxBound = ControllerValue 127+data State =+ State {+ stateWaitMode_ :: WaitMode,+ stateWaiting_ :: Bool,+ stateTime_ :: Time,+ stateRecentTimes_ :: Seq.Seq Time+ } -type State = (WaitMode, Time)+stateWaitMode :: Acc.T State WaitMode+stateWaitMode = Acc.fromSetGet (\x s -> s{stateWaitMode_ = x}) stateWaitMode_ +stateWaiting :: Acc.T State Bool+stateWaiting = Acc.fromSetGet (\x s -> s{stateWaiting_ = x}) stateWaiting_++stateTime :: Acc.T State Time+stateTime = Acc.fromSetGet (\x s -> s{stateTime_ = x}) stateTime_++stateRecentTimes :: Acc.T State (Seq.Seq Time)+stateRecentTimes = Acc.fromSetGet (\x s -> s{stateRecentTimes_ = x}) stateRecentTimes_++initState :: State+initState = State Event.RealTime False mempty Seq.empty++runState :: (Monad m) => MS.StateT State m a -> m a+runState = flip MS.evalStateT Event.initState++ play :: (SndSeq.AllowInput mode, SndSeq.AllowOutput mode) => Sequencer mode ->- Chan WaitResult -> (Exception.Message -> IO ()) -> Term ->- ExceptionalT Exception.Message (MS.StateT State IO) ()-play sq waitChan throwAsync x = case Term.viewNode x of- Just ("Wait", [Number _ n]) ->--- threadDelay (fromIntegral n * 1000)- MT.lift $ wait sq waitChan $ Just (n * 10^(6::Int))+ ExceptionalT Exception.Message (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 $+ "pause of negative duration: " ++ show n+ MT.lift $ AccM.set stateWaiting True+ return $ Just $ Time.milliseconds n - Just ( "Say", [String_Literal rng arg] ) -> runIO $ do+ Just ( "Say", [StringLiteral rng arg] ) ->+ MT.lift $ (AccM.set stateWaiting False >>) $ liftIO $ do let cmd = unwords [ "echo", show arg, "|", "festival", "--tts" ] Log.put cmd@@ -138,45 +149,51 @@ throwAsync $ Exception.Message Exception.Term rng errText + return Nothing+ Just ("Event", [event]) -> case Term.viewNode event of- Just ("Channel", [chann, body]) ->- withRangeCheck "channel" CM.toChannel CM.fromChannel chann $ \chan ->- processChannelMsg sq waitChan chan body- _ -> processChannelMsg sq waitChan (CM.toChannel 0) event- -- termException "Event must contain Channel, but not " x- _ -> termException "can only process Wait or Event, but not " x+ Just ("Channel", [chann, body]) -> do+ chan <-+ checkRange "channel" id id+ 0 (Seq.length (ALSA.ports sq) * 16 - 1) chann+ let (p, c) = divMod chan 16+ processChannelMsg sq (Seq.index (ALSA.ports sq) p, CM.toChannel c) body+ _ -> processChannelMsg sq (ALSA.publicPort sq, CM.toChannel 0) event+ -- termException x "Event must contain Channel, but not "+ _ -> termException x "can only process Wait or Event, but not " processChannelMsg :: (SndSeq.AllowOutput mode) => Sequencer mode ->- Chan WaitResult ->- CM.Channel -> Term ->- ExceptionalT Exception.Message (MS.StateT State IO) ()-processChannelMsg sq waitChan chan body = do+ (Port.T, CM.Channel) -> Term ->+ ExceptionalT Exception.Message (MS.StateT State IO) (Maybe Time)+processChannelMsg sq chanPort@(port, chan) body = do+ MT.lift $ AccM.set stateWaiting False+ let checkVelocity =+ checkRange "velocity" CM.toVelocity CM.fromVelocity+ (CM.toVelocity 1) (CM.toVelocity 127) case Term.viewNode body of- Just ("On", [pn, vn]) ->- withRangeCheck "pitch" CM.toPitch CM.fromPitch pn $ \p ->- withRangeCheck "velocity" CM.toVelocity CM.fromVelocity vn $ \v ->- runIO $- sendNote sq SeqEvent.NoteOn chan p v- Just ("Off", [pn, vn]) ->- withRangeCheck "pitch" CM.toPitch CM.fromPitch pn $ \p ->- withRangeCheck "velocity" CM.toVelocity CM.fromVelocity vn $ \v ->- runIO $- sendNote sq SeqEvent.NoteOff chan p v- Just ("PgmChange", [pn]) ->- withRangeCheck "program" CM.toProgram CM.fromProgram pn $ \p ->+ Just ("On", [pn, vn]) -> do+ p <- checkRangeAuto "pitch" CM.toPitch CM.fromPitch pn+ v <- checkVelocity vn+ runIO $ sendNote sq SeqEvent.NoteOn chanPort p v+ Just ("Off", [pn, vn]) -> do+ p <- checkRangeAuto "pitch" CM.toPitch CM.fromPitch pn+ v <- checkVelocity vn+ runIO $ sendNote sq SeqEvent.NoteOff chanPort p v+ Just ("PgmChange", [pn]) -> do+ p <- checkRangeAuto "program" CM.toProgram CM.fromProgram pn runIO $- sendEvent sq $ SeqEvent.CtrlEv SeqEvent.PgmChange $+ sendEvent sq port $ SeqEvent.CtrlEv SeqEvent.PgmChange $ MidiAlsa.programChangeEvent chan p- Just ("Controller", [ccn, vn]) ->- withRangeCheck "controller" CM.toController CM.fromController ccn $ \cc ->- withRangeCheck "controller value" ControllerValue fromControllerValue vn $ \(ControllerValue v) ->+ Just ("Controller", [ccn, vn]) -> do+ cc <- checkRangeAuto "controller" CM.toController CM.fromController ccn+ v <- checkRange "controller value" id id 0 127 vn runIO $- sendEvent sq $ SeqEvent.CtrlEv SeqEvent.Controller $+ sendEvent sq port $ SeqEvent.CtrlEv SeqEvent.Controller $ MidiAlsa.controllerEvent chan cc (fromIntegral v)- _ -> termException "invalid channel event: " body- MT.lift $ wait sq waitChan Nothing+ _ -> termException body "invalid channel event: "+ return Nothing wait ::@@ -192,19 +209,20 @@ liftIO $ Log.put $ "read from waitChan: " ++ show ev case ev of ModeChange newMode -> do- oldMode <- MS.gets fst+ oldMode <- AccM.get stateWaitMode if newMode /= oldMode then do- AccM.set AccTuple.first newMode+ AccM.set stateWaitMode newMode (cont,newTarget) <- prepare sq mdur when cont $ loop newTarget else loop target ReachedTime stamp -> case stamp of SeqEvent.RealTime rt ->- let reached = RealTime.toInteger rt+ let reached =+ Time.nanoseconds $ RealTime.toInteger rt in if Just reached == target- then AccM.set AccTuple.second reached+ then AccM.set stateTime reached else loop target _ -> loop target NextStep ->@@ -220,17 +238,17 @@ MS.StateT State IO (Bool, Maybe Time) prepare sq mt = do liftIO $ Log.put $ "prepare waiting for " ++ show mt- (waitMode,currentTime) <- MS.get+ (State waitMode _ currentTime _) <- MS.get case waitMode of RealTime -> do case mt of Nothing -> return (False, Nothing) Just dur -> do- let t = currentTime + dur+ let t = mappend currentTime dur sendEcho sq t return (True, Just t) SlowMotion dur -> do- let t = currentTime + dur * 10^(6::Int)+ let t = mappend currentTime $ Time.up $ Time.up dur sendEcho sq t return (True, Just t) SingleStep ->@@ -241,7 +259,7 @@ (MonadIO io, SndSeq.AllowOutput mode) => Sequencer mode -> Time -> io ()-sendEcho sq t = do+sendEcho sq (Time.Time t) = do c <- liftIO $ Client.getId (handle sq) {-@@ -305,10 +323,10 @@ (SndSeq.AllowOutput mode) => Sequencer mode -> SeqEvent.NoteEv ->- CM.Channel ->+ (Port.T, CM.Channel) -> CM.Pitch -> CM.Velocity -> IO ()-sendNote sq onoff chan pitch velocity =- sendEvent sq $+sendNote sq onoff (port,chan) pitch velocity =+ sendEvent sq port $ SeqEvent.NoteEv onoff $ MidiAlsa.noteEvent chan pitch velocity velocity 0
src/Exception.hs view
@@ -1,12 +1,19 @@ module Exception where -import Term ( Range(Range) )+import qualified Term+import Term ( Term, Range(Range) ) +import qualified Control.Monad.Exception.Synchronous as Exc++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.Bool.HT ( if' ) + data Message = Message Type Range String -- deriving (Show) @@ -19,25 +26,30 @@ Pos.sourceName pos : show (Pos.sourceLine pos) : show (Pos.sourceColumn pos) : stringFromType typ :- flattenMultiline descr :+ head (lines descr) : [] statusFromMessage :: Message -> String statusFromMessage (Message typ (Range pos _) descr) = stringFromType typ ++ " - " ++- Pos.sourceName pos ++ ':' :- show (Pos.sourceLine pos) ++ ':' :- show (Pos.sourceColumn pos) ++ " " +++ formatPos typ pos ++ " - " ++ flattenMultiline descr multilineFromMessage :: Message -> String multilineFromMessage (Message typ (Range pos _) descr) = stringFromType typ ++ " - " ++- Pos.sourceName pos ++ ':' :- show (Pos.sourceLine pos) ++ ':' :- show (Pos.sourceColumn pos) ++ "\n" +++ 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 = case typ of@@ -48,3 +60,77 @@ 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)++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 ->+ String -> (Int -> a) -> (a -> Int) ->+ a -> a ->+ Term ->+ Exc.Exceptional Message a+checkRange excType typ fromInt toInt minb maxb (Term.Number rng x) =+ if' (x < fromIntegral (toInt minb))+ (Exc.throw $ Message excType 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)) $+ return $ fromInt $ fromInteger x+checkRange excType typ _ _ _ _ t =+ Exc.throw $+ Message excType+ (Term.termRange t) (typ ++ " argument is not a number")++checkRangeAuto ::+ (Bounded a) =>+ Type ->+ 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
src/GUI.hs view
@@ -7,1049 +7,1478 @@ The GUI shall be responsive also if a program is loaded or a term is reduced. Thus the GUI has its own thread. If a GUI element requires a more complicated action,-it sends an Action message via then 'input' Chan to the 'machine'.--machine:-This thread manages loading and parsing of modules-as well as the operation mode of the interpreter.-It gets most of its messages from the GUI-and sends its result as GuiUpdate via the 'output' Chan to the GUI.--execute:-This runs the interpreter.-It reduces expressions and sends according MIDI messages-or waits according to Wait events.--ALSA:-With ALSA we can wait only for all kinds of events at once.-Thus this thread receives all incoming messages and distributes them-to the right receiver.-E.g. NoteOn events are sent to the GUI as text inserts-and Echo messages are sent to the 'execute' thread for handling Wait events.--HTTPServer:-Waits for and responds to incoming HTTP requests.--}--import qualified IO-import qualified Term-import qualified Program-import qualified Exception-import qualified Module-import qualified Controls-import qualified Rewrite-import qualified Option-import qualified Log-import Program ( Program, modules )-import Term ( Term, Identifier )-import Utility.Concurrent ( writeTMVar, writeTChanIO )-import Utility.WX ( cursor, editable, notebookSelection )--import qualified HTTPServer.GUI as HTTPGui--import qualified Graphics.UI.WX as WX-import Graphics.UI.WX.Attributes ( Prop((:=)), set, get )-import Graphics.UI.WX.Classes-import Graphics.UI.WX.Controls-import Graphics.UI.WX.Events-import Graphics.UI.WX.Layout-import Graphics.UI.WX.Types- ( Color, rgb, fontFixed, Point2(Point), sz,- varCreate, varSwap, varUpdate )-import Control.Concurrent ( forkIO )-import Control.Concurrent.MVar-import Control.Concurrent.Chan-import Control.Concurrent.STM.TChan-import Control.Concurrent.STM.TVar-import Control.Concurrent.STM.TMVar-import Control.Monad.STM ( STM )-import qualified Control.Monad.STM as STM--import Data.IORef ( newIORef, readIORef, writeIORef, modifyIORef )--import qualified Graphics.UI.WXCore as WXCore-import qualified Graphics.UI.WXCore.WxcClassesAL as WXCAL-import qualified Graphics.UI.WXCore.WxcClassesMZ as WXCMZ-import Graphics.UI.WXCore.WxcDefs ( wxID_HIGHEST )--import Graphics.UI.WXCore.Events-import qualified Event--import Foreign.Storable ( peek )-import Foreign.Marshal.Alloc ( alloca )--import qualified ALSA-import qualified Sound.ALSA.Sequencer as SndSeq-import qualified Sound.MIDI.Message.Channel.Voice as VM--import qualified Control.Monad.Trans.State as MS-import qualified Control.Monad.Trans.Writer as MW-import qualified Control.Monad.Trans.Maybe as MaybeT-import qualified Control.Monad.Exception.Synchronous as Exc-import Control.Monad.IO.Class ( liftIO )-import Control.Monad.Trans.Class ( lift )-import Control.Monad ( when, liftM2, forever, )-import Control.Functor.HT ( void )-import Data.Foldable ( forM_ )-import qualified Text.ParserCombinators.Parsec as Parsec-import qualified Text.ParserCombinators.Parsec.Pos as Pos-import qualified Text.ParserCombinators.Parsec.Token as Token--import Control.Exception ( bracket, finally, try )-import qualified System.IO as IO-import qualified System.IO.Error as Err-import qualified System.Exit as Exit-import qualified System.FilePath as FilePath--import qualified Data.Accessor.Monad.Trans.State as AccM-import qualified Data.Accessor.Tuple as AccTuple--import qualified Data.Traversable as Trav-import qualified Data.Foldable as Fold-import qualified Data.Sequence as Seq-import qualified Data.Map as M-import Data.Maybe ( maybeToList, fromMaybe )--import qualified Data.Char as Char-import qualified Data.List as List-import Data.Tuple.HT ( fst3 )--import Prelude hiding ( log )----- | read rules files, should contain definition for "main"-main :: IO ()-main = do- IO.hSetBuffering IO.stderr IO.LineBuffering- opt <- Option.get-- (p,ctrls) <-- Exc.resolveT- (\e ->- IO.hPutStrLn IO.stderr (Exception.multilineFromMessage e) >>- Exit.exitFailure) $- prepareProgram =<<- Program.chase (Option.importPaths opt) (Option.moduleName opt)-- input <- newChan- output <- newTChanIO- writeTChanIO output $ Register p ctrls- ALSA.withSequencer "Rewrite-Sequencer" $ \sq -> do- ALSA.parseAndConnect sq- ( Option.connectFrom opt ) ( Option.connectTo opt )- flip finally (ALSA.stopQueue sq) $ WX.start $ do- gui input output- void $ forkIO $ machine input output (Option.importPaths opt) p sq- void $ forkIO $- HTTPGui.run- (HTTPGui.methods (writeTChanIO output . HTTP))- (Option.httpOption opt)----- | messages that are sent from GUI to machine-data Action =- Modification (Maybe (MVar HTTPGui.Feedback)) Module.Name String Int- -- ^ MVar of the HTTP server, modulename, sourcetext, position- | Execution Execution- | NextStep- | Control Controls.Event- | Load FilePath--data Execution =- Mode Event.WaitMode | Restart | Stop | PlayTerm String----- | messages that are sent from machine to GUI-data GuiUpdate =- Term { _steps :: [ Rewrite.Message ], _currentTerm :: String }- | Exception { _message :: Exception.Message }- | Register Program [(Identifier, Controls.Control)]- | Refresh { _moduleName :: Module.Name, _content :: String, _position :: Int }- | InsertText { _insertedText :: String }- | HTTP HTTPGui.GuiUpdate- | Running { _runningMode :: Event.WaitMode }- | ResetDisplay---exceptionToGUI ::- TChan GuiUpdate ->- Exc.ExceptionalT Exception.Message STM () ->- STM ()-exceptionToGUI output =- Exc.resolveT (writeTChan output . Exception)--exceptionToGUIIO ::- TChan GuiUpdate ->- Exc.ExceptionalT Exception.Message IO () ->- IO ()-exceptionToGUIIO output =- Exc.resolveT (writeTChanIO output . Exception)--prepareProgram ::- (Monad m) =>- Program ->- Exc.ExceptionalT Exception.Message m- (Program, [(Identifier, Controls.Control)])-prepareProgram p0 = do- let ctrls = Controls.collect p0- p1 <- Exc.ExceptionalT $ return $- Program.add_module (Controls.controller_module ctrls) p0- return (p1, ctrls)--formatPitch :: VM.Pitch -> String-formatPitch p =- let (oct,cls) = divMod (VM.fromPitch p) 12- name =- case cls of- 00 -> "c"- 01 -> "cs"- 02 -> "d"- 03 -> "ds"- 04 -> "e"- 05 -> "f"- 06 -> "fs"- 07 -> "g"- 08 -> "gs"- 09 -> "a"- 10 -> "as"- 11 -> "b"- _ -> error "pitch class must be a number from 0 to 11"- in "note qn (" ++ name ++ " " ++ show (oct-1) ++ ") : "---{--TODO: handle the case that the module changed its name-(might happen if user changes the text in the editor)--}-modifyModule ::- TVar Program ->- TChan GuiUpdate ->- Module.Name ->- [Char] ->- Int ->- Exc.ExceptionalT Exception.Message STM ()-modifyModule program output moduleName sourceCode pos = do- p <- lift $ readTVar program- let Just previous = M.lookup moduleName $ modules p- m <-- Exc.mapExceptionT Program.messageFromParserError $- Exc.fromEitherT $ return $- Parsec.parse- (Module.parseUntilEOF (Module.source_location previous) sourceCode)- ( Module.deconsName moduleName ) sourceCode- lift . writeTVar program =<<- (Exc.ExceptionalT $ return $- Program.add_module m p)- lift $ writeTChan output $- Refresh moduleName sourceCode pos--- lift $ Log.put "parsed and modified OK"---{--This runs concurrently-and is fed with changes to the modules by the GUI.-It parses them and provides the parsed modules to the execution engine.-Since parsing is a bit of work-we can keep the GUI and the execution of code going while parsing.--}-machine :: Chan Action -- ^ machine reads program text from here- -- (module name, module contents)- -> TChan GuiUpdate -- ^ and writes output to here- -- (log message (for highlighting), current term)- -> [FilePath]- -> Program -- ^ initial program- -> ALSA.Sequencer SndSeq.DuplexMode- -> IO ()-machine input output importPaths progInit sq = do- program <- newTVarIO progInit- let mainName = read "main"- term <- newTMVarIO mainName- waitChan <- newChan-- void $ forkIO $ forever $ do- action <- readChan input- let withMode mode transaction = do- writeChan waitChan $ Event.ModeChange mode- STM.atomically $ do- writeTChan output $ Running mode- transaction- case action of- Control event -> do- Log.put $ show event- STM.atomically $ exceptionToGUI output $ do- p <- lift $ readTVar program- p' <-- Exc.ExceptionalT $ return $- Controls.change_controller_module p event- lift $ writeTVar program p'- -- return $ Controls.get_controller_module p'- -- Log.put $ show m- NextStep -> writeChan waitChan Event.NextStep- Execution exec ->- case exec of- Mode mode -> do- case mode of- Event.RealTime -> do- ALSA.continueQueue sq- Event.SlowMotion _ -> do- ALSA.continueQueue sq- Event.SingleStep -> do- ALSA.pauseQueue sq- withMode mode $ return ()- Restart -> do- ALSA.quietContinueQueue sq- withMode Event.RealTime $ writeTMVar term mainName- Stop -> do- ALSA.stopQueue sq- withMode Event.SingleStep $ writeTMVar term mainName- PlayTerm str ->- case Parsec.parse- (Parsec.between- (Token.whiteSpace Term.lexer)- (Parsec.eof)- IO.input)- "marked range" str of- Left msg ->- writeTChanIO output . Exception $- Program.messageFromParserError msg- Right t -> do- ALSA.quietContinueQueue sq- withMode Event.RealTime $ writeTMVar term t- Modification feedback moduleName sourceCode pos -> do- Log.put $- Module.tellName moduleName ++- " has new input\n" ++ sourceCode- case feedback of- Nothing ->- STM.atomically $- exceptionToGUI output $- modifyModule program output moduleName sourceCode pos- Just mvar -> do- x <-- STM.atomically $- fmap (Exc.switch- (\e ->- (Just $ Exception.multilineFromMessage e,- sourceCode))- (\() -> (Nothing, sourceCode))) $- Exc.runExceptionalT $- Exc.catchT- (modifyModule program output moduleName sourceCode pos)- (\e -> do- lift $ writeTChan output $ Exception e- Exc.throwT e)- putMVar mvar $ Exc.Success x- Load filePath -> do- Log.put $- "load " ++ filePath ++ " and all its dependencies"- exceptionToGUIIO output $ do- (p,ctrls) <-- prepareProgram =<<- Program.load importPaths Program.empty- (FilePath.takeBaseName filePath) filePath- lift $ do- ALSA.stopQueue sq- withMode Event.RealTime $ do- writeTVar program p- writeTMVar term mainName- writeTChan output $ Register p ctrls- ALSA.continueQueue sq- Log.put "chased and parsed OK"-- void $ forkIO $- Event.listen sq- ( writeTChanIO output . InsertText . formatPitch )- waitChan- ALSA.startQueue sq- flip MS.evalStateT (Event.RealTime, 0) $- execute program term ( writeTChan output ) sq waitChan---execute :: TVar Program- -- ^ current program (GUI might change the contents)- -> TMVar Term -- ^ current term- -> ( GuiUpdate -> STM () ) -- ^ sink for messages (show current term)- -> ALSA.Sequencer SndSeq.DuplexMode -- ^ for playing MIDI events- -> Chan Event.WaitResult- -> MS.StateT Event.State IO ()-execute program term output sq waitChan =- forever $-- excSwitchT- (\e -> do- liftIO $ do- ALSA.stopQueue sq- -- writeChan waitChan $ Event.ModeChange Event.SingleStep- STM.atomically $ do- output $ Exception e- output $ Running Event.SingleStep- {-- We have to alter the mode directly,- since the channel is only read when we wait for a duration other than Nothing- -}- AccM.set AccTuple.first Event.SingleStep- Event.wait sq waitChan Nothing)- (\x -> do- let writeExcMsg = STM.atomically . output . Exception- {-- exceptions on processing an event are not fatal and we keep running- -}- Exc.resolveT- (liftIO . writeExcMsg)- (Event.play sq waitChan writeExcMsg x)- case Term.viewNode x of- Just ("Wait", _) ->- liftIO $ STM.atomically $ output ResetDisplay- _ -> return ())- (let mainName = read "main"- in Exc.mapExceptionalT (liftIO . STM.atomically) $- flip Exc.catchT (\(pos,msg) -> do- lift $ putTMVar term mainName- Exc.throwT $ Exception.Message Exception.Term pos msg) $ do- t <- lift $ takeTMVar term- p <- lift $ readTVar program- {- this happens anew at each click- since the program text might have changed in the editor -}- (s,log) <-- Exc.mapExceptionalT- (fmap (\(ms,log) -> liftM2 (,) ms (return log)) .- MW.runWriterT) $- Rewrite.runEval p (Rewrite.force_head t)- {-- This way the term will be pretty printed in the GUI thread- which may block the GUI thread.- However evaluating it here may defer playing notes,- which is not better.- -}- lift $ output . Term log . show $ s- case Term.viewNode s of- Just (":", [x, xs]) -> do- lift $ putTMVar term xs- return x- Just ("[]", []) ->- Exc.throwT (Term.termRange s, "finished.")- _ ->- Exc.throwT (Term.termRange s,- "I do not know how to handle this term: " ++ show s))---- also available in explicit-exception>=0.1.7-excSwitchT ::- (Monad m) =>- (e -> m b) -> (a -> m b) ->- Exc.ExceptionalT e m a -> m b-excSwitchT e s m = Exc.switch e s =<< Exc.runExceptionalT m----- | following code taken from http://snipplr.com/view/17538/-myEventId :: Int-myEventId = wxID_HIGHEST+100- -- the custom event ID, avoid clash with Graphics.UI.WXCore.Types.varTopId---- | the custom event is registered as a menu event-createMyEvent :: IO (WXCore.CommandEvent ())-createMyEvent =- WXCAL.commandEventCreate WXCMZ.wxEVT_COMMAND_MENU_SELECTED myEventId--registerMyEvent :: WXCore.EvtHandler a -> IO () -> IO ()-registerMyEvent win io = evtHandlerOnMenuCommand win myEventId io---{--The order of widget creation is important-for cycling through widgets using tabulator key.--}-gui :: Chan Action -- ^ the gui writes here- -- (if the program text changes due to an edit action)- -> TChan GuiUpdate -- ^ the machine writes here- -- (a textual representation of "current expression")- -> IO ()-gui input output = do- program <- newIORef Program.empty- controls <- newIORef []- panels <- newIORef M.empty-- let highlighters = fmap ( \ (_pnl,_,h) -> h )- editors = fmap ( \ (_pnl,e,_) -> e )--- frameError <- WX.frame [ text := "errors" ]-- panelError <- WX.panel frameError [ ]-- errorLog <- WX.listCtrl panelError- [ columns :=- ("Module", AlignLeft, 120) :- ("Row", AlignRight, -1) :- ("Column", AlignRight, -1) :- ("Type", AlignLeft, -1) :- ("Description", AlignLeft, 500) :- []- ]- errorList <- newIORef Seq.empty- let updateErrorLog f = do- errors <- readIORef errorList- let newErrors = f errors- writeIORef errorList newErrors- set errorLog [ items :=- map Exception.lineFromMessage $ Fold.toList newErrors ]-- clearLog <- WX.button panelError- [ text := "Clear",- on command := updateErrorLog (const Seq.empty) ]-- frameControls <- WX.frame [ text := "controls" ]-- f <- WX.frame- [ text := "live-sequencer", visible := False- ]-- out <- newChan-- void $ forkIO $ forever $ do- writeChan out =<< STM.atomically (readTChan output)- WXCAL.evtHandlerAddPendingEvent f =<< createMyEvent-- p <- WX.panel f [ ]--- fileMenu <- WX.menuPane [text := "&File"]-- let haskellFilenames =- [ ("Haskell modules", ["*.hs"]),- ("All files", ["*"]) ]-- loadItem <- WX.menuItem fileMenu- [ text := "L&oad and check program ...\tCtrl-O",- help :=- "flush all modules " ++- "and load a new program with all its dependencies" ]- reloadItem <- WX.menuItem fileMenu- [ text := "&Reload module",- help :=- "reload a module from its original file, " ++- "but do not pass it to the interpreter" ]- saveItem <- WX.menuItem fileMenu- [ text := "&Save module\tCtrl-S",- help :=- "overwrite original file with current module content" ]- saveAsItem <- WX.menuItem fileMenu- [ text := "Save module &as ...",- help :=- "save module content to a different or new file " ++- "and make this the new file target" ]-- WX.menuLine fileMenu-- quitItem <- WX.menuQuit fileMenu []--- execMenu <- WX.menuPane [text := "&Execution"]-- refreshItem <- WX.menuItem execMenu- [ text := "&Refresh\tCtrl-R",- help :=- "parse the edited program and if successful " ++- "replace the executed program" ]- WX.menuLine execMenu- realTimeItem <- WX.menuItem execMenu- [ text := "Real time\tCtrl-1",- checkable := True,- checked := True,- help := "pause according to Wait elements" ]- slowMotionItem <- WX.menuItem execMenu- [ text := "Slow motion\tCtrl-2",- checkable := True,- help := "pause between every list element" ]- singleStepItem <- WX.menuItem execMenu- [ text := "Single step\tCtrl-3",- checkable := True,- help := "wait for user confirmation after every list element" ]- WX.menuLine execMenu- _restartItem <- WX.menuItem execMenu- [ text := "Res&tart\tCtrl-T",- on command := writeChan input (Execution Restart),- help :=- "stop sound and restart program execution with 'main'" ]- playTermItem <- WX.menuItem execMenu- [ text := "Play term\tCtrl-M",- help :=- "stop sound and restart program execution " ++- "with the marked editor area as current term, " ++- "or use the surrounding identifier if nothing is marked" ]- _stopItem <- WX.menuItem execMenu- [ text := "Stop\tCtrl-Space",- on command := writeChan input (Execution Stop),- help :=- "stop program execution and sound, " ++- "reset term to 'main'" ]-- WX.menuLine execMenu-- fasterItem <- WX.menuItem execMenu- [ text := "Faster\tCtrl->",- enabled := False,- help := "decrease pause in slow motion mode" ]- slowerItem <- WX.menuItem execMenu- [ text := "Slower\tCtrl-<",- enabled := False,- help := "increase pause in slow motion mode" ]- nextStepItem <- WX.menuItem execMenu- [ text := "Next step\tCtrl-N",- enabled := False,- on command := writeChan input NextStep,- help := "perform next step in single step mode" ]--- windowMenu <- WX.menuPane [text := "&Window"]-- appRunning <- newIORef True- let windowMenuItem title win = do- itm <- WX.menuItem windowMenu- [ text := title,- help := "show or hide " ++ title ++ " window",- checkable := True,- checked := True ]- set itm- [ on command := do- b <- get itm checked- set win [ visible := b ] ]- set win- [ on closing := do- run <- readIORef appRunning- if run- then do- set itm [ checked := False ]- set win [ visible := False ]- -- WXCMZ.closeEventVeto ??? True- else propagateEvent ]-- windowMenuItem "errors" frameError- windowMenuItem "controls" frameControls- WX.menuLine windowMenu- reducerVisibleItem <- WX.menuItem windowMenu- [ text := "current term",- checkable := True,- checked := True,- help := "show or hide current term - " ++- "hiding may improve performance drastically" ]--- nb <- WX.notebook p [ ]--- reducer <-- textCtrl p- [ font := fontFixed, editable := False, wrap := WrapNone ]-- status <- WX.statusField- [ text := "Welcome to interactive music composition with Haskell" ]--- let handleException moduleName act = do- result <- try act- case result of- Left err ->- writeTChanIO output $- Exception $ Exception.Message Exception.InOut- (Program.dummyRange (Module.deconsName moduleName))- (Err.ioeGetErrorString err)- Right () -> return ()-- set loadItem [- on command := do- mfilename <- WX.fileOpenDialog- f False {- change current directory -} True- "Load Haskell program" haskellFilenames "" ""- forM_ mfilename $ writeChan input . Load- ]-- set reloadItem [- on command := do- index <- get nb notebookSelection- (moduleName, (_panel, editor, _highlighter)) <-- fmap ( M.elemAt index ) $ readIORef panels- prg <- readIORef program- let path =- Module.source_location $ snd $- M.elemAt index (modules prg)-- handleException moduleName $ do- content <- readFile path- set editor [ text := content ]- set status [- text := Module.tellName moduleName ++ " reloaded from " ++ path ]- ]-- let getCurrentModule = do- index <- get nb notebookSelection- (moduleName, (_panel, editor, _highlighter)) <-- fmap ( M.elemAt index ) $ readIORef panels- content <- get editor text- prg <- readIORef program- return- (Module.source_location $ snd $- M.elemAt index (modules prg),- moduleName, content)- saveModule (path, moduleName, content) =- handleException moduleName $ do- -- Log.put path- writeFile path content- set status [- text := Module.tellName moduleName ++ " saved to " ++ path ]-- set saveItem [- on command := do- saveModule =<< getCurrentModule ]-- set saveAsItem [- on command := do- (filePath, moduleName, content) <- getCurrentModule- let (path,file) = FilePath.splitFileName filePath- -- print (path,file)- mfilename <- WX.fileSaveDialog- f False {- change current directory -} True- ("Save " ++ Module.tellName moduleName) haskellFilenames path file- forM_ mfilename $ \fileName -> do- saveModule (fileName, moduleName, content)- modifyIORef program $ \prg ->- prg { Program.modules =- M.adjust- (\modu -> modu { Module.source_location = fileName })- moduleName (Program.modules prg) }- ]--- let refreshProgram (moduleName, (_panel, editor, _highlighter)) = do- s <- get editor text- pos <- get editor cursor- writeChan input $ Modification Nothing moduleName s pos-- updateErrorLog $ Seq.filter $- \(Exception.Message _ errorRng _) ->- Module.deconsName moduleName /=- Pos.sourceName (Term.start errorRng)-- set refreshItem- [ on command := do- refreshProgram =<< getFromNotebook nb =<< readIORef panels- -- mapM_ refreshProgram pnls- ]-- set playTermItem- [ on command := do- (_moduleName, (_panel, editor, _highlighter)) <-- getFromNotebook nb =<< readIORef panels- marked <- WXCMZ.textCtrlGetStringSelection editor- expr <-- if null marked- then do- (i,line) <-- textColumnRowFromPos editor- =<< get editor cursor- content <- WXCMZ.textCtrlGetLineText editor line-{- simpler but inefficient- content <- get editor text- i <- get editor cursor--}- case splitAt i content of- (prefix,suffix) ->- let identLetter c = Char.isAlphaNum c || c == '_' || c == '.'- in return $- (reverse $ takeWhile identLetter $ reverse prefix)- ++- takeWhile identLetter suffix- else return marked- writeChan input . Execution . PlayTerm $ expr ]-- waitDuration <- newIORef 500-- let updateSlowMotionDur = do- dur <- readIORef waitDuration- writeChan input $ Execution $ Mode $ Event.SlowMotion dur-- set fasterItem [- on command := do- modifyIORef waitDuration (\d -> max 100 (d-100))- updateSlowMotionDur- d <- readIORef waitDuration- set status [ text :=- "decreased pause to " ++ show d ++ "ms" ] ]-- set slowerItem [- on command := do- modifyIORef waitDuration (100+)- updateSlowMotionDur- d <- readIORef waitDuration- set status [ text :=- "increased pause to " ++ show d ++ "ms" ] ]-- let setRealTime b = do- set realTimeItem [ checked := b ]-- setSlowMotion b = do- set slowMotionItem [ checked := b ]- set fasterItem [ enabled := b ]- set slowerItem [ enabled := b ]-- setSingleStep b = do- set singleStepItem [ checked := b ]- set nextStepItem [ enabled := b ]-- onActivation w act =- set w [ on command := do- b <- get w checked- if b then act else set w [checked := True] ]-- activateRealTime = do- setRealTime True- setSlowMotion False- setSingleStep False-- activateSlowMotion = do- setRealTime False- setSlowMotion True- setSingleStep False-- activateSingleStep = do- setRealTime False- setSlowMotion False- setSingleStep True-- onActivation realTimeItem $ do- activateRealTime- writeChan input $ Execution $ Mode Event.RealTime- onActivation slowMotionItem $ do- activateSlowMotion- updateSlowMotionDur- onActivation singleStepItem $ do- activateSingleStep- writeChan input $ Execution $ Mode Event.SingleStep-- set reducerVisibleItem- [ on command := do- b <- get reducerVisibleItem checked- set reducer [ visible := b ]- windowReFit reducer ]-- set f [- layout := container p $ margin 5- $ column 5- [ WX.fill $ tabs nb []- , WX.fill $ widget reducer- ]- , WX.statusBar := [status]- , WX.menuBar := [fileMenu, execMenu, windowMenu]- , visible := True- , clientSize := sz 1280 720- ]--- set errorLog- [ on listEvent := \ev -> void $ MaybeT.runMaybeT $ do- ListItemSelected n <- return ev- errors <- liftIO $ readIORef errorList- let (Exception.Message typ errorRng _descr) =- Seq.index errors n- Right moduleIdent <- return $- Parsec.parse IO.input "" $- Pos.sourceName $ Term.start errorRng- pnls <- liftIO $ readIORef panels- pnl <- MaybeT.MaybeT $ return $ M.lookupIndex moduleIdent pnls- liftIO $ set nb [ notebookSelection := pnl ]- let activateText textField = do- h <- MaybeT.MaybeT $ return $- M.lookup moduleIdent textField- i <- liftIO $ textPosFromSourcePos h $ Term.start errorRng- j <- liftIO $ textPosFromSourcePos h $ Term.end errorRng- liftIO $ set h [ cursor := i ]- liftIO $ WXCMZ.textCtrlSetSelection h i j- case typ of- Exception.Parse ->- activateText $ editors pnls- Exception.Term ->- activateText $ highlighters pnls- Exception.InOut ->- return ()- ]-- set frameError- [ layout := container panelError $ margin 5- $ column 5 $- [ WX.fill $ widget errorLog,- WX.hfloatLeft $ widget clearLog ]- , clientSize := sz 500 300- ]-- let closeOther =- writeIORef appRunning False >>- close frameError >> close frameControls- set quitItem [ on command := closeOther >> close f]- set f [ on closing := closeOther >> propagateEvent- {- 'close f' would trigger the closing handler again -} ]- focusOn f--- highlights <- varCreate M.empty-- registerMyEvent f $ do- msg <- readChan out- let setColorHighlighters ::- M.Map Module.Name [Identifier] -> Int -> Int -> Int -> IO ()- setColorHighlighters m r g b = do- pnls <- readIORef panels- set_color nb ( highlighters pnls ) m ( rgb r g b )- case msg of- Term steps sr -> do- get reducerVisibleItem checked >>=- flip when ( set reducer [ text := sr, cursor := 0 ] )- forM_ steps $ \step ->- case step of- Rewrite.Step target mrule -> do-- let m = M.fromList $ do- t <- target : maybeToList mrule- return (Module.Name $ Pos.sourceName $ Term.start $ Term.range t, [t])- void $ varUpdate highlights $ M.unionWith (++) m- setColorHighlighters m 0 200 200-- Rewrite.Data origin -> do- set reducer [ text := sr, cursor := 0 ]-- let m = M.singleton- (Module.Name $ Pos.sourceName $- Term.start $ Term.range origin)- [origin]- void $ varUpdate highlights $ M.unionWith (++) m- setColorHighlighters m 200 200 0-- Exception exc -> do- itemAppend errorLog $ Exception.lineFromMessage exc- modifyIORef errorList (Seq.|> exc)- set status [ text := Exception.statusFromMessage exc ]-- -- update highlighter text field only if parsing was successful- Refresh moduleName s pos -> do- pnls <- readIORef panels- Fold.mapM_- (\h -> set h [ text := s, cursor := pos ])- (M.lookup moduleName $ highlighters pnls)- set status [ text :=- Module.tellName moduleName ++ " reloaded into interpreter" ]- InsertText str -> do- (_moduleName, (_panel, editor, _highlighter)) <-- getFromNotebook nb =<< readIORef panels- WXCMZ.textCtrlWriteText editor str- set status [ text :=- "inserted note from external controller" ]-- Register prg ctrls -> do- writeIORef program prg- writeIORef controls ctrls-- void $ WXCMZ.notebookDeleteAllPages nb- pnls <- displayModules input- frameControls ctrls nb prg- writeIORef panels pnls- Fold.forM_ (M.mapWithKey (,) $ fmap fst3 pnls) $- \(moduleName,sub) ->- WXCMZ.notebookAddPage nb sub (Module.deconsName moduleName) False (-1)-- updateErrorLog (const Seq.empty)-- set status [ text :=- "modules loaded: " ++- (List.intercalate ", " $ map Module.deconsName $- M.keys $ Program.modules prg) ]-- ResetDisplay -> do- previous <- varSwap highlights M.empty- setColorHighlighters previous 255 255 255-- Running mode -> do- case mode of- Event.RealTime -> do- set status [ text := "interpreter in real-time mode" ]- activateRealTime- Event.SlowMotion dur -> do- set status [ text :=- ("interpreter in slow-motion mode with pause " ++- show dur ++ "ms") ]- activateSlowMotion- Event.SingleStep -> do- set status [ text :=- "interpreter in single step mode," ++- " waiting for next step" ]- activateSingleStep-- HTTP request ->- HTTPGui.update- (\contentMVar name newContent pos ->- writeChan input $- Modification (Just contentMVar) name newContent pos)- status panels request---displayModules ::- Chan Action ->- WX.Frame c ->- [(Identifier, Controls.Control)] ->- WXCore.Window b ->- Program ->- IO (M.Map Module.Name (Panel (), TextCtrl (), TextCtrl ()))-displayModules input frameControls ctrls nb prog = do- Controls.create frameControls ctrls- $ \ e -> writeChan input ( Control e )-- Trav.forM (modules prog) $ \ content -> do- psub <- panel nb []- editor <- textCtrl psub [ font := fontFixed, wrap := WrapNone ]- highlighter <- textCtrlRich psub- [ font := fontFixed, wrap := WrapNone, editable := False ]- set editor [ text := Module.source_text content ]- set highlighter [ text := Module.source_text content ]- set psub [ layout := (row 5 $- map WX.fill $ [widget editor, widget highlighter]) ]- return (psub, editor, highlighter)---getFromNotebook ::- Notebook b -> M.Map k a -> IO (k, a)-getFromNotebook nb m =- fmap (flip M.elemAt m) $ get nb notebookSelection--textPosFromSourcePos ::- TextCtrl a -> Pos.SourcePos -> IO Int-textPosFromSourcePos textArea pos =- WXCMZ.textCtrlXYToPosition textArea- $ Point (Pos.sourceColumn pos - 1)- (Pos.sourceLine pos - 1)--textColumnRowFromPos ::- TextCtrl a -> Int -> IO (Int, Int)-textColumnRowFromPos textArea pos =- alloca $ \rowPtr ->- alloca $ \columnPtr -> do- void $ WXCMZ.textCtrlPositionToXY textArea pos columnPtr rowPtr- liftM2 (,)- (fmap fromIntegral $ peek columnPtr)- (fmap fromIntegral $ peek rowPtr)--set_color ::- (Ord k) =>- Notebook a ->- M.Map k (TextCtrl a) ->- M.Map k [Identifier] ->- Color ->- IO ()-set_color nb highlighters positions hicolor = void $ do- (p, highlighter) <- getFromNotebook nb highlighters- attr <- WXCMZ.textCtrlGetDefaultStyle highlighter- bracket- (WXCMZ.textAttrGetBackgroundColour attr)- (WXCMZ.textAttrSetBackgroundColour attr) $ const $ do- WXCMZ.textAttrSetBackgroundColour attr hicolor- forM_ (fromMaybe [] $ M.lookup p positions) $ \ ident -> do- let rng = Term.range ident- from <- textPosFromSourcePos highlighter $ Term.start rng- to <- textPosFromSourcePos highlighter $ Term.end rng- WXCMZ.textCtrlSetStyle highlighter from to attr+it sends an Action message via the 'input' Chan to the 'machine'.+It does not have direct access to the 'program'.++machine:+This thread manages loading and parsing of modules+as well as the operation mode of the interpreter.+It gets most of its messages from the GUI+and sends its result as GuiUpdate via the 'output' Chan to the GUI.+It is the only thread that is allowed to modify the 'program'.+Thus it sequences all accesses to 'program'+and warrants atomic modification (a single read-write sequence)+even outside the STM monad.++execute:+This runs the interpreter.+It reduces expressions and sends according MIDI messages+or waits according to Wait events.+It can read the current state of the 'program'+but is not allowed to modify it.++ALSA:+With ALSA we can wait only for all kinds of events at once.+Thus this thread receives all incoming messages and distributes them+to the right receiver.+E.g. NoteOn events are sent to the GUI as text inserts+and Echo messages are sent to the 'execute' thread for handling Wait events.++HTTPServer:+Waits for and responds to incoming HTTP requests.+-}++import qualified IO+import qualified Term+import qualified Time+import qualified Program+import qualified Exception+import qualified Module+import qualified Controls+import qualified Rewrite+import qualified Option+import qualified Log+import Program ( Program )+import Term ( Term, Identifier, mainName )+import Option.Utility ( exitFailureMsg )+import Utility.Concurrent ( writeTMVar, writeTChanIO, liftSTM )+import Utility.WX ( cursor, editable, notebookSelection, splitterWindowSetSashGravity )++import qualified HTTPServer.GUI as HTTPGui++import qualified Graphics.UI.WX as WX+import Graphics.UI.WX.Attributes ( Prop((:=)), set, get )+import Graphics.UI.WX.Classes+ ( itemAppend, items, checkable, checked, clientSize,+ close, enabled, font, help, text, visible )+import Graphics.UI.WX.Controls+ ( Notebook, TextCtrl, wrap, focusOn, columns, listEvent,+ Align(AlignLeft, AlignRight), Wrap(WrapNone) )+import Graphics.UI.WX.Events+ ( on, closing, command )+import Graphics.UI.WX.Layout+ ( widget, container, layout, margin )+import Graphics.UI.WX.Types+ ( Color, rgb, fontFixed, Point2(Point), sz,+ varCreate, varSwap, varUpdate )+import Control.Concurrent ( forkIO )+import Control.Concurrent.MVar ( MVar, putMVar )+import Control.Concurrent.Chan ( Chan, newChan, readChan, writeChan )+import Control.Concurrent.STM.TChan ( TChan, newTChanIO, readTChan, writeTChan )+import Control.Concurrent.STM.TVar ( TVar, newTVarIO, readTVarIO, readTVar, writeTVar )+import Control.Concurrent.STM.TMVar ( TMVar, newTMVarIO, putTMVar, readTMVar, takeTMVar )+import Control.Monad.STM ( STM )+import qualified Control.Monad.STM as STM++import Data.IORef ( IORef, newIORef, readIORef, writeIORef, modifyIORef )++import qualified Graphics.UI.WXCore as WXCore+import qualified Graphics.UI.WXCore.WxcClassesAL as WXCAL+import qualified Graphics.UI.WXCore.WxcClassesMZ as WXCMZ+import Graphics.UI.WXCore.WxcDefs ( wxID_HIGHEST )++import qualified Graphics.UI.WXCore.Events as WXEvent+import qualified Event++import Foreign.Ptr ( Ptr )+import Foreign.Storable ( peek )+import Foreign.Marshal.Alloc ( alloca )+import qualified Foreign.C.Types as C++import qualified ALSA+import qualified Sound.ALSA.Sequencer as SndSeq+import qualified Sound.MIDI.Message.Channel.Voice as VM++import qualified Control.Monad.Trans.State as MS+import qualified Control.Monad.Trans.Writer as MW+import qualified Control.Monad.Trans.Maybe as MaybeT+import qualified Control.Monad.Exception.Synchronous as Exc+import Control.Monad.IO.Class ( liftIO )+import Control.Monad.Trans.Class ( lift )+import Control.Monad ( when, liftM, liftM2, forever )+import Control.Functor.HT ( void )+import Data.Foldable ( forM_ )+import Data.Traversable ( forM )+import qualified Text.ParserCombinators.Parsec as Parsec+import qualified Text.ParserCombinators.Parsec.Pos as Pos+import qualified Text.ParserCombinators.Parsec.Token as Token++import Control.Exception ( bracket, finally, try )+import qualified System.IO as IO+import qualified System.IO.Error as Err+import qualified System.FilePath as FilePath++import qualified Data.Accessor.Monad.Trans.State as AccM+import qualified Data.Accessor.Basic as Acc+import qualified Data.Accessor.Tuple as AccTuple++import qualified Data.Foldable as Fold+import qualified Data.Sequence as Seq+import qualified Data.Map as M++import qualified Data.Monoid as Mn++import qualified Data.Char as Char+import qualified Data.List as List+import Data.Tuple.HT ( mapSnd )+import Data.Bool.HT ( if' )++import Prelude hiding ( log )+++-- | read rules files, should contain definition for "main"+main :: IO ()+main = do+ IO.hSetBuffering IO.stderr IO.LineBuffering+ opt <- Option.get++ (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++ input <- newChan+ output <- newTChanIO+ STM.atomically $ registerProgram output mainMod p+ ALSA.withSequencer opt $ \sq -> do+ flip finally (ALSA.stopQueue sq) $ WX.start $ do+ gui input output+ void $ forkIO $+ machine input output+ (Option.limits opt) (Option.importPaths opt) p sq+ void $ forkIO $+ HTTPGui.run+ (HTTPGui.methods (writeTChanIO output . HTTP))+ (Option.httpOption opt)+++-- | messages that are sent from GUI to machine+data Action =+ Execution Execution+ | Modification Modification+ | Control Controls.Event++data Execution =+ Mode Event.WaitMode | Restart | Stop | NextStep |+ PlayTerm MarkedText | ApplyTerm MarkedText++data Modification =+ Load FilePath+ | NewModule+ | CloseModule Module.Name+ | FlushModules Module.Name+ | RefreshModule (Maybe (MVar HTTPGui.Feedback)) Module.Name String Int+ -- ^ MVar of the HTTP server, modulename, sourcetext, position+++-- | messages that are sent from machine to GUI+data GuiUpdate =+ ReductionSteps { _steps :: [ Rewrite.Message ] }+ | CurrentTerm { _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 }+ | InsertPage { _activate :: Bool, _module :: Module.Module }+ | DeletePage Module.Name+ | RenamePage Module.Name Module.Name+ | RebuildControls Controls.Assignments+ | InsertText { _insertedText :: String }+ | StatusLine { _statusLine :: String }+ | HTTP HTTPGui.GuiUpdate+ | Running { _runningMode :: Event.WaitMode }+ | ResetDisplay+++exceptionToGUI ::+ TChan GuiUpdate ->+ Exc.ExceptionalT Exception.Message STM () ->+ STM ()+exceptionToGUI output =+ Exc.resolveT (writeTChan output . Exception)++exceptionToGUIIO ::+ TChan GuiUpdate ->+ Exc.ExceptionalT Exception.Message IO () ->+ IO ()+exceptionToGUIIO output =+ Exc.resolveT (writeTChanIO output . Exception)++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+++formatPitch :: VM.Pitch -> String+formatPitch p =+ let (oct,cls) = divMod (VM.fromPitch p) 12+ name =+ case cls of+ 00 -> "c"+ 01 -> "cs"+ 02 -> "d"+ 03 -> "ds"+ 04 -> "e"+ 05 -> "f"+ 06 -> "fs"+ 07 -> "g"+ 08 -> "gs"+ 09 -> "a"+ 10 -> "as"+ 11 -> "b"+ _ -> error "pitch class must be a number from 0 to 11"+ in "note qn (" ++ name ++ " " ++ show (oct-1) ++ ") : "++formatModuleList :: [Module.Name] -> String+formatModuleList =+ List.intercalate ", " . map Module.deconsName+++{-+We do not put the program update into a big a STM+because loading new imported modules may take a while+and blocking access to 'program'+would block the read access by the interpreter.+-}+modifyModule ::+ [ FilePath ] ->+ TVar Program ->+ TChan GuiUpdate ->+ Module.Name ->+ String ->+ Int ->+ IO (Maybe Exception.Message)+modifyModule importPaths program output moduleName sourceCode pos = do+ p <- readTVarIO program+ Exception.switchT+ (\e -> do+ writeTChanIO output $ Exception e+ return $ Just e)+ (\(newP, updates) -> do+ STM.atomically $ do+ mapM_ ( writeTChan output ) updates+ writeTVar program newP+-- Log.put "parsed and modified OK"+ return Nothing) $ do+ let exception =+ Exception.Message Exception.Parse (Module.nameRange moduleName)+ previous <-+ case M.lookup moduleName $ Program.modules p of+ Nothing ->+ Exc.throwT $ exception $+ Module.tellName moduleName ++ " does no longer exist"+ Just m -> return m+ m <-+ Exception.lift $ Module.parse+ (Module.deconsName moduleName)+ (Module.sourceLocation previous) sourceCode+ {-+ My first thought was that renaming of modules+ should be generally forbidden via HTTP.+ My second thought was that renaming of modules+ can be easily allowed or forbidden using the separation marker.+ Actually currently renaming via HTTP is not possible,+ because the separation marker is not allowed before the 'module' line.+ If you like to strictly forbid renaming in some circumstances,+ then make 'allowRename' a parameter of the function.+ -}+ let allowRename = True+ MW.runWriterT $ do+ p1 <-+ if' (moduleName == Module.name m)+ (lift $ Exception.lift $ Program.replaceModule m p) $+ if' allowRename (do+ lift $ Exc.assertT+ (exception $ Module.tellName (Module.name m) ++ " already exists")+ (not $ M.member (Module.name m) $ Program.modules p)+ MW.tell+ [ RenamePage moduleName (Module.name m) ]+ lift $ Exception.lift $ Program.addModule m $+ Program.removeModule moduleName p) $+ (lift $ Exc.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 )+ -- Refresh must happen after a Rename+ MW.tell [ Refresh (Module.name m) sourceCode pos,+ RebuildControls $ Program.controls p2 ]+ return p2++registerProgram :: TChan GuiUpdate -> Module.Name -> Program -> STM ()+registerProgram output mainModName p = do+ writeTChan output $ Register mainModName $ Program.modules p+ writeTChan output $ RebuildControls $ Program.controls p++updateProgram :: TVar Program -> TChan GuiUpdate -> Program -> STM ()+updateProgram program output p = do+ liftSTM $ writeTVar program p+ liftSTM $ writeTChan output $ RebuildControls $ Program.controls p+++{-+This runs concurrently+and is fed with changes to the modules by the GUI.+It parses them and provides the parsed modules to the execution engine.+Since parsing is a bit of work+we can keep the GUI and the execution of code going while parsing.+-}+machine :: Chan Action -- ^ machine reads program text from here+ -- (module name, module contents)+ -> TChan GuiUpdate -- ^ and writes output to here+ -- (log message (for highlighting), current term)+ -> Option.Limits+ -> [FilePath]+ -> Program -- ^ initial program+ -> ALSA.Sequencer SndSeq.DuplexMode+ -> IO ()+machine input output limits importPaths progInit sq = do+ program <- newTVarIO progInit+ term <- newTMVarIO mainName+ waitChan <- newChan++ void $ forkIO $ forever $ do+ action <- readChan input+ let withMode mode transaction = do+ writeChan waitChan $ Event.ModeChange mode+ STM.atomically $ do+ writeTChan output $ Running mode+ transaction+ case action of+ Control event -> do+ Log.put $ show event+ STM.atomically $ exceptionToGUI output $ do+ p <- lift $ readTVar program+ p' <- Exception.lift $ Controls.changeControllerModule p event+ lift $ writeTVar program p'+ -- return $ Controls.getControllerModule p'+ -- Log.put $ show m++ Execution exec ->+ case exec of+ Mode mode -> do+ case mode of+ Event.RealTime -> do+ ALSA.continueQueue sq+ Event.SlowMotion _ -> do+ ALSA.continueQueue sq+ Event.SingleStep -> do+ ALSA.pauseQueue sq+ withMode mode $ return ()+ Restart -> do+ ALSA.quietContinueQueue sq+ withMode Event.RealTime $ writeTMVar term mainName+ Stop -> do+ ALSA.stopQueue sq+ withMode Event.SingleStep $ writeTMVar term mainName+ NextStep -> writeChan waitChan Event.NextStep+ PlayTerm txt -> exceptionToGUIIO output $ do+ t <- parseTerm txt+ lift $ ALSA.quietContinueQueue sq+ lift $ withMode Event.RealTime $ writeTMVar term t+ ApplyTerm txt -> exceptionToGUIIO output $ do+ fterm <- parseTerm txt+ case fterm of+ Term.Node f xs ->+ lift $ STM.atomically $ do+ t0 <- readTMVar term+ let t1 = Term.Node f (xs++[t0])+ writeTMVar term t1+ writeTChan output $ CurrentTerm $ show t1+ writeTChan output $ StatusLine $+ "applied function term " +++ show (markedString txt)+ _ ->+ Exc.throwT .+ Exception.Message Exception.Parse (Term.termRange fterm) $+ "tried to apply the non-function term " +++ show (markedString txt)++ Modification modi ->+ case modi of+ RefreshModule feedback moduleName 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+ putMVar mvar $ Exc.Success+ (fmap Exception.multilineFromMessage x,+ sourceCode)++ Load filePath -> do+ Log.put $+ "load " ++ filePath ++ " and all its dependencies"+ exceptionToGUIIO output $ do+ let stem = FilePath.takeBaseName filePath+ p <-+ Program.load importPaths stem filePath+ Program.empty+ lift $ do+ ALSA.stopQueue sq+ withMode Event.RealTime $ do+ writeTVar program p+ writeTMVar term mainName+ registerProgram output (Module.Name stem) p+ ALSA.continueQueue sq+ Log.put "chased and parsed OK"++ NewModule ->+ STM.atomically $ do+ prg <- readTVar program+ let modName =+ head $+ filter (not . flip M.member (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 ->+ error ("new module has no declarations and thus should not lead to conflicts with existing modules - " ++ Exception.statusFromMessage e)+ Exc.Success newPrg ->+ liftSTM $ updateProgram program output newPrg+ liftSTM $ writeTChan output $ InsertPage True modu++ CloseModule modName ->+ STM.atomically $ exceptionToGUI output $+ Exc.mapExceptionT+ (Module.inoutExceptionMsg modName .+ ("cannot close module: " ++)) $ do+ prg <- liftSTM $ readTVar program+ let modules = Program.modules prg+ importingModules =+ M.keys $+ M.filter (elem modName . map Module.source .+ Module.imports) $+ M.delete modName modules+ flip Exc.assertT (null importingModules) $+ "it is still imported by " +++ formatModuleList importingModules+ flip Exc.assertT (M.member modName modules) $+ "it does not exist"+ flip Exc.assertT (M.size modules > 1) $+ "there must remain at least one module"+ liftSTM $ updateProgram program output $+ Program.removeModule modName prg+ liftSTM $ writeTChan output $ DeletePage modName++ FlushModules modName ->+ STM.atomically $ do+ prg <- readTVar program+ let (removed, minPrg) = Program.minimize modName prg+ updateProgram program output minPrg+ Fold.mapM_ (writeTChan output . DeletePage) removed++ void $ forkIO $+ Event.listen sq+ ( writeTChanIO output . InsertText . formatPitch )+ waitChan+ ALSA.startQueue sq+ Event.runState $+ execute limits program term ( writeTChan output ) sq waitChan+++execute :: Option.Limits+ -> TVar Program+ -- ^ current program (GUI might change the contents)+ -> TMVar Term -- ^ current term+ -> ( GuiUpdate -> STM () ) -- ^ sink for messages (show current term)+ -> ALSA.Sequencer SndSeq.DuplexMode -- ^ for playing MIDI events+ -> Chan Event.WaitResult+ -> MS.StateT Event.State IO ()+execute limits program term output sq waitChan =+ forever $ do+ (mdur,outputs) <- MW.runWriterT $ do+ waiting <- lift $ AccM.get Event.stateWaiting+ when waiting $ writeUpdate ResetDisplay+ maxEventsSat <- lift $ checkMaxEvents limits+ executeStep limits program term+ (STM.atomically . output . Exception) sq maxEventsSat+ liftIO $ STM.atomically $ mapM_ output outputs+ Event.wait sq waitChan mdur++{-+We maintain the timestamps of the last 'maxEvents' events, including 'Wait's.+Then we check whether the earliest stored event is old enough.+-}+checkMaxEvents :: (Monad m) =>+ Option.Limits -> MS.StateT Event.State m Bool+checkMaxEvents limits = do+ mode <- AccM.get Event.stateWaitMode+ case mode of+ Event.RealTime -> do+ current <- AccM.get Event.stateTime+ recent <- AccM.get Event.stateRecentTimes+ cont <-+ case Seq.viewl recent of+ Seq.EmptyL -> return True+ past Seq.:< ts ->+ if' (Seq.length recent < Option.maxEvents limits)+ (return True) $+ if' (Mn.mappend past+ (Time.up $ Time.up $+ Option.eventPeriod limits)+ <= current)+ (AccM.set Event.stateRecentTimes ts >> return True)+ (AccM.set Event.stateRecentTimes Seq.empty >> return False)+ AccM.modify Event.stateRecentTimes (Seq.|> current)+ return cont+ _ -> do+ AccM.set Event.stateRecentTimes Seq.empty+ return True++executeStep ::+ Option.Limits ->+ TVar Program ->+ TMVar Term ->+ ( Exception.Message -> IO () ) ->+ ALSA.Sequencer SndSeq.DuplexMode ->+ Bool ->+ MW.WriterT [ GuiUpdate ]+ ( MS.StateT Event.State IO ) ( Maybe Event.Time )+executeStep limits program term writeExcMsg sq maxEventsSat =+ Exception.switchT+ (\e -> do+ liftIO $ ALSA.stopQueue sq+ -- writeChan waitChan $ Event.ModeChange Event.SingleStep+ writeUpdate $ Exception e+ writeUpdate $ Running Event.SingleStep+ {-+ We have to alter the mode directly,+ since the channel is only read when we wait for a duration other than Nothing+ -}+ lift $ AccM.set Event.stateWaitMode Event.SingleStep+ return Nothing)+ (\(x,s) -> do+ {-+ exceptions on processing an event are not fatal and we keep running+ -}+ wait <- Exc.resolveT+ (fmap (const Nothing) . writeUpdate . Exception)+ (Exc.mapExceptionalT lift $+ Event.play sq writeExcMsg x)++ waitMode <- lift $ AccM.get Event.stateWaitMode+ waiting <- lift $ AccM.get Event.stateWaiting+ {-+ This way the term will be pretty printed in the GUI thread+ which may block the GUI thread.+ However evaluating it here may defer playing notes,+ which is not better.+ -}+ when (waiting || waitMode /= Event.RealTime) $+ writeUpdate $ CurrentTerm $ show s+ {-+ liftIO $ Log.put $+ "term size: " ++ ( show $ length $ Term.subterms s ) +++ ", term depth: " ++ ( show $ length $ Term.breadths s )+ -}+ return wait)+ (Exc.mapExceptionalT (MW.mapWriterT (liftIO . STM.atomically)) $+ flip Exc.catchT (\(pos,msg) -> do+ liftSTM $ putTMVar term mainName+ Exc.throwT $ Exception.Message Exception.Term pos msg) $ do+ t <- liftSTM $ takeTMVar term+ p <- liftSTM $ readTVar program+ {- this happens anew at each click+ since the program text might have changed in the editor -}+ Exc.assertT+ (Term.termRange t, "too many events in a too short period")+ maxEventsSat+ (s,log) <-+ Exc.mapExceptionalT+ (fmap (\(ms,log) -> liftM2 (,) ms (return log)) .+ MW.runWriterT) $+ Rewrite.runEval+ (Option.maxReductions limits) p (Rewrite.forceHead t)+ Exc.assertT+ (Term.termRange s,+ "term size exceeds limit " ++ show (Option.maxTermSize limits))+ (null $ drop (Option.maxTermSize limits) $ Term.subterms s)+ Exc.assertT+ (Term.termRange s,+ "term depth exceeds limit " ++ show (Option.maxTermDepth limits))+ (null $ drop (Option.maxTermDepth limits) $ Term.breadths s)+ lift $ writeUpdate $ ReductionSteps log+ case Term.viewNode s of+ Just (":", [x, xs]) -> do+ liftSTM $ putTMVar term xs+ return (x,s)+ Just ("[]", []) -> do+ lift $ writeUpdate $ CurrentTerm $ show s+ Exc.throwT (Term.termRange s, "finished.")+ _ -> do+ lift $ writeUpdate $ CurrentTerm $ show s+ Exc.throwT (Term.termRange s,+ "I do not know how to handle this term: " ++ show s))+++voidStateT :: (Monad m) => (s -> m s) -> MS.StateT s m ()+voidStateT f = MS.StateT $ liftM ((,) ()) . f+++writeUpdate ::+ (Monad m) =>+ GuiUpdate -> MW.WriterT [GuiUpdate] m ()+writeUpdate update = MW.tell [update]+++-- | following code taken from http://snipplr.com/view/17538/+myEventId :: Int+myEventId = wxID_HIGHEST+100+ -- the custom event ID, avoid clash with Graphics.UI.WXCore.Types.varTopId++-- | the custom event is registered as a menu event+createMyEvent :: IO (WXCore.CommandEvent ())+createMyEvent =+ WXCAL.commandEventCreate WXCMZ.wxEVT_COMMAND_MENU_SELECTED myEventId++registerMyEvent :: WXCore.EvtHandler a -> IO () -> IO ()+registerMyEvent win io = WXEvent.evtHandlerOnMenuCommand win myEventId io+++{-+The order of widget creation is important+for cycling through widgets using tabulator key.+-}+gui :: Chan Action -- ^ the gui writes here+ -- (if the program text changes due to an edit action)+ -> TChan GuiUpdate -- ^ the machine writes here+ -- (a textual representation of "current expression")+ -> IO ()+gui input output = do+ panels <- newIORef M.empty++ frameError <- newFrameError++ frameControls <- WX.frame [ text := "controls" ]++ f <- WX.frame+ [ text := "live-sequencer", visible := False+ ]++ out <- newChan++ void $ forkIO $ forever $ do+ writeChan out =<< STM.atomically (readTChan output)+ WXCAL.evtHandlerAddPendingEvent f =<< createMyEvent++ p <- WX.panel f [ ]+++ fileMenu <- WX.menuPane [text := "&File"]++ let haskellFilenames =+ [ ("Haskell modules", ["*.hs"]),+ ("All files", ["*"]) ]++ loadItem <- WX.menuItem fileMenu+ [ text := "L&oad and check program ...\tCtrl-O",+ help :=+ "flush all modules " +++ "and load a new program with all its dependencies" ]+ reloadItem <- WX.menuItem fileMenu+ [ text := "&Reload module",+ help :=+ "reload a module from its original file, " +++ "but do not pass it to the interpreter" ]+ saveItem <- WX.menuItem fileMenu+ [ text := "&Save module\tCtrl-S",+ help :=+ "overwrite original file with current module content" ]+ saveAsItem <- WX.menuItem fileMenu+ [ text := "Save module &as ...",+ help :=+ "save module content to a different or new file " +++ "and make this the new file target" ]++ WX.menuLine fileMenu++ newModuleItem <- WX.menuItem fileMenu+ [ text := "&New module\tCtrl-Shift-N",+ help := "add a new empty module" ]++ closeModuleItem <- WX.menuItem fileMenu+ [ text := "&Close module\tCtrl-W",+ help := "close the active module" ]++ flushModulesItem <- WX.menuItem fileMenu+ [ text := "&Flush modules",+ help := "close all modules that are not transitively imported by the active module" ]++ WX.menuLine fileMenu++ quitItem <- WX.menuQuit fileMenu []+++ execMenu <- WX.menuPane [text := "&Execution"]++ refreshItem <- WX.menuItem execMenu+ [ text := "&Refresh\tCtrl-R",+ help :=+ "parse the edited module and if successful " +++ "rename the page to the modified module name, " +++ "load new imported modules and " +++ "replace the executed program" ]+ WX.menuLine execMenu+ realTimeItem <- WX.menuItem execMenu+ [ text := "Real time\tCtrl-1",+ checkable := True,+ checked := True,+ help := "pause according to Wait elements" ]+ slowMotionItem <- WX.menuItem execMenu+ [ text := "Slow motion\tCtrl-2",+ checkable := True,+ help := "pause between every list element" ]+ singleStepItem <- WX.menuItem execMenu+ [ text := "Single step\tCtrl-3",+ checkable := True,+ help := "wait for user confirmation after every list element" ]+ WX.menuLine execMenu+ _restartItem <- WX.menuItem execMenu+ [ text := "Res&tart\tCtrl-T",+ on command := writeChan input (Execution Restart),+ help :=+ "stop sound and restart program execution with 'main'" ]+ playTermItem <- WX.menuItem execMenu+ [ text := "Play term\tCtrl-M",+ help :=+ "stop sound and restart program execution " +++ "with the marked editor area as current term, " +++ "or use the surrounding identifier if nothing is marked" ]+ applyTermItem <- WX.menuItem execMenu+ [ text := "Apply term\tCtrl-Y",+ help :=+ "apply marked expression as function to the current term, " +++ "the execution mode remains the same, " +++ "example terms: (merge track) or (flip append track)" ]+ _stopItem <- WX.menuItem execMenu+ [ text := "Stop\tCtrl-Space",+ on command := writeChan input (Execution Stop),+ help :=+ "stop program execution and sound, " +++ "reset term to 'main'" ]++ WX.menuLine execMenu++ fasterItem <- WX.menuItem execMenu+ [ text := "Faster\tCtrl->",+ enabled := False,+ help := "decrease pause in slow motion mode" ]+ slowerItem <- WX.menuItem execMenu+ [ text := "Slower\tCtrl-<",+ enabled := False,+ help := "increase pause in slow motion mode" ]+ nextStepItem <- WX.menuItem execMenu+ [ text := "Next step\tCtrl-N",+ enabled := False,+ on command := writeChan input (Execution NextStep),+ help := "perform next step in single step mode" ]+++ windowMenu <- WX.menuPane [text := "&Window"]++ appRunning <- newIORef True+ let windowMenuItem title win = do+ itm <- WX.menuItem windowMenu+ [ text := title,+ help := "show or hide " ++ title ++ " window",+ checkable := True,+ checked := True ]+ set itm+ [ on command := do+ b <- get itm checked+ set win [ visible := b ] ]+ set win+ [ on closing := do+ run <- readIORef appRunning+ if run+ then do+ set itm [ checked := False ]+ set win [ visible := False ]+ -- WXCMZ.closeEventVeto ??? True+ else WXEvent.propagateEvent ]++ windowMenuItem "errors" $ errorFrame frameError+ windowMenuItem "controls" frameControls+ WX.menuLine windowMenu+ reducerVisibleItem <- WX.menuItem windowMenu+ [ text := "current term",+ checkable := True,+ checked := True,+ help := "show or hide current term - " +++ "hiding may improve performance drastically" ]+++ splitter <- WX.splitterWindow p []++ nb <- WX.notebook splitter [ ]++ reducer <-+ WX.textCtrl splitter+ [ font := fontFixed, editable := False, wrap := WrapNone ]++ status <- WX.statusField+ [ text := "Welcome to interactive music composition with Haskell" ]+++ let handleException moduleName act = do+ result <- try act+ case result of+ Left err ->+ writeTChanIO output $ Exception $+ Module.inoutExceptionMsg moduleName $+ Err.ioeGetErrorString err+ Right () -> return ()++ set loadItem [+ on command := do+ mfilename <- WX.fileOpenDialog+ f False {- change current directory -} True+ "Load Haskell program" haskellFilenames "" ""+ forM_ mfilename $ writeChan input . Modification . Load+ ]++ set reloadItem [+ on command := do+ (moduleName, pnl) <-+ getFromNotebook nb =<< readIORef panels+ let path = sourceLocation pnl++ handleException moduleName $ do+ content <- readFile path+ set (editor pnl) [ text := content ]+ set status [+ text := Module.tellName moduleName ++ " reloaded from " ++ path ]+ ]++ let getCurrentModule = do+ (moduleName, pnl) <-+ getFromNotebook nb =<< readIORef panels+ 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 ]++ set saveItem [+ on command := do+ saveModule =<< getCurrentModule ]++ set saveAsItem [+ on command := do+ (filePath, moduleName, content) <- getCurrentModule+ let (path,file) = FilePath.splitFileName filePath+ -- print (path,file)+ mfilename <- WX.fileSaveDialog+ f False {- change current directory -} True+ ("Save " ++ Module.tellName moduleName) haskellFilenames path file+ forM_ mfilename $ \fileName -> do+ saveModule (fileName, moduleName, content)+ modifyIORef panels $+ M.adjust+ (\pnl -> pnl { sourceLocation = fileName })+ moduleName+ ]+++ set newModuleItem [+ on command :=+ writeChan input $ Modification NewModule+ ]++ set closeModuleItem [+ on command :=+ writeChan input . Modification . CloseModule . fst+ =<< getFromNotebook nb =<< readIORef panels+ ]++ set flushModulesItem [+ on command :=+ writeChan input . Modification . FlushModules . fst+ =<< getFromNotebook nb =<< readIORef panels+ ]++ let refreshProgram (moduleName, pnl) = do+ s <- get (editor pnl) text+ pos <- get (editor pnl) cursor+ writeChan input $ Modification $ RefreshModule Nothing moduleName s pos++ updateErrorLog frameError $ Seq.filter $+ \(Exception.Message _ errorRng _) ->+ Module.deconsName moduleName /=+ Pos.sourceName (Term.start errorRng)++ set refreshItem+ [ on command := do+ refreshProgram =<< getFromNotebook nb =<< readIORef panels+ -- mapM_ refreshProgram pnls+ ]++ set playTermItem+ [ on command :=+ writeChan input . Execution . PlayTerm+ =<< uncurry getMarkedExpr . mapSnd editor+ =<< getFromNotebook nb+ =<< readIORef panels ]++ set applyTermItem+ [ on command :=+ writeChan input . Execution . ApplyTerm+ =<< uncurry getMarkedExpr . mapSnd editor+ =<< getFromNotebook nb+ =<< readIORef panels ]++ waitDuration <- newIORef $ Time.milliseconds 500++ let updateSlowMotionDur = do+ dur <- readIORef waitDuration+ writeChan input $ Execution $ Mode $ Event.SlowMotion dur+ slowmoUnit = Time.milliseconds 100++ set fasterItem [+ on command := do+ modifyIORef waitDuration $+ \d -> max slowmoUnit (Time.sub d slowmoUnit)+ updateSlowMotionDur+ d <- readIORef waitDuration+ set status [ text :=+ "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 ] ]++ let setRealTime b = do+ set realTimeItem [ checked := b ]++ setSlowMotion b = do+ set slowMotionItem [ checked := b ]+ set fasterItem [ enabled := b ]+ set slowerItem [ enabled := b ]++ setSingleStep b = do+ set singleStepItem [ checked := b ]+ set nextStepItem [ enabled := b ]++ onActivation w act =+ set w [ on command := do+ b <- get w checked+ if b then act else set w [checked := True] ]++ activateRealTime = do+ setRealTime True+ setSlowMotion False+ setSingleStep False++ activateSlowMotion = do+ setRealTime False+ setSlowMotion True+ setSingleStep False++ activateSingleStep = do+ setRealTime False+ setSlowMotion False+ setSingleStep True++ onActivation realTimeItem $ do+ activateRealTime+ writeChan input $ Execution $ Mode Event.RealTime+ onActivation slowMotionItem $ do+ activateSlowMotion+ updateSlowMotionDur+ onActivation singleStepItem $ do+ activateSingleStep+ writeChan input $ Execution $ Mode Event.SingleStep++ splitterWindowSetSashGravity splitter 0.5+ let initSplitterPosition = 0 {- equal division of heights -}+ newIORef initSplitterPosition >>= \splitterPosition ->+ set reducerVisibleItem+ [ on command := do+ b <- get reducerVisibleItem checked+ isSplit <- WXCMZ.splitterWindowIsSplit splitter+ when (b /= isSplit) $ void $+ if b+ then WXCMZ.splitterWindowSplitHorizontally+ splitter nb reducer =<<+ readIORef splitterPosition+ else do+ writeIORef splitterPosition =<<+ WXCMZ.splitterWindowGetSashPosition splitter+ WXCMZ.splitterWindowUnsplit splitter reducer+ ]++ {-+ Without this dummy page the notebook sometimes gets a very small height,+ although we explicitly set the splitter position to 0 (= balanced tiling).+ However the imbalance is not reproducable.+ Maybe this is a race condition.+ -}+ do+ pnl <- displayModule nb (Module.empty $ Module.Name "Dummy")+ void $ WXCMZ.notebookAddPage nb (panel pnl) "Dummy" True (-1)++ set f [+ layout :=+ container p $ margin 5 $+ WX.fill $+ WX.hsplit splitter+ 5 {- sash width -} initSplitterPosition+ (widget nb) (widget reducer)+ , WX.statusBar := [status]+ , WX.menuBar := [fileMenu, execMenu, windowMenu]+ , visible := True+ , clientSize := sz 1280 720+ ]++ onErrorSelection frameError $ \(Exception.Message typ errorRng _descr) -> do+ let moduleIdent =+ Module.Name $+ Pos.sourceName $ Term.start errorRng+ pnls <- liftIO $ readIORef panels+ pnl <- MaybeT.MaybeT $ return $ M.lookupIndex moduleIdent pnls+ liftIO $ set nb [ notebookSelection := pnl ]+ let activateText textField = do+ h <- MaybeT.MaybeT $ return $+ M.lookup moduleIdent textField+ (i,j) <- liftIO $ textRangeFromRange h errorRng+ liftIO $ set h [ cursor := i ]+ liftIO $ WXCMZ.textCtrlSetSelection h i j+ case typ of+ Exception.Parse ->+ activateText $ fmap editor pnls+ Exception.Term ->+ activateText $ fmap highlighter pnls+ Exception.InOut ->+ return ()++ let closeOther =+ writeIORef appRunning False >>+ close (errorFrame frameError) >> close frameControls+ set quitItem [ on command := closeOther >> close f]+ set f [ on closing := closeOther >> WXEvent.propagateEvent+ {- 'close f' would trigger the closing handler again -} ]+ focusOn f+++ highlights <- varCreate M.empty++ registerMyEvent f $ do+ msg <- readChan out+ case msg of+ CurrentTerm sr -> do+ get reducerVisibleItem checked >>=+ flip when ( set reducer [ text := sr, cursor := 0 ] )++ ReductionSteps steps -> do+ hls <- fmap (fmap highlighter) $ readIORef panels+ visibleModule <- fmap fst $ getFromNotebook nb hls+ let highlight ::+ Int -> Int -> Int -> [Identifier] -> IO ()+ highlight r g b idents = do+ let m = M.fromListWith (++) $+ filter ((visibleModule==) . fst) $+ map (\ident -> (Module.nameFromIdentifier ident, [ident])) idents+ void $ varUpdate highlights $ M.unionWith (++) $ m+ setColor hls ( rgb r g b ) m++ let prep step =+ case step of+ Rewrite.Step target -> (AccTuple.first3, (target:))+ Rewrite.Rule rule -> (AccTuple.second3, (rule:))+ Rewrite.Data origin -> (AccTuple.third3, (origin:))+ (targets, rules, origins) =+ foldr (uncurry Acc.modify) ([],[],[]) $+ map prep steps++ highlight 0 200 200 targets+ highlight 200 0 200 rules+ highlight 200 200 0 origins++ ResetDisplay -> do+ hls <- fmap (fmap highlighter) $ readIORef panels+ setColor hls WXCore.white+ =<< varSwap highlights M.empty++ Exception exc -> do+ addToErrorLog frameError exc+ set status [ text := Exception.statusFromMessage exc ]++ -- update highlighter text field only if parsing was successful+ Refresh moduleName s pos -> do+ pnls <- readIORef panels+ Fold.mapM_+ (\pnl -> set (highlighter pnl) [ text := s, cursor := pos ])+ (M.lookup moduleName pnls)+ set status [ text :=+ Module.tellName moduleName ++ " reloaded into interpreter" ]++ InsertText str -> do+ pnl <- fmap snd $ getFromNotebook nb =<< readIORef panels+ WXCMZ.textCtrlWriteText (editor pnl) str+ set status [ text :=+ "inserted note from external controller" ]++ StatusLine str -> do+ set status [ text := str ]++ Register mainModName mods -> do+ void $ WXCMZ.notebookDeleteAllPages nb+ (writeIORef panels =<<) $ forM mods $ \modu -> do+ pnl <- displayModule nb modu+ void $ WXCMZ.notebookAddPage nb (panel pnl)+ (Module.deconsName $ Module.name modu)+ (Module.name modu == mainModName) (-1)+ return pnl++ updateErrorLog frameError (const Seq.empty)++ set status [ text :=+ "modules loaded: " ++ formatModuleList ( M.keys mods ) ]++ InsertPage act modu -> do+ pnls <- readIORef panels+ pnl <- displayModule nb modu+ let modName = Module.name modu+ newPnls = M.insert modName pnl pnls+ writeIORef panels newPnls+ success <-+ WXCMZ.notebookInsertPage nb+ (M.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 ]+ else+ writeTChanIO output $ Exception $+ Module.inoutExceptionMsg modName $+ "Panic: cannot add page for the module"++ DeletePage modName -> do+ pnls <- readIORef panels+ forM_ ( M.lookupIndex modName pnls ) $+ WXCMZ.notebookDeletePage nb+ writeIORef panels $ M.delete modName pnls+ set status [ text := "closed " ++ Module.tellName modName ]++ RenamePage fromName toName -> do+ pnls <- readIORef panels+ forM_+ ( liftM2 (,)+ ( M.lookupIndex fromName pnls )+ ( M.lookup fromName pnls ) ) $ \(i,pnl) -> do+ success <- WXCMZ.notebookRemovePage nb i+ when (not success) $+ writeTChanIO output $ Exception $+ Module.inoutExceptionMsg fromName $+ "Panic: cannot remove page for renaming module"+ let newPnls =+ M.insert toName pnl $ M.delete fromName pnls+ writeIORef panels newPnls+ forM_ ( M.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 ]++ RebuildControls ctrls ->+ Controls.create frameControls ctrls $+ writeChan input . Control++ Running mode -> do+ case mode of+ Event.RealTime -> do+ set status [ text := "interpreter in real-time mode" ]+ activateRealTime+ Event.SlowMotion dur -> do+ set status [ text :=+ ("interpreter in slow-motion mode with pause " +++ Time.format dur) ]+ activateSlowMotion+ Event.SingleStep -> do+ set status [ text :=+ "interpreter in single step mode," +++ " waiting for next step" ]+ activateSingleStep++ HTTP request -> do+ pnls <- readIORef panels+ HTTPGui.update+ (\contentMVar name newContent pos ->+ writeChan input $ Modification $+ RefreshModule (Just contentMVar) name newContent pos)+ status (fmap editor pnls) request+++data FrameError =+ FrameError {+ errorFrame :: WX.Frame (),+ errorLog :: WX.ListCtrl (),+ errorText :: WX.TextCtrl (),+ errorList :: IORef (Seq.Seq Exception.Message)+ }++newFrameError :: IO FrameError+newFrameError = do+ frame <- WX.frame [ text := "errors" ]++ pnl <- WX.panel frame [ ]++ splitter <- WX.splitterWindow pnl [ ]+ splitterWindowSetSashGravity splitter 1++ log <- WX.listCtrl splitter+ [ columns :=+ ("Module", AlignLeft, 120) :+ ("Row", AlignRight, -1) :+ ("Column", AlignRight, -1) :+ ("Type", AlignLeft, -1) :+ ("Description", AlignLeft, 500) :+ []+ ]+ list <- newIORef Seq.empty++ txt <- WX.textCtrl splitter+ [ font := fontFixed, wrap := WrapNone, editable := False ]++ let rec =+ FrameError {+ errorFrame = frame,+ errorLog = log,+ errorText = txt,+ errorList = list+ }++ clearLog <- WX.button pnl+ [ text := "Clear",+ on command := do+ updateErrorLog rec (const Seq.empty)+ set txt [ text := "" ] ]++ set frame+ [ layout := container pnl $ margin 5 $ WX.column 5 $+ [ WX.fill $ WX.hsplit splitter 5 0 (widget log) (widget txt),+ WX.hfloatLeft $ widget clearLog ]+ , clientSize := sz 500 300+ ]++ return rec++onErrorSelection ::+ FrameError -> (Exception.Message -> MaybeT.MaybeT IO ()) -> IO ()+onErrorSelection r act =+ set (errorLog r)+ [ on listEvent := \ev -> void $ MaybeT.runMaybeT $ do+ WXEvent.ListItemSelected n <- return ev+ errors <- liftIO $ readIORef (errorList r)+ let msg@(Exception.Message _typ _errorRng descr) =+ Seq.index errors n+ liftIO $ set (errorText r) [ text := descr ]+ act msg+ ]++updateErrorLog ::+ FrameError ->+ (Seq.Seq Exception.Message -> Seq.Seq Exception.Message) ->+ IO ()+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 ]++addToErrorLog ::+ FrameError -> Exception.Message -> IO ()+addToErrorLog r exc = do+ itemAppend (errorLog r) $ Exception.lineFromMessage exc+ modifyIORef (errorList r) (Seq.|> exc)+++data Panel =+ Panel {+ panel :: WX.SplitterWindow (),+ editor, highlighter :: WX.TextCtrl (),+ sourceLocation :: FilePath+ }++displayModule ::+ WXCore.Window b ->+ Module.Module ->+ IO Panel+displayModule nb modu = do+ psub <- WX.splitterWindow nb []+ splitterWindowSetSashGravity psub 0.5+ ed <- WX.textCtrl psub [ font := fontFixed, wrap := WrapNone ]+ hl <- WX.textCtrlRich psub+ [ font := fontFixed, wrap := WrapNone, editable := False ]+ set ed [ text := Module.sourceText modu ]+ set hl [ text := Module.sourceText 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+++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)+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))++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)++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+++data MarkedText =+ MarkedText {+ _markedPosition :: Pos.SourcePos,+ markedString :: String+ }++getMarkedExpr :: Module.Name -> TextCtrl () -> IO MarkedText+getMarkedExpr modu ed = do+ marked <- WXCMZ.textCtrlGetStringSelection ed+ if null marked+ then do+ (i,line) <-+ textColumnRowFromPos ed =<< get ed cursor+ content <- WXCMZ.textCtrlGetLineText ed line+{- simpler but inefficient+ content <- get ed text+ i <- get ed cursor+-}+ case splitAt i content of+ (prefix,suffix) ->+ let identLetter c = Char.isAlphaNum c || c == '_' || c == '.'+ in return $+ MarkedText+ (sourcePosFromTextColumnRow modu (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
src/IO.hs view
@@ -9,10 +9,10 @@ class Input a where input :: Parsec.Parser a class Output a where output :: a -> Doc -parsec_reader ::+parsecReader :: (Input a) => t -> String -> [(a, String)]-parsec_reader _p s =+parsecReader _p s = case Parsec.parse ( liftM2 (,) input Parsec.getInput ) "" s of Left _err -> [] Right (x,t) -> [(x,t)]
src/Module.hs view
@@ -3,30 +3,40 @@ import IO ( Input, Output, input, output ) import Term ( Term, Identifier, lexer ) import Rule ( Rule )+import qualified ControlsBase as Controls import qualified Type import qualified Term import qualified Rule +import qualified Exception+import qualified Control.Monad.Exception.Synchronous as Exc++import qualified Data.Set as S import qualified Data.Map as M 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 ) import Text.ParserCombinators.Parsec.Expr ( Assoc(AssocLeft, AssocRight, AssocNone) )+import qualified Text.PrettyPrint.HughesPJ as Pretty import Text.PrettyPrint.HughesPJ- ( (<+>), ($$), empty, hsep, sep, hang, punctuate,+ ( (<+>), ($$), hsep, sep, hang, punctuate, render, text, comma, vcat, parens ) import qualified Data.Char as Char +import qualified System.FilePath as FP+import Data.List.HT ( chop )+ import Control.Functor.HT ( void ) -nestDepth :: Int-nestDepth = 4+indent :: Int+indent = 4 data Import = Import { qualified :: Bool , source :: Name@@ -68,10 +78,10 @@ instance Output Import where output i = hsep [ text "import"- , if qualified i then text "qualified" else empty+ , if qualified i then text "qualified" else Pretty.empty , output $ source i , case rename i of- Nothing -> empty+ Nothing -> Pretty.empty Just r -> text "as" <+> output r ] @@ -97,10 +107,10 @@ output (TypeSig names context typeExpr) = hang (hsep ( punctuate ( text "," ) $ map output names ) <+> text "::")- nestDepth+ indent (sep [if null context- then empty+ then Pretty.empty else parens ( hsep ( punctuate ( text "," ) $ map output context ) ) <+> text "=>", output typeExpr <+> text ";"])@@ -143,7 +153,7 @@ output d = hang ( text "type" <+> output ( typeLhs d ) <+> text "=" )- nestDepth+ indent ( output ( typeRhs d ) <+> text ";" ) @@ -191,22 +201,22 @@ AssocNone -> "" in hang (text ( "infix" ++ assocStr ) <+> text ( show prec ))- nestDepth+ indent (hsep ( punctuate comma $ map output idents ) <+> text ";") -data Declaration = Type_Signature TypeSig- | Rule_Declaration Rule- | Type_Declaration Type- | Data_Declaration Data- | Infix_Declaration Infix+data Declaration = TypeSignature TypeSig+ | RuleDeclaration Rule+ | TypeDeclaration Type+ | DataDeclaration Data+ | InfixDeclaration Infix deriving (Show) instance Input Declaration where- input = fmap Data_Declaration input- <|> fmap Infix_Declaration input- <|> fmap Type_Declaration input- <|> fmap Type_Signature (do+ input = fmap DataDeclaration input+ <|> fmap InfixDeclaration input+ <|> fmap TypeDeclaration input+ <|> fmap TypeSignature (do names <- Parsec.try $ do names <- parseIdentList reservedOp lexer "::"@@ -218,31 +228,34 @@ typeExpr <- Type.parseExpression void $ Token.semi lexer return $ TypeSig names context typeExpr)- <|> fmap Rule_Declaration input+ <|> fmap RuleDeclaration input instance Output Declaration where output decl = case decl of- Type_Signature d -> output d- Data_Declaration d -> output d- Type_Declaration d -> output d- Rule_Declaration d -> output d- Infix_Declaration d -> output d+ TypeSignature d -> output d+ DataDeclaration d -> output d+ TypeDeclaration d -> output d+ 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" -- of the module name (which is an identifier). -- So, sourceName is NOT the actual file name.--- instead, the actual file name is kept in source_location (defined here)+-- instead, the actual file name is kept in sourceLocation (defined here) -data Module = Module- { name :: Name- , imports :: [ Import ]- , declarations :: [ Declaration ]- , functions :: FunctionDeclarations- , source_text :: String- , source_location :: FilePath- }+data Module =+ Module+ { name :: Name+ , imports :: [ Import ]+ , declarations :: [ Declaration ]+ , functions :: FunctionDeclarations+ , constructors :: ConstructorDeclarations+ , controls :: Controls.Assignments+ , sourceText :: String+ , sourceLocation :: FilePath+ } newtype Name = Name {deconsName :: String} deriving (Eq, Ord)@@ -256,42 +269,103 @@ tellName :: Name -> String tellName (Name n) = "module " ++ n +nameFromIdentifier :: Identifier -> Name+nameFromIdentifier =+ Name . Pos.sourceName . Term.start . Term.range +{- |+Make a dummy Range if only the module name is known.+-}+nameRange :: Name -> Term.Range+nameRange (Name n) = Exception.dummyRange n++inoutExceptionMsg :: Module.Name -> String -> Exception.Message+inoutExceptionMsg moduleName msg =+ Exception.Message Exception.InOut (Module.nameRange moduleName) msg++makeFileName :: Name -> FilePath+makeFileName (Name n) =+ FP.addExtension (FP.joinPath $ chop ('.'==) n) "hs"++ type FunctionDeclarations = M.Map Identifier [Rule]+type ConstructorDeclarations = S.Set Identifier ++empty :: Name -> Module+empty moduleName =+ Module {+ name = moduleName,+ imports = [],+ sourceText = show $ outputModuleHead moduleName,+ sourceLocation = "/dev/null",+ functions = M.empty,+ constructors = S.empty,+ controls = M.empty,+ declarations = []+ }+ -- | add, or replace (if rule with exact same lhs is already present)-add_rule :: Rule -> Module -> Module-add_rule rule@(Rule.Rule ident params _rhs) m =+addRule :: Rule -> Module -> Module+addRule rule@(Rule.Rule ident params _rhs) m = m { declarations =- update+ revUpdate (\d -> case d of- Rule_Declaration r' ->+ RuleDeclaration r' -> ident == Rule.name r' && params == Rule.parameters r' _ -> False)- (Rule_Declaration rule) $+ (RuleDeclaration rule) $ declarations m, functions = M.insertWith- (\_ -> update ((params ==) . Rule.parameters) rule)+ (\_ -> revUpdate ((params ==) . Rule.parameters) rule) ident [rule] $ functions m } +{- |+replace a matching element if it exists+and append the new element otherwise.+-} update :: (a -> Bool) -> a -> [a] -> [a] update matches x xs = let ( pre, post ) = span ( not . matches ) xs in pre ++ x : drop 1 post -make_functions ::+{- |+replace a matching element if it exists+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]-make_functions =+makeFunctions = M.fromListWith (flip (++)) . mapMaybe (\decl -> case decl of- Rule_Declaration rule -> Just (Rule.name rule, [rule])+ RuleDeclaration rule -> Just (Rule.name rule, [rule]) _ -> Nothing) +makeConstructors ::+ [Declaration] -> S.Set Identifier+makeConstructors decls = S.fromList $ do+ DataDeclaration (Data {dataRhs = summands}) <- decls+ Term.Node ident _ <- summands+ return ident +makeControls ::+ [Declaration] ->+ Exc.Exceptional Exception.Message Controls.Assignments+makeControls decls =+ flip (foldr+ (\r go a -> Controls.collect r >>= Controls.union a >>= go)+ return) M.empty $ do+ Module.RuleDeclaration rule <- decls+ return $ Rule.rhs rule++ {- We do not define the instance Input Module, because for proper module parsing@@ -300,10 +374,11 @@ instance Input Module where input = do -}-parse ::+parser :: FilePath -> String ->- Parsec.GenParser Char () Module-parse srcLoc srcText = do+ Parsec.GenParser Char ()+ (Exc.Exceptional Exception.Message Module)+parser srcLoc srcText = do m <- Parsec.option (Name "Main") $ do reserved lexer "module" m <- input@@ -312,27 +387,40 @@ return m is <- Parsec.many input ds <- Parsec.many input- return $ Module {- name = m, imports = is, declarations = ds,- functions = make_functions ds,- source_text = srcText,- source_location = srcLoc }+ return $ do+ ctrls <- makeControls ds+ return $ Module {+ name = m, imports = is, declarations = ds,+ functions = makeFunctions ds,+ constructors = makeConstructors ds,+ controls = ctrls,+ sourceText = srcText,+ sourceLocation = srcLoc+ } -parseUntilEOF ::- FilePath -> String ->- Parsec.GenParser Char () Module-parseUntilEOF srcLoc srcText = do- m <- parse srcLoc srcText- Parsec.eof- return m+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 ++outputModuleHead :: Name -> Pretty.Doc+outputModuleHead nm =+ hsep [ text "module", output nm, text "where" ]+ instance Output Module where output p = vcat- [ hsep [ text "module", output $ name p, text "where" ]+ [ outputModuleHead (name p) , vcat $ map output $ imports p , vcat $ map output $ declarations p ] instance Show Module where show = render . output--- instance Read Module where readsPrec = parsec_reader+-- instance Read Module where readsPrec = parsecReader
src/Option.hs view
@@ -1,8 +1,9 @@ module Option where import qualified Module+import qualified Time import qualified IO-import Option.Utility ( exitFailureMsg, fmapOptDescr )+import Option.Utility ( exitFailureMsg, fmapOptDescr, parseNumber ) import qualified HTTPServer.Option as HTTP import qualified Text.ParserCombinators.Parsec as Parsec@@ -10,7 +11,7 @@ import qualified Paths_live_sequencer as Paths import qualified System.Console.GetOpt as Opt import System.Console.GetOpt- (getOpt, ArgOrder(..), ArgDescr(..), usageInfo, )+ (getOpt, usageInfo, ArgDescr(NoArg, ReqArg), ) import System.Environment (getArgs, getProgName, ) import System.FilePath ( (</>), searchPathSeparator ) @@ -19,14 +20,18 @@ import Control.Monad ( when ) +import qualified Utility.NonEmptyList as NEList+import Data.Traversable ( forM ) import Data.List.HT ( chop ) import Data.List ( intercalate ) data Option = Option {- moduleName :: Module.Name,+ moduleNames :: [Module.Name], importPaths :: [FilePath],- connectTo, connectFrom :: Maybe String,+ connect :: NEList.T Port,+ sequencerName :: String,+ limits :: Limits, httpOption :: HTTP.Option } @@ -35,14 +40,42 @@ dataDir <- Paths.getDataDir return $ Option {- moduleName = error "no module specified",- importPaths = map (dataDir </>) [ "data", "data" </> "prelude" ],- connectTo = Nothing,- connectFrom = Nothing,+ moduleNames = [],+ importPaths =+ map ((dataDir </>) . ("data" </>))+ [ "prelude", "base", "example" ],+ connect = NEList.singleton (Port "inout" (Just []) (Just [])),+ sequencerName = "Rewrite-Sequencer",+ limits = limitsDeflt, httpOption = HTTP.deflt } +data Port =+ Port {+ portName :: String,+ connectFrom, connectTo :: Maybe [String]+ }+++data Limits =+ Limits {+ maxTermSize, maxTermDepth,+ maxReductions,+ maxEvents :: Int,+ eventPeriod :: Time.Milliseconds Integer+ }++limitsDeflt :: Limits+limitsDeflt = Limits {+ maxTermSize = 2000,+ maxTermDepth = 100,+ maxReductions = 1000,+ maxEvents = 150,+ eventPeriod = Time.milliseconds 1000+ }++ {- Guide for common Linux/Unix command-line options: http://www.faqs.org/docs/artu/ch10s05.html@@ -53,7 +86,7 @@ (NoArg $ \ _flags -> do programName <- getProgName putStrLn $- usageInfo ("Usage: " ++ programName ++ " [OPTIONS]") $+ usageInfo ("Usage: " ++ programName ++ " [OPTIONS] MODULE") $ description deflt Exit.exitSuccess) "show options" :@@ -63,25 +96,94 @@ ("colon separated import paths,\ndefault " ++ intercalate ":" (importPaths deflt)) : Opt.Option ['p'] ["connect-to"]- (flip ReqArg "ALSA-PORT" $ \str flags ->- return $ flags{connectTo = Just str})- ("connect to an ALSA port at startup") :+ (flip ReqArg "ADDRESS" $ \str flags ->+ case connect flags of+ NEList.Cons port ports ->+ case connectTo port of+ Just conns ->+ return $ flags{connect = NEList.Cons+ (port{connectTo = Just $ str : conns}) ports}+ _ ->+ exitFailureMsg $+ "cannot connect to " ++ str +++ ", since port " ++ portName port ++ " does not allow output")+ ("connect to an ALSA port at startup,\n" +++ "multiple connections per port are possible") : Opt.Option [] ["connect-from"]- (flip ReqArg "ALSA-PORT" $ \str flags ->- return $ flags{connectFrom = Just str})+ (flip ReqArg "ADDRESS" $ \str flags ->+ case connect flags of+ NEList.Cons port ports ->+ case connectFrom port of+ Just conns ->+ return $ flags{connect = NEList.Cons+ (port{connectFrom = Just $ str : conns}) ports}+ _ ->+ exitFailureMsg $+ "cannot connect from " ++ str +++ ", since port " ++ portName port ++ " does not allow input") ("connect from an ALSA port at startup") :+ Opt.Option [] ["new-out-port"]+ (flip ReqArg "PORTNAME" $ \str flags ->+ return $ flags{connect =+ NEList.cons (Port str Nothing (Just [])) $+ connect flags})+ ("create new ALSA output port and add 16 MIDI channels") :+ Opt.Option [] ["sequencer-name"]+ (flip ReqArg "NAME" $ \str flags ->+ return $ flags{sequencerName = str})+ ("name of the ALSA sequencer client, default " +++ sequencerName deflt) : map (fmapOptDescr $ \update old -> do+ newLimits <- update $ limits old+ return $ old {limits = newLimits})+ (limitsDescription (limits deflt)) +++ map (fmapOptDescr $ \update old -> do newHTTP <- update $ httpOption old return $ old {httpOption = newHTTP}) HTTP.description +limitsDescription :: Limits -> [ Opt.OptDescr (Limits -> IO Limits) ]+limitsDescription deflt =+ Opt.Option [] ["max-term-size"]+ (flip ReqArg "SIZE" $ \str flags ->+ fmap (\p -> flags{maxTermSize = fromInteger p}) $+ parseNumber "term size" (\n -> 0<n && n<1000000000) "positive 30 bit" str)+ ("maximum allowed term size, default " +++ show (maxTermSize deflt)) :+ Opt.Option [] ["max-term-depth"]+ (flip ReqArg "SIZE" $ \str flags ->+ fmap (\p -> flags{maxTermDepth = fromInteger p}) $+ parseNumber "term depth" (\n -> 0<n && n<1000000000) "positive 30 bit" str)+ ("maximum allowed term depth, default " +++ show (maxTermDepth deflt)) :+ Opt.Option [] ["max-reductions"]+ (flip ReqArg "NUMBER" $ \str flags ->+ fmap (\p -> flags{maxReductions = fromInteger p}) $+ parseNumber "number of reductions" (\n -> 0<n && n<1000000000) "positive 30 bit" str)+ ("maximum allowed reductions for every list element, default " +++ show (maxReductions deflt)) :+ Opt.Option [] ["max-events-per-period"]+ (flip ReqArg "NUMBER" $ \str flags ->+ fmap (\p -> flags{maxEvents = fromInteger p}) $+ parseNumber "number of events" (\n -> 0<n && n<1000000000) "positive 30 bit" str)+ ("maximum number of allowed events per period, default " +++ show (maxEvents deflt)) :+ Opt.Option [] ["event-period"]+ (flip ReqArg "MILLISECONDS" $ \str flags ->+ fmap (\p -> flags{eventPeriod = Time.milliseconds p}) $+ parseNumber "event period" (\n -> 0<n && n<1000000000) "positive 30 bit" str)+ ("period for limitting adjacent events, default " +++ Time.format (eventPeriod deflt)) :+ []++ get :: IO Option get = do argv <- getArgs deflt <- getDeflt let (opts, files, errors) =- getOpt RequireOrder (description deflt) argv+ getOpt Opt.RequireOrder (description deflt) argv when (not $ null errors) $ exitFailureMsg (init (concat errors)) @@ -90,10 +192,12 @@ fmap (\o -> o { importPaths = map (dir </>) $ importPaths o } ) $ foldl (>>=) (return deflt) opts - case files of- [] -> exitFailureMsg "no module specified"- _:_:_ -> exitFailureMsg "more than one module specified"- [modu] ->- case Parsec.parse IO.input "" modu of- Right name -> return $ parsedOpts {moduleName = name}+ names <-+ forM files $ \modu ->+ case Parsec.parse IO.input modu modu of+ Right name -> return name Left _ -> exitFailureMsg $ show modu ++ " is not a module name"+ return $ parsedOpts {+ connect = NEList.reverse $ connect parsedOpts,+ moduleNames = names+ }
src/Program.hs view
@@ -1,70 +1,137 @@ module Program where -import Term ( Range (Range, start), Identifier (..) )+import Term ( Identifier ) import Module ( Module )+import qualified Term import qualified Module import qualified Log import qualified Exception+import qualified ControlsBase as Controls import qualified Control.Monad.Exception.Synchronous as Exc import Control.Monad.Trans.Class ( lift ) import qualified Control.Exception as ExcBase -import Text.ParserCombinators.Parsec ( parse )-import qualified Text.ParserCombinators.Parsec.Pos as Pos-import qualified Text.ParserCombinators.Parsec.Error as PErr-+import qualified System.IO.Strict as StrictIO import System.Directory ( doesFileExist ) import System.FilePath ( (</>) ) import qualified System.IO.Error as Err-import qualified System.FilePath as FP +import qualified Data.Foldable as Fold import qualified Data.Traversable as Trav import qualified Data.Map as M-import Control.Monad ( foldM )-import Data.List.HT ( chop )+import qualified Data.Set as S+import Control.Monad ( foldM, liftM4 ) -data Program = Program- { modules :: M.Map Module.Name Module- , functions :: Module.FunctionDeclarations- }+data Program =+ Program+ { modules :: M.Map Module.Name Module+ , functions :: Module.FunctionDeclarations+ , constructors :: Module.ConstructorDeclarations+ , controls :: Controls.Assignments+ , controlValues :: Controls.Values+ } -- deriving (Show) empty :: Program empty =- Program { modules = M.empty, functions = M.empty }+ Program {+ modules = M.empty,+ functions = M.empty,+ constructors = S.empty,+ controls = M.empty,+ controlValues = Controls.emptyValues+ } -add_module ::+singleton :: Module -> Program+singleton m =+ Program {+ modules = M.singleton (Module.name m) m,+ functions = Module.functions m,+ constructors = Module.constructors m,+ controls = Module.controls m,+ controlValues = Controls.emptyValues+ }++{- |+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-add_module m p =- fmap (\newFuncs ->- p { modules = M.insert ( Module.name m ) m $ modules p,- functions = newFuncs }) $- union_functions ( Module.functions m ) $- M.difference- (functions p)- (M.findWithDefault M.empty ( Module.name m )- ( fmap Module.functions $ modules p ))+addModule m p =+ liftM4+ ( Program ( M.insert ( Module.name m ) m ( modules p ) ) )+ ( unionDecls ( Module.functions m ) ( functions p ) )+ ( fmap M.keysSet $+ unionDecls+ ( mapFromSet $ Module.constructors m )+ ( mapFromSet $ constructors p ) )+ ( Controls.union+ ( Controls.updateValues+ ( controlValues p ) ( Module.controls m ) )+ ( controls p ) )+ ( return $ controlValues p ) -union_functions ::- Module.FunctionDeclarations ->- Module.FunctionDeclarations ->- Exc.Exceptional Exception.Message Module.FunctionDeclarations-union_functions m0 m1 =+removeModule ::+ Module.Name -> Program -> Program+removeModule nm p =+ case M.lookup nm $ modules p of+ Nothing -> p+ Just m -> Program {+ modules = M.delete nm $ modules p,+ functions = M.difference ( functions p ) ( Module.functions m ),+ constructors =+ S.difference ( constructors p ) ( Module.constructors m ),+ controls = M.difference ( controls p ) ( Module.controls m ),+ controlValues = controlValues p+ }++replaceModule ::+ Module -> Program ->+ Exc.Exceptional Exception.Message 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 )+unionDecls m0 m1 = let f = M.mapWithKey (\nm rs -> (nm, Exc.Success rs)) in Trav.sequenceA . fmap snd $ M.unionWith (\(n0,_) (n1,_) -> (n0, Exc.Exception $ Exception.Message Exception.Parse- (range n0)+ (Term.range n0) ("duplicate definition of " ++ show n0 ++- " in " ++ (show $ Pos.sourceName $ start $ range n0) ++- " and " ++ (show $ Pos.sourceName $ start $ range n1))))+ " 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 seed p =+ let trace modName ms =+ if S.member modName ms+ then foldl (flip trace) (S.delete modName ms) $+ maybe [] (map Module.source . Module.imports) $+ M.lookup modName (modules p)+ else ms+ removed = trace seed $ M.keysSet $ modules p+ in (removed, Fold.foldl (flip removeModule) p removed)++ -- | load from disk, with import chasing chase :: [ FilePath ] -> Module.Name ->@@ -81,29 +148,34 @@ Just _ -> lift $ do Log.put $ "module is already loaded" return p- Nothing ->- let nn = Module.deconsName n- in load dirs p nn =<<- chaseFile dirs- ( FP.addExtension (FP.joinPath $ chop ('.'==) nn) "hs" )+ Nothing -> do+ path <- chaseFile dirs ( Module.makeFileName n )+ load dirs ( Module.deconsName n ) path p +chaseMany ::+ [ FilePath ] -> [ Module.Name ] -> Program ->+ Exc.ExceptionalT Exception.Message IO Program+chaseMany dirs names p =+ foldM ( chaser dirs ) p names++chaseImports ::+ [ FilePath ] -> Module.Module -> Program ->+ Exc.ExceptionalT Exception.Message IO Program+chaseImports dirs =+ chaseMany dirs . map Module.source . Module.imports+ load ::- [ FilePath ] -> Program -> String -> FilePath ->+ [ FilePath ] -> String -> FilePath -> Program -> Exc.ExceptionalT Exception.Message IO Program-load dirs p n ff = do- parseResult <-+load dirs n ff p = do+ content <- Exc.mapExceptionT (\e -> Exception.Message- Exception.InOut (dummyRange ff) (Err.ioeGetErrorString e)) $- Exc.fromEitherT $ ExcBase.try $- fmap (\s -> parse (Module.parseUntilEOF ff s) n s) $ readFile ff- case parseResult of- Left err -> Exc.throwT (messageFromParserError err)- Right m -> do- lift $ Log.put $ show m- pNew <- Exc.ExceptionalT $ return $ add_module m p- foldM ( chaser dirs ) pNew $- map Module.source $ Module.imports m+ 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 ) -- | look for file, trying to append its name to the directories in the path, -- in turn. Will fail if file is not found.@@ -121,26 +193,6 @@ return ff else go) (Exc.throwT $ Exception.Message Exception.InOut- (dummyRange f)+ (Exception.dummyRange f) (unwords [ "module", "not", "found:", f ])) dirs--dummyRange :: String -> Range-dummyRange f =- let pos = Pos.initialPos f- in Range pos pos--messageFromParserError :: PErr.ParseError -> Exception.Message-messageFromParserError err = Exception.Message- Exception.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)--removeLeadingNewline :: String -> String-removeLeadingNewline ('\n':str) = str-removeLeadingNewline str = str
src/Rewrite.hs view
@@ -1,41 +1,57 @@ module Rewrite where -import Term ( Term(..), Identifier(..), Range(..), termRange )-import Program+import Term ( Term(Node, Number, StringLiteral),+ Identifier(Identifier, range, name), Range, termRange )+import Program ( Program )+import qualified Program import qualified Term import qualified Rule-import qualified Module -import Control.Monad.Trans.Reader ( Reader, runReader, asks )-import Control.Monad.Trans.Writer ( WriterT, runWriter, tell, mapWriterT )+import qualified Control.Monad.Trans.Writer as MW+import qualified Control.Monad.Trans.RWS as MRWS+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 )+ mapExceptionalT, throwT, assertT ) import qualified Data.Map as M+import qualified Data.Set as S import qualified Data.Traversable as Trav import Data.Maybe.HT ( toMaybe ) import Data.Tuple.HT ( mapSnd ) import Data.List ( intercalate ) +-- import Debug.Trace ( trace ) -data Message = Step { target :: Identifier- , rule :: Maybe Identifier -- ^ Nothing for builtins- }- | Data { origin :: Identifier }++data Message =+ Step { target :: Identifier }+ | Rule { rule :: Identifier }+ | Data { origin :: Identifier } deriving Show +type Count = Int+ type Evaluator =- ExceptionalT (Range, String) ( WriterT [ Message ] ( Reader Program ) )+ ExceptionalT (Range, String) ( RWS (Count, Program) [ Message ] Count ) + runEval :: (Monad m) =>- Program -> Evaluator a ->- ExceptionalT (Range, String) ( WriterT [ Message ] m ) a-runEval p =- mapExceptionalT (mapWriterT (return . flip runReader p))+ Count -> Program -> Evaluator a ->+ ExceptionalT (Range, 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 -> MW.WriterT $ return $ MRWS.evalRWS evl (maxRed,p) 0)+{-+ mapExceptionalT (\evl ->+ MW.WriterT $ return $+ (\(a,s,w) -> trace (show s) (a,w)) $+ MRWS.runRWS evl (maxRed,p) 0)+-} + exception :: Range -> String -> Evaluator a exception rng msg = throwT $ (rng, msg)@@ -44,8 +60,8 @@ -- | force head of stream: -- evaluate until we have Cons or Nil at root, -- then evaluate first argument of Cons fully.-force_head :: Term -> Evaluator Term-force_head t = do+forceHead :: Term -> Evaluator Term+forceHead t = do t' <- top t case t' of Node i [ x, xs ] | name i == ":" -> do@@ -65,26 +81,25 @@ Node f args -> fmap (Node f) $ mapM full args Number _ _ -> return x'- String_Literal _ _ -> return x'+ StringLiteral _ _ -> return x' -- | evaluate until root symbol is constructor. top :: Term -> Evaluator Term top t = case t of Number {} -> return t- String_Literal {} -> return t+ StringLiteral {} -> return t Node f xs -> if Term.isConstructor f then return t- else do- rs <- lift $ lift $ asks functions- eval rs f xs >>= top+ else eval f xs >>= top -- | do one reduction step at the root-eval :: Module.FunctionDeclarations -> Identifier -> [Term] -> Evaluator Term-eval _ i xs+eval ::+ Identifier -> [Term] -> Evaluator Term+eval i xs | name i `elem` [ "compare", "<", "-", "+", "*", "div", "mod" ] = do ys <- mapM top xs- lift $ tell $ [ Step { target = i, rule = Nothing } ]+ lift $ tell $ [ Step { target = i } ] case ys of [ Number _ a, Number _ b] -> case name i of@@ -106,25 +121,30 @@ exception (range i) $ "unknown operation " ++ show opName _ -> exception (range i) $ "wrong number of arguments" -eval funcs g ys =+eval g ys = do+ funcs <- lift $ asks ( Program.functions . snd ) case M.lookup g funcs of Nothing -> exception (range g) $ unwords [ "unknown function", show $ Node g ys ] Just rules ->- eval_decls g rules ys+ evalDecls g rules ys -eval_decls :: Identifier -> [ Rule.Rule ] -> [Term] -> Evaluator Term-eval_decls g =+evalDecls ::+ Identifier -> [ Rule.Rule ] -> [Term] -> Evaluator Term+evalDecls g = foldr (\(Rule.Rule f xs rhs) go ys -> do- (m, ys') <- match_expand_list M.empty xs ys+ (m, ys') <- matchExpandList M.empty xs ys case m of Nothing -> go ys' Just (substitions, additionalArgs) -> do- lift $ tell [ Step { target = g- , rule = Just f } ]+ conss <- lift $ asks ( Program.constructors . snd )+ lift $ tell $+ Step g : Rule f :+ ( map Data $ S.toList $ S.intersection conss $+ S.fromList $ foldr constructors [] xs ) rhs' <- apply substitions rhs appendArguments rhs' additionalArgs) (\ys ->@@ -132,6 +152,13 @@ unwords [ "no matching pattern for function", show g, "and arguments", show ys ]) +constructors :: Term -> [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 f xs = case Term.appendArguments f xs of@@ -142,10 +169,10 @@ -- | check whether term matches pattern. -- do some reductions if they are necessary to decide about the match. -- return the reduced term in the second result component.-match_expand ::+matchExpand :: Term -> Term -> Evaluator ( Maybe (M.Map Identifier Term) , Term )-match_expand pat t = case pat of+matchExpand pat t = case pat of Node f [] | Term.isVariable f -> return ( Just $ M.singleton f t , t ) Node f xs | Term.isConstructor f -> do@@ -155,7 +182,7 @@ if f /= g then return ( Nothing, t' ) else do- ( m, ys' ) <- match_expand_list M.empty xs ys+ ( m, ys' ) <- matchExpandList M.empty xs ys return ( fmap fst m, Node f ys' ) _ -> exception (termRange t') $@@ -171,45 +198,53 @@ _ -> exception (termRange t') $ "number pattern matched against non-number term: " ++ show t'- String_Literal _ a -> do+ StringLiteral _ a -> do t' <- top t case t' of- String_Literal _ b ->+ StringLiteral _ b -> return ( toMaybe (a==b) M.empty, t' ) _ -> exception (termRange t') $ "string pattern matched against non-string term: " ++ show t' -match_expand_list ::+matchExpandList :: M.Map Identifier Term -> [Term] -> [Term] -> Evaluator (Maybe (M.Map Identifier Term, [Term]), [Term])-match_expand_list s [] ys = return ( Just (s,ys), ys )-match_expand_list s (x:xs) (y:ys) = do- (m, y') <- match_expand x y+matchExpandList s [] ys = return ( Just (s,ys), ys )+matchExpandList s (x:xs) (y:ys) = do+ (m, y') <- matchExpand x y case m of Nothing -> return ( Nothing, y' : ys ) Just s' -> do s'' <-- case runWriter $ Trav.sequenceA $- M.unionWithKey (\var t _ -> tell [var] >> t)+ case MW.runWriter $ Trav.sequenceA $+ M.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) fmap (mapSnd (y':)) $- match_expand_list s'' xs ys-match_expand_list _ (x:_) _ =+ matchExpandList s'' xs ys+matchExpandList _ (x:_) _ = exception (termRange x) "too few arguments" apply :: M.Map Identifier Term -> Term -> Evaluator Term-apply m t = case t of+apply m t = checkMaxReductions (termRange t) >> case t of Node f xs -> do ys <- mapM ( apply m ) xs case M.lookup f m of Nothing -> return $ Node f ys Just t' -> appendArguments t' ys _ -> return t++checkMaxReductions :: Range -> Evaluator ()+checkMaxReductions rng = do+ maxCount <- lift $ asks fst+ count <- lift get+ assertT (rng, "number of reductions exceeds limit " ++ show maxCount) $+ count < maxCount+ lift $ put $ succ count
src/Rule.hs view
@@ -1,6 +1,6 @@ module Rule where -import IO+import IO ( Input(input), Output(output), parsecReader ) import Term ( Term(Node), Identifier ) import qualified Term @@ -14,7 +14,7 @@ } instance Show Rule where show = render . output-instance Read Rule where readsPrec = parsec_reader+instance Read Rule where readsPrec = parsecReader instance Output Rule where output r =
src/Step.hs view
@@ -21,9 +21,7 @@ _ -> mzero -root_step :: Rule -> Term -> Maybe Term-root_step r t = do+rootStep :: Rule -> Term -> Maybe Term+rootStep r t = do m <- match ( vars r ) ( lhs r ) t return $ apply m ( rhs r )--
src/Term.hs view
@@ -1,6 +1,6 @@ module Term where -import IO ( Input, Output, input, output, parsec_reader )+import IO ( Input, Output, input, output, parsecReader ) import qualified Text.ParserCombinators.Parsec.Token as T import qualified Text.ParserCombinators.Parsec.Language as L@@ -157,18 +157,22 @@ output i = text $ name i instance Show Identifier where show = render . output-instance Read Identifier where readsPrec = parsec_reader+instance Read Identifier where readsPrec = parsecReader data Term = Node Identifier [ Term ] | Number Range Integer- | String_Literal Range String+ | StringLiteral Range String deriving ( Eq, Ord ) instance Show Term where show = render . output-instance Read Term where readsPrec = parsec_reader+instance Read Term where readsPrec = parsecReader +mainName :: Term+mainName = read "main"++ {- | simplifies case analysis -}@@ -208,11 +212,11 @@ parseAtom = (T.lexeme lexer $ fmap (uncurry Number) $ ranged (fmap read $ Parsec.many1 Parsec.digit))- <|> fmap (uncurry String_Literal)+ <|> fmap (uncurry StringLiteral) (T.lexeme lexer (ranged parseStringLiteral))--- <|> fmap (uncurry String_Literal) (ranged (T.stringLiteral lexer))+-- <|> fmap (uncurry StringLiteral) (ranged (T.stringLiteral lexer)) <|> T.parens lexer input- <|> bracketed_list+ <|> bracketedList <|> fmap (flip Node []) input parse :: Parser Term@@ -244,13 +248,13 @@ return $ \ l r -> Node ( Identifier { name = s, range = rng } ) [ l, r ] -bracketed_list :: Parser Term-bracketed_list = do+bracketedList :: Parser Term+bracketedList = do (r,_) <- ranged $ symbol "["- inside_bracketed_list r+ insideBracketedList r -inside_bracketed_list :: Range -> Parser Term-inside_bracketed_list rng =+insideBracketedList :: Range -> Parser Term+insideBracketedList rng = do (r,_) <- ranged $ symbol "]" return $ Node ( Identifier { name = "[]", range = r } ) [] <|> do x <- input@@ -258,13 +262,13 @@ xs <- do symbol "]" ; r <- getPosition return $ Node ( Identifier { name = "[]", range = Range q r } ) [] <|> do symbol "," ; r <- getPosition- inside_bracketed_list $ Range q r+ insideBracketedList $ Range q r return $ Node ( Identifier { name = ":", range = rng } ) [ x, xs ] instance Output Term where output t = case t of Number _ n -> text $ show n- String_Literal _ s -> text $ show s+ StringLiteral _ s -> text $ show s Node f args -> output f <+> fsep ( map protected args ) protected :: Term -> Doc@@ -273,13 +277,27 @@ _ -> output t -type Position = [ Int ]- termRange :: Term -> Range termRange (Node i _) = range i termRange (Number rng _) = rng-termRange (String_Literal rng _) = rng+termRange (StringLiteral rng _) = rng +{- |+compute the number of nodes in the same depth+-}+breadths :: Term -> [ Int ]+breadths t = 1 : case t of+ Node _f xs -> foldl addList [] $ map breadths xs+ _ -> []++addList :: [ Int ] -> [ Int ] -> [ Int ]+addList (x:xs) (y:ys) = (x+y) : addList xs ys+addList [] ys = ys+addList xs [] = xs+++type Position = [ Int ]+ subterms :: Term -> [ (Position, Term) ] subterms t = ( [], t ) : case t of Node _f xs -> do@@ -305,3 +323,5 @@ let (pre, x : post) = splitAt k xs y <- poke x ks s return $ Node f $ pre ++ y : post+poke _ (_:_) _ =+ error "Term.poke: cannot access a leaf with an index"
+ src/Time.hs view
@@ -0,0 +1,110 @@+{-# LANGUAGE EmptyDataDecls #-}+module Time where++import Control.Concurrent ( threadDelay )+import qualified Data.Monoid as Mn+++newtype Time factor a = Time a+ deriving (Eq, Ord, Show)++instance Functor (Time factor) where+ fmap f (Time a) = Time (f a)+++instance (Num a) => Mn.Monoid (Time factor a) where+ mempty = Time 0+ mappend (Time x) (Time y) = Time (x+y)++sub :: Num a => Time factor a -> Time factor a -> Time factor a+sub (Time x) (Time y) = Time (x-y)+++data One+data EM3 a++type Milli = EM3 One+type Micro = EM3 Milli+type Nano = EM3 Micro++type Seconds a = Time One a+type Milliseconds a = Time Milli a -- unit in Wait constructor+type Microseconds a = Time Micro a -- unit of threadDelay+type Nanoseconds a = Time Nano a -- unit of ALSA realtime+++up :: Num a => Time factor a -> Time (EM3 factor) a+up (Time a) = Time (1000*a)+++class Factor factor where+ seconds :: Num a => a -> Time factor a++instance Factor One where+ seconds = Time++instance Factor factor => Factor (EM3 factor) where+ seconds = up . seconds+++mul3 :: Time factor a -> Time (EM3 factor) a+mul3 (Time t) = Time t++milliseconds ::+ (Factor factor, Num a) =>+ a -> Time (EM3 factor) a+milliseconds =+ mul3 . seconds++nanoseconds ::+ (Factor factor, Num a) =>+ a -> Time (EM3 (EM3 (EM3 factor))) a+nanoseconds =+ mul3 . mul3 . mul3 . seconds+++pause :: Time Micro Int -> IO ()+pause (Time t) = threadDelay t++++-- | we check by the types whether we can format the time value or not+class Format factor where+ formatUnit :: Time factor a -> String++instance Format One where+ formatUnit = const "s"+++class Format1 factor where+ formatUnit1 :: Time (EM3 factor) a -> String++instance Format1 One where+ formatUnit1 = const "ms"++instance Format1 factor => Format (EM3 factor) where+ formatUnit = formatUnit1+++class Format2 factor where+ formatUnit2 :: Time (EM3 (EM3 factor)) a -> String++instance Format2 One where+ formatUnit2 = const "us"++instance Format2 factor => Format1 (EM3 factor) where+ formatUnit1 = formatUnit2+++class 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+++format :: (Format factor, Show a) => Time factor a -> String+format time@(Time t) = show t ++ formatUnit time
src/Utility/Concurrent.hs view
@@ -5,6 +5,12 @@ import Control.Monad.STM ( STM ) import qualified Control.Monad.STM as STM +import qualified Control.Monad.Trans.Class as MT+import qualified Control.Monad.Trans.State as MS+import qualified Control.Monad.Trans.Writer as MW+import qualified Control.Monad.Exception.Synchronous as Exc+import Data.Monoid ( Monoid )+ import Control.Functor.HT ( void ) @@ -19,3 +25,19 @@ writeTChanIO :: TChan a -> a -> IO () writeTChanIO chan a = STM.atomically $ writeTChan chan a+++class Monad m => MonadSTM m where+ liftSTM :: STM a -> m a++instance MonadSTM STM where+ liftSTM = id++instance (MonadSTM m, Monoid w) => MonadSTM (MW.WriterT w m) where+ liftSTM = MT.lift . liftSTM++instance MonadSTM m => MonadSTM (MS.StateT s m) where+ liftSTM = MT.lift . liftSTM++instance MonadSTM m => MonadSTM (Exc.ExceptionalT e m) where+ liftSTM = MT.lift . liftSTM
+ src/Utility/NonEmptyList.hs view
@@ -0,0 +1,39 @@+{-+See also packages NonEmpty and NonEmptyList,+where NonEmpty is not much useful functions+and NonEmptyList depends on a large number of packages.+-}+module Utility.NonEmptyList where++import Data.Foldable (Foldable, foldr, )++import qualified Prelude as P+import Prelude (Eq, Ord, Show, Functor, fmap, flip, ($), )+++data T a = Cons { head :: a, tail :: [a] }+ deriving (Eq, Ord, Show)+++instance Functor T where+ fmap f (Cons x xs) = Cons (f x) (fmap f xs)++instance Foldable T where+ foldr f y (Cons x xs) = f x $ foldr f y xs+++toList :: T a -> [a]+toList (Cons x xs) = x:xs++cons :: a -> T a -> T a+cons x0 (Cons x1 xs) = Cons x0 (x1:xs)++singleton :: a -> T a+singleton x = Cons x []++reverse :: T a -> T a+reverse (Cons x xs) =+ P.foldl (flip cons) (singleton x) xs++mapHead :: (a -> a) -> T a -> T a+mapHead f (Cons x xs) = Cons (f x) xs
src/Utility/WX.hs view
@@ -35,3 +35,6 @@ WX.newAttr "selection" WXCMZ.notebookGetSelection (\nb -> void . WXCMZ.notebookSetSelection nb)++splitterWindowSetSashGravity :: WX.SplitterWindow a -> Double -> IO ()+splitterWindowSetSashGravity _w _g = return ()