live-sequencer 0.0.3.1 → 0.0.4
raw patch · 26 files changed
+990/−286 lines, 26 filesdep +bytestringdep +non-emptydep ~containersdep ~directorydep ~midi
Dependencies added: bytestring, non-empty
Dependency ranges changed: containers, directory, midi, unix
Files
- data/base/Bool.hs +6/−0
- data/base/Chords.hs +7/−6
- data/base/Enum.hs +13/−0
- data/base/List.hs +19/−24
- data/base/List/Advanced.hs +41/−0
- data/base/List/Basic.hs +36/−0
- data/base/ListLive.hs +19/−3
- data/base/Midi.hs +39/−11
- data/base/Tuple.hs +2/−1
- data/example/CrossSum.hs +5/−2
- data/example/DeBruijn.hs +5/−2
- data/example/Fibonacci.hs +5/−2
- data/example/GrayCode.hs +85/−0
- data/example/JohnsonTrotter.hs +91/−0
- data/prelude/Prelude.hs +1/−3
- http/enable/HTTPServer.hs +9/−6
- http/enable/HTTPServer/Option.hs +12/−0
- live-sequencer.cabal +68/−14
- src/ALSA.hs +1/−1
- src/Event.hs +58/−8
- src/GUI.hs +297/−120
- src/Option.hs +16/−7
- src/Rewrite.hs +71/−31
- src/Term.hs +10/−6
- src/TermFocus.hs +74/−0
- src/Utility/NonEmptyList.hs +0/−39
data/base/Bool.hs view
@@ -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 && ;
data/base/Chords.hs view
@@ -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) ;
+ data/base/Enum.hs view
@@ -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) ;
data/base/List.hs view
@@ -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 ;
+ data/base/List/Advanced.hs view
@@ -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) [] ;
+ data/base/List/Basic.hs view
@@ -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 _ [] = [] ;
data/base/ListLive.hs view
@@ -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'
data/base/Midi.hs view
@@ -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<x) ( applyStrict consWait (div t k + (x-t)) xs ) ( applyStrict consWait (div x k) ( applyStrict (compressTimeAux k) (t-x) xs ) ) ; compressTimeAux k t ( ev : xs ) = ev : compressTimeAux k t xs ;+++{- |+Keep only Wait constructors.+You can use this as a lazily generated pause+which is usually more efficient than @(Wait (duration xs))@.+-}+lazyPause :: [Event a] -> [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] ;
data/base/Tuple.hs view
@@ -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 ;
data/example/CrossSum.hs view
@@ -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 ;
data/example/DeBruijn.hs view
@@ -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 ;
data/example/Fibonacci.hs view
@@ -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 ;
+ data/example/GrayCode.hs view
@@ -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 ;
+ data/example/JohnsonTrotter.hs view
@@ -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 ;
data/prelude/Prelude.hs view
@@ -2,6 +2,7 @@ import Bool import Integer+import Enum data Ordering = LT | EQ | GT ;@@ -20,9 +21,6 @@ min x y = ifThenElse (x<y) x y ; negate x = 0 - x ;--succ x = x+1 ;-pred x = x-1 ; -- fromInteger :: Integer -> Int ; fromInteger x = x ;
http/enable/HTTPServer.hs view
@@ -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
http/enable/HTTPServer/Option.hs view
@@ -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<n && n<65536) "positive 16 bit" str) ("provide a web server under this port,\ndefault " ++ (show $ deconsPort $ port deflt) ) :+ Opt.Option [] ["html-rows"]+ (flip ReqArg "NUMBER" $ \str flags ->+ 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) : []
live-sequencer.cabal view
@@ -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 <waldmann@imn.htwk-leipzig.de>, Henning Thielemann <haskell@henning-thielemann.de> Category: Sound, Music, GUI License: GPL License-file: LICENSE Cabal-Version: >= 1.6-Tested-With: GHC==6.12.3, GHC==7.2.1+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
src/ALSA.hs view
@@ -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
src/Event.hs view
@@ -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)
src/GUI.hs view
@@ -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 =
src/Option.hs view
@@ -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
src/Rewrite.hs view
@@ -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
src/Term.hs view
@@ -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"
+ src/TermFocus.hs view
@@ -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 []
− src/Utility/NonEmptyList.hs
@@ -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