diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,1 @@ +GPL diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#! /usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/data/Band.hs b/data/Band.hs new file mode 100644 --- /dev/null +++ b/data/Band.hs @@ -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 ] ; diff --git a/data/Bool.hs b/data/Bool.hs new file mode 100644 --- /dev/null +++ b/data/Bool.hs @@ -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 ; diff --git a/data/Chords.hs b/data/Chords.hs new file mode 100644 --- /dev/null +++ b/data/Chords.hs @@ -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) ; diff --git a/data/CrossSum.hs b/data/CrossSum.hs new file mode 100644 --- /dev/null +++ b/data/CrossSum.hs @@ -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 ; diff --git a/data/DeBruijn.hs b/data/DeBruijn.hs new file mode 100644 --- /dev/null +++ b/data/DeBruijn.hs @@ -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 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 ; diff --git a/data/Drum.hs b/data/Drum.hs new file mode 100644 --- /dev/null +++ b/data/Drum.hs @@ -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 ; diff --git a/data/Fibonacci.hs b/data/Fibonacci.hs new file mode 100644 --- /dev/null +++ b/data/Fibonacci.hs @@ -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 ; diff --git a/data/Finite.hs b/data/Finite.hs new file mode 100644 --- /dev/null +++ b/data/Finite.hs @@ -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) ; diff --git a/data/Function.hs b/data/Function.hs new file mode 100644 --- /dev/null +++ b/data/Function.hs @@ -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) ; diff --git a/data/Instrument.hs b/data/Instrument.hs new file mode 100644 --- /dev/null +++ b/data/Instrument.hs @@ -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 ; diff --git a/data/Integer.hs b/data/Integer.hs new file mode 100644 --- /dev/null +++ b/data/Integer.hs @@ -0,0 +1,5 @@ +module Integer where + +isZero :: Integer -> Bool ; +isZero 0 = True ; +isZero _ = False ; diff --git a/data/Klingklong.hs b/data/Klingklong.hs new file mode 100644 --- /dev/null +++ b/data/Klingklong.hs @@ -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 ; diff --git a/data/List.hs b/data/List.hs new file mode 100644 --- /dev/null +++ b/data/List.hs @@ -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) [] ; diff --git a/data/ListLive.hs b/data/ListLive.hs new file mode 100644 --- /dev/null +++ b/data/ListLive.hs @@ -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 ; diff --git a/data/Midi.hs b/data/Midi.hs new file mode 100644 --- /dev/null +++ b/data/Midi.hs @@ -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 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 [] ; diff --git a/data/Music.hs b/data/Music.hs new file mode 100644 --- /dev/null +++ b/data/Music.hs @@ -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 ] ; diff --git a/data/Pattern.hs b/data/Pattern.hs new file mode 100644 --- /dev/null +++ b/data/Pattern.hs @@ -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 ; diff --git a/data/Pitch.hs b/data/Pitch.hs new file mode 100644 --- /dev/null +++ b/data/Pitch.hs @@ -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) ; diff --git a/data/Render.hs b/data/Render.hs new file mode 100644 --- /dev/null +++ b/data/Render.hs @@ -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 diff --git a/data/Simplesong.hs b/data/Simplesong.hs new file mode 100644 --- /dev/null +++ b/data/Simplesong.hs @@ -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) ] ) ; diff --git a/data/Sweep.hs b/data/Sweep.hs new file mode 100644 --- /dev/null +++ b/data/Sweep.hs @@ -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) ; diff --git a/data/Tuple.hs b/data/Tuple.hs new file mode 100644 --- /dev/null +++ b/data/Tuple.hs @@ -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 ; diff --git a/data/UD.hs b/data/UD.hs new file mode 100644 --- /dev/null +++ b/data/UD.hs @@ -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 ] + ] ) ; diff --git a/data/prelude/Prelude.hs b/data/prelude/Prelude.hs new file mode 100644 --- /dev/null +++ b/data/prelude/Prelude.hs @@ -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 Int ; +fromInteger x = x ; + +-- fromIntegral :: Int -> Integer ; +fromIntegral x = x ; diff --git a/http/disable/HTTPServer/GUI.hs b/http/disable/HTTPServer/GUI.hs new file mode 100644 --- /dev/null +++ b/http/disable/HTTPServer/GUI.hs @@ -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 () diff --git a/http/disable/HTTPServer/Option.hs b/http/disable/HTTPServer/Option.hs new file mode 100644 --- /dev/null +++ b/http/disable/HTTPServer/Option.hs @@ -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 = [] diff --git a/http/enable/HTTPServer.hs b/http/enable/HTTPServer.hs new file mode 100644 --- /dev/null +++ b/http/enable/HTTPServer.hs @@ -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]) diff --git a/http/enable/HTTPServer/GUI.hs b/http/enable/HTTPServer/GUI.hs new file mode 100644 --- /dev/null +++ b/http/enable/HTTPServer/GUI.hs @@ -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 diff --git a/http/enable/HTTPServer/Option.hs b/http/enable/HTTPServer/Option.hs new file mode 100644 --- /dev/null +++ b/http/enable/HTTPServer/Option.hs @@ -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, Henning Thielemann +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 diff --git a/src/ALSA.hs b/src/ALSA.hs new file mode 100644 --- /dev/null +++ b/src/ALSA.hs @@ -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 diff --git a/src/Console.hs b/src/Console.hs new file mode 100644 --- /dev/null +++ b/src/Console.hs @@ -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 diff --git a/src/Controls.hs b/src/Controls.hs new file mode 100644 --- /dev/null +++ b/src/Controls.hs @@ -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 ) + ) + _ -> [] diff --git a/src/Event.hs b/src/Event.hs new file mode 100644 --- /dev/null +++ b/src/Event.hs @@ -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 diff --git a/src/Exception.hs b/src/Exception.hs new file mode 100644 --- /dev/null +++ b/src/Exception.hs @@ -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 diff --git a/src/GUI.hs b/src/GUI.hs new file mode 100644 --- /dev/null +++ b/src/GUI.hs @@ -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 diff --git a/src/IO.hs b/src/IO.hs new file mode 100644 --- /dev/null +++ b/src/IO.hs @@ -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)] diff --git a/src/Lilypond.hs b/src/Lilypond.hs new file mode 100644 --- /dev/null +++ b/src/Lilypond.hs @@ -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")) + ++ + " ++" diff --git a/src/Log.hs b/src/Log.hs new file mode 100644 --- /dev/null +++ b/src/Log.hs @@ -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 diff --git a/src/Module.hs b/src/Module.hs new file mode 100644 --- /dev/null +++ b/src/Module.hs @@ -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 diff --git a/src/Option.hs b/src/Option.hs new file mode 100644 --- /dev/null +++ b/src/Option.hs @@ -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" diff --git a/src/Option/Utility.hs b/src/Option/Utility.hs new file mode 100644 --- /dev/null +++ b/src/Option/Utility.hs @@ -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 diff --git a/src/Program.hs b/src/Program.hs new file mode 100644 --- /dev/null +++ b/src/Program.hs @@ -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 diff --git a/src/Rewrite.hs b/src/Rewrite.hs new file mode 100644 --- /dev/null +++ b/src/Rewrite.hs @@ -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 diff --git a/src/Rule.hs b/src/Rule.hs new file mode 100644 --- /dev/null +++ b/src/Rule.hs @@ -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 } diff --git a/src/Step.hs b/src/Step.hs new file mode 100644 --- /dev/null +++ b/src/Step.hs @@ -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 ) + + diff --git a/src/Term.hs b/src/Term.hs new file mode 100644 --- /dev/null +++ b/src/Term.hs @@ -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 diff --git a/src/Type.hs b/src/Type.hs new file mode 100644 --- /dev/null +++ b/src/Type.hs @@ -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 diff --git a/src/Utility/Concurrent.hs b/src/Utility/Concurrent.hs new file mode 100644 --- /dev/null +++ b/src/Utility/Concurrent.hs @@ -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 diff --git a/src/Utility/WX.hs b/src/Utility/WX.hs new file mode 100644 --- /dev/null +++ b/src/Utility/WX.hs @@ -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)