diff --git a/data/base/Bool.hs b/data/base/Bool.hs --- a/data/base/Bool.hs +++ b/data/base/Bool.hs @@ -12,6 +12,12 @@ not False = True ; not True = False ; +-- the same as (/=) for Bool +xor :: Bool -> Bool -> Bool ; +xor False True = True ; +xor True False = True ; +xor _ _ = False ; + infixr 3 && ; diff --git a/data/base/Chords.hs b/data/base/Chords.hs --- a/data/base/Chords.hs +++ b/data/base/Chords.hs @@ -1,30 +1,31 @@ module Chords where import Midi +import Pitch ( Pitch ) chord :: - Integer -> [Integer] -> + Time -> [Pitch] -> [Midi.Event Midi.Message] ; chord dur = mergeMany . map (note dur) ; chord3 :: - Integer -> - Integer -> Integer -> Integer -> + Time -> + Pitch -> Pitch -> Pitch -> [Midi.Event Midi.Message] ; chord3 dur p0 p1 p2 = chord dur [p0, p1, p2] ; chord4 :: - Integer -> - Integer -> Integer -> Integer -> Integer -> + Time -> + Pitch -> Pitch -> Pitch -> Pitch -> [Midi.Event Midi.Message] ; chord4 dur p0 p1 p2 p3 = chord dur [p0, p1, p2, p3] ; major, major7, minor, minor7 :: - Integer -> Integer -> [Midi.Event Midi.Message] ; + Time -> Pitch -> [Midi.Event Midi.Message] ; major dur base = chord4 dur base (base + 4) (base + 7) (base + 12) ; diff --git a/data/base/Enum.hs b/data/base/Enum.hs new file mode 100644 --- /dev/null +++ b/data/base/Enum.hs @@ -0,0 +1,13 @@ +module Enum where + +import Prelude (Eq, Num, (+), (-), ) ; + +succ, pred :: (Num a) => a -> a ; +succ x = x+1 ; +pred x = x-1 ; + +enumFrom, enumFromLazy :: (Eq a, Num a) => a -> [a] ; +enumFrom 0 = enumFromLazy 0 ; +enumFrom n = enumFromLazy n ; + +enumFromLazy n = n : enumFrom (succ n) ; diff --git a/data/base/List.hs b/data/base/List.hs --- a/data/base/List.hs +++ b/data/base/List.hs @@ -1,6 +1,7 @@ module List ( map, zipWith, + zipWith3, foldr, foldl, length, @@ -24,11 +25,13 @@ drop, filter, takeWhile, + inits, + tails, ) where +import List.Basic import ListLive import Function -import Bool import Prelude ( (-), (+), Num, Int, Bool(False,True), error ) @@ -41,6 +44,11 @@ f x y : zipWith f xs ys ; zipWith _f _xs _ys = [] ; +zipWith3 :: (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d] ; +zipWith3 f (x : xs) (y : ys) (z : zs) = + f x y z : zipWith3 f xs ys zs ; +zipWith3 _f _xs _ys _zs = [] ; + foldr :: (b -> a -> a) -> a -> [b] -> a ; foldr _ a [] = a ; foldr f a (x : xs) = f x ( foldr f a xs ) ; @@ -87,12 +95,6 @@ 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 ; @@ -113,29 +115,22 @@ (_: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) [] ; +inits :: [a] -> [[a]] ; +inits xs = [] : initsAux xs ; -filterElem :: (a -> Bool) -> a -> [a] -> [a] ; -filterElem p x xs = ifThenElse (p x) (x:xs) xs ; +initsAux :: [a] -> [[a]] ; +initsAux [] = [] ; +initsAux (x:xs) = map (cons x) (inits xs) ; -takeWhile :: (a -> Bool) -> [a] -> [a] ; -takeWhile p = - foldr (takeWhileElem p) [] ; +tails :: [a] -> [[a]] ; +tails xs = xs : tailsAux xs ; -takeWhileElem :: (a -> Bool) -> a -> [a] -> [a] ; -takeWhileElem p x xs = ifThenElse (p x) (x:xs) [] ; +tailsAux :: [a] -> [[a]] ; +tailsAux [] = [] ; +tailsAux (_:xs) = tails xs ; diff --git a/data/base/List/Advanced.hs b/data/base/List/Advanced.hs new file mode 100644 --- /dev/null +++ b/data/base/List/Advanced.hs @@ -0,0 +1,41 @@ +module List.Advanced where +{- +This module contains implementations of list functions +using higher-order functions like foldr. +This allows concise definitions +but looks ugly in the reduction window +and needs usually more reductions. +-} + +import ListLive ( cons, append ) +import Bool + + +(++) :: [a] -> [a] -> [a] ; +xs ++ ys = foldr cons ys xs ; + +concat :: [[a]] -> [a] ; +concat = foldr append []; + + +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) ; + + +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/base/List/Basic.hs b/data/base/List/Basic.hs new file mode 100644 --- /dev/null +++ b/data/base/List/Basic.hs @@ -0,0 +1,36 @@ +module List.Basic where +{- +This module contains implementations of list functions +using plain recursion. +The definitions become a bit longer +but the reductions look a bit nicer +and there are usually less one than in higher-order style. +-} + +import Bool +import Prelude ( (-), Num, Int, Bool ) + + +infixr 5 ++ + +(++) :: [a] -> [a] -> [a] ; +(x:xs) ++ ys = x : (xs ++ ys) ; +[] ++ ys = ys ; + +concat :: [[a]] -> [a] ; +concat (x:xs) = x ++ concat xs ; +concat [] = [] ; + + +take :: Int -> [a] -> [a] ; +take 0 _xs = [] ; +take n (x:xs) = x : take (n-1) xs ; +take _ [] = [] ; + +filter :: (a -> Bool) -> [a] -> [a] ; +filter p (x:xs) = ifThenElse (p x) (x : filter p xs) (filter p xs) ; +filter _ [] = [] ; + +takeWhile :: (a -> Bool) -> [a] -> [a] ; +takeWhile p (x:xs) = ifThenElse (p x) (x : takeWhile p xs) [] ; +takeWhile _ [] = [] ; diff --git a/data/base/ListLive.hs b/data/base/ListLive.hs --- a/data/base/ListLive.hs +++ b/data/base/ListLive.hs @@ -2,10 +2,12 @@ cons, append, splitAt, + span, afterEach, dropWhileRev, sumInteger, + productInteger, iterateInteger, iterateIntegerList, applyStrictList, @@ -15,7 +17,7 @@ import Tuple import Function import Bool -import Prelude ( (-), (+), Num, Int, Integer, Integral, Bool, foldr, null, reverse ) +import Prelude ( (-), (+), (*), Num, Int, Integer, Integral, Bool, foldr, null, reverse ) cons :: a -> [a] -> [a] ; @@ -26,14 +28,19 @@ {- -This does not work well and fails for infinite lists, -because consFirst matches strictly on Pair. +This is not very efficient +since the result of the recursive call to 'splitAt' cannot be shared. -} splitAt :: Int -> [a] -> Tuple.Pair [a] [a] ; splitAt 0 xs = Pair [] xs ; splitAt _ [] = Pair [] [] ; splitAt n (x : xs) = consFirst x ( splitAt (n-1) xs ) ; +span :: (a -> Bool) -> [a] -> Tuple.Pair [a] [a] ; +span _ [] = Pair [] [] ; +span p (x : xs) = + ifThenElse (p x) ( consFirst x ( span p xs ) ) (Pair [] (x:xs)) ; + consFirst :: a -> Tuple.Pair [a] [a] -> Tuple.Pair [a] [a] ; consFirst x p = Pair (x : fst p) (snd p) ; @@ -61,6 +68,15 @@ sumIntegerAux 0 [] = 0 ; sumIntegerAux s [] = s ; sumIntegerAux s (x:xs) = sumIntegerAux (s+x) xs ; + + +productInteger :: (Integral a) => [a] -> a ; +productInteger = productIntegerAux 1 ; + +productIntegerAux :: (Integral a) => a -> [a] -> a ; +productIntegerAux 0 [] = 0 ; +productIntegerAux p [] = p ; +productIntegerAux p (x:xs) = productIntegerAux (p*x) xs ; -- | constant space usage in contrast to 'iterate' diff --git a/data/base/Midi.hs b/data/base/Midi.hs --- a/data/base/Midi.hs +++ b/data/base/Midi.hs @@ -8,7 +8,7 @@ Channel(Channel), Message(PgmChange, Controller, On, Off), - note, + note, noteOn, noteOff, rest, program, controller, @@ -24,6 +24,9 @@ skipTime, compressTime, + lazyPause, + duration, + (+:+), merge, (=:=), mergeWait, @@ -59,18 +62,22 @@ will be released later. -} note :: Time -> Pitch -> [Event Message] ; -note duration = applyStrict (noteLazy duration) ; +note dur = applyStrict (noteLazy dur) ; noteLazy :: Time -> Pitch -> [Event Message] ; -noteLazy duration pitch = - [ Event (On pitch normalVelocity) - , Wait duration - , Event (Off pitch normalVelocity) +noteLazy dur pitch = + [ noteOn pitch + , Wait dur + , noteOff pitch ] ; +noteOn, noteOff :: Pitch -> Event Message ; +noteOn pitch = Event (On pitch normalVelocity) ; +noteOff pitch = Event (Off pitch normalVelocity) ; + rest :: Time -> [Event a] ; -rest duration = - [ Wait duration ] ; +rest dur = + [ Wait dur ] ; program :: Program -> [Event Message] ; program n = @@ -85,7 +92,7 @@ channelEvent :: Chan -> Event a -> Event (Channel a) ; channelEvent chan (Event event) = Event (Channel chan event) ; -channelEvent _chan (Wait duration) = Wait duration ; +channelEvent _chan (Wait dur) = Wait dur ; channelEvent _chan (Say text) = Say text ; @@ -98,7 +105,7 @@ transposeEvent _d event = event ; -changeTempo :: Integer -> [Event Message] -> [Event Message] ; +changeTempo :: Integer -> [Event a] -> [Event a] ; changeTempo d = map ( changeTempoEvent d ) ; changeTempoEvent :: Integer -> Event a -> Event a ; @@ -175,13 +182,34 @@ compressTime k = applyStrict (applyStrict compressTimeAux k) ; compressTimeAux :: Integer -> Time -> [Event a] -> [Event a] ; -compressTimeAux _ _ [] = [] ; +compressTimeAux _k _t [] = [] ; compressTimeAux k t ( Wait x : xs ) = ifThenElse (t [Event a] ; +lazyPause = filter isWait ; + +isWait :: Event a -> Bool ; +isWait (Wait _d) = True ; +isWait _ = False ; + +duration :: [Event a] -> Time ; +duration = durationAux 0 ; + +durationAux :: Time -> [Event a] -> Time ; +durationAux t ( Wait d : xs ) = applyStrict durationAux (t+d) xs ; +durationAux t ( _ : xs ) = durationAux t xs ; +durationAux t [] = t ; consWait :: Time -> [Event a] -> [Event a] ; diff --git a/data/base/Tuple.hs b/data/base/Tuple.hs --- a/data/base/Tuple.hs +++ b/data/base/Tuple.hs @@ -1,6 +1,7 @@ module Tuple where -data Pair a b = Pair a b ; +data Pair a b = Pair a b + deriving (Show) ; fst :: Pair a b -> a ; fst ( Pair a _ ) = a ; diff --git a/data/example/CrossSum.hs b/data/example/CrossSum.hs --- a/data/example/CrossSum.hs +++ b/data/example/CrossSum.hs @@ -10,7 +10,7 @@ main :: [ Event (Channel Message) ] ; main = - channel 0 $ + channel 0 $ changeTempo timeUnit $ concatMap (note qn . makePitch) $ modCrossSums 4 ; @@ -58,5 +58,8 @@ modAdd m x y = mod (x+y) m ; +timeUnit :: Time ; +timeUnit = 150 ; + qn :: Integer ; -qn = 150 ; +qn = 1 ; diff --git a/data/example/DeBruijn.hs b/data/example/DeBruijn.hs --- a/data/example/DeBruijn.hs +++ b/data/example/DeBruijn.hs @@ -11,7 +11,7 @@ main :: [ Event (Channel Message) ] ; main = - channel 0 $ + channel 0 $ changeTempo timeUnit $ concatMap (note qn . makePitch) $ cycle $ deBruijnSequence 4 2 ; @@ -45,5 +45,8 @@ -- * auxiliary +timeUnit :: Time ; +timeUnit = 150 ; + qn :: Integer ; -qn = 150 ; +qn = 1 ; diff --git a/data/example/Fibonacci.hs b/data/example/Fibonacci.hs --- a/data/example/Fibonacci.hs +++ b/data/example/Fibonacci.hs @@ -9,7 +9,7 @@ main :: [ Event (Channel Message) ] ; main = - channel 0 $ + channel 0 $ changeTempo timeUnit $ concatMap (note qn . makePitch) $ modFibonacci3 4 1 1 0 ; @@ -44,5 +44,8 @@ -- * auxiliary +timeUnit :: Time ; +timeUnit = 150 ; + qn :: Integer ; -qn = 150 ; +qn = 1 ; diff --git a/data/example/GrayCode.hs b/data/example/GrayCode.hs new file mode 100644 --- /dev/null +++ b/data/example/GrayCode.hs @@ -0,0 +1,85 @@ +module GrayCode where + +import Midi ; +import Pitch ; +import Tuple ; +import List () ; +import Bool (ifThenElse) ; +import ListLive ; +import Prelude hiding (fst, snd) ; + + +main :: [ Event (Channel Message) ] ; +main = + channel 0 $ changeTempo timeUnit $ cycle overlapping ; + +shortChords, overlapping :: [ Event Message ] ; +shortChords = + concatMap chordFromCode $ grayCodes 4 ; + +chordFromCode :: [ Bool ] -> [ Event Message ] ; +chordFromCode bits = + (filterWith bits $ map noteOn pitches) + ++ + Wait qn + : + (filterWith bits $ map noteOff pitches) ; + +filterWith :: [ Bool ] -> [ a ] -> [ a ] ; +filterWith bits = + map snd . filter fst . zipWith Pair bits ; + + +overlapping = + concatMap (cons (Wait qn) . flip cons []) $ + grayChanges makeNoteOnOff 4 ; + +makeNoteOnOff :: Bool -> Integer -> Event Message ; +makeNoteOnOff bl n = + ifThenElse bl noteOn noteOff $ makePitch n ; + +pitches :: [ Pitch ] ; +pitches = map makePitch $ enumFrom 0 ; + +makePitch :: Integer -> Pitch ; +makePitch 0 = c 4 ; +makePitch 1 = e 4 ; +makePitch 2 = g 4 ; +makePitch _ = c 5 ; + + +-- * Enumerate binary codes + +{- | +Enumerate binary codes where only one bit changes between adjacent codes. +-} +grayCodes :: Integer -> [[Bool]] ; +grayCodes 0 = [[]] ; +grayCodes n = + map (cons False) (grayCodes (n-1)) ++ + map (cons True) (reverse $ grayCodes (n-1)) ; + + +{- | +Positions that change in the gray code +bundled with the bit value after the change. +-} +grayChanges :: (Bool -> Integer -> a) -> Integer -> [a] ; +grayChanges mk n = + grayChangesRec mk True n ++ [mk False n] ; + +grayChangesRec :: (Bool -> Integer -> a) -> Bool -> Integer -> [a] ; +grayChangesRec _mk _bl 0 = [] ; +grayChangesRec mk bl n = + grayChangesRec mk True (n-1) ++ + mk bl (n-1) : + grayChangesRec mk False (n-1) ; + + +-- * auxiliary + +timeUnit :: Time ; +timeUnit = 150 ; + +qn :: Integer ; +qn = 1 ; diff --git a/data/example/JohnsonTrotter.hs b/data/example/JohnsonTrotter.hs new file mode 100644 --- /dev/null +++ b/data/example/JohnsonTrotter.hs @@ -0,0 +1,91 @@ +module JohnsonTrotter where + +import Midi ; +import Pitch ; +import List (inits, tails) ; +import ListLive ; +{- +import List ; +import Function ; +import Prelude ( Integer, (*), (+), mod ) ; +-} + + +main :: [ Event (Channel Message) ] ; +main = + channel 0 $ changeTempo timeUnit $ cycle $ + concatMap (addBass . concatMap (note qn . makePitch)) $ + johnsonTrotter indexes ; + +addBass :: [Event Message] -> [Event Message] ; +addBass xs = + noteOn (makePitch 0) : + xs ++ + noteOff (makePitch 0) : + [] ; + +indexes :: [Integer] ; +indexes = [1,2,3,4] ; + +makePitch :: Integer -> Pitch ; +makePitch 0 = c 2 ; +makePitch 1 = c 4 ; +makePitch 2 = e 4 ; +makePitch 3 = g 4 ; +makePitch _ = c 5 ; + + +-- * Enumerate permutations + +{- | +Enumerate permutations with only one swap of adjacent elements +between two successuve permutations. +-} +johnsonTrotter :: [a] -> [[a]] ; +johnsonTrotter [] = [[]] ; +johnsonTrotter (x:xs) = + concat $ + zipWith id + (cycle [walkRight x, walkLeft x]) + (johnsonTrotter xs) ; + +{- does not reduce term size +johnsonTrotterInt :: [Integer] -> [[Integer]] ; +johnsonTrotterInt [] = [[]] ; +johnsonTrotterInt (x:xs) = + concat $ + zipWith applyStrictList + (cycle [walkRight x, walkLeft x]) + (johnsonTrotterInt xs) ; +-} + +{- +reduces term size, +but easily exceeds number of allowed reductions +-} +johnsonTrotterInt :: [Integer] -> [[Integer]] ; +johnsonTrotterInt [] = [[]] ; +johnsonTrotterInt (x:xs) = + concat $ + applyStrictListList + (zipWith id + (cycle [walkRight x, walkLeft x])) + (johnsonTrotterInt xs) ; + +walkLeft :: a -> [a] -> [[a]] ; +walkLeft x xs = reverse (walkRight x xs) ; + +walkRight :: a -> [a] -> [[a]] ; +walkRight x xs = + zipWith (insert x) (inits xs) (tails xs) ; + +insert :: a -> [a] -> [a] -> [a] ; +insert x prefix suffix = prefix ++ x : suffix ; + +-- * auxiliary + +timeUnit :: Time ; +timeUnit = 150 ; + +qn :: Integer ; +qn = 1 ; diff --git a/data/prelude/Prelude.hs b/data/prelude/Prelude.hs --- a/data/prelude/Prelude.hs +++ b/data/prelude/Prelude.hs @@ -2,6 +2,7 @@ import Bool import Integer +import Enum data Ordering = LT | EQ | GT ; @@ -20,9 +21,6 @@ min x y = ifThenElse (x Int ; fromInteger x = x ; diff --git a/http/enable/HTTPServer.hs b/http/enable/HTTPServer.hs --- a/http/enable/HTTPServer.hs +++ b/http/enable/HTTPServer.hs @@ -64,13 +64,14 @@ case Option.port opt of Option.Port port -> void $ HTTPd.initServer port $ - handleException . server dict + handleException . server dict opt server :: Methods -> + Option.Option -> HTTPd.Request -> ExceptionalT Error IO HTTPd.Response -server dict req = +server dict opt req = case HTTPd.reqMethod req of "GET" -> case uriPath (HTTPd.reqURI req) of @@ -83,7 +84,7 @@ modIdent <- parseModuleName modName content <- getModuleContent dict modIdent return $ HTTPd.Response 200 headers $ - formatModuleContent modList modIdent (Nothing, content) + formatModuleContent opt modList modIdent (Nothing, content) _ -> Exc.throwT $ badRequest $ "Bad path in URL" "POST" -> @@ -99,7 +100,7 @@ updatedContent <- updateModuleContent dict modIdent editable return $ HTTPd.Response 200 headers $ - formatModuleContent modList modIdent updatedContent + formatModuleContent opt modList modIdent updatedContent _ -> Exc.throwT $ badRequest $ "Bad path in URL" method -> @@ -141,8 +142,9 @@ Html.body (htmlFromModuleList list) formatModuleContent :: + Option.Option -> [Module.Name] -> Module.Name -> (Maybe String, String) -> String -formatModuleContent list name (mmsg, content) = +formatModuleContent opt list name (mmsg, content) = Html.renderHtml $ Html.header (Html.thetitle << ("Haskell Live Sequencer - " ++ Module.tellName name)) +++ @@ -167,7 +169,8 @@ +++ Html.textarea Html.! [Html.name "content", - Html.rows "30", Html.cols "100"] + Html.rows $ Option.rows opt, + Html.cols $ Option.columns opt] << editable +++ Html.br diff --git a/http/enable/HTTPServer/Option.hs b/http/enable/HTTPServer/Option.hs --- a/http/enable/HTTPServer/Option.hs +++ b/http/enable/HTTPServer/Option.hs @@ -7,6 +7,7 @@ data Option = Option { + rows, columns :: String, port :: Port } @@ -16,6 +17,7 @@ deflt :: Option deflt = Option { + rows = "30", columns = "100", port = Port 8080 } @@ -28,4 +30,14 @@ parseNumber "HTTP port" (\n -> 0 + return $ flags{rows = str}) + ("number of rows in the text area for the module content,\ndefault " ++ + rows deflt) : + Opt.Option [] ["html-columns"] + (flip ReqArg "NUMBER" $ \str flags -> + return $ flags{columns = str}) + ("number of columns in the text area for the module content,\ndefault " ++ + columns deflt) : [] diff --git a/live-sequencer.cabal b/live-sequencer.cabal --- a/live-sequencer.cabal +++ b/live-sequencer.cabal @@ -1,13 +1,15 @@ Name: live-sequencer -Version: 0.0.3.1 +Version: 0.0.4 Author: Henning Thielemann and Johannes Waldmann Maintainer: Johannes Waldmann , 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 +Tested-With: GHC==6.12.3 +Tested-With: GHC==7.2.1, GHC==7.4.2, GHC==7.6.3 Homepage: http://www.haskell.org/haskellwiki/Live-Sequencer +Bug-Reports: http://dfa.imn.htwk-leipzig.de/bugzilla/describecomponents.cgi?product=live-sequencer Synopsis: Live coding of MIDI music Description: An editor shows a textual description of music (like Haskore), @@ -143,6 +145,10 @@ This mode is for demonstration, debugging and as a pause mode, when the interpreter reaches the end of the main list. You can trigger evaluation of the next element using @CTRL-N@. + You can perform a single reduction with @CTRL-U@, + which also highlights the rule that will be applied next. + Changes to the program are only respected + when an element is completely reduced and sent via MIDI. Unfortunately it is currently not possible to undo a step. . 6. Editing ***** @@ -237,7 +243,7 @@ and then set @--event-period@ large enough to match the power of your machine. . - 8. ALSA + 8. ALSA ***** . Using the @--new-out-port@ option you may add more ALSA MIDI ports. @@ -255,6 +261,40 @@ to any synthesizer once it is running using @aconnect@ (command line) or @kaconnect@, @alsa-patch-bay@, @patchage@ (graphical interfaces). + . + The live-sequencer itself can be controlled to some extent. + You may start the live-sequencer this way + . + > live-sequencer --connect-from YourMidiController + . + or connect to it once it is running. + This enables the following functions: + . + * If you press a key on your MIDI keyboard named YourMidiController, + then the according note name is inserted in the current module. + However, note durations cannot be preserved + and velocities are ignored, as well. + Thus don't expect that the live-sequencer captures complex songs, + this function is just intended as assistance for note input. + . + * You can control execution of the live-sequencer + using MIDI Machine Control SysEx messages. + Some MIDI controller keyboards have transportation buttons + that support those messages. + . + The supported MMC commands are: + . + * RECORD STROBE: + Toggle between receiving and ignoring note input from MIDI keyboard + . + * PLAY: Restart the interpreter + . + * STOP: Halt the interpreter and turn sound off + . + * PAUSE: Toggle between real time and single step mode + . + * FAST FORWARD: Next element in single step mode + Build-Type: Simple Data-Files: @@ -268,17 +308,22 @@ data/example/CrossSum.hs data/example/Fibonacci.hs data/example/DeBruijn.hs + data/example/JohnsonTrotter.hs + data/example/GrayCode.hs data/example/Pattern.hs data/base/Bool.hs data/base/Chords.hs data/base/Controls.hs data/base/Drum.hs + data/base/Enum.hs data/base/Function.hs data/base/Instrument.hs data/base/Integer.hs data/base/List.hs data/base/ListLive.hs + data/base/List/Basic.hs + data/base/List/Advanced.hs data/base/Midi.hs data/base/Music.hs data/base/Pitch.hs @@ -300,7 +345,7 @@ Source-Repository this Type: git - Tag: 0.0.3.1 + Tag: 0.0.4 Location: http://code.haskell.org/~thielema/livesequencer/ Flag gui @@ -330,6 +375,7 @@ Chords Controls Drum + Enum Function Instrument Integer @@ -340,11 +386,15 @@ Tuple Other-Modules: List + List.Advanced + List.Basic Pattern Finite CrossSum DeBruijn Fibonacci + JohnsonTrotter + GrayCode Executable live-sequencer @@ -362,11 +412,11 @@ Rule Step Term + TermFocus Time Type Log Paths_live_sequencer - Utility.NonEmptyList Other-Modules: Lilypond GHC-Options: -Wall -threaded @@ -380,16 +430,18 @@ parsec >=2.1 && <3.2, pretty >=1.0 && <1.2, midi-alsa >=0.2 && <0.3, - midi >=0.2 && <0.3, + midi >=0.2.1 && <0.3, alsa-seq >=0.6 && <0.7, 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, + non-empty >=0.0 && <0.1, + containers >=0.3 && <0.6, + bytestring >=0.9 && <0.11, process >=1.0 && <1.2, - directory >=1.0 && <1.2, + directory >=1.0 && <1.3, filepath >=1.1 && <1.4, base >=4.2 && <5 @@ -405,16 +457,18 @@ parsec >=2.1 && <3.2, pretty >=1.0 && <1.2, midi-alsa >=0.2 && <0.3, - midi >=0.2 && <0.3, + midi >=0.2.1 && <0.3, alsa-seq >=0.6 && <0.7, 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, + non-empty >=0.0 && <0.1, utility-ht >=0.0.8 && <0.1, - containers >=0.3 && <0.5, + containers >=0.3 && <0.6, + bytestring >=0.9 && <0.11, process >=1.0 && <1.2, - directory >=1.0 && <1.2, + directory >=1.0 && <1.3, filepath >=1.1 && <1.4, base >=4.2 && <5 Else @@ -437,11 +491,11 @@ Rule Step Term + TermFocus Time Type Log Paths_live_sequencer - Utility.NonEmptyList Utility.Concurrent Utility.WX @@ -472,8 +526,8 @@ midi >=0.2 && <0.3, alsa-seq >=0.6 && <0.7, alsa-core >=0.5 && <0.6, - unix >=2.4 && <2.6, - directory >=1.0 && <1.2, + unix >=2.4 && <2.7, + directory >=1.0 && <1.3, transformers >=0.2.2 && <0.4, base >=4.2 && <5 Else diff --git a/src/ALSA.hs b/src/ALSA.hs --- a/src/ALSA.hs +++ b/src/ALSA.hs @@ -22,7 +22,7 @@ import qualified System.IO as IO import qualified Data.Sequence as Seq -import qualified Utility.NonEmptyList as NEList +import qualified Data.NonEmpty as NEList import qualified Control.Monad.Trans.Class as MT import qualified Control.Monad.Trans.State as MS diff --git a/src/Event.hs b/src/Event.hs --- a/src/Event.hs +++ b/src/Event.hs @@ -92,6 +92,7 @@ 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.MIDI.MachineControl as MMC import qualified Sound.ALSA.Sequencer.RealTime as RealTime import qualified Sound.ALSA.Sequencer.Time as ATime @@ -101,10 +102,12 @@ import qualified Control.Monad.Trans.State as MS import qualified Control.Monad.Trans.Class as MT +import qualified Control.Monad.Exception.Asynchronous as ExcA import Control.Monad.Exception.Synchronous ( ExceptionalT, throwT ) import Control.Monad.IO.Class ( MonadIO, liftIO ) import Control.Monad ( when, forever ) import Control.Functor.HT ( void ) +import Data.Foldable ( forM_ ) import Data.Monoid ( mempty, mappend ) @@ -112,28 +115,39 @@ import qualified System.Exit as Exit import qualified System.IO.Strict as StrictIO import qualified System.IO as IO +import Data.IORef ( newIORef, readIORef, modifyIORef ) import qualified Data.Accessor.Monad.Trans.State as AccM import qualified Data.Accessor.Basic as Acc import Data.Accessor.Basic ((^.), ) import qualified Data.Sequence as Seq +import qualified Data.ByteString as B import Data.Maybe ( isJust ) +import Data.Bool.HT ( if' ) import qualified Control.Concurrent.Split.Chan as Chan import Control.Concurrent ( forkIO ) -import Data.Bool.HT ( if' ) - -data WaitMode = RealTime | SlowMotion (Time.Milliseconds Integer) | SingleStep +data WaitMode = + RealTime | SlowMotion (Time.Milliseconds Integer) | SingleStep Continue deriving (Eq, Show) data WaitResult = - ModeChange WaitMode | ReachedTime Time | NextStep | + ModeChange WaitMode | SwitchMode (WaitMode -> IO ()) | + ReachedTime Time | NextStep Continue | AlsaSend (MS.StateT State ALSA.Send ()) +data Continue = + NextElement | NextReduction | NextReductionShow + deriving (Eq, Show) + +singleStep :: WaitMode +singleStep = SingleStep NextElement + + termException :: (Monad m) => Term -> String -> ExceptionalT Exception.Message m a @@ -301,13 +315,21 @@ (cont,newTarget) <- runSend sq $ prepare mdur when cont $ loop newTarget else loop target + SwitchMode update -> do + oldMode <- AccM.get stateWaitMode + liftIO $ update $ + case oldMode of + SingleStep _ -> RealTime + _ -> SingleStep NextElement + loop target ReachedTime reached -> {- check for equality only works because we have not set TimeStamping -} if Just reached == target then AccM.set stateTime reached else loop target - NextStep -> do + NextStep cont -> do + AccM.set stateWaitMode $ SingleStep cont runSend sq forwardStoppedQueue when (isJust target) $ loop target AlsaSend send -> do @@ -357,7 +379,7 @@ Nothing -> return (False, Nothing) Just dur -> sendEchoCont dur SlowMotion dur -> sendEchoCont $ Time.up $ Time.up dur - SingleStep -> return (True, Nothing) + SingleStep _ -> return (True, Nothing) newtype EchoId = EchoId SeqEvent.Tag @@ -394,6 +416,18 @@ return targetTime +data Command = + NoteInput VM.Pitch + | Transportation Transportation + deriving (Show) + +data Transportation = + Play + | Stop + | Pause + | Forward + deriving (Show) + {- We cannot concurrently wait for different kinds of ALSA sequencer events. Thus we run one thread that listens to all incoming ALSA sequencer events @@ -402,13 +436,14 @@ listen :: (SndSeq.AllowInput mode) => Sequencer mode -> - (VM.Pitch -> IO ()) -> + (Command -> IO ()) -> IO () -> Chan.In WaitResult -> IO () listen sq noteInput visualize waitChan = do Log.put "listen to ALSA port" dest <- ALSA.privateAddress sq + recording <- newIORef True forever $ do Log.put "wait, wait for echo" @@ -416,7 +451,22 @@ Log.put $ "wait, get message " ++ show ev case SeqEvent.body ev of SeqEvent.NoteEv SeqEvent.NoteOn note -> - noteInput $ note ^. MidiAlsa.notePitch + readIORef recording + >>= flip when (noteInput $ NoteInput $ note ^. MidiAlsa.notePitch) + SeqEvent.ExtEv SeqEvent.SysEx msg -> + {- FIXME: How to cope with the device id? -} + case B.unpack msg of + 0xF0 : 0x7F : 0x00 : 0x06 : cmds -> + forM_ (ExcA.result $ fst $ + MMC.runParser MMC.getCommands cmds) $ \cmd -> + case cmd of + MMC.RecordStrobe -> modifyIORef recording not + MMC.Play -> noteInput $ Transportation Play + MMC.Stop -> noteInput $ Transportation Stop + MMC.Pause -> noteInput $ Transportation Pause + MMC.FastForward -> noteInput $ Transportation Forward + _ -> return () + _ -> return () SeqEvent.CustomEv SeqEvent.Echo _cust -> when (dest == SeqEvent.dest ev) $ if' (EchoId (SeqEvent.tag ev) == evaluateId) diff --git a/src/GUI.hs b/src/GUI.hs --- a/src/GUI.hs +++ b/src/GUI.hs @@ -39,6 +39,7 @@ -} import qualified IO +import qualified TermFocus import qualified Term import qualified Time import qualified Program @@ -49,7 +50,8 @@ import qualified Option import qualified Log import Program ( Program ) -import Term ( Term, Identifier, mainName ) +import TermFocus ( TermFocus ) +import Term ( Term, Identifier ) import Option.Utility ( exitFailureMsg ) import Utility.WX ( cursor, editable, notebookSelection, splitterWindowSetSashGravity ) @@ -76,7 +78,7 @@ import qualified Control.Concurrent.STM.Split.Chan as TChan import Control.Concurrent.STM.TVar ( TVar, newTVarIO, readTVarIO, readTVar, writeTVar ) import Control.Concurrent.STM.TMVar ( TMVar, newTMVarIO, putTMVar, readTMVar, takeTMVar ) -import Utility.Concurrent ( writeTMVar, liftSTM ) +import Utility.Concurrent ( MonadSTM, writeTMVar, liftSTM ) import Control.Monad.STM ( STM ) import qualified Control.Monad.STM as STM @@ -101,7 +103,6 @@ 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 ) @@ -130,8 +131,9 @@ import qualified Data.Char as Char import qualified Data.List as List -import Data.Tuple.HT ( mapSnd ) +import Data.Tuple.HT ( mapFst, mapSnd ) import Data.Bool.HT ( if' ) +import Data.Maybe ( mapMaybe, maybeToList ) import Prelude hiding ( log ) @@ -181,6 +183,7 @@ gui guiIn machineIn (forEvent machineOut) void $ forkIO $ machine guiOut machineIn + (processMidiCommand guiIn machineIn) (Option.limits opt) (Option.importPaths opt) p sq void $ forkIO $ HTTPGui.run @@ -195,7 +198,8 @@ | Control Controls.Event data Execution = - Mode Event.WaitMode | Restart | Stop | NextStep | + Mode Event.WaitMode | SwitchMode | Restart | Stop | + NextStep Event.Continue | PlayTerm MarkedText | ApplyTerm MarkedText data Modification = @@ -209,11 +213,12 @@ -- | messages that are sent from machine to GUI data GuiUpdate = - ReductionSteps { _steps :: [ Rewrite.Message ] } - | CurrentTerm { _currentTerm :: String } + ReductionSteps { _steps :: [ Rewrite.Source ] } + | CurrentTerm { _range :: (Int, Int), _currentTerm :: String } | Exception { _message :: Exception.Message } | Register { _mainModName :: Module.Name, _modules :: M.Map Module.Name Module.Module } | Refresh { _moduleName :: Module.Name, _content :: String, _position :: Int } + | SelectPage Module.Name ( Maybe Term.Range ) | InsertPage { _activate :: Bool, _module :: Module.Module } | DeletePage Module.Name | RenamePage Module.Name Module.Name @@ -224,7 +229,16 @@ | Running { _runningMode :: Event.WaitMode } | ResetDisplay +-- | the messages describe the steps towards the stateTerm +data State = State { stateMessages :: Maybe [ Rewrite.Message ], stateTerm :: Term } +initialState :: State +initialState = State Nothing Term.mainName + +stateFromTerm :: Term -> State +stateFromTerm t = State Nothing t + + exceptionToGUI :: TChan.In GuiUpdate -> Exc.ExceptionalT Exception.Message STM () -> @@ -256,6 +270,20 @@ Right t -> return t +processMidiCommand :: + Chan.In Action -> TChan.In GuiUpdate -> + Event.Command -> IO () +processMidiCommand machineChan guiChan cmd = + case cmd of + Event.NoteInput p -> + TChan.writeIO guiChan . InsertText . formatPitch $ p + Event.Transportation trans -> + case trans of + Event.Play -> Chan.write machineChan $ Execution Restart + Event.Stop -> Chan.write machineChan $ Execution Stop + Event.Pause -> Chan.write machineChan $ Execution SwitchMode + Event.Forward -> Chan.write machineChan $ Execution $ NextStep Event.NextElement + formatPitch :: VM.Pitch -> String formatPitch p = let (oct,cls) = divMod (VM.fromPitch p) 12 @@ -374,14 +402,15 @@ -- (module name, module contents) -> TChan.In GuiUpdate -- ^ and writes output to here -- (log message (for highlighting), current term) + -> (Event.Command -> IO ()) -> Option.Limits -> [FilePath] -> Program -- ^ initial program -> ALSA.Sequencer SndSeq.DuplexMode -> IO () -machine input output limits importPaths progInit sq = do +machine input output procMidi limits importPaths progInit sq = do program <- newTVarIO progInit - term <- newTMVarIO mainName + term <- newTMVarIO initialState (waitIn,waitOut) <- Chan.new void $ forkIO $ forever $ do @@ -392,6 +421,12 @@ STM.atomically $ do TChan.write output $ Running mode transaction + setMode mode = + flip (withMode mode) (return ()) $ + case mode of + Event.RealTime -> ALSA.continueQueue + Event.SlowMotion _ -> ALSA.continueQueue + Event.SingleStep _ -> ALSA.pauseQueue case action of Control event -> do Log.put $ show event @@ -404,35 +439,32 @@ Execution exec -> case exec of - Mode mode -> - flip (withMode mode) (return ()) $ - case mode of - Event.RealTime -> ALSA.continueQueue - Event.SlowMotion _ -> ALSA.continueQueue - Event.SingleStep -> ALSA.pauseQueue + Mode mode -> setMode mode + SwitchMode -> Chan.write waitIn $ Event.SwitchMode setMode Restart -> withMode Event.RealTime Event.forwardQuietContinueQueue - (writeTMVar term mainName) + (writeTMVar term initialState) Stop -> - withMode Event.SingleStep + withMode Event.singleStep Event.forwardStopQueue - (writeTMVar term mainName) - NextStep -> Chan.write waitIn Event.NextStep + (writeTMVar term initialState) + NextStep cont -> Chan.write waitIn $ Event.NextStep cont PlayTerm txt -> exceptionToGUIIO output $ do t <- parseTerm txt lift $ withMode Event.RealTime Event.forwardQuietContinueQueue - (writeTMVar term t) + (writeTMVar term $ stateFromTerm t) ApplyTerm txt -> exceptionToGUIIO output $ do fterm <- parseTerm txt case fterm of Term.Node f xs -> lift $ STM.atomically $ do t0 <- readTMVar term - let t1 = Term.Node f (xs++[t0]) - writeTMVar term t1 - TChan.write output $ CurrentTerm $ show t1 + let t1 = Term.Node f (xs ++ [stateTerm t0]) + writeTMVar term $ stateFromTerm t1 + TChan.write output $ uncurry CurrentTerm $ + TermFocus.format $ TermFocus.fromTerm t1 TChan.write output $ StatusLine $ "applied function term " ++ show (markedString txt) @@ -470,7 +502,7 @@ withMode Event.RealTime Event.forwardQuietContinueQueue $ do writeTVar program p - writeTMVar term mainName + writeTMVar term initialState registerProgram output (Module.Name stem) p Log.put "chased and parsed OK" @@ -524,8 +556,7 @@ (delayedUpdatesIn, delayedUpdatesOut) <- Chan.new void $ forkIO $ - Event.listen sq - ( TChan.writeIO output . InsertText . formatPitch ) + Event.listen sq procMidi ( STM.atomically . mapM_ (TChan.write output) =<< Chan.read delayedUpdatesOut ) waitIn @@ -538,7 +569,7 @@ Option.Limits -> TVar Program -- ^ current program (GUI might change the contents) - -> TMVar Term -- ^ current term + -> TMVar State -- ^ current term -> Chan.In [ GuiUpdate ] -- ^ sink for time-stamped delayed messages (show current term) -> ( Exception.Message -> IO () ) @@ -562,7 +593,7 @@ executeStep limits program term sendWarning sq maxEventsSat {- This update will take effect - when the above visualisation trigger event is arrives. + when the above visualisation trigger event arrives. -} lift $ Chan.write delayedUpdatesIn updates Event.wait sq waitChan mdur @@ -600,13 +631,14 @@ executeStep :: Option.Limits -> TVar Program -> - TMVar Term -> + TMVar State -> ( Exception.Message -> IO () ) -> ALSA.Sequencer SndSeq.DuplexMode -> Bool -> MW.WriterT [ GuiUpdate ] ( MS.StateT Event.State IO ) ( Maybe ALSA.Time ) -executeStep limits program term sendWarning sq maxEventsSat = +executeStep limits program term sendWarning sq maxEventsSat = do + waitMode <- lift $ AccM.get Event.stateWaitMode Exception.switchT (\e -> do -- liftIO $ ALSA.stopQueue sq @@ -616,24 +648,27 @@ liftIO $ ALSA.runSend sq $ ALSA.stopQueueLater currentTime -- Chan.write waitChan $ Event.ModeChange Event.SingleStep writeUpdate $ Exception e - writeUpdate $ Running Event.SingleStep + writeUpdate $ Running Event.singleStep {- We have to alter the mode directly, since waitChan is only read when we wait for a duration other than Nothing -} - lift $ AccM.set Event.stateWaitMode Event.SingleStep + lift $ AccM.set Event.stateWaitMode Event.singleStep lift $ AccM.set Event.stateTime newTime return Nothing) - (\(x,s) -> do + (\(mx,s) -> do {- exceptions on processing an event are not fatal and we keep running -} - wait <- Exc.resolveT - (fmap (const Nothing) . writeUpdate . Exception) - (Exc.mapExceptionalT lift $ - Event.play sq sendWarning x) + wait <- + case mx of + Nothing -> return Nothing + Just x -> + Exc.resolveT + (fmap (const Nothing) . writeUpdate . Exception) + (Exc.mapExceptionalT lift $ + Event.play sq sendWarning x) - waitMode <- lift $ AccM.get Event.stateWaitMode waiting <- lift $ AccM.get Event.stateWaiting {- This way the term will be pretty printed in the GUI thread @@ -642,7 +677,7 @@ which is not better. -} when (waiting || waitMode /= Event.RealTime) $ - writeUpdate $ CurrentTerm $ show s + writeUpdate $ uncurry CurrentTerm $ TermFocus.format s {- liftIO $ Log.put $ "term size: " ++ ( show $ length $ Term.subterms s ) ++ @@ -651,43 +686,122 @@ return wait) (Exc.mapExceptionalT (MW.mapWriterT (liftIO . STM.atomically)) $ flip Exc.catchT (\(pos,msg) -> do - liftSTM $ putTMVar term mainName - Exc.throwT $ Exception.Message Exception.Term pos msg) $ do - t <- liftSTM $ takeTMVar term - p <- liftSTM $ readTVar program - {- this happens anew at each click - since the program text might have changed in the editor -} - Exc.assertT - (Term.termRange t, "too many events in a too short period") - maxEventsSat - (s,log) <- - Exc.mapExceptionalT - (fmap (\(ms,log) -> liftM2 (,) ms (return log)) . - MW.runWriterT) $ - Rewrite.runEval - (Option.maxReductions limits) p (Rewrite.forceHead t) - Exc.assertT - (Term.termRange s, - "term size exceeds limit " ++ show (Option.maxTermSize limits)) - (null $ drop (Option.maxTermSize limits) $ Term.subterms s) - Exc.assertT - (Term.termRange s, - "term depth exceeds limit " ++ show (Option.maxTermDepth limits)) - (null $ drop (Option.maxTermDepth limits) $ Term.breadths s) - lift $ writeUpdate $ ReductionSteps log - case Term.viewNode s of - Just (":", [x, xs]) -> do - liftSTM $ putTMVar term xs - return (x,s) - Just ("[]", []) -> do - lift $ writeUpdate $ CurrentTerm $ show s - Exc.throwT (Term.termRange s, "finished.") - _ -> do - lift $ writeUpdate $ CurrentTerm $ show s - Exc.throwT (Term.termRange s, - "I do not know how to handle this term: " ++ show s)) + liftSTM $ putTMVar term initialState + Exc.throwT $ Exception.Message Exception.Term pos msg) $ + computeStep limits program term maxEventsSat waitMode) +computeStep :: + (MonadSTM m) => + Option.Limits -> + TVar Program -> + TMVar State -> + Bool -> + Event.WaitMode -> + Exc.ExceptionalT + (Term.Range, String) + (MW.WriterT [GuiUpdate] m) + (Maybe Term, TermFocus) +computeStep limits program term maxEventsSat waitMode = do + t <- liftSTM $ takeTMVar term + p <- liftSTM $ readTVar program + {- this happens anew at each click + since the program text might have changed in the editor -} + Exc.assertT + (Term.termRange $ stateTerm t, "too many events in a too short period") + maxEventsSat + + let forceHead = + Exc.mapExceptionalT + (liftM (\(ms,msgs) -> fmap ((,) msgs) ms) . + MW.runWriterT) $ + Rewrite.runEval + (Option.maxReductions limits) p + (Rewrite.forceHead $ stateTerm t) + + nextReduction = do + (msgs, nt) <- + case stateMessages t of + Nothing -> forceHead + Just msgs -> return (msgs, stateTerm t) + case splitAtReduction msgs of + (steps, Just (red, rest)) -> + return (steps, red, Just (rest, nt)) + (steps, Nothing) -> + return (steps, TermFocus.fromTerm nt, Nothing) + + (steps, focusedTerm, mst) <- + case waitMode of + Event.SingleStep Event.NextReduction -> nextReduction + Event.SingleStep Event.NextReductionShow -> do + {- + Using these statements + we will highlight the rule that led to the current focusTerm. + x@(steps, _, _) <- nextReduction + case do {Rewrite.Rule r <- steps; return r} of + -} + {- + Using these statements + we will highlight the rule that will be tried next. + -} + x@(_, _, mst) <- nextReduction + case do {st <- maybeToList mst; Rewrite.AttemptRule r <- fst $ splitAtReduction $ fst st; return r} of + (f : _) -> + lift $ writeUpdate $ + SelectPage + (Module.nameFromIdentifier f) + (Just $ Term.range f) + _ -> return () + return x + _ -> do + (msgs, nt) <- forceHead + return + (mapMaybe (\msg -> + case msg of + Rewrite.Source step -> Just step + _ -> Nothing) msgs, + TermFocus.fromTerm nt, Nothing) + + liftM (flip (,) focusedTerm) $ + case mst of + Nothing -> do + let s = TermFocus.subTerm focusedTerm + Exc.assertT + (Term.termRange s, + "term size exceeds limit " ++ show (Option.maxTermSize limits)) + (null $ drop (Option.maxTermSize limits) $ Term.subterms s) + Exc.assertT + (Term.termRange s, + "term depth exceeds limit " ++ show (Option.maxTermDepth limits)) + (null $ drop (Option.maxTermDepth limits) $ Term.breadths s) + lift $ writeUpdate $ ReductionSteps steps + case Term.viewNode s of + Just (":", [x, xs]) -> do + liftSTM $ putTMVar term $ stateFromTerm xs + return (Just x) + Just ("[]", []) -> do + lift $ writeUpdate $ uncurry CurrentTerm $ + TermFocus.format $ TermFocus.fromTerm s + Exc.throwT (Term.termRange s, "finished.") + _ -> do + lift $ writeUpdate $ uncurry CurrentTerm $ + TermFocus.format $ TermFocus.fromTerm s + Exc.throwT (Term.termRange s, + "I do not know how to handle this term: " ++ show s) + Just (msgs, nt) -> do + lift $ writeUpdate $ ReductionSteps steps + liftSTM $ putTMVar term $ State (Just msgs) nt + return Nothing + + +splitAtReduction :: + [ Rewrite.Message ] -> + ( [ Rewrite.Source ] , Maybe ( TermFocus , [ Rewrite.Message ] ) ) +splitAtReduction [] = ( [], Nothing ) +splitAtReduction (Rewrite.Term t : ms) = ( [], Just (t, ms ) ) +splitAtReduction (Rewrite.Source s : ms) = + mapFst (s:) $ splitAtReduction ms + voidStateT :: (Monad m) => (s -> m s) -> MS.StateT s m () voidStateT f = MS.StateT $ liftM ((,) ()) . f @@ -781,7 +895,7 @@ WX.menuLine fileMenu newModuleItem <- WX.menuItem fileMenu - [ text := "&New module\tCtrl-Shift-N", + [ text := "&New module\tCtrl-Shift-M", help := "add a new empty module" ] closeModuleItem <- WX.menuItem fileMenu @@ -855,11 +969,22 @@ [ text := "Slower\tCtrl-<", enabled := False, help := "increase pause in slow motion mode" ] - nextStepItem <- WX.menuItem execMenu - [ text := "Next step\tCtrl-N", + nextElemItem <- WX.menuItem execMenu + [ text := "Next element\tCtrl-N", enabled := False, - on command := Chan.write input (Execution NextStep), - help := "perform next step in single step mode" ] + on command := Chan.write input (Execution $ NextStep Event.NextElement), + help := "compute next list element in single step mode" ] + nextRedItem <- WX.menuItem execMenu + [ text := "Next reduction\tCtrl-Shift-N", + enabled := False, + on command := Chan.write input (Execution $ NextStep Event.NextReduction), + help := "compute next reduction in single step mode" ] + nextShowItem <- WX.menuItem execMenu + [ text := "Next reduction and highlight rule\tCtrl-U", + enabled := False, + on command := Chan.write input (Execution $ NextStep Event.NextReductionShow), + help := "compute next reduction in single step mode " ++ + "and highlight currently processed rule" ] windowMenu <- WX.menuPane [text := "&Window"] @@ -900,9 +1025,7 @@ nb <- WX.notebook splitter [ ] - reducer <- - WX.textCtrl splitter - [ font := fontFixed, editable := False, wrap := WrapNone ] + reducer <- textCtrlMono splitter [ editable := False ] status <- WX.statusField [ text := "Welcome to interactive music composition with Haskell" ] @@ -1052,7 +1175,9 @@ setSingleStep b = do set singleStepItem [ checked := b ] - set nextStepItem [ enabled := b ] + set nextElemItem [ enabled := b ] + set nextRedItem [ enabled := b ] + set nextShowItem [ enabled := b ] onActivation w act = set w [ on command := do @@ -1082,7 +1207,7 @@ updateSlowMotionDur onActivation singleStepItem $ do activateSingleStep - Chan.write input $ Execution $ Mode Event.SingleStep + Chan.write input $ Execution $ Mode Event.singleStep splitterWindowSetSashGravity splitter 0.5 let initSplitterPosition = 0 {- equal division of heights -} @@ -1129,22 +1254,19 @@ let moduleIdent = Module.Name $ Pos.sourceName $ Term.start errorRng - pnls <- liftIO $ readIORef panels - pnl <- MaybeT.MaybeT $ return $ M.lookupIndex moduleIdent pnls - liftIO $ set nb [ notebookSelection := pnl ] - let activateText textField = do - h <- MaybeT.MaybeT $ return $ - M.lookup moduleIdent textField - (i,j) <- liftIO $ textRangeFromRange h errorRng - liftIO $ set h [ cursor := i ] - liftIO $ WXCMZ.textCtrlSetSelection h i j - case typ of - Exception.Parse -> - activateText $ fmap editor pnls - Exception.Term -> - activateText $ fmap highlighter pnls - Exception.InOut -> - return () + pnls <- readIORef panels + forM_ (liftM2 (,) + (M.lookupIndex moduleIdent pnls) + (M.lookup moduleIdent pnls)) $ + \ (i,pnl) -> do + set nb [ notebookSelection := i ] + case typ of + Exception.Parse -> + flip markText errorRng $ editor pnl + Exception.Term -> + flip markText errorRng $ highlighter pnl + Exception.InOut -> + return () let closeOther = writeIORef appRunning False >> @@ -1159,9 +1281,12 @@ procEvent f $ \msg -> case msg of - CurrentTerm sr -> do + CurrentTerm rng sr -> get reducerVisibleItem checked >>= - flip when ( set reducer [ text := sr, cursor := 0 ] ) + flip when ( + set reducer [ text := sr, cursor := 0 ] >> + setColorCurrentTerm reducer ( rgb 200 100 (0::Int) ) rng + ) ReductionSteps steps -> do hls <- fmap (fmap highlighter) $ readIORef panels @@ -1177,12 +1302,13 @@ let prep step = case step of - Rewrite.Step target -> (AccTuple.first3, (target:)) - Rewrite.Rule rule -> (AccTuple.second3, (rule:)) - Rewrite.Data origin -> (AccTuple.third3, (origin:)) + Rewrite.Step target -> Just (AccTuple.first3, (target:)) + Rewrite.Rule rule -> Just (AccTuple.second3, (rule:)) + Rewrite.Data origin -> Just (AccTuple.third3, (origin:)) + Rewrite.AttemptRule _ -> Nothing (targets, rules, origins) = foldr (uncurry Acc.modify) ([],[],[]) $ - map prep steps + mapMaybe prep steps highlight 0 200 200 targets highlight 200 0 200 rules @@ -1229,6 +1355,15 @@ set status [ text := "modules loaded: " ++ formatModuleList ( M.keys mods ) ] + SelectPage modName mrng -> do + pnls <- readIORef panels + forM_ (liftM2 (,) + (M.lookupIndex modName pnls) + (M.lookup modName pnls)) $ + \ (i,pnl) -> do + set nb [ notebookSelection := i ] + Fold.mapM_ ( markText ( highlighter pnl ) ) mrng + InsertPage act modu -> do pnls <- readIORef panels pnl <- displayModule nb modu @@ -1292,7 +1427,7 @@ ("interpreter in slow-motion mode with pause " ++ Time.format dur) ] activateSlowMotion - Event.SingleStep -> do + Event.SingleStep _ -> do set status [ text := "interpreter in single step mode," ++ " waiting for next step" ] @@ -1335,8 +1470,7 @@ ] list <- newIORef Seq.empty - txt <- WX.textCtrl splitter - [ font := fontFixed, wrap := WrapNone, editable := False ] + txt <- textCtrlMono splitter [ editable := False ] let rec = FrameError { @@ -1362,16 +1496,18 @@ return rec onErrorSelection :: - FrameError -> (Exception.Message -> MaybeT.MaybeT IO ()) -> IO () + FrameError -> (Exception.Message -> IO ()) -> IO () onErrorSelection r act = set (errorLog r) - [ on listEvent := \ev -> void $ MaybeT.runMaybeT $ do - WXEvent.ListItemSelected n <- return ev - errors <- liftIO $ readIORef (errorList r) - let msg@(Exception.Message _typ _errorRng descr) = - Seq.index errors n - liftIO $ set (errorText r) [ text := descr ] - act msg + [ on listEvent := \ev -> + case ev of + WXEvent.ListItemSelected n -> do + errors <- readIORef (errorList r) + let msg@(Exception.Message _typ _errorRng descr) = + Seq.index errors n + set (errorText r) [ text := descr ] + act msg + _ -> return () ] updateErrorLog :: @@ -1392,6 +1528,13 @@ modifyIORef (errorList r) (Seq.|> exc) +markText :: TextCtrl a -> Term.Range -> IO () +markText textCtrl rng = do + (i,j) <- textRangeFromRange textCtrl rng + set textCtrl [ cursor := i ] + WXCMZ.textCtrlSetSelection textCtrl i j + + data Panel = Panel { panel :: WX.SplitterWindow (), @@ -1406,9 +1549,8 @@ displayModule nb modu = do psub <- WX.splitterWindow nb [] splitterWindowSetSashGravity psub 0.5 - ed <- WX.textCtrl psub [ font := fontFixed, wrap := WrapNone ] - hl <- WX.textCtrlRich psub - [ font := fontFixed, wrap := WrapNone, editable := False ] + ed <- textCtrlMono psub [] + hl <- textCtrlRichMono psub [ editable := False ] set ed [ text := Module.sourceText modu ] set hl [ text := Module.sourceText modu ] void $ WXCMZ.splitterWindowSplitVertically psub ed hl 0 @@ -1420,6 +1562,27 @@ return $ Panel psub ed hl $ Module.sourceLocation modu +textCtrlMono :: + WXCore.Window a -> [Prop (TextCtrl ())] -> IO (TextCtrl ()) +textCtrlMono parent prop = +{- + WX.textCtrlEx parent + ( WXCore.wxTE_MULTILINE WXCore..+. WXCore.wxTE_RICH ) $ +-} + WX.textCtrl parent $ + ( font := fontFixed ) : ( wrap := WrapNone ) : prop + +textCtrlRichMono :: + WXCore.Window a -> [Prop (TextCtrl ())] -> IO (TextCtrl ()) +textCtrlRichMono parent prop = +{- + WX.textCtrlEx parent + ( WXCore.wxTE_MULTILINE WXCore..+. WXCore.wxTE_RICH2 ) $ +-} + WX.textCtrlRich parent $ + ( font := fontFixed ) : ( wrap := WrapNone ) : prop + + getFromNotebook :: Notebook b -> M.Map Module.Name a -> IO (Module.Name, a) getFromNotebook nb m = @@ -1482,6 +1645,20 @@ (from, to) <- textRangeFromRange hl $ Term.range ident WXCMZ.textCtrlSetStyle hl from to attr + +setColorCurrentTerm :: + TextCtrl a -> + Color -> + (Int, Int)-> + IO () +setColorCurrentTerm reducer hicolor (from, to) = do + attr <- WXCMZ.textCtrlGetDefaultStyle reducer + bracket + (WXCMZ.textAttrGetBackgroundColour attr) + (WXCMZ.textAttrSetBackgroundColour attr) $ const $ do + WXCMZ.textAttrSetBackgroundColour attr hicolor + void $ WXCMZ.textCtrlSetStyle reducer from to attr + return () data MarkedText = diff --git a/src/Option.hs b/src/Option.hs --- a/src/Option.hs +++ b/src/Option.hs @@ -13,24 +13,23 @@ import System.Console.GetOpt (getOpt, usageInfo, ArgDescr(NoArg, ReqArg), ) import System.Environment (getArgs, getProgName, ) -import System.FilePath ( (), searchPathSeparator ) +import System.FilePath ( (), searchPathSeparator, isSearchPathSeparator, ) import System.Directory ( getCurrentDirectory ) import qualified System.Exit as Exit import Control.Monad ( when ) -import qualified Utility.NonEmptyList as NEList +import qualified Data.NonEmpty as NEList import Data.Traversable ( forM ) import Data.Bool.HT ( if' ) import Data.List.HT ( chop ) -import Data.List ( intercalate ) data Option = Option { moduleNames :: [Module.Name], importPaths :: [FilePath], - connect :: NEList.T Port, + connect :: NEList.T [] Port, sequencerName :: String, latency :: Double, limits :: Limits, @@ -44,10 +43,12 @@ getDeflt :: IO Option getDeflt = do dataDir <- Paths.getDataDir + curDir <- getCurrentDirectory return $ Option { moduleNames = [], importPaths = + curDir : map ((dataDir ) . ("data" )) [ "prelude", "base", "example" ], connect = NEList.singleton (Port "inout" (Just []) (Just [])), @@ -99,9 +100,17 @@ "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)) : + return $ flags{importPaths = + if null str + then [] + else chop isSearchPathSeparator str ++ importPaths flags + }) + ("if empty: clear import paths\n" ++ + "otherwise: add colon separated import paths,\n" ++ + "default: " ++ + (case importPaths deflt of + [] -> "" + x:xs -> unlines $ x : map ((" "++) . (searchPathSeparator:)) xs)) : Opt.Option ['p'] ["connect-to"] (flip ReqArg "ADDRESS" $ \str flags -> case connect flags of diff --git a/src/Rewrite.hs b/src/Rewrite.hs --- a/src/Rewrite.hs +++ b/src/Rewrite.hs @@ -2,8 +2,10 @@ import Term ( Term(Node, Number, StringLiteral), Identifier(Identifier, range, name), Range, termRange ) +import TermFocus ( TermFocus(TermFocus), SuperTerm ) import Program ( Program ) import qualified Program +import qualified TermFocus import qualified Term import qualified Rule @@ -18,6 +20,7 @@ import qualified Data.Set as S import qualified Data.Traversable as Trav +import Data.Monoid ( Monoid ) import Data.Maybe.HT ( toMaybe ) import Data.Tuple.HT ( mapSnd ) import Data.List ( intercalate ) @@ -26,15 +29,28 @@ data Message = + Term { term :: TermFocus } + | Source { source :: Source } + deriving Show + +data Source = Step { target :: Identifier } + | AttemptRule { rule :: Identifier } | Rule { rule :: Identifier } | Data { origin :: Identifier } deriving Show +data Context = + Context { + maxReductions :: Count, + program :: Program, + superTerms :: [ SuperTerm ] + } + type Count = Int type Evaluator = - ExceptionalT (Range, String) ( RWS (Count, Program) [ Message ] Count ) + ExceptionalT (Range, String) ( RWS Context [ Message ] Count ) runEval :: @@ -43,7 +59,8 @@ ExceptionalT (Range, String) ( MW.WriterT [ Message ] m ) a runEval maxRed p = -- in transformers-0.3 you can write MW.writer instead of MW.WriterT . return - mapExceptionalT (\evl -> MW.WriterT $ return $ MRWS.evalRWS evl (maxRed,p) 0) + mapExceptionalT (\evl -> + MW.WriterT $ return $ MRWS.evalRWS evl (Context {maxReductions = maxRed, program = p, superTerms = []}) 0) {- mapExceptionalT (\evl -> MW.WriterT $ return $ @@ -65,7 +82,7 @@ t' <- top t case t' of Node i [ x, xs ] | name i == ":" -> do - y <- full x + y <- localSuperTerm i [] [xs] $ full x return $ Node i [ y, xs ] Node i [] | name i == "[]" -> return $ Node i [] @@ -78,14 +95,13 @@ full x = do x' <- top x case x' of - Node f args -> - fmap (Node f) $ mapM full args + Node f args -> fmap (Node f) $ mapArgs f full args Number _ _ -> return x' StringLiteral _ _ -> return x' -- | evaluate until root symbol is constructor. top :: Term -> Evaluator Term -top t = case t of +top t = ( lift $ tell . (:[]) . Term . TermFocus t =<< asks superTerms ) >> case t of Number {} -> return t StringLiteral {} -> return t Node f xs -> @@ -93,13 +109,34 @@ then return t else eval f xs >>= top +mapArgs :: Identifier -> (Term -> Evaluator Term) -> [Term] -> Evaluator [Term] +mapArgs i f = + let go _ [] = return [] + go done (x:xs) = do + y <- localSuperTerm i done xs $ f x + fmap (y:) $ go (y:done) xs + in go [] + +localSuperTerm :: + (Monad m, Monoid w) => + Identifier -> + [Term] -> + [Term] -> + ExceptionalT e (MRWS.RWST Context w s m) b -> + ExceptionalT e (MRWS.RWST Context w s m) b +localSuperTerm i done xs = + mapExceptionalT + (MRWS.local (\ctx -> ctx{superTerms = + TermFocus.Node i (TermFocus.List done xs) : + superTerms ctx})) + -- | do one reduction step at the root eval :: Identifier -> [Term] -> Evaluator Term eval i xs | name i `elem` [ "compare", "<", "-", "+", "*", "div", "mod" ] = do - ys <- mapM top xs - lift $ tell $ [ Step { target = i } ] + ys <- mapArgs i top xs + lift $ tell $ [ Source $ Step { target = i } ] case ys of [ Number _ a, Number _ b] -> case name i of @@ -122,7 +159,7 @@ _ -> exception (range i) $ "wrong number of arguments" eval g ys = do - funcs <- lift $ asks ( Program.functions . snd ) + funcs <- lift $ asks ( Program.functions . program ) case M.lookup g funcs of Nothing -> exception (range g) $ @@ -136,12 +173,13 @@ evalDecls g = foldr (\(Rule.Rule f xs rhs) go ys -> do - (m, ys') <- matchExpandList M.empty xs ys + lift $ tell [ Source $ AttemptRule f ] + (m, ys') <- matchExpandList M.empty g [] xs ys case m of Nothing -> go ys' Just (substitions, additionalArgs) -> do - conss <- lift $ asks ( Program.constructors . snd ) - lift $ tell $ + conss <- lift $ asks ( Program.constructors . program ) + lift $ tell $ map Source $ Step g : Rule f : ( map Data $ S.toList $ S.intersection conss $ S.fromList $ foldr constructors [] xs ) @@ -182,7 +220,7 @@ if f /= g then return ( Nothing, t' ) else do - ( m, ys' ) <- matchExpandList M.empty xs ys + ( m, ys' ) <- matchExpandList M.empty g [] xs ys return ( fmap fst m, Node f ys' ) _ -> exception (termRange t') $ @@ -210,26 +248,28 @@ matchExpandList :: M.Map Identifier Term -> + Identifier -> [Term] -> [Term] -> + [Term] -> Evaluator (Maybe (M.Map Identifier Term, [Term]), [Term]) -matchExpandList s [] ys = return ( Just (s,ys), ys ) -matchExpandList s (x:xs) (y:ys) = do - (m, y') <- matchExpand x y - case m of - Nothing -> return ( Nothing, y' : ys ) - Just s' -> do - s'' <- - case MW.runWriter $ Trav.sequenceA $ - M.unionWithKey (\var t _ -> MW.tell [var] >> t) - (fmap return s) (fmap return s') of - (un, []) -> return $ un - (_, vars) -> exception (termRange y') $ - "variables bound more than once in pattern: " ++ - intercalate ", " (map name vars) - fmap (mapSnd (y':)) $ - matchExpandList s'' xs ys -matchExpandList _ (x:_) _ = +matchExpandList s _ _ [] ys = return ( Just (s,ys), ys ) +matchExpandList s i done (x:xs) (y:ys) = do + (m, y') <- localSuperTerm i done ys $ matchExpand x y + fmap (mapSnd (y':)) $ + case m of + Nothing -> return ( Nothing, ys ) + Just s' -> do + s'' <- + case MW.runWriter $ Trav.sequenceA $ + M.unionWithKey (\var t _ -> MW.tell [var] >> t) + (fmap return s) (fmap return s') of + (un, []) -> return un + (_, vars) -> exception (termRange y') $ + "variables bound more than once in pattern: " ++ + intercalate ", " (map name vars) + matchExpandList s'' i (y':done) xs ys +matchExpandList _ _ _ (x:_) _ = exception (termRange x) "too few arguments" apply :: M.Map Identifier Term -> Term -> Evaluator Term @@ -243,7 +283,7 @@ checkMaxReductions :: Range -> Evaluator () checkMaxReductions rng = do - maxCount <- lift $ asks fst + maxCount <- lift $ asks maxReductions count <- lift get assertT (rng, "number of reductions exceeds limit " ++ show maxCount) $ count < maxCount diff --git a/src/Term.hs b/src/Term.hs --- a/src/Term.hs +++ b/src/Term.hs @@ -313,15 +313,19 @@ peek :: Term -> Position -> Maybe Term peek t [] = return t -peek (Node _f xs) (k : ks) | k < length xs = - peek (xs !! k) ks +peek (Node _f xs) (k : ks) = + case drop k xs of + x:_ -> peek x ks + [] -> mzero 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 +poke (Node f xs) (k : ks) s = + case splitAt k xs of + (pre, x : post) -> do + y <- poke x ks s + return $ Node f $ pre ++ y : post + (_, []) -> error "Term.poke: index too large" poke _ (_:_) _ = error "Term.poke: cannot access a leaf with an index" diff --git a/src/TermFocus.hs b/src/TermFocus.hs new file mode 100644 --- /dev/null +++ b/src/TermFocus.hs @@ -0,0 +1,74 @@ +module TermFocus where + +import qualified Term +import Term ( Term, Identifier ) +import IO ( Output, output ) + +import Text.PrettyPrint.HughesPJ ( Doc, (<+>), fsep, parens, render, text ) + +import Data.Tuple.HT ( mapPair ) +import Data.List.HT ( tails ) +import Data.List ( isPrefixOf ) + + +data TermFocus = + TermFocus { subTerm :: Term, superTerms :: [ SuperTerm ] } + deriving (Show) + +data SuperTerm = Node Identifier ( List Term ) + deriving (Show) + +data List a = List [a] [a] + deriving (Show) + +instance Output TermFocus where + output tf = + foldl (flip outputSuperTerm) (outputSubTerm (subTerm tf)) $ + superTerms tf + +outputSuperTerm :: SuperTerm -> Doc -> Doc +outputSuperTerm (Node nm (List leftArgs rightArgs)) focus = + output nm <+> + fsep ( map Term.protected ( reverse leftArgs ) ++ + parens focus : map Term.protected rightArgs ) + +outputSubTerm :: Term -> Doc +outputSubTerm t = case t of + Term.Number _ n -> text $ mark $ show n + Term.StringLiteral _ s -> text $ mark $ show s + Term.Node f args -> + ( text $ mark $ Term.name f ) <+> fsep ( map Term.protected args ) + +markStart, markStop :: String +markStart = "{{" +markStop = "}}" + +mark :: String -> String +mark str = markStart ++ str ++ markStop + +format :: TermFocus -> ((Int, Int), String) +format t = + let s = render $ output t + in case splitAtInfix markStart s of + (_, Nothing) -> ((0,0), s) + (prefix, Just suffix0) -> + let n = length prefix + in mapPair ((\j -> (n, n+j)), (prefix ++)) $ + case splitAtInfix markStop suffix0 of + (_, Nothing) -> + (length suffix0, suffix0) + (marked, Just suffix) -> + (length marked, marked ++ suffix) + +splitAtInfix :: Eq a => [a] -> [a] -> ([a], Maybe [a]) +splitAtInfix infx str = + mapPair + (map head, + \suffix -> + case suffix of + [] -> Nothing + xs:_ -> Just $ drop (length infx) xs) $ + break (isPrefixOf infx) $ init $ tails str + +fromTerm :: Term -> TermFocus +fromTerm t = TermFocus t [] diff --git a/src/Utility/NonEmptyList.hs b/src/Utility/NonEmptyList.hs deleted file mode 100644 --- a/src/Utility/NonEmptyList.hs +++ /dev/null @@ -1,39 +0,0 @@ -{- -See also packages NonEmpty and NonEmptyList, -where NonEmpty is not much useful functions -and NonEmptyList depends on a large number of packages. --} -module Utility.NonEmptyList where - -import Data.Foldable (Foldable, foldr, ) - -import qualified Prelude as P -import Prelude (Eq, Ord, Show, Functor, fmap, flip, ($), ) - - -data T a = Cons { head :: a, tail :: [a] } - deriving (Eq, Ord, Show) - - -instance Functor T where - fmap f (Cons x xs) = Cons (f x) (fmap f xs) - -instance Foldable T where - foldr f y (Cons x xs) = f x $ foldr f y xs - - -toList :: T a -> [a] -toList (Cons x xs) = x:xs - -cons :: a -> T a -> T a -cons x0 (Cons x1 xs) = Cons x0 (x1:xs) - -singleton :: a -> T a -singleton x = Cons x [] - -reverse :: T a -> T a -reverse (Cons x xs) = - P.foldl (flip cons) (singleton x) xs - -mapHead :: (a -> a) -> T a -> T a -mapHead f (Cons x xs) = Cons (f x) xs