live-sequencer (empty) → 0.0
raw patch · 52 files changed
+5471/−0 lines, 52 filesdep +alsa-coredep +alsa-seqdep +basesetup-changed
Dependencies added: alsa-core, alsa-seq, base, cgi, containers, data-accessor, data-accessor-transformers, directory, event-list, explicit-exception, filepath, html, httpd-shed, midi, midi-alsa, network, non-negative, parsec, pretty, process, stm, strict, transformers, utility-ht, wx, wxcore
Files
- LICENSE +1/−0
- Setup.lhs +3/−0
- data/Band.hs +34/−0
- data/Bool.hs +24/−0
- data/Chords.hs +41/−0
- data/CrossSum.hs +62/−0
- data/DeBruijn.hs +49/−0
- data/Drum.hs +76/−0
- data/Fibonacci.hs +48/−0
- data/Finite.hs +18/−0
- data/Function.hs +34/−0
- data/Instrument.hs +135/−0
- data/Integer.hs +5/−0
- data/Klingklong.hs +261/−0
- data/List.hs +141/−0
- data/ListLive.hs +114/−0
- data/Midi.hs +153/−0
- data/Music.hs +100/−0
- data/Pattern.hs +38/−0
- data/Pitch.hs +38/−0
- data/Render.hs +82/−0
- data/Simplesong.hs +20/−0
- data/Sweep.hs +39/−0
- data/Tuple.hs +9/−0
- data/UD.hs +62/−0
- data/prelude/Prelude.hs +31/−0
- http/disable/HTTPServer/GUI.hs +46/−0
- http/disable/HTTPServer/Option.hs +12/−0
- http/enable/HTTPServer.hs +209/−0
- http/enable/HTTPServer/GUI.hs +120/−0
- http/enable/HTTPServer/Option.hs +31/−0
- live-sequencer.cabal +236/−0
- src/ALSA.hs +134/−0
- src/Console.hs +80/−0
- src/Controls.hs +109/−0
- src/Event.hs +314/−0
- src/Exception.hs +50/−0
- src/GUI.hs +1055/−0
- src/IO.hs +18/−0
- src/Lilypond.hs +71/−0
- src/Log.hs +11/−0
- src/Module.hs +338/−0
- src/Option.hs +99/−0
- src/Option/Utility.hs +34/−0
- src/Program.hs +146/−0
- src/Rewrite.hs +215/−0
- src/Rule.hs +37/−0
- src/Step.hs +29/−0
- src/Term.hs +307/−0
- src/Type.hs +94/−0
- src/Utility/Concurrent.hs +21/−0
- src/Utility/WX.hs +37/−0
+ LICENSE view
@@ -0,0 +1,1 @@+GPL
+ Setup.lhs view
@@ -0,0 +1,3 @@+#! /usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ data/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/Bool.hs view
@@ -0,0 +1,24 @@+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 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/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/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/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/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/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/Function.hs view
@@ -0,0 +1,34 @@+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 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/Integer.hs view
@@ -0,0 +1,5 @@+module Integer where++isZero :: Integer -> Bool ;+isZero 0 = True ;+isZero _ = False ;
+ data/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/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/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/Midi.hs view
@@ -0,0 +1,153 @@+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 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/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/Pitch.hs view
@@ -0,0 +1,38 @@+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 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/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/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/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/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 ]+ ] ) ;
+ data/prelude/Prelude.hs view
@@ -0,0 +1,31 @@+module Prelude where++import Bool+import Integer+++data Ordering = LT | EQ | GT ;++signumFromOrdering LT = 0-1 ;+signumFromOrdering EQ = 0 ;+signumFromOrdering GT = 1 ;++signum x = signumFromOrdering (compare x 0) ;++abs x = signum x * x ;++(==) :: Integer -> Integer -> Bool ;+x == y = isZero (x-y) ;++min x y = ifThenElse (x<y) x y ;++negate x = 0 - x ;++succ x = x+1 ;+pred x = x-1 ;++-- fromInteger :: Integer -> Int ;+fromInteger x = x ;++-- fromIntegral :: Int -> Integer ;+fromIntegral x = x ;
+ http/disable/HTTPServer/GUI.hs view
@@ -0,0 +1,46 @@+module HTTPServer.GUI (+ run,+ GuiUpdate,+ Feedback,+ update,+ methods,+ ) where++import qualified HTTPServer.Option as Option++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+++-- custom 'data' would be nicer, but it yields warning about unused constructor+-- EmptyDataDecls would be a way out+type GuiUpdate = ()++type Error = ()++data Methods = Methods++type Feedback = Exc.Exceptional Error (Maybe String, String)++run :: Methods -> Option.Option -> IO ()+run _dict _opt = return ()++methods :: (GuiUpdate -> IO ()) -> Methods+methods _output = Methods++update ::+ (MVar Feedback -> Module.Name -> String -> Int -> IO ()) ->+ WX.StatusField ->+ IORef (M.Map Module.Name (a, TextCtrl b, c)) ->+ GuiUpdate ->+ IO ()+update _input _status _panels _req = return ()
+ http/disable/HTTPServer/Option.hs view
@@ -0,0 +1,12 @@+module HTTPServer.Option where++import qualified System.Console.GetOpt as Opt+++data Option = Option++deflt :: Option+deflt = Option++description :: [Opt.OptDescr (Option -> IO Option)]+description = []
+ http/enable/HTTPServer.hs view
@@ -0,0 +1,209 @@+module HTTPServer (+ Methods(Methods),+ run,+ getModuleList,+ getModuleContent,+ updateModuleContent,+ separatorLine,+ splitProtected,+ Error, notFound,+ ) where++import qualified HTTPServer.Option as Option+import qualified Module+import qualified IO++import qualified Network.Shed.Httpd as HTTPd+import qualified Network.CGI as CGI+import Network.URI ( uriPath )++import Text.Html((<<), (+++), )+import qualified Text.Html as Html++import qualified Control.Monad.Exception.Synchronous as Exc+import Control.Monad.Exception.Synchronous ( ExceptionalT )++import qualified Text.ParserCombinators.Parsec as Parsec++import qualified Control.Monad.Trans.Class as MT++import qualified Data.List.HT as ListHT+import qualified Data.List as List+import Data.Tuple.HT ( mapPair )+import Control.Functor.HT ( void )+++headers :: [(String, String)]+headers =+ [("Content-Type", "text/html; charset=latin1")]++data Error = Error Int String++badRequest :: String -> Error+badRequest = Error 400++notFound :: String -> Error+notFound = Error 404++methodNotAllowed :: String -> Error+methodNotAllowed = Error 405+++data Methods =+ Methods {+ getModuleList :: IO [Module.Name],+ getModuleContent ::+ Module.Name -> ExceptionalT Error IO String,+ updateModuleContent ::+ Module.Name -> String ->+ ExceptionalT Error IO (Maybe String, String)+ }++run :: Methods -> Option.Option -> IO ()+run dict opt = + case Option.port opt of+ Option.Port port ->+ void $ HTTPd.initServer port $+ handleException . server dict++server ::+ Methods ->+ HTTPd.Request ->+ ExceptionalT Error IO HTTPd.Response+server dict req =+ case HTTPd.reqMethod req of+ "GET" ->+ case uriPath (HTTPd.reqURI req) of+ "/" ->+ MT.lift $+ fmap (HTTPd.Response 200 headers . formatModuleList) $+ getModuleList dict+ '/':modName -> do+ modList <- MT.lift $ getModuleList dict+ modIdent <- parseModuleName modName+ content <- getModuleContent dict modIdent+ return $ HTTPd.Response 200 headers $+ formatModuleContent modList modIdent (Nothing, content)+ _ ->+ Exc.throwT $ badRequest $ "Bad path in URL"+ "POST" ->+ case uriPath $ HTTPd.reqURI req of+ '/':modName -> do+ modList <- MT.lift $ getModuleList dict+ modIdent <- parseModuleName modName+ editable <-+ case lookup "content" $ CGI.formDecode $ HTTPd.reqBody req of+ Just str -> return str+ _ -> Exc.throwT $ badRequest $+ "Argument 'content' missing"+ updatedContent <-+ updateModuleContent dict modIdent editable+ return $ HTTPd.Response 200 headers $+ formatModuleContent modList modIdent updatedContent+ _ ->+ Exc.throwT $ badRequest $ "Bad path in URL"+ method ->+ Exc.throwT $ methodNotAllowed $+ "Method " ++ method ++ " not allowed"+++handleException ::+ (Monad m) =>+ ExceptionalT Error m HTTPd.Response -> m HTTPd.Response+handleException =+ Exc.resolveT $ \(Error errorCode msg) ->+ return $+ HTTPd.Response errorCode headers $+ Html.renderHtml $+ Html.header (Html.thetitle <<+ ("Haskell Live Sequencer - Error " ++ show errorCode)) ++++ (Html.body $ Html.concatHtml $+ map (\line -> Html.toHtml line +++ Html.br) $ lines msg)+++parseModuleName ::+ (Monad m) =>+ String -> ExceptionalT Error m Module.Name+parseModuleName modName =+ Exc.mapExceptionT+ (badRequest .+ ("syntax error in module name:\n"++) .+ show) $+ Exc.fromEitherT $ return $+ Parsec.parse+ (Parsec.between (return ()) Parsec.eof IO.input)+ "" modName++formatModuleList :: [Module.Name] -> String+formatModuleList list =+ Html.renderHtml $+ Html.header (Html.thetitle << "Haskell Live Sequencer - Module list") ++++ Html.body (htmlFromModuleList list)++formatModuleContent ::+ [Module.Name] -> Module.Name -> (Maybe String, String) -> String+formatModuleContent list name (mmsg, content) =+ Html.renderHtml $+ Html.header (Html.thetitle <<+ ("Haskell Live Sequencer - " ++ Module.tellName name)) ++++ (Html.body $+ sideBySide+ (htmlFromModuleList list)+ (Html.h1 << Module.deconsName name ++++ maybe Html.noHtml+ (\msg -> (Html.! [Html.color Html.red]) $ Html.font $+ htmlFromMultiline $ "error:\n" ++ msg) mmsg ++++ ((Html.! [Html.action $ Module.deconsName name, Html.method "post",+ Html.HtmlAttr "accept-charset" "ISO-8859-1"]) $+ Html.form $+ case splitProtected content of+ (protected, sepEditable) ->+ Html.pre << protected+ ++++ case sepEditable of+ Nothing -> Html.noHtml+ Just (separator, editable) ->+ Html.pre << separator+ ++++ Html.textarea+ Html.! [Html.name "content",+ Html.rows "30", Html.cols "100"]+ << editable+ ++++ Html.br+ ++++ Html.submit "" "submit")))++splitProtected :: String -> (String, Maybe (String, String))+splitProtected =+ mapPair (unlines,+ \lns ->+ case lns of+ separator:suffix -> Just (separator, unlines suffix)+ [] -> Nothing) .+ ListHT.break (List.isPrefixOf separatorLine) .+ lines++separatorLine :: String+separatorLine = replicate 8 '-'++htmlFromMultiline :: String -> Html.Html+htmlFromMultiline =+ Html.concatHtml . List.intersperse Html.br .+ map Html.toHtml . lines++{-+As far as I can see,+CSS would require me to use an absolute horizontal position+for the module content.+Thus I stick to the much-maligned tables.+-}+sideBySide :: Html.Html -> Html.Html -> Html.Html+sideBySide left right =+ Html.simpleTable [] [Html.valign "top"] [[left, right]]++htmlFromModuleList :: [Module.Name] -> Html.Html+htmlFromModuleList =+ (Html.! [Html.identifier "module-list"]) .+ Html.unordList . map+ (\name -> (Html.anchor << Module.deconsName name) Html.! [Html.href $ Module.deconsName name])
+ http/enable/HTTPServer/GUI.hs view
@@ -0,0 +1,120 @@+module HTTPServer.GUI (+ HTTPServer.run,+ GuiUpdate,+ Feedback,+ update,+ methods,+ ) where++import qualified Module+import Utility.WX ( cursor )++import qualified HTTPServer++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 Control.Concurrent.MVar++import Data.IORef ( IORef, readIORef )++import qualified Control.Monad.Exception.Synchronous as Exc+import Control.Monad.Trans.Class ( lift )++import qualified Data.Map as M+++data GuiUpdate =+ GetModuleList { _moduleList :: MVar [ Module.Name ] }+ | GetModuleContent {+ _moduleName :: Module.Name,+ _moduleContent :: MVar (Exc.Exceptional HTTPServer.Error String) }+ | UpdateModuleContent {+ _moduleName :: Module.Name,+ _moduleEditableContent :: String,+ _moduleNewContent :: MVar Feedback }++type Feedback = Exc.Exceptional HTTPServer.Error (Maybe String, String)+++methods :: (GuiUpdate -> IO ()) -> HTTPServer.Methods+methods output =+ HTTPServer.Methods {+ HTTPServer.getModuleList = do+ modList <- newEmptyMVar+ output $ GetModuleList modList+ takeMVar modList,+ HTTPServer.getModuleContent = \name -> Exc.ExceptionalT $ do+ content <- newEmptyMVar+ output $ GetModuleContent name content+ takeMVar content,+ HTTPServer.updateModuleContent = \name edited -> Exc.ExceptionalT $ do+ newContent <- newEmptyMVar+ output $ UpdateModuleContent name edited newContent+ takeMVar newContent+ }++update ::+ (MVar Feedback -> Module.Name -> String -> Int -> IO ()) ->+ WX.StatusField ->+ IORef (M.Map Module.Name (a, TextCtrl b, c)) ->+ GuiUpdate ->+ IO ()+update input status panels req =+ case req of+ GetModuleList modList ->+ putMVar modList . M.keys =<< readIORef panels++ GetModuleContent name content ->+ (putMVar content =<<) $ Exc.runExceptionalT $ do+ pnls <- lift $ readIORef panels+ (_,editor,_) <- getModule pnls 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+ Nothing ->+ Exc.throwT+ (Module.tellName name ++ " no longer available.",+ "")+ Just pnl -> return pnl+ lift $ set status [ text :=+ Module.tellName name ++ " updated by web client" ]+ pos <- lift $ get editor cursor+ localContent <- lift $ get editor text+ case HTTPServer.splitProtected localContent of+ (protected, sepEditable) ->+ case sepEditable of+ Nothing ->+ Exc.throwT+ ("Module does no longer contain a separation mark, " +++ "thus you cannot alter the content.",+ protected)+ Just (sep, _edit) -> do+ let newContent = protected ++ sep ++ '\n' : content+ lift $ set editor [ text := newContent, cursor := pos ]+ return (newContent, pos)+ case result of+ Exc.Exception (e, protected) ->+ putMVar contentMVar $+ Exc.Success (Just e,+ protected ++ HTTPServer.separatorLine ++ '\n' : content)+ Exc.Success (newContent, pos) ->+ input contentMVar name newContent pos++getModule ::+ (Monad m) =>+ M.Map Module.Name a ->+ Module.Name ->+ Exc.ExceptionalT HTTPServer.Error m a+getModule pnls name =+ Exc.ExceptionalT $ return $+ Exc.fromMaybe+ (HTTPServer.notFound $ Module.tellName name ++ " not found") $+ M.lookup name pnls
+ http/enable/HTTPServer/Option.hs view
@@ -0,0 +1,31 @@+module HTTPServer.Option where++import Option.Utility ( parseNumber )++import qualified System.Console.GetOpt as Opt+import System.Console.GetOpt (ArgDescr(..), )+++data Option = Option {+ port :: Port+ }++newtype Port = Port { deconsPort :: Int }+ deriving (Eq, Show)++deflt :: Option+deflt =+ Option {+ port = Port 8080+ }+++description :: [Opt.OptDescr (Option -> IO Option)]+description =+ Opt.Option [] ["http-port"]+ (flip ReqArg "HTTP-PORT" $ \str flags ->+ fmap (\p -> flags{port = Port $ fromInteger p}) $+ parseNumber "HTTP port" (\n -> 0<n && n<65536) "positive 16 bit" str)+ ("provide a web server under this port,\ndefault " +++ (show $ deconsPort $ port deflt) ) :+ []
+ live-sequencer.cabal view
@@ -0,0 +1,236 @@+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+Cabal-Version: >= 1.6+Tested-With: GHC==6.12.3, GHC==7.2.1+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,+ and (that's the main point) the user can change the program on the fly.+ .+ 1. example usage *****+ .+ @+ timidity -iA &+ ./live-sequencer-gui --connect-to TiMidity Stream &+ @+ .+ 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)@+ .+ 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)+ .+ 2. input language *****+ .+ 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+ 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.+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/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++Extra-Source-Files:+ http/enable/HTTPServer.hs+ http/enable/HTTPServer/GUI.hs+ http/enable/HTTPServer/Option.hs+ http/disable/HTTPServer/GUI.hs+ http/disable/HTTPServer/Option.hs++Source-Repository head+ Type: git+ Location: git://dfa.imn.htwk-leipzig.de/srv/git/seq/++Source-Repository this+ Type: git+ Tag: 0.0+ Location: http://code.haskell.org/~thielema/livesequencer/++Flag httpServer+ Description: Enable access to modules via a web browser+ Default: True+++Library+ Hs-Source-Dirs: data+ GHC-Options: -Wall+ Build-Depends:+ -- for Render+ non-negative >=0.0.6 && <0.2,+ event-list >=0.0.11 && <0.2,+ base >=4.2 && <5+ Exposed-Modules:+ Render+ Bool+ Chords+ Drum+ Function+ Instrument+ Integer+ ListLive+ Midi+ Music+ Pitch+ Tuple+ Other-Modules:+ List+ Pattern+ Finite+ CrossSum+ DeBruijn+ Fibonacci+++Executable live-sequencer+ Hs-Source-Dirs: src, http/disable+ Main-is: Console.hs+ Other-Modules:+ ALSA+ Event+ IO+ Module+ Option+ Option.Utility+ Program+ Rewrite+ Rule+ Step+ Term+ Type+ Log+ Paths_live_sequencer+ Other-Modules:+ Lilypond+ GHC-Options: -Wall -threaded+ Build-Depends:+ 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++Executable live-sequencer-gui+ Hs-Source-Dirs: src+ Main-is: GUI.hs+ Other-Modules:+ ALSA+ Utility.Concurrent+ Utility.WX+ Event+ IO+ Exception+ Module+ Option+ Option.Utility+ Controls+ Program+ Rewrite+ Rule+ Step+ Term+ Type+ Log+ Paths_live_sequencer+ 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:+ HTTPServer+ Build-Depends:+ httpd-shed >=0.4 && <0.5,+ network >=2.3 && <2.4,+ cgi >=3001.1 && <3001.2,+ html >=1.0 && <1.1+ Else+ Hs-Source-Dirs: http/disable
+ src/ALSA.hs view
@@ -0,0 +1,134 @@+module ALSA where++import qualified Sound.ALSA.Sequencer.Address as Addr+import qualified Sound.ALSA.Sequencer.Client as Client+import qualified Sound.ALSA.Sequencer.Port as Port+import qualified Sound.ALSA.Sequencer.Queue as Queue+import qualified Sound.ALSA.Sequencer.Event as Event+import qualified Sound.ALSA.Sequencer as SndSeq+import qualified Sound.ALSA.Exception as AlsaExc++import qualified Sound.MIDI.Message.Channel.Mode as ModeMsg+import qualified Sound.MIDI.ALSA as MIDI++import qualified System.IO as IO++import Data.Foldable ( forM_ )+import Control.Monad ( (<=<) )+import Control.Functor.HT ( void )+++data Sequencer mode =+ Sequencer {+ handle :: SndSeq.T mode,+ publicPort, privatePort :: Port.T,+ queue :: Queue.T+ }+++sendEvent ::+ (SndSeq.AllowOutput mode) =>+ Sequencer mode -> Event.Data -> IO ()+sendEvent sq ev = do+ c <- Client.getId (handle sq)+ void $+ Event.outputDirect (handle sq) $+ Event.simple (Addr.Cons c (publicPort sq)) ev++queueControl ::+ Sequencer mode -> Event.QueueEv -> IO ()+queueControl sq cmd =+ Queue.control (handle sq) (queue sq) cmd 0 Nothing++drainOutput ::+ (SndSeq.AllowOutput mode) =>+ Sequencer mode -> IO ()+drainOutput sq =+ void $ Event.drainOutput (handle sq)++startQueue ::+ (SndSeq.AllowOutput mode) =>+ Sequencer mode -> IO ()+startQueue sq = do+ -- Log.put "start queue"+ queueControl sq Event.QueueStart+ drainOutput sq++stopQueue ::+ (SndSeq.AllowOutput mode) =>+ Sequencer mode -> IO ()+stopQueue sq = do+ -- Log.put "stop queue"+ mapM_ (Event.output (handle sq)) =<< allNotesOff sq+ queueControl sq Event.QueueStop+ drainOutput sq++pauseQueue ::+ (SndSeq.AllowOutput mode) =>+ Sequencer mode -> IO ()+pauseQueue sq = do+ -- Log.put "pause queue"+ queueControl sq Event.QueueStop+ drainOutput sq++continueQueue ::+ (SndSeq.AllowOutput mode) =>+ Sequencer mode -> IO ()+continueQueue sq = do+ -- Log.put "continue queue"+ queueControl sq Event.QueueContinue+ drainOutput sq++quietContinueQueue ::+ (SndSeq.AllowOutput mode) =>+ Sequencer mode -> IO ()+quietContinueQueue sq = do+ -- Log.put "continue queue"+ mapM_ (Event.output (handle sq)) =<< allNotesOff sq+ queueControl sq Event.QueueContinue+ drainOutput sq++allNotesOff ::+ (SndSeq.AllowOutput mode) =>+ Sequencer mode -> IO [Event.T]+allNotesOff sq = do+ c <- Client.getId (handle sq)+ return $+ map (Event.simple (Addr.Cons c (publicPort sq)) .+ Event.CtrlEv Event.Controller .+ flip MIDI.modeEvent ModeMsg.AllNotesOff)+ [minBound .. maxBound]++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))+++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
+ src/Console.hs view
@@ -0,0 +1,80 @@+-- module Console where++import Term+import Program ( Program (..), chase )+import qualified Event+import qualified Rewrite+import qualified Exception++import qualified Option+import qualified ALSA++import qualified Sound.ALSA.Sequencer as SndSeq++import Control.Concurrent ( forkIO )+import Control.Concurrent.Chan++import qualified Control.Monad.Trans.Writer as MW+import qualified Control.Monad.Trans.State as MS+import Control.Monad.Exception.Synchronous+ ( mapExceptionalT, resolveT, throwT )+import Control.Monad.IO.Class ( liftIO )+import Control.Monad.Trans.Class ( lift )+import Control.Monad ( forM_, (>=>) )+import Control.Functor.HT ( void )++import qualified System.IO as IO+import qualified System.Exit as Exit++import Prelude hiding ( log )+++-- | read rules files, start expansion of "main"+main :: IO ()+main = do+ opt <- Option.get+ 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+ 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" )++writeExcMsg :: Exception.Message -> IO ()+writeExcMsg = putStrLn . Exception.statusFromMessage++execute ::+ Program ->+ ALSA.Sequencer SndSeq.DuplexMode ->+ Chan Event.WaitResult ->+ Term ->+ MS.StateT Event.State IO ()+execute 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)+ 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)+ go xs+ _ -> throwT+ (termRange s,+ "do not know how to handle term\n" ++ show s)+ in resolveT+ (\(pos, msg) ->+ liftIO $ IO.hPutStrLn IO.stderr $ show pos ++ " " ++ msg)+ . go
+ src/Controls.hs view
@@ -0,0 +1,109 @@+-- | controls are widgets that are:+-- * specified in the program text,+-- * displayed in the GUI,+-- * read while executing the program.++module Controls where++import qualified Program+import qualified Module+import qualified Rule+import qualified Term+import qualified Exception++import qualified Control.Monad.Exception.Synchronous as Exc++import qualified 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 qualified Data.Map as M+import Control.Monad ( forM )+import Control.Functor.HT ( void )+++data Event = EventBool Term.Identifier Bool+ 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++change_controller_module ::+ Program.Program ->+ Controls.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++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 ) [] )++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++create ::+ WX.Frame b ->+ [(Term.Identifier, Control)] ->+ (Controls.Event -> IO ()) ->+ IO ()+create frame controls sink = do+ 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 )+ )+ _ -> []
+ src/Event.hs view
@@ -0,0 +1,314 @@+module Event where++import Term+import ALSA ( Sequencer(handle, queue, privatePort), sendEvent )+import qualified Exception+import qualified Log++import qualified Sound.MIDI.Message.Channel as CM+import qualified Sound.MIDI.Message.Channel.Voice as VM+import qualified Sound.MIDI.ALSA as MidiAlsa++import qualified Sound.ALSA.Sequencer.Address as Addr+import qualified Sound.ALSA.Sequencer.RealTime as RealTime+import qualified Sound.ALSA.Sequencer.Client as Client+import qualified Sound.ALSA.Sequencer.Port as Port+import qualified Sound.ALSA.Sequencer.Event as SeqEvent+import qualified Sound.ALSA.Sequencer as SndSeq++import qualified Control.Monad.Trans.State as MS+import qualified Control.Monad.Trans.Class as MT+import Control.Monad.Exception.Synchronous ( ExceptionalT, throwT )+import Control.Monad.IO.Class ( MonadIO, liftIO )+import Control.Monad ( when, forever )+import Control.Functor.HT ( void )++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 Data.Accessor.Basic ((^.), )++import Data.Maybe ( isJust )+import Data.Bool.HT ( if' )++import Control.Concurrent.Chan ( Chan, readChan, writeChan )+import Control.Concurrent ( forkIO {- threadDelay -} )+++type Time = Integer++data WaitMode = RealTime | SlowMotion Time | SingleStep+ deriving (Eq, Show)++data WaitResult =+ ModeChange WaitMode | ReachedTime SeqEvent.TimeStamp | NextStep+ deriving (Show)+++termException ::+ (Monad m) =>+ String -> Term -> ExceptionalT Exception.Message m ()+termException msg s =+ throwT $+ Exception.Message Exception.Term+ (termRange s) (msg ++ " " ++ show s)+++runIO :: (MonadIO m) => IO () -> ExceptionalT Exception.Message m ()+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 ::+ (Bounded a, Monad m) =>+ String -> (Int -> a) -> (a -> Int) ->+ 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")+++newtype ControllerValue = ControllerValue {fromControllerValue :: Int}+ deriving (Eq, Ord, Show)++instance Bounded ControllerValue where+ minBound = ControllerValue 0+ maxBound = ControllerValue 127++type State = (WaitMode, Time)++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))++ Just ( "Say", [String_Literal rng arg] ) -> runIO $ do+ let cmd = unwords+ [ "echo", show arg, "|", "festival", "--tts" ]+ Log.put cmd+ void $ forkIO $ do+ (inp,_out,err,pid) <-+ Proc.runInteractiveProcess+ "festival" [ "--tts" ] Nothing Nothing+ void $ forkIO (IO.hPutStr inp arg >> IO.hClose inp)+ errText <- StrictIO.hGetContents err+ exitCode <- Proc.waitForProcess pid+ case exitCode of+ Exit.ExitSuccess ->+ when (not (null errText)) $+ throwAsync $+ Exception.Message Exception.Term rng ("warning: " ++ errText)+ Exit.ExitFailure _ ->+ throwAsync $+ Exception.Message Exception.Term rng errText++ 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++processChannelMsg ::+ (SndSeq.AllowOutput mode) =>+ Sequencer mode ->+ Chan WaitResult ->+ CM.Channel -> Term ->+ ExceptionalT Exception.Message (MS.StateT State IO) ()+processChannelMsg sq waitChan chan body = do+ 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 ->+ runIO $+ sendEvent sq $ 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) ->+ runIO $+ sendEvent sq $ SeqEvent.CtrlEv SeqEvent.Controller $+ MidiAlsa.controllerEvent chan cc (fromIntegral v)+ _ -> termException "invalid channel event: " body+ MT.lift $ wait sq waitChan Nothing+++wait ::+ (SndSeq.AllowOutput mode) =>+ Sequencer mode ->+ Chan WaitResult ->+ Maybe Time ->+ MS.StateT State IO ()+wait sq waitChan mdur = do+ let loop target = do+ liftIO $ Log.put $ "readChan waitChan"+ ev <- liftIO $ readChan waitChan+ liftIO $ Log.put $ "read from waitChan: " ++ show ev+ case ev of+ ModeChange newMode -> do+ oldMode <- MS.gets fst+ if newMode /= oldMode+ then do+ AccM.set AccTuple.first 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+ in if Just reached == target+ then AccM.set AccTuple.second reached+ else loop target+ _ -> loop target+ NextStep ->+ when (isJust target) $ loop target++ (cont,targetTime) <- prepare sq mdur+ when cont $ loop targetTime+++prepare ::+ (SndSeq.AllowOutput mode) =>+ Sequencer mode -> Maybe Time ->+ MS.StateT State IO (Bool, Maybe Time)+prepare sq mt = do+ liftIO $ Log.put $ "prepare waiting for " ++ show mt+ (waitMode,currentTime) <- MS.get+ case waitMode of+ RealTime -> do+ case mt of+ Nothing -> return (False, Nothing)+ Just dur -> do+ let t = currentTime + dur+ sendEcho sq t+ return (True, Just t)+ SlowMotion dur -> do+ let t = currentTime + dur * 10^(6::Int)+ sendEcho sq t+ return (True, Just t)+ SingleStep ->+ return (True, Nothing)+++sendEcho ::+ (MonadIO io, SndSeq.AllowOutput mode) =>+ Sequencer mode -> Time ->+ io ()+sendEcho sq t = do+ c <- liftIO $ Client.getId (handle sq)++ {-+ liftIO $ Log.put . ("wait, send echo for " ++) . show =<< MS.get+ -}+ let dest =+ Addr.Cons {+ Addr.client = c,+ Addr.port = privatePort sq+ }++ liftIO $ Log.put $ "send echo message to " ++ show dest+ liftIO $ void $ SeqEvent.output (handle sq) $+ (SeqEvent.simple+ (Addr.Cons c Port.unknown)+ (SeqEvent.CustomEv SeqEvent.Echo (SeqEvent.Custom 0 0 0)))+ { SeqEvent.queue = queue sq+ , SeqEvent.timestamp =+ SeqEvent.RealTime $ RealTime.fromInteger t+ , SeqEvent.dest = dest+ }++ liftIO $ void $ SeqEvent.drainOutput (handle sq)+++{-+We cannot concurrently wait for different kinds of events.+Thus we run one thread that listens to all incoming events+and distributes them to who they might concern.+-}+listen ::+ (SndSeq.AllowInput mode) =>+ Sequencer mode ->+ (VM.Pitch -> IO ()) ->+ Chan WaitResult -> IO ()+listen sq noteInput waitChan = do+ Log.put "listen to ALSA port"+ c <- Client.getId (handle sq)++ let dest =+ Addr.Cons {+ Addr.client = c,+ Addr.port = privatePort sq+ }++ forever $ do+ Log.put "wait, wait for echo"+ ev <- SeqEvent.input (handle sq)+ Log.put $ "wait, get message " ++ show ev+ case SeqEvent.body ev of+ SeqEvent.NoteEv SeqEvent.NoteOn note ->+ noteInput $ note ^. MidiAlsa.notePitch+ SeqEvent.CustomEv SeqEvent.Echo _ ->+ when (dest == SeqEvent.dest ev) $ do+ Log.put "write waitChan"+ writeChan waitChan $ ReachedTime $ SeqEvent.timestamp ev+ _ -> return ()+++sendNote ::+ (SndSeq.AllowOutput mode) =>+ Sequencer mode ->+ SeqEvent.NoteEv ->+ CM.Channel ->+ CM.Pitch ->+ CM.Velocity ->+ IO ()+sendNote sq onoff chan pitch velocity =+ sendEvent sq $+ SeqEvent.NoteEv onoff $ MidiAlsa.noteEvent chan pitch velocity velocity 0
+ src/Exception.hs view
@@ -0,0 +1,50 @@+module Exception where++import Term ( Range(Range) )++import qualified Text.ParserCombinators.Parsec.Pos as Pos++import qualified Data.List as List+++data Message = Message Type Range String+-- deriving (Show)++data Type = Parse | Term | InOut+ deriving (Show, Eq, Ord, Enum)+++lineFromMessage :: Message -> [String]+lineFromMessage (Message typ (Range pos _) descr) =+ Pos.sourceName pos :+ show (Pos.sourceLine pos) : show (Pos.sourceColumn pos) :+ stringFromType typ :+ flattenMultiline descr :+ []++statusFromMessage :: Message -> String+statusFromMessage (Message typ (Range pos _) descr) =+ stringFromType typ ++ " - " +++ Pos.sourceName pos ++ ':' :+ show (Pos.sourceLine pos) ++ ':' :+ show (Pos.sourceColumn 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" +++ descr++stringFromType :: Type -> String+stringFromType typ =+ case typ of+ Parse -> "parse error"+ Term -> "term error"+ InOut -> "in/out error"++flattenMultiline :: String -> String+flattenMultiline =+ List.intercalate "; " . lines
+ src/GUI.hs view
@@ -0,0 +1,1055 @@+-- module GUI where++{- |+The program manages a number of threads:++GUI:+The GUI shall be responsive also if a program is loaded or a term is reduced.+Thus the GUI has its own thread.+If a GUI element requires a more complicated action,+it sends an Action message via then 'input' Chan to the 'machine'.++machine:+This thread manages loading and parsing of modules+as well as the operation mode of the interpreter.+It gets most of its messages from the GUI+and sends its result as GuiUpdate via the 'output' Chan to the GUI.++execute:+This runs the interpreter.+It reduces expressions and sends according MIDI messages+or waits according to Wait events.++ALSA:+With ALSA we can wait only for all kinds of events at once.+Thus this thread receives all incoming messages and distributes them+to the right receiver.+E.g. NoteOn events are sent to the GUI as text inserts+and Echo messages are sent to the 'execute' thread for handling Wait events.++HTTPServer:+Waits for and responds to incoming HTTP requests.+-}++import qualified IO+import qualified Term+import qualified Program+import qualified Exception+import qualified Module+import qualified Controls+import qualified Rewrite+import qualified Option+import qualified Log+import Program ( Program, modules )+import Term ( Term, Identifier )+import Utility.Concurrent ( writeTMVar, writeTChanIO )+import Utility.WX ( cursor, editable, notebookSelection )++import qualified HTTPServer.GUI as HTTPGui++import qualified Graphics.UI.WX as WX+import Graphics.UI.WX.Attributes ( Prop((:=)), set, get )+import Graphics.UI.WX.Classes+import Graphics.UI.WX.Controls+import Graphics.UI.WX.Events+import Graphics.UI.WX.Layout+import Graphics.UI.WX.Types+ ( Color, rgb, fontFixed, Point2(Point), sz,+ varCreate, varSwap, varUpdate )+import Control.Concurrent ( forkIO )+import Control.Concurrent.MVar+import Control.Concurrent.Chan+import Control.Concurrent.STM.TChan+import Control.Concurrent.STM.TVar+import Control.Concurrent.STM.TMVar+import Control.Monad.STM ( STM )+import qualified Control.Monad.STM as STM++import Data.IORef ( newIORef, readIORef, writeIORef, modifyIORef )++import qualified Graphics.UI.WXCore as WXCore+import qualified Graphics.UI.WXCore.WxcClassesAL as WXCAL+import qualified Graphics.UI.WXCore.WxcClassesMZ as WXCMZ+import Graphics.UI.WXCore.WxcDefs ( wxID_HIGHEST )++import Graphics.UI.WXCore.Events+import qualified Event++import Foreign.Storable ( peek )+import Foreign.Marshal.Alloc ( alloca )++import qualified ALSA+import qualified Sound.ALSA.Sequencer as SndSeq+import qualified Sound.MIDI.Message.Channel.Voice as VM++import qualified Control.Monad.Trans.State as MS+import qualified Control.Monad.Trans.Writer as MW+import qualified Control.Monad.Trans.Maybe as MaybeT+import qualified Control.Monad.Exception.Synchronous as Exc+import Control.Monad.IO.Class ( liftIO )+import Control.Monad.Trans.Class ( lift )+import Control.Monad ( when, liftM2, forever, )+import Control.Functor.HT ( void )+import Data.Foldable ( forM_ )+import qualified Text.ParserCombinators.Parsec as Parsec+import qualified Text.ParserCombinators.Parsec.Pos as Pos+import qualified Text.ParserCombinators.Parsec.Token as Token++import Control.Exception ( bracket, finally, try )+import qualified System.IO as IO+import qualified System.IO.Error as Err+import qualified System.Exit as Exit+import qualified System.FilePath as FilePath++import qualified Data.Accessor.Monad.Trans.State as AccM+import qualified Data.Accessor.Tuple as AccTuple++import qualified Data.Traversable as Trav+import qualified Data.Foldable as Fold+import qualified Data.Sequence as Seq+import qualified Data.Map as M+import Data.Maybe ( maybeToList, fromMaybe )++import qualified Data.Char as Char+import qualified Data.List as List+import Data.Tuple.HT ( fst3 )++import Prelude hiding ( log )+++-- | read rules files, should contain definition for "main"+main :: IO ()+main = do+ IO.hSetBuffering IO.stderr IO.LineBuffering+ opt <- Option.get++ (p,ctrls) <-+ Exc.resolveT+ (\e ->+ IO.hPutStrLn IO.stderr (Exception.multilineFromMessage e) >>+ Exit.exitFailure) $+ prepareProgram =<<+ Program.chase (Option.importPaths opt) (Option.moduleName opt)++ input <- newChan+ output <- newTChanIO+ writeTChanIO output $ Register p ctrls+ ALSA.withSequencer "Rewrite-Sequencer" $ \sq -> do+ ALSA.parseAndConnect sq+ ( Option.connectFrom opt ) ( Option.connectTo opt )+ flip finally (ALSA.stopQueue sq) $ WX.start $ do+ gui input output+ void $ forkIO $ machine input output (Option.importPaths opt) p sq+ void $ forkIO $+ HTTPGui.run+ (HTTPGui.methods (writeTChanIO output . HTTP))+ (Option.httpOption opt)+++-- | messages that are sent from GUI to machine+data Action =+ Modification (Maybe (MVar HTTPGui.Feedback)) Module.Name String Int+ -- ^ MVar of the HTTP server, modulename, sourcetext, position+ | Execution Execution+ | NextStep+ | Control Controls.Event+ | Load FilePath++data Execution =+ Mode Event.WaitMode | Restart | Stop | PlayTerm String+++-- | messages that are sent from machine to GUI+data GuiUpdate =+ Term { _steps :: [ Rewrite.Message ], _currentTerm :: String }+ | Exception { _message :: Exception.Message }+ | Register Program [(Identifier, Controls.Control)]+ | Refresh { _moduleName :: Module.Name, _content :: String, _position :: Int }+ | InsertText { _insertedText :: String }+ | HTTP HTTPGui.GuiUpdate+ | Running { _runningMode :: Event.WaitMode }+ | ResetDisplay+++exceptionToGUI ::+ TChan GuiUpdate ->+ Exc.ExceptionalT Exception.Message STM () ->+ STM ()+exceptionToGUI output =+ Exc.resolveT (writeTChan output . Exception)++exceptionToGUIIO ::+ TChan GuiUpdate ->+ Exc.ExceptionalT Exception.Message IO () ->+ IO ()+exceptionToGUIIO output =+ Exc.resolveT (writeTChanIO output . Exception)++prepareProgram ::+ (Monad m) =>+ Program ->+ Exc.ExceptionalT Exception.Message m+ (Program, [(Identifier, Controls.Control)])+prepareProgram p0 = do+ let ctrls = Controls.collect p0+ p1 <- Exc.ExceptionalT $ return $+ Program.add_module (Controls.controller_module ctrls) p0+ return (p1, ctrls)++formatPitch :: VM.Pitch -> String+formatPitch p =+ let (oct,cls) = divMod (VM.fromPitch p) 12+ name =+ case cls of+ 00 -> "c"+ 01 -> "cs"+ 02 -> "d"+ 03 -> "ds"+ 04 -> "e"+ 05 -> "f"+ 06 -> "fs"+ 07 -> "g"+ 08 -> "gs"+ 09 -> "a"+ 10 -> "as"+ 11 -> "b"+ _ -> error "pitch class must be a number from 0 to 11"+ in "note qn (" ++ name ++ " " ++ show (oct-1) ++ ") : "+++{-+TODO: handle the case that the module changed its name+(might happen if user changes the text in the editor)+-}+modifyModule ::+ TVar Program ->+ TChan GuiUpdate ->+ Module.Name ->+ [Char] ->+ Int ->+ Exc.ExceptionalT Exception.Message STM ()+modifyModule program output moduleName sourceCode pos = do+ p <- lift $ readTVar program+ let Just previous = M.lookup moduleName $ modules p+ m <-+ Exc.mapExceptionT Program.messageFromParserError $+ Exc.fromEitherT $ return $+ Parsec.parse+ (Module.parseUntilEOF (Module.source_location previous) sourceCode)+ ( Module.deconsName moduleName ) sourceCode+ lift . writeTVar program =<<+ (Exc.ExceptionalT $ return $+ Program.add_module m p)+ lift $ writeTChan output $+ Refresh moduleName sourceCode pos+-- lift $ Log.put "parsed and modified OK"+++{-+This runs concurrently+and is fed with changes to the modules by the GUI.+It parses them and provides the parsed modules to the execution engine.+Since parsing is a bit of work+we can keep the GUI and the execution of code going while parsing.+-}+machine :: Chan Action -- ^ machine reads program text from here+ -- (module name, module contents)+ -> TChan GuiUpdate -- ^ and writes output to here+ -- (log message (for highlighting), current term)+ -> [FilePath]+ -> Program -- ^ initial program+ -> ALSA.Sequencer SndSeq.DuplexMode+ -> IO ()+machine input output importPaths progInit sq = do+ program <- newTVarIO progInit+ let mainName = read "main"+ term <- newTMVarIO mainName+ waitChan <- newChan++ void $ forkIO $ forever $ do+ action <- readChan input+ let withMode mode transaction = do+ writeChan waitChan $ Event.ModeChange mode+ STM.atomically $ do+ writeTChan output $ Running mode+ transaction+ case action of+ Control event -> do+ Log.put $ show event+ STM.atomically $ exceptionToGUI output $ do+ p <- lift $ readTVar program+ p' <-+ Exc.ExceptionalT $ return $+ Controls.change_controller_module p event+ lift $ writeTVar program p'+ -- return $ Controls.get_controller_module p'+ -- Log.put $ show m+ NextStep -> writeChan waitChan Event.NextStep+ Execution exec ->+ case exec of+ Mode mode -> do+ case mode of+ Event.RealTime -> do+ ALSA.continueQueue sq+ Event.SlowMotion _ -> do+ ALSA.continueQueue sq+ Event.SingleStep -> do+ ALSA.pauseQueue sq+ withMode mode $ return ()+ Restart -> do+ ALSA.quietContinueQueue sq+ withMode Event.RealTime $ writeTMVar term mainName+ Stop -> do+ ALSA.stopQueue sq+ withMode Event.SingleStep $ writeTMVar term mainName+ PlayTerm str ->+ case Parsec.parse+ (Parsec.between+ (Token.whiteSpace Term.lexer)+ (Parsec.eof)+ IO.input)+ "marked range" str of+ Left msg ->+ writeTChanIO output . Exception $+ Program.messageFromParserError msg+ Right t -> do+ ALSA.quietContinueQueue sq+ withMode Event.RealTime $ writeTMVar term t+ Modification feedback moduleName sourceCode pos -> do+ Log.put $+ Module.tellName moduleName +++ " has new input\n" ++ sourceCode+ case feedback of+ Nothing ->+ STM.atomically $+ exceptionToGUI output $+ modifyModule program output moduleName sourceCode pos+ Just mvar -> do+ x <-+ STM.atomically $+ fmap (Exc.switch+ (\e ->+ (Just $ Exception.multilineFromMessage e,+ sourceCode))+ (\() -> (Nothing, sourceCode))) $+ Exc.runExceptionalT $+ Exc.catchT+ (modifyModule program output moduleName sourceCode pos)+ (\e -> do+ lift $ writeTChan output $ Exception e+ Exc.throwT e)+ putMVar mvar $ Exc.Success x+ Load filePath -> do+ Log.put $+ "load " ++ filePath ++ " and all its dependencies"+ exceptionToGUIIO output $ do+ (p,ctrls) <-+ prepareProgram =<<+ Program.load importPaths Program.empty+ (FilePath.takeBaseName filePath) filePath+ lift $ do+ ALSA.stopQueue sq+ withMode Event.RealTime $ do+ writeTVar program p+ writeTMVar term mainName+ writeTChan output $ Register p ctrls+ ALSA.continueQueue sq+ Log.put "chased and parsed OK"++ void $ forkIO $+ Event.listen sq+ ( writeTChanIO output . InsertText . formatPitch )+ waitChan+ ALSA.startQueue sq+ flip MS.evalStateT (Event.RealTime, 0) $+ execute program term ( writeTChan output ) sq waitChan+++execute :: TVar Program+ -- ^ current program (GUI might change the contents)+ -> TMVar Term -- ^ current term+ -> ( GuiUpdate -> STM () ) -- ^ sink for messages (show current term)+ -> ALSA.Sequencer SndSeq.DuplexMode -- ^ for playing MIDI events+ -> Chan Event.WaitResult+ -> MS.StateT Event.State IO ()+execute program term output sq waitChan =+ forever $++ excSwitchT+ (\e -> do+ liftIO $ do+ ALSA.stopQueue sq+ -- writeChan waitChan $ Event.ModeChange Event.SingleStep+ STM.atomically $ do+ output $ Exception e+ output $ Running Event.SingleStep+ {-+ We have to alter the mode directly,+ since the channel is only read when we wait for a duration other than Nothing+ -}+ AccM.set AccTuple.first Event.SingleStep+ Event.wait sq waitChan Nothing)+ (\x -> do+ let writeExcMsg = STM.atomically . output . Exception+ {-+ exceptions on processing an event are not fatal and we keep running+ -}+ Exc.resolveT+ (liftIO . writeExcMsg)+ (Event.play sq waitChan writeExcMsg x)+ case Term.viewNode x of+ Just ("Wait", _) ->+ liftIO $ STM.atomically $ output ResetDisplay+ _ -> return ())+ (let mainName = read "main"+ in Exc.mapExceptionalT (liftIO . STM.atomically) $+ flip Exc.catchT (\(pos,msg) -> do+ lift $ putTMVar term mainName+ Exc.throwT $ Exception.Message Exception.Term pos msg) $ do+ t <- lift $ takeTMVar term+ p <- lift $ readTVar program+ {- this happens anew at each click+ since the program text might have changed in the editor -}+ (s,log) <-+ Exc.mapExceptionalT+ (fmap (\(ms,log) -> liftM2 (,) ms (return log)) .+ MW.runWriterT) $+ Rewrite.runEval p (Rewrite.force_head t)+ {-+ This way the term will be pretty printed in the GUI thread+ which may block the GUI thread.+ However evaluating it here may defer playing notes,+ which is not better.+ -}+ lift $ output . Term log . show $ s+ case Term.viewNode s of+ Just (":", [x, xs]) -> do+ lift $ putTMVar term xs+ return x+ Just ("[]", []) ->+ Exc.throwT (Term.termRange s, "finished.")+ _ ->+ Exc.throwT (Term.termRange s,+ "I do not know how to handle this term: " ++ show s))++-- also available in explicit-exception>=0.1.7+excSwitchT ::+ (Monad m) =>+ (e -> m b) -> (a -> m b) ->+ Exc.ExceptionalT e m a -> m b+excSwitchT e s m = Exc.switch e s =<< Exc.runExceptionalT m+++-- | following code taken from http://snipplr.com/view/17538/+myEventId :: Int+myEventId = wxID_HIGHEST+100+ -- the custom event ID, avoid clash with Graphics.UI.WXCore.Types.varTopId++-- | the custom event is registered as a menu event+createMyEvent :: IO (WXCore.CommandEvent ())+createMyEvent =+ WXCAL.commandEventCreate WXCMZ.wxEVT_COMMAND_MENU_SELECTED myEventId++registerMyEvent :: WXCore.EvtHandler a -> IO () -> IO ()+registerMyEvent win io = evtHandlerOnMenuCommand win myEventId io+++{-+The order of widget creation is important+for cycling through widgets using tabulator key.+-}+gui :: Chan Action -- ^ the gui writes here+ -- (if the program text changes due to an edit action)+ -> TChan GuiUpdate -- ^ the machine writes here+ -- (a textual representation of "current expression")+ -> IO ()+gui input output = do+ program <- newIORef Program.empty+ controls <- newIORef []+ panels <- newIORef M.empty++ let highlighters = fmap ( \ (_pnl,_,h) -> h )+ editors = fmap ( \ (_pnl,e,_) -> e )+++ frameError <- WX.frame [ text := "errors" ]++ panelError <- WX.panel frameError [ ]++ errorLog <- WX.listCtrl panelError+ [ columns :=+ ("Module", AlignLeft, 120) :+ ("Row", AlignRight, -1) :+ ("Column", AlignRight, -1) :+ ("Type", AlignLeft, -1) :+ ("Description", AlignLeft, 500) :+ []+ ]+ errorList <- newIORef Seq.empty+ let updateErrorLog f = do+ errors <- readIORef errorList+ let newErrors = f errors+ writeIORef errorList newErrors+ set errorLog [ items :=+ map Exception.lineFromMessage $ Fold.toList newErrors ]++ clearLog <- WX.button panelError+ [ text := "Clear",+ on command := updateErrorLog (const Seq.empty) ]++ frameControls <- WX.frame [ text := "controls" ]++ f <- WX.frame+ [ text := "live-sequencer", visible := False+ ]++ out <- newChan++ void $ forkIO $ forever $ do+ writeChan out =<< STM.atomically (readTChan output)+ WXCAL.evtHandlerAddPendingEvent f =<< createMyEvent++ p <- WX.panel f [ ]+++ fileMenu <- WX.menuPane [text := "&File"]++ let haskellFilenames =+ [ ("Haskell modules", ["*.hs"]),+ ("All files", ["*"]) ]++ loadItem <- WX.menuItem fileMenu+ [ text := "L&oad and check program ...\tCtrl-O",+ help :=+ "flush all modules " +++ "and load a new program with all its dependencies" ]+ reloadItem <- WX.menuItem fileMenu+ [ text := "&Reload module",+ help :=+ "reload a module from its original file, " +++ "but do not pass it to the interpreter" ]+ saveItem <- WX.menuItem fileMenu+ [ text := "&Save module\tCtrl-S",+ help :=+ "overwrite original file with current module content" ]+ saveAsItem <- WX.menuItem fileMenu+ [ text := "Save module &as ...",+ help :=+ "save module content to a different or new file " +++ "and make this the new file target" ]++ WX.menuLine fileMenu++ quitItem <- WX.menuQuit fileMenu []+++ execMenu <- WX.menuPane [text := "&Execution"]++ refreshItem <- WX.menuItem execMenu+ [ text := "&Refresh\tCtrl-R",+ help :=+ "parse the edited program and if successful " +++ "replace the executed program" ]+ WX.menuLine execMenu+ realTimeItem <- WX.menuItem execMenu+ [ text := "Real time\tCtrl-1",+ checkable := True,+ checked := True,+ help := "pause according to Wait elements" ]+ slowMotionItem <- WX.menuItem execMenu+ [ text := "Slow motion\tCtrl-2",+ checkable := True,+ help := "pause between every list element" ]+ singleStepItem <- WX.menuItem execMenu+ [ text := "Single step\tCtrl-3",+ checkable := True,+ help := "wait for user confirmation after every list element" ]+ WX.menuLine execMenu+ _restartItem <- WX.menuItem execMenu+ [ text := "Res&tart\tCtrl-T",+ on command := writeChan input (Execution Restart),+ help :=+ "stop sound and restart program execution with 'main'" ]+ playTermItem <- WX.menuItem execMenu+ [ text := "Play term\tCtrl-M",+ help :=+ "stop sound and restart program execution " +++ "with the marked editor area as current term, " +++ "or use the surrounding identifier if nothing is marked" ]+ _stopItem <- WX.menuItem execMenu+ [ text := "Stop\tCtrl-Space",+ on command := writeChan input (Execution Stop),+ help :=+ "stop program execution and sound, " +++ "reset term to 'main'" ]++ WX.menuLine execMenu++ fasterItem <- WX.menuItem execMenu+ [ text := "Faster\tCtrl->",+ enabled := False,+ help := "decrease pause in slow motion mode" ]+ slowerItem <- WX.menuItem execMenu+ [ text := "Slower\tCtrl-<",+ enabled := False,+ help := "increase pause in slow motion mode" ]+ nextStepItem <- WX.menuItem execMenu+ [ text := "Next step\tCtrl-N",+ enabled := False,+ on command := writeChan input NextStep,+ help := "perform next step in single step mode" ]+++ windowMenu <- WX.menuPane [text := "&Window"]++ appRunning <- newIORef True+ let windowMenuItem title win = do+ itm <- WX.menuItem windowMenu+ [ text := title,+ help := "show or hide " ++ title ++ " window",+ checkable := True,+ checked := True ]+ set itm+ [ on command := do+ b <- get itm checked+ set win [ visible := b ] ]+ set win+ [ on closing := do+ run <- readIORef appRunning+ if run+ then do+ set itm [ checked := False ]+ set win [ visible := False ]+ -- WXCMZ.closeEventVeto ??? True+ else propagateEvent ]++ windowMenuItem "errors" frameError+ windowMenuItem "controls" frameControls+ WX.menuLine windowMenu+ reducerVisibleItem <- WX.menuItem windowMenu+ [ text := "current term",+ checkable := True,+ checked := True,+ help := "show or hide current term - " +++ "hiding may improve performance drastically" ]+++ nb <- WX.notebook p [ ]+++ reducer <-+ textCtrl p+ [ font := fontFixed, editable := False, wrap := WrapNone ]++ status <- WX.statusField+ [ text := "Welcome to interactive music composition with Haskell" ]+++ let handleException moduleName act = do+ result <- try act+ case result of+ Left err ->+ writeTChanIO output $+ Exception $ Exception.Message Exception.InOut+ (Program.dummyRange (Module.deconsName moduleName))+ (Err.ioeGetErrorString err)+ Right () -> return ()++ set loadItem [+ on command := do+ mfilename <- WX.fileOpenDialog+ f False {- change current directory -} True+ "Load Haskell program" haskellFilenames "" ""+ forM_ mfilename $ writeChan input . Load+ ]++ set reloadItem [+ on command := do+ index <- get nb notebookSelection+ (moduleName, (_panel, editor, _highlighter)) <-+ fmap ( M.elemAt index ) $ readIORef panels+ prg <- readIORef program+ let path =+ Module.source_location $ snd $+ M.elemAt index (modules prg)++ handleException moduleName $ do+ content <- readFile path+ set editor [ text := content ]+ set status [+ text := Module.tellName moduleName ++ " reloaded from " ++ path ]+ ]++ let getCurrentModule = do+ index <- get nb notebookSelection+ (moduleName, (_panel, editor, _highlighter)) <-+ fmap ( M.elemAt index ) $ readIORef panels+ content <- get editor text+ prg <- readIORef program+ return+ (Module.source_location $ snd $+ M.elemAt index (modules prg),+ moduleName, content)+ saveModule (path, moduleName, content) =+ handleException moduleName $ do+ -- Log.put path+ writeFile path content+ set status [+ text := Module.tellName moduleName ++ " saved to " ++ path ]++ set saveItem [+ on command := do+ saveModule =<< getCurrentModule ]++ set saveAsItem [+ on command := do+ (filePath, moduleName, content) <- getCurrentModule+ let (path,file) = FilePath.splitFileName filePath+ -- print (path,file)+ mfilename <- WX.fileSaveDialog+ f False {- change current directory -} True+ ("Save " ++ Module.tellName moduleName) haskellFilenames path file+ forM_ mfilename $ \fileName -> do+ saveModule (fileName, moduleName, content)+ modifyIORef program $ \prg ->+ prg { Program.modules =+ M.adjust+ (\modu -> modu { Module.source_location = fileName })+ moduleName (Program.modules prg) }+ ]+++ let refreshProgram (moduleName, (_panel, editor, _highlighter)) = do+ s <- get editor text+ pos <- get editor cursor+ writeChan input $ Modification Nothing moduleName s pos++ updateErrorLog $ Seq.filter $+ \(Exception.Message _ errorRng _) ->+ Module.deconsName moduleName /=+ Pos.sourceName (Term.start errorRng)++ set refreshItem+ [ on command := do+ refreshProgram =<< getFromNotebook nb =<< readIORef panels+ -- mapM_ refreshProgram pnls+ ]++ set playTermItem+ [ on command := do+ (_moduleName, (_panel, editor, _highlighter)) <-+ getFromNotebook nb =<< readIORef panels+ marked <- WXCMZ.textCtrlGetStringSelection editor+ expr <-+ if null marked+ then do+ (i,line) <-+ textColumnRowFromPos editor+ =<< get editor cursor+ content <- WXCMZ.textCtrlGetLineText editor line+{- simpler but inefficient+ content <- get editor text+ i <- get editor cursor+-}+ case splitAt i content of+ (prefix,suffix) ->+ let identLetter c = Char.isAlphaNum c || c == '_' || c == '.'+ in return $+ (reverse $ takeWhile identLetter $ reverse prefix)+ +++ takeWhile identLetter suffix+ else return marked+ writeChan input . Execution . PlayTerm $ expr ]++ waitDuration <- newIORef 500++ let updateSlowMotionDur = do+ dur <- readIORef waitDuration+ writeChan input $ Execution $ Mode $ Event.SlowMotion dur++ set fasterItem [+ on command := do+ modifyIORef waitDuration (\d -> max 100 (d-100))+ updateSlowMotionDur+ d <- readIORef waitDuration+ set status [ text :=+ "decreased pause to " ++ show d ++ "ms" ] ]++ set slowerItem [+ on command := do+ modifyIORef waitDuration (100+)+ updateSlowMotionDur+ d <- readIORef waitDuration+ set status [ text :=+ "increased pause to " ++ show d ++ "ms" ] ]++ let setRealTime b = do+ set realTimeItem [ checked := b ]++ setSlowMotion b = do+ set slowMotionItem [ checked := b ]+ set fasterItem [ enabled := b ]+ set slowerItem [ enabled := b ]++ setSingleStep b = do+ set singleStepItem [ checked := b ]+ set nextStepItem [ enabled := b ]++ onActivation w act =+ set w [ on command := do+ b <- get w checked+ if b then act else set w [checked := True] ]++ activateRealTime = do+ setRealTime True+ setSlowMotion False+ setSingleStep False++ activateSlowMotion = do+ setRealTime False+ setSlowMotion True+ setSingleStep False++ activateSingleStep = do+ setRealTime False+ setSlowMotion False+ setSingleStep True++ onActivation realTimeItem $ do+ activateRealTime+ writeChan input $ Execution $ Mode Event.RealTime+ onActivation slowMotionItem $ do+ activateSlowMotion+ updateSlowMotionDur+ onActivation singleStepItem $ do+ activateSingleStep+ writeChan input $ Execution $ Mode Event.SingleStep++ set reducerVisibleItem+ [ on command := do+ b <- get reducerVisibleItem checked+ set reducer [ visible := b ]+ windowReFit reducer ]++ set f [+ layout := container p $ margin 5+ $ column 5+ [ WX.fill $ tabs nb []+ , WX.fill $ widget reducer+ ]+ , WX.statusBar := [status]+ , WX.menuBar := [fileMenu, execMenu, windowMenu]+ , visible := True+ , clientSize := sz 1280 720+ ]+++ set errorLog+ [ on listEvent := \ev -> void $ MaybeT.runMaybeT $ do+ ListItemSelected n <- return ev+ errors <- liftIO $ readIORef errorList+ let (Exception.Message typ errorRng _descr) =+ Seq.index errors n+ Right moduleIdent <- return $+ Parsec.parse IO.input "" $+ Pos.sourceName $ Term.start errorRng+ pnls <- liftIO $ readIORef panels+ pnl <- MaybeT.MaybeT $ return $ M.lookupIndex moduleIdent pnls+ liftIO $ set nb [ notebookSelection := pnl ]+ let activateText textField = do+ h <- MaybeT.MaybeT $ return $+ M.lookup moduleIdent textField+ i <- liftIO $ textPosFromSourcePos h $ Term.start errorRng+ j <- liftIO $ textPosFromSourcePos h $ Term.end errorRng+ liftIO $ set h [ cursor := i ]+ liftIO $ WXCMZ.textCtrlSetSelection h i j+ case typ of+ Exception.Parse ->+ activateText $ editors pnls+ Exception.Term ->+ activateText $ highlighters pnls+ Exception.InOut ->+ return ()+ ]++ set frameError+ [ layout := container panelError $ margin 5+ $ column 5 $+ [ WX.fill $ widget errorLog,+ WX.hfloatLeft $ widget clearLog ]+ , clientSize := sz 500 300+ ]++ let closeOther =+ writeIORef appRunning False >>+ close frameError >> close frameControls+ set quitItem [ on command := closeOther >> close f]+ set f [ on closing := closeOther >> propagateEvent+ {- 'close f' would trigger the closing handler again -} ]+ focusOn f+++ highlights <- varCreate M.empty++ registerMyEvent f $ do+ msg <- readChan out+ let setColorHighlighters ::+ M.Map Module.Name [Identifier] -> Int -> Int -> Int -> IO ()+ setColorHighlighters m r g b = do+ pnls <- readIORef panels+ set_color nb ( highlighters pnls ) m ( rgb r g b )+ case msg of+ Term steps sr -> do+ get reducerVisibleItem checked >>=+ flip when ( set reducer [ text := sr, cursor := 0 ] )+ forM_ steps $ \step ->+ case step of+ Rewrite.Step target mrule -> do++ let m = M.fromList $ do+ t <- target : maybeToList mrule+ return (Module.Name $ Pos.sourceName $ Term.start $ Term.range t, [t])+ void $ varUpdate highlights $ M.unionWith (++) m+ setColorHighlighters m 0 200 200++ Rewrite.Data origin -> do+ set reducer [ text := sr, cursor := 0 ]++ let m = M.singleton+ (Module.Name $ Pos.sourceName $+ Term.start $ Term.range origin)+ [origin]+ void $ varUpdate highlights $ M.unionWith (++) m+ setColorHighlighters m 200 200 0++ Exception exc -> do+ itemAppend errorLog $ Exception.lineFromMessage exc+ modifyIORef errorList (Seq.|> exc)+ set status [ text := Exception.statusFromMessage exc ]++ -- update highlighter text field only if parsing was successful+ Refresh moduleName s pos -> do+ pnls <- readIORef panels+ Fold.mapM_+ (\h -> set h [ text := s, cursor := pos ])+ (M.lookup moduleName $ highlighters pnls)+ set status [ text :=+ Module.tellName moduleName ++ " reloaded into interpreter" ]+ InsertText str -> do+ (_moduleName, (_panel, editor, _highlighter)) <-+ getFromNotebook nb =<< readIORef panels+ WXCMZ.textCtrlWriteText editor str+ set status [ text :=+ "inserted note from external controller" ]++ Register prg ctrls -> do+ writeIORef program prg+ writeIORef controls ctrls++ void $ WXCMZ.notebookDeleteAllPages nb+ pnls <- displayModules input+ frameControls ctrls nb prg+ writeIORef panels pnls+ Fold.forM_ (M.mapWithKey (,) $ fmap fst3 pnls) $+ \(moduleName,sub) ->+ WXCMZ.notebookAddPage nb sub (Module.deconsName moduleName) False (-1)++ updateErrorLog (const Seq.empty)++ set status [ text :=+ "modules loaded: " +++ (List.intercalate ", " $ map Module.deconsName $+ M.keys $ Program.modules prg) ]++ ResetDisplay -> do+ previous <- varSwap highlights M.empty+ setColorHighlighters previous 255 255 255++ Running mode -> do+ case mode of+ Event.RealTime -> do+ set status [ text := "interpreter in real-time mode" ]+ activateRealTime+ Event.SlowMotion dur -> do+ set status [ text :=+ ("interpreter in slow-motion mode with pause " +++ show dur ++ "ms") ]+ activateSlowMotion+ Event.SingleStep -> do+ set status [ text :=+ "interpreter in single step mode," +++ " waiting for next step" ]+ activateSingleStep++ HTTP request ->+ HTTPGui.update+ (\contentMVar name newContent pos ->+ writeChan input $+ Modification (Just contentMVar) name newContent pos)+ status panels request+++displayModules ::+ Chan Action ->+ WX.Frame c ->+ [(Identifier, Controls.Control)] ->+ WXCore.Window b ->+ Program ->+ IO (M.Map Module.Name (Panel (), TextCtrl (), TextCtrl ()))+displayModules input frameControls ctrls nb prog = do+ Controls.create frameControls ctrls+ $ \ e -> writeChan input ( Control e )++ Trav.forM (modules prog) $ \ content -> do+ psub <- panel nb []+ editor <- textCtrl psub [ font := fontFixed, wrap := WrapNone ]+ highlighter <- textCtrlRich psub+ [ font := fontFixed, wrap := WrapNone, editable := False ]+ set editor [ text := Module.source_text content ]+ set highlighter [ text := Module.source_text content ]+ set psub [ layout := (row 5 $+ map WX.fill $ [widget editor, widget highlighter]) ]+ return (psub, editor, highlighter)+++getFromNotebook ::+ Notebook b -> M.Map k a -> IO (k, a)+getFromNotebook nb m =+ fmap (flip M.elemAt m) $ get nb notebookSelection++textPosFromSourcePos ::+ TextCtrl a -> Pos.SourcePos -> IO Int+textPosFromSourcePos textArea pos =+ WXCMZ.textCtrlXYToPosition textArea+ $ Point (Pos.sourceColumn pos - 1)+ (Pos.sourceLine pos - 1)++textColumnRowFromPos ::+ TextCtrl a -> Int -> IO (Int, Int)+textColumnRowFromPos textArea pos =+ alloca $ \rowPtr ->+ alloca $ \columnPtr -> do+ void $ WXCMZ.textCtrlPositionToXY textArea pos columnPtr rowPtr+ liftM2 (,)+ (fmap fromIntegral $ peek columnPtr)+ (fmap fromIntegral $ peek rowPtr)++set_color ::+ (Ord k) =>+ Notebook a ->+ M.Map k (TextCtrl a) ->+ M.Map k [Identifier] ->+ Color ->+ IO ()+set_color nb highlighters positions hicolor = void $ do+ (p, highlighter) <- getFromNotebook nb highlighters+ attr <- WXCMZ.textCtrlGetDefaultStyle highlighter+ bracket+ (WXCMZ.textAttrGetBackgroundColour attr)+ (WXCMZ.textAttrSetBackgroundColour attr) $ const $ do+ WXCMZ.textAttrSetBackgroundColour attr hicolor+ forM_ (fromMaybe [] $ M.lookup p positions) $ \ ident -> do+ let rng = Term.range ident+ from <- textPosFromSourcePos highlighter $ Term.start rng+ to <- textPosFromSourcePos highlighter $ Term.end rng+ WXCMZ.textCtrlSetStyle highlighter from to attr
+ src/IO.hs view
@@ -0,0 +1,18 @@+module IO where++import qualified Text.ParserCombinators.Parsec as Parsec+import Text.PrettyPrint.HughesPJ ( Doc )++import Control.Monad ( liftM2 )+++class Input a where input :: Parsec.Parser a+class Output a where output :: a -> Doc++parsec_reader ::+ (Input a) =>+ t -> String -> [(a, String)]+parsec_reader _p s =+ case Parsec.parse ( liftM2 (,) input Parsec.getInput ) "" s of+ Left _err -> []+ Right (x,t) -> [(x,t)]
+ src/Lilypond.hs view
@@ -0,0 +1,71 @@+module Lilypond where++import qualified Text.ParserCombinators.Parsec as P++import Control.Monad (liftM2, )+import Control.Applicative ((<$))+++{- |+Convert a monophonic melody in absolute pitch Lilypond notation+to live-sequencer notation.++E.g.++> toNotes "a'4 b,8 c4"+-}+toNotes :: String -> String+toNotes =+ either (error . show) id .+ P.parse parseNotes "input string" .+ filter (flip notElem "~[]")++parseNotes :: P.Parser String+parseNotes =+ parseOptional $+ P.many parseWhiteSpace +|++ let go =+ parseOptional $+ parseNote+ +|++ (parseOptional $+ P.many1 parseWhiteSpace +|+ go)+ in go++infixr 5 +|+++(+|+) :: Monad m => m [a] -> m [a] -> m [a]+(+|+) = liftM2 (++)++parseWhiteSpace :: P.Parser Char+parseWhiteSpace = P.oneOf " \t\n"++parseOptional :: P.Parser String -> P.Parser String+parseOptional p =+ p P.<|> return "[]"++parseNote :: P.Parser String+parseNote = do+ name <- P.many1 P.letter+ addDur <-+ case name of+ "r" -> return ("rest " ++)+ _ -> do+ octave <-+ (fmap length $ P.many1 $ P.char '\'')+ P.<|>+ (fmap (negate . length) $ P.many $ P.char ',')+ return $ \dur ->+ "note " ++ dur +++ " (" ++ name ++ " " ++ show (octave+3) ++ ")"+ dur <-+ P.try ("s" <$ P.string "16") P.<|>+ ("e" <$ P.string "8") P.<|>+ ("q" <$ P.string "4") P.<|>+ ("h" <$ P.string "2") P.<|>+ ("w" <$ P.string "1")+ dotted <- P.optionMaybe (P.char '.')+ return $+ (addDur $ maybe id (++) ("d" <$ dotted) (dur++"n"))+ +++ " ++"
+ src/Log.hs view
@@ -0,0 +1,11 @@+module Log where++import qualified System.IO as IO+import Control.Monad ( when )+++toConsole :: Bool+toConsole = False++put :: String -> IO ()+put msg = when toConsole $ IO.hPutStrLn IO.stderr msg
+ src/Module.hs view
@@ -0,0 +1,338 @@+module Module where++import IO ( Input, Output, input, output )+import Term ( Term, Identifier, lexer )+import Rule ( Rule )+import qualified Type+import qualified Term+import qualified Rule++import qualified Data.Map as M+import Data.Maybe ( mapMaybe )++import qualified Text.ParserCombinators.Parsec as Parsec+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 Text.PrettyPrint.HughesPJ+ ( (<+>), ($$), empty, hsep, sep, hang, punctuate,+ render, text, comma, vcat, parens )+import qualified Data.Char as Char++import Control.Functor.HT ( void )++++nestDepth :: Int+nestDepth = 4++data Import = Import { qualified :: Bool+ , source :: Name+ , rename :: Maybe Identifier+ }+-- deriving (Show)++parsePortList ::+ Parsec.GenParser Char () [Identifier]+parsePortList =+ Token.parens lexer $ flip Parsec.sepEndBy (Token.comma lexer) $+ (do ident <- input+ void $ Parsec.option [] $ Token.parens lexer $+ Token.commaSep lexer $ Token.identifier lexer+ return ident)+ <|>+ Term.parenOperator++{-+A semicolon behind an import statement is necessary when parsing++> import Prelude ;+>+> (+) :: a -> a -> a++otherwise the parentheses around the plus+would be interpreted as parentheses behind @Prelude@.+-}+instance Input Import where+ input = do+ reserved lexer "import"+ q <- Parsec.option False $ do reserved lexer "qualified" ; return True+ t <- input+ r <- Parsec.optionMaybe $ reserved lexer "as" >> input+ void $ Parsec.optionMaybe $ reserved lexer "hiding"+ void $ Parsec.optionMaybe $ parsePortList+ void $ Parsec.option "" $ Token.semi lexer+ return $ Import { qualified = q, source = t, rename = r }++instance Output Import where+ output i = hsep [ text "import"+ , if qualified i then text "qualified" else empty+ , output $ source i+ , case rename i of+ Nothing -> empty+ Just r -> text "as" <+> output r+ ]+++data TypeSig = TypeSig [Identifier] [Term] Term+ deriving (Show)++parseIdentList :: Parsec.CharParser () [Identifier]+parseIdentList =+ Token.commaSep lexer+ (input <|> Term.parenOperator)++instance Input TypeSig where+ input = do+ names <- parseIdentList+ reservedOp lexer "::"+ context <- Type.parseContext+ typeExpr <- Type.parseExpression+ void $ Token.semi lexer+ return $ TypeSig names context typeExpr++instance Output TypeSig where+ output (TypeSig names context typeExpr) =+ hang+ (hsep ( punctuate ( text "," ) $ map output names ) <+> text "::")+ nestDepth+ (sep+ [if null context+ then empty+ else parens ( hsep ( punctuate ( text "," ) $+ map output context ) ) <+> text "=>",+ output typeExpr <+> text ";"])+++data Data = Data { dataLhs :: Term+ , dataRhs :: [ Term ]+ }+ deriving (Show)++instance Input Data where+ input = do+ reserved lexer "data"+ l <- input+ reservedOp lexer "="+ rs <- Parsec.sepBy input ( reservedOp lexer "|" )+ void $ Token.semi lexer+ return $ Data { dataLhs = l, dataRhs = rs }++instance Output Data where+ output d = text "data" <+> output ( dataLhs d ) <+> text "="+ $$ hsep ( punctuate ( text "|" ) $ map output ( dataRhs d ) ) <+> text ";"+++data Type = Type { typeLhs :: Term+ , typeRhs :: Term+ }+ deriving (Show)++instance Input Type where+ input = do+ reserved lexer "type"+ l <- input+ reservedOp lexer "="+ r <- input+ void $ Token.semi lexer+ return $ Type { typeLhs = l, typeRhs = r }++instance Output Type where+ output d =+ hang+ ( text "type" <+> output ( typeLhs d ) <+> text "=" )+ nestDepth+ ( output ( typeRhs d ) <+> text ";" )+++data Infix = Infix Assoc Int [ Identifier ]++showAssoc :: Assoc -> String+showAssoc AssocLeft = "AssocLeft"+showAssoc AssocRight = "AssocRight"+showAssoc AssocNone = "AssocNone"++instance Show Infix where+ showsPrec p (Infix assoc prec idents) =+ showParen (p>10) $+ showString "Infix " .+ showString (showAssoc assoc) .+ showString " " .+ shows prec .+ showString " " .+ shows idents++instance Input Infix where+ input = do+ assoc <-+ Parsec.try $+ Token.lexeme lexer $+ Parsec.string "infix" >>+ ((Parsec.char 'l' >> return AssocLeft)+ <|>+ (Parsec.char 'r' >> return AssocRight)+ <|>+ return AssocNone)+ prec <-+ fmap (\c -> Char.ord c - Char.ord '0') $+ Token.lexeme lexer Parsec.digit+ ops <- Parsec.sepBy1 Term.infixOperator (Token.comma lexer)+ void $ Parsec.option "" $ Token.semi lexer+ return $ Infix assoc prec ops++instance Output Infix where+ output (Infix assoc prec idents) =+ let assocStr =+ case assoc of+ AssocLeft -> "l"+ AssocRight -> "r"+ AssocNone -> ""+ in hang+ (text ( "infix" ++ assocStr ) <+> text ( show prec ))+ nestDepth+ (hsep ( punctuate comma $ map output idents ) <+> text ";")+++data Declaration = Type_Signature TypeSig+ | Rule_Declaration Rule+ | Type_Declaration Type+ | Data_Declaration Data+ | Infix_Declaration Infix+ deriving (Show)++instance Input Declaration where+ input = fmap Data_Declaration input+ <|> fmap Infix_Declaration input+ <|> fmap Type_Declaration input+ <|> fmap Type_Signature (do+ names <- Parsec.try $ do+ names <- parseIdentList+ reservedOp lexer "::"+ return names+ context <-+ Parsec.try Type.parseContext+ <|>+ return []+ typeExpr <- Type.parseExpression+ void $ Token.semi lexer+ return $ TypeSig names context typeExpr)+ <|> fmap Rule_Declaration 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++-- | 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)++data Module = Module+ { name :: Name+ , imports :: [ Import ]+ , declarations :: [ Declaration ]+ , functions :: FunctionDeclarations+ , source_text :: String+ , source_location :: FilePath+ }++newtype Name = Name {deconsName :: String}+ deriving (Eq, Ord)++instance Input Name where+ input = fmap Name Term.identifier++instance Output Name where+ output (Name n) = text n++tellName :: Name -> String+tellName (Name n) = "module " ++ n+++type FunctionDeclarations = M.Map Identifier [Rule]++-- | 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 =+ m { declarations =+ update+ (\d -> case d of+ Rule_Declaration r' ->+ ident == Rule.name r' &&+ params == Rule.parameters r'+ _ -> False)+ (Rule_Declaration rule) $+ declarations m,+ functions =+ M.insertWith+ (\_ -> update ((params ==) . Rule.parameters) rule)+ ident [rule] $+ functions m }++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 ::+ [Declaration] -> M.Map Identifier [Rule]+make_functions =+ M.fromListWith (flip (++)) .+ mapMaybe (\decl ->+ case decl of+ Rule_Declaration rule -> Just (Rule.name rule, [rule])+ _ -> Nothing)+++{-+We do not define the instance Input Module,+because for proper module parsing+the caller should provide the source file path and content.++instance Input Module where+ input = do+-}+parse ::+ FilePath -> String ->+ Parsec.GenParser Char () Module+parse srcLoc srcText = do+ m <- Parsec.option (Name "Main") $ do+ reserved lexer "module"+ m <- input+ void $ Parsec.optionMaybe $ parsePortList+ reserved lexer "where"+ 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 }++parseUntilEOF ::+ FilePath -> String ->+ Parsec.GenParser Char () Module+parseUntilEOF srcLoc srcText = do+ m <- parse srcLoc srcText+ Parsec.eof+ return m+++instance Output Module where+ output p = vcat+ [ hsep [ text "module", output $ name p, text "where" ]+ , vcat $ map output $ imports p+ , vcat $ map output $ declarations p+ ]++instance Show Module where show = render . output+-- instance Read Module where readsPrec = parsec_reader
+ src/Option.hs view
@@ -0,0 +1,99 @@+module Option where++import qualified Module+import qualified IO+import Option.Utility ( exitFailureMsg, fmapOptDescr )+import qualified HTTPServer.Option as HTTP++import qualified Text.ParserCombinators.Parsec as Parsec++import qualified Paths_live_sequencer as Paths+import qualified System.Console.GetOpt as Opt+import System.Console.GetOpt+ (getOpt, ArgOrder(..), ArgDescr(..), usageInfo, )+import System.Environment (getArgs, getProgName, )+import System.FilePath ( (</>), searchPathSeparator )++import System.Directory ( getCurrentDirectory )+import qualified System.Exit as Exit++import Control.Monad ( when )++import Data.List.HT ( chop )+import Data.List ( intercalate )+++data Option = Option {+ moduleName :: Module.Name,+ importPaths :: [FilePath],+ connectTo, connectFrom :: Maybe String,+ httpOption :: HTTP.Option+ }++getDeflt :: IO Option+getDeflt = do+ dataDir <- Paths.getDataDir+ return $+ Option {+ moduleName = error "no module specified",+ importPaths = map (dataDir </>) [ "data", "data" </> "prelude" ],+ connectTo = Nothing,+ connectFrom = Nothing,+ httpOption = HTTP.deflt+ }+++{-+Guide for common Linux/Unix command-line options:+ http://www.faqs.org/docs/artu/ch10s05.html+-}+description :: Option -> [ Opt.OptDescr (Option -> IO Option) ]+description deflt =+ Opt.Option ['h'] ["help"]+ (NoArg $ \ _flags -> do+ programName <- getProgName+ putStrLn $+ usageInfo ("Usage: " ++ programName ++ " [OPTIONS]") $+ description deflt+ Exit.exitSuccess)+ "show options" :+ Opt.Option ['i'] ["import-paths"]+ (flip ReqArg "PATHS" $ \str flags ->+ return $ flags{importPaths = chop (searchPathSeparator==) str})+ ("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") :+ Opt.Option [] ["connect-from"]+ (flip ReqArg "ALSA-PORT" $ \str flags ->+ return $ flags{connectFrom = Just str})+ ("connect from an ALSA port at startup") :+ map (fmapOptDescr $ \update old -> do+ newHTTP <- update $ httpOption old+ return $ old {httpOption = newHTTP})+ HTTP.description+++get :: IO Option+get = do+ argv <- getArgs+ deflt <- getDeflt+ let (opts, files, errors) =+ getOpt RequireOrder (description deflt) argv+ when (not $ null errors) $+ exitFailureMsg (init (concat errors))++ dir <- getCurrentDirectory+ parsedOpts <-+ 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}+ Left _ -> exitFailureMsg $ show modu ++ " is not a module name"
+ src/Option/Utility.hs view
@@ -0,0 +1,34 @@+module Option.Utility where++import qualified System.Console.GetOpt as G+import qualified System.Exit as Exit+import qualified System.IO as IO+++parseNumber ::+ (Read a) =>+ String -> (a -> Bool) -> String -> String -> IO a+parseNumber name constraint constraintName str =+ case reads str of+ [(n, "")] ->+ if constraint n+ then return n+ else exitFailureMsg $ name ++ " must be a " ++ constraintName ++ " number"+ _ ->+ exitFailureMsg $ name ++ " must be a number, but is '" ++ str ++ "'"++exitFailureMsg :: String -> IO a+exitFailureMsg msg = do+ IO.hPutStrLn IO.stderr msg+ Exit.exitFailure++fmapArgDescr :: (a -> b) -> (G.ArgDescr a -> G.ArgDescr b)+fmapArgDescr f d =+ case d of+ G.NoArg a -> G.NoArg $ f a+ G.ReqArg g str -> G.ReqArg (f.g) str+ G.OptArg g str -> G.OptArg (f.g) str++fmapOptDescr :: (a -> b) -> (G.OptDescr a -> G.OptDescr b)+fmapOptDescr f (G.Option short long arg help) =+ G.Option short long (fmapArgDescr f arg) help
+ src/Program.hs view
@@ -0,0 +1,146 @@+module Program where++import Term ( Range (Range, start), Identifier (..) )+import Module ( Module )+import qualified Module+import qualified Log+import qualified Exception++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 System.Directory ( doesFileExist )+import System.FilePath ( (</>) )+import qualified System.IO.Error as Err+import qualified System.FilePath as FP++import qualified Data.Traversable as Trav+import qualified Data.Map as M+import Control.Monad ( foldM )+import Data.List.HT ( chop )+++data Program = Program+ { modules :: M.Map Module.Name Module+ , functions :: Module.FunctionDeclarations+ }+-- deriving (Show)++empty :: Program+empty =+ Program { modules = M.empty, functions = M.empty }++add_module ::+ 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 ))++union_functions ::+ Module.FunctionDeclarations ->+ Module.FunctionDeclarations ->+ Exc.Exceptional Exception.Message Module.FunctionDeclarations+union_functions 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)+ ("duplicate definition of " ++ show n0 +++ " in " ++ (show $ Pos.sourceName $ start $ range n0) +++ " and " ++ (show $ Pos.sourceName $ start $ range n1))))+ (f m0) (f m1)++-- | load from disk, with import chasing+chase ::+ [ FilePath ] -> Module.Name ->+ Exc.ExceptionalT Exception.Message IO Program+chase dirs n =+ chaser dirs empty n++chaser ::+ [ FilePath ] -> Program -> Module.Name ->+ Exc.ExceptionalT Exception.Message IO Program+chaser dirs p n = do+ lift $ Log.put $ "chasing " ++ Module.tellName n+ case M.lookup n ( modules p ) of+ Just _ -> lift $ do+ 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" )++load ::+ [ FilePath ] -> Program -> String -> FilePath ->+ Exc.ExceptionalT Exception.Message IO Program+load dirs p n ff = do+ parseResult <-+ 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++-- | look for file, trying to append its name to the directories in the path,+-- in turn. Will fail if file is not found.+chaseFile ::+ [FilePath] -> FilePath ->+ Exc.ExceptionalT Exception.Message IO FilePath+chaseFile dirs f =+ foldr+ (\dir go -> do+ let ff = dir </> f+ e <- lift $ doesFileExist ff+ if e+ then lift $ do+ Log.put $ unwords [ "found at location", ff ]+ return ff+ else go)+ (Exc.throwT $ Exception.Message Exception.InOut+ (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
@@ -0,0 +1,215 @@+module Rewrite where++import Term ( Term(..), Identifier(..), Range(..), termRange )+import 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 Control.Monad.Trans.Class ( lift )+import Control.Monad.Exception.Synchronous+ ( Exceptional(Exception,Success), ExceptionalT,+ mapExceptionalT, throwT )+import qualified Data.Map as M+import qualified Data.Traversable as Trav++import Data.Maybe.HT ( toMaybe )+import Data.Tuple.HT ( mapSnd )+import Data.List ( intercalate )+++data Message = Step { target :: Identifier+ , rule :: Maybe Identifier -- ^ Nothing for builtins+ }+ | Data { origin :: Identifier }+ deriving Show++type Evaluator =+ ExceptionalT (Range, String) ( WriterT [ Message ] ( Reader Program ) )++runEval ::+ (Monad m) =>+ Program -> Evaluator a ->+ ExceptionalT (Range, String) ( WriterT [ Message ] m ) a+runEval p =+ mapExceptionalT (mapWriterT (return . flip runReader p))++exception :: Range -> String -> Evaluator a+exception rng msg =+ throwT $ (rng, msg)+++-- | force head of stream:+-- evaluate until we have Cons or Nil at root,+-- then evaluate first argument of Cons fully.+force_head :: Term -> Evaluator Term+force_head t = do+ t' <- top t+ case t' of+ Node i [ x, xs ] | name i == ":" -> do+ y <- full x+ return $ Node i [ y, xs ]+ Node i [] | name i == "[]" ->+ return $ Node i []+ _ ->+ exception (termRange t') $ "not a list term: " ++ show t++-- | force full evaluation+-- (result has only constructors and numbers)+full :: Term -> Evaluator Term+full x = do+ x' <- top x+ case x' of+ Node f args ->+ fmap (Node f) $ mapM full args+ Number _ _ -> return x'+ String_Literal _ _ -> return x'++-- | evaluate until root symbol is constructor.+top :: Term -> Evaluator Term+top t = case t of+ Number {} -> return t+ String_Literal {} -> return t+ Node f xs ->+ if Term.isConstructor f+ then return t+ else do+ rs <- lift $ lift $ asks functions+ eval rs f xs >>= top++-- | do one reduction step at the root+eval :: Module.FunctionDeclarations -> 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 } ]+ case ys of+ [ Number _ a, Number _ b] ->+ case name i of+ -- FIXME: handling of positions is dubious+ "<" ->+ return $+ Node ( Identifier { name = show (a < b)+ , range = range i } ) []+ "compare" ->+ return $+ Node ( Identifier { name = show (compare a b)+ , range = range i } ) []+ "-" -> return $ Number (range i) $ a - b+ "+" -> return $ Number (range i) $ a + b+ "*" -> return $ Number (range i) $ a * b+ "div" -> return $ Number (range i) $ div a b+ "mod" -> return $ Number (range i) $ mod a b+ opName ->+ exception (range i) $ "unknown operation " ++ show opName+ _ -> exception (range i) $ "wrong number of arguments"++eval funcs g ys =+ case M.lookup g funcs of+ Nothing ->+ exception (range g) $+ unwords [ "unknown function", show $ Node g ys ]+ Just rules ->+ eval_decls g rules ys+++eval_decls :: Identifier -> [ Rule.Rule ] -> [Term] -> Evaluator Term+eval_decls g =+ foldr+ (\(Rule.Rule f xs rhs) go ys -> do+ (m, ys') <- match_expand_list M.empty xs ys+ case m of+ Nothing -> go ys'+ Just (substitions, additionalArgs) -> do+ lift $ tell [ Step { target = g+ , rule = Just f } ]+ rhs' <- apply substitions rhs+ appendArguments rhs' additionalArgs)+ (\ys ->+ exception (range g) $+ unwords [ "no matching pattern for function", show g,+ "and arguments", show ys ])++appendArguments :: Term -> [Term] -> Evaluator Term+appendArguments f xs =+ case Term.appendArguments f xs of+ Success t -> return t+ Exception e -> exception (termRange f) e+++-- | 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 ::+ Term -> Term ->+ Evaluator ( Maybe (M.Map Identifier Term) , Term )+match_expand pat t = case pat of+ Node f [] | Term.isVariable f ->+ return ( Just $ M.singleton f t , t )+ Node f xs | Term.isConstructor f -> do+ t' <- top t+ case t' of+ Node g ys ->+ if f /= g+ then return ( Nothing, t' )+ else do+ ( m, ys' ) <- match_expand_list M.empty xs ys+ return ( fmap fst m, Node f ys' )+ _ ->+ exception (termRange t') $+ "constructor pattern matched against non-constructor term: " ++ show t'+ Node _ _ ->+ exception (termRange pat) $+ "pattern is neither constructor nor number: " ++ show pat+ Number _ a -> do+ t' <- top t+ case t' of+ Number _ b ->+ return ( toMaybe (a==b) M.empty, t' )+ _ ->+ exception (termRange t') $+ "number pattern matched against non-number term: " ++ show t'+ String_Literal _ a -> do+ t' <- top t+ case t' of+ String_Literal _ b ->+ return ( toMaybe (a==b) M.empty, t' )+ _ ->+ exception (termRange t') $+ "string pattern matched against non-string term: " ++ show t'+++match_expand_list ::+ 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+ case m of+ Nothing -> return ( Nothing, y' : ys )+ Just s' -> do+ s'' <-+ case runWriter $ Trav.sequenceA $+ M.unionWithKey (\var t _ -> 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:_) _ =+ exception (termRange x) "too few arguments"++apply :: M.Map Identifier Term -> Term -> Evaluator Term+apply m 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
+ src/Rule.hs view
@@ -0,0 +1,37 @@+module Rule where++import IO+import Term ( Term(Node), Identifier )+import qualified Term++import Text.PrettyPrint.HughesPJ ( fsep, render, text )+++data Rule = Rule+ { name :: Identifier+ , parameters :: [ Term ]+ , rhs :: Term+ }++instance Show Rule where show = render . output+instance Read Rule where readsPrec = parsec_reader++instance Output Rule where+ output r =+ fsep [ output ( Node (name r) (parameters r) ), text "=",+ output ( rhs r ), text ";" ]++instance Input Rule where+ input = do+ t <- input+ (nm, ps) <-+ case t of+ Term.Node nm args ->+ if Term.isVariable nm+ then return (nm, args)+ else fail $ show nm ++ " is not a function identifier"+ _ -> fail $ "the term " ++ show t ++ " is not a valid left-hand side of a rule"+ Term.symbol "="+ r <- input+ Term.symbol ";"+ return $ Rule { name = nm, parameters = ps, rhs = r }
+ src/Step.hs view
@@ -0,0 +1,29 @@+module Step where++import Term+import Rule++import qualified Data.Map as M+import Control.Monad ( forM, mzero )++-- | pattern must be linear+match :: [ Identifier ] -- ^ list of variables in pattern+ -> Term -- ^ pattern+ -> Term -- ^ term to match+ -> Maybe ( M.Map Identifier Term )+match vs p t = case p of+ Number {} | p == t -> return $ M.empty+ Node v [] | v `elem` vs -> return $ M.fromList [ (v, t) ]+ Node f xs -> case t of+ Node g ys | f == g && length xs == length ys -> do+ ms <- forM ( zip xs ys ) $ \ (x,y) -> match vs x y+ return $ M.unionsWith ( error "non-linear pattern" ) ms+ _ -> mzero+++root_step :: Rule -> Term -> Maybe Term+root_step r t = do+ m <- match ( vars r ) ( lhs r ) t+ return $ apply m ( rhs r )++
+ src/Term.hs view
@@ -0,0 +1,307 @@+module Term where++import IO ( Input, Output, input, output, parsec_reader )++import qualified Text.ParserCombinators.Parsec.Token as T+import qualified Text.ParserCombinators.Parsec.Language as L+import qualified Text.ParserCombinators.Parsec.Expr as Expr+import qualified Text.ParserCombinators.Parsec as Parsec+import Text.ParserCombinators.Parsec+ ( CharParser, Parser, getPosition, (<|>), (<?>), )+import Text.ParserCombinators.Parsec.Pos+ ( SourcePos, )+import Text.ParserCombinators.Parsec.Expr+ ( Assoc(AssocLeft, AssocRight, AssocNone) )+import Text.PrettyPrint.HughesPJ ( Doc, (<+>), fsep, parens, render, text )++import qualified Data.Set as S+import Control.Monad.Exception.Synchronous ( Exceptional(Success,Exception) )+import Control.Monad ( liftM2, mzero )+import Control.Functor.HT ( void )+import Data.Char (isUpper, isLower)+import Data.Ord (comparing)+++data Range = Range { start :: SourcePos , end :: SourcePos }+ deriving (Eq, Ord, Show)++data Identifier =+ Identifier { range :: Range, name :: String }++instance Eq Identifier where+-- | FIXME: this is ignoring the module.+-- for a complete implementation, we'd need fully qualified names+ i == j = name i == name j++instance Ord Identifier where+ compare = comparing name++isConstructor :: Identifier -> Bool+isConstructor i =+ case name i of+ c:_ -> c == '[' || c == ':' || isUpper c+ _ -> error "isConstructor: identifier must be non-empty"++isVariable :: Identifier -> Bool+isVariable i =+ case name i of+ c:_ -> isLower c || elem c ('_':operatorSymbols)+ _ -> error "isVariable: identifier must be non-empty"+++lexer :: T.TokenParser st+lexer =+ T.makeTokenParser $ L.emptyDef {+ L.commentStart = "{-",+ L.commentEnd = "-}",+ L.commentLine = "--",+ L.nestedComments = True,+ L.identStart = identifierStart,+ L.identLetter = identifierLetter,+ L.opStart = operatorStart,+ L.opLetter = operatorLetter,+ L.caseSensitive = True,+ L.reservedNames = [ "module", "where", "import", "qualified"+ , "as", "data", "class", "instance", "case", "of"+ , "infix", "infixl", "infixr" ],+ L.reservedOpNames = [ "=", "::", "|" ]+ }+++-- FIXME: this should be read from a file (Prelude.hs).+-- but then we need a parser that correctly handles fixity information+-- on-the-fly.+-- A simplified solution could be:+-- Allow fixity definitions only between import and the first declaration.+-- With this restriction we could parse the preamble first+-- and then start with a fresh parser for the module body.+-- For now, we hard-code Prelude's fixities:+{-+++infixr 9 .+infixr 8 ^, ^^, **+infixl 7 *, /, `quot`, `rem`, `div`, `mod`+infixl 6 +, -++-- The (:) operator is built-in syntax, and cannot legally be given+-- a fixity declaration; but its fixity is given by:+-- infixr 5 :++infix 4 ==, /=, <, <=, >=, >+infixr 3 &&+infixr 2 ||+infixl 1 >>, >>=+infixr 1 =<<+infixr 0 $, $!, `seq`+-}++operators :: [[([Char], Assoc)]]+operators =+ [ [ ( ".", AssocRight ), ( "!!", AssocLeft ) ]+ , [ ( "^", AssocRight) ]+ , [ ( "*", AssocLeft), ("/", AssocLeft), ("%", AssocLeft), ("+:+", AssocRight) ]+ , [ ( "+", AssocLeft), ("-", AssocLeft), ("=:=", AssocRight) ]+ , [ ( ":", AssocRight ), ( "++", AssocRight ) ]+ , map ( \ s -> (s, AssocNone) ) [ "==", "/=", "<", "<=", ">=", ">" ]+ , [ ( "&&", AssocRight ) ]+ , [ ( "||", AssocRight ) ]+ , [ ( "$", AssocRight ) ]+ ]++identifierStart, identifierLetter :: CharParser st Char+identifierStart = Parsec.letter <|> Parsec.char '_'++-- FIXME: check the distinction between '.' in qualified names, and as operator+identifierLetter =+ Parsec.alphaNum <|> Parsec.char '_' <|> Parsec.char '.'++identifierCore :: Parser String+identifierCore =+ liftM2 (:) identifierStart (Parsec.many identifierLetter)++identifier :: Parser String+identifier = T.identifier lexer++parenOperator :: Parser Identifier+parenOperator =+ T.parens lexer $ T.lexeme lexer $+ fmap (uncurry Identifier) $ ranged $+ liftM2 (:) operatorStart (Parsec.many operatorLetter)++infixOperator :: Parser Identifier+infixOperator =+ T.lexeme lexer $+ fmap (uncurry Identifier) $ ranged $+ Parsec.between (Parsec.char '`') (Parsec.char '`') identifierCore+ <|>+ liftM2 (:) operatorStart (Parsec.many operatorLetter)++symbol :: String -> Parser ()+symbol = void . T.symbol lexer++ranged :: CharParser st a -> CharParser st (Range, a)+ranged p = do+ from <- getPosition+ x <- p+ to <- getPosition+ return $ (Range from to, x)+++instance Input Identifier where+ input =+ T.lexeme lexer $+ fmap (uncurry Identifier) $ ranged identifierCore++instance Output Identifier where+ output i = text $ name i++instance Show Identifier where show = render . output+instance Read Identifier where readsPrec = parsec_reader+++data Term = Node Identifier [ Term ]+ | Number Range Integer+ | String_Literal Range String+ deriving ( Eq, Ord )++instance Show Term where show = render . output+instance Read Term where readsPrec = parsec_reader+++{- |+simplifies case analysis+-}+viewNode :: Term -> Maybe (String, [Term])+viewNode (Node f xs) = Just (Term.name f, xs)+viewNode _ = Nothing++appendArguments :: Term -> [Term] -> Exceptional String Term+appendArguments g ys =+ case (g, ys) of+ (Node f xs, _) -> return $ Node f $ xs ++ ys+ (t, []) -> return t+ (t, _) ->+ Exception $+ unwords [ "cannot apply ", show t,+ "to arguments like a function" ]++{- |+I would like to use 'T.stringLiteral'+but this skips trailing spaces+and we need the precise range of the literal.+However this implementation is very simplistic,+since T.stringChar is not exported.+-}+parseStringLiteral :: Parsec.GenParser Char st String+parseStringLiteral =+ flip (<?>) "literal string" $+-- fmap catMaybes $+ Parsec.between+ (Parsec.char '"')+ (Parsec.char '"' <?> "end of string")+ (Parsec.many (Parsec.noneOf $ '"':"\n\r\\"))+-- (Parsec.many (T.stringChar lexer))+++parseAtom :: Parser Term+parseAtom =+ (T.lexeme lexer $ fmap (uncurry Number) $+ ranged (fmap read $ Parsec.many1 Parsec.digit))+ <|> fmap (uncurry String_Literal)+ (T.lexeme lexer (ranged parseStringLiteral))+-- <|> fmap (uncurry String_Literal) (ranged (T.stringLiteral lexer))+ <|> T.parens lexer input+ <|> bracketed_list+ <|> fmap (flip Node []) input++parse :: Parser Term+parse = do+ t <- liftM2 appendArguments parseAtom $ Parsec.many parseAtom+ case t of+ Success t' -> return t'+ Exception e -> fail e++instance Input Term where+ input = Expr.buildExpressionParser table parse++operatorStart, operatorLetter :: CharParser st Char+operatorStart = Parsec.oneOf operatorSymbols+operatorLetter = Parsec.oneOf operatorSymbols++operatorSymbols :: [Char]+operatorSymbols = ":!#$%&*+./<=>?@\\^|-~"++table :: Expr.OperatorTable Char st Term+table = map ( map binary ) operators++binary :: (String, Assoc) -> Expr.Operator Char st Term+binary (s, assoc) = flip Expr.Infix assoc $ do+ rng <- Parsec.try $ T.lexeme lexer $ do+ (rng,_) <- ranged $ Parsec.string s+ Parsec.notFollowedBy operatorLetter <?> ("end of " ++ show s)+ return rng+ return $ \ l r -> Node ( Identifier { name = s, range = rng } ) [ l, r ]+++bracketed_list :: Parser Term+bracketed_list = do+ (r,_) <- ranged $ symbol "["+ inside_bracketed_list r++inside_bracketed_list :: Range -> Parser Term+inside_bracketed_list rng =+ do (r,_) <- ranged $ symbol "]"+ return $ Node ( Identifier { name = "[]", range = r } ) []+ <|> do x <- input+ q <- getPosition+ xs <- do symbol "]" ; r <- getPosition+ return $ Node ( Identifier { name = "[]", range = Range q r } ) []+ <|> do symbol "," ; r <- getPosition+ inside_bracketed_list $ 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+ Node f args -> output f <+> fsep ( map protected args )++protected :: Term -> Doc+protected t = case t of+ Node _f (_:_) -> parens $ output t+ _ -> output t+++type Position = [ Int ]++termRange :: Term -> Range+termRange (Node i _) = range i+termRange (Number rng _) = rng+termRange (String_Literal rng _) = rng++subterms :: Term -> [ (Position, Term) ]+subterms t = ( [], t ) : case t of+ Node _f xs -> do+ (k, x) <- zip [ 0.. ] xs+ (p, s) <- subterms x+ return (k : p, s)+ _ -> []++signature :: Term -> S.Set Identifier+signature t = S.fromList $ do+ (_p, Node f _xs) <- subterms t+ return f++peek :: Term -> Position -> Maybe Term+peek t [] = return t+peek (Node _f xs) (k : ks) | k < length xs =+ peek (xs !! k) ks+peek _ _ = mzero++poke :: Term -> Position -> Term -> Maybe Term+poke _t [] s = return s+poke (Node f xs) (k : ks) s | k < length xs = do+ let (pre, x : post) = splitAt k xs+ y <- poke x ks s+ return $ Node f $ pre ++ y : post
+ src/Type.hs view
@@ -0,0 +1,94 @@+module Type where++import qualified Term+import Term ( Term(Node), Identifier(Identifier) )+import IO ( Input, input )++import qualified Text.ParserCombinators.Parsec.Token as T+import qualified Text.ParserCombinators.Parsec.Language as L+import qualified Text.ParserCombinators.Parsec.Expr as Expr+import qualified Text.ParserCombinators.Parsec as Parsec+import Text.ParserCombinators.Parsec+ ( CharParser, Parser, (<|>), (<?>), )+import Text.ParserCombinators.Parsec.Expr+ ( Assoc(AssocRight) )++import Control.Monad.Exception.Synchronous ( Exceptional(Success,Exception) )+import Control.Monad ( liftM2 )+++lexer :: T.TokenParser st+lexer =+ T.makeTokenParser $ L.emptyDef {+ L.commentStart = "{-",+ L.commentEnd = "-}",+ L.commentLine = "--",+ L.nestedComments = True,+ L.identStart = Term.identifierStart,+ L.identLetter = Term.identifierLetter,+ L.opStart = operatorStart,+ L.opLetter = operatorLetter,+ L.caseSensitive = True,+ L.reservedNames = [ "forall" ],+ L.reservedOpNames = [ "=", "::", "|" ]+ }+++operators :: [[([Char], Assoc)]]+operators =+ [ [ ( "->", AssocRight ) ]+-- , [ ( ",", AssocRight) ]+ ]+++parseBracket :: Parser Term+parseBracket = T.lexeme lexer $ do+ (rng,term) <-+ Term.ranged $+ Parsec.between (T.symbol lexer "[") (Parsec.char ']') parseExpression+ return (Node (Identifier { Term.name = "[]", Term.range = rng }) [term])++parseAtom :: Parser Term+parseAtom =+ T.parens lexer parseExpression+ <|> parseBracket+ <|> fmap (flip Node []) input++parseApply :: Parser Term+parseApply = do+ t <- liftM2 Term.appendArguments parseAtom $ Parsec.many parseAtom+ case t of+ Success t' -> return t'+ Exception e -> fail e+++operatorStart, operatorLetter :: CharParser st Char+operatorStart = Parsec.oneOf operatorSymbols+operatorLetter = Parsec.oneOf operatorSymbols++operatorSymbols :: [Char]+operatorSymbols = ":->"++table :: Expr.OperatorTable Char st Term+table = map ( map binary ) operators++binary :: (String, Assoc) -> Expr.Operator Char st Term+binary (s, assoc) = flip Expr.Infix assoc $ do+ rng <- Parsec.try $ T.lexeme lexer $ do+ (rng,_) <- Term.ranged $ Parsec.string s+ Parsec.notFollowedBy operatorLetter <?> ("end of " ++ show s)+ return rng+ return $ \ l r -> Node ( Identifier { Term.name = s, Term.range = rng } ) [ l, r ]+++parseContext :: Parsec.GenParser Char () [Term]+parseContext = do+ constraints <-+ T.parens lexer $+ T.commaSep lexer input+ T.reservedOp lexer "=>"+ return constraints++parseExpression :: Parsec.GenParser Char () Term+parseExpression =+ Expr.buildExpressionParser table parseApply
+ src/Utility/Concurrent.hs view
@@ -0,0 +1,21 @@+module Utility.Concurrent where++import Control.Concurrent.STM.TChan+import Control.Concurrent.STM.TMVar+import Control.Monad.STM ( STM )+import qualified Control.Monad.STM as STM++import Control.Functor.HT ( void )+++writeTMVar :: TMVar a -> a -> STM ()+writeTMVar var a =+ clearTMVar var >> putTMVar var a++clearTMVar :: TMVar a -> STM ()+clearTMVar var =+ void $ tryTakeTMVar var++writeTChanIO :: TChan a -> a -> IO ()+writeTChanIO chan a =+ STM.atomically $ writeTChan chan a
+ src/Utility/WX.hs view
@@ -0,0 +1,37 @@+-- | might be moved to wx package+module Utility.WX where++import qualified Graphics.UI.WX as WX+import Graphics.UI.WX.Controls ( TextCtrl, Notebook )++-- import qualified Graphics.UI.WXCore as WXCore+-- import qualified Graphics.UI.WXCore.WxcClassesAL as WXCAL+import qualified Graphics.UI.WXCore.WxcClassesMZ as WXCMZ++import Control.Functor.HT ( void )+++cursor :: WX.Attr (TextCtrl a) Int+cursor =+ WX.newAttr "cursor"+ WXCMZ.textCtrlGetInsertionPoint+ WXCMZ.textCtrlSetInsertionPoint++editable :: WX.Attr (TextCtrl a) Bool+editable =+ WX.newAttr "editable"+ WXCMZ.textCtrlIsEditable+ WXCMZ.textCtrlSetEditable++modified :: WX.ReadAttr (TextCtrl a) Bool+modified =+ WX.readAttr "modified"+ WXCMZ.textCtrlIsModified+-- WXCMZ.textCtrlDiscardEdits+-- WXCMZ.textCtrlMarkDirty++notebookSelection :: WX.Attr (Notebook a) Int+notebookSelection =+ WX.newAttr "selection"+ WXCMZ.notebookGetSelection+ (\nb -> void . WXCMZ.notebookSetSelection nb)