midi 0.1.3.2 → 0.1.4

raw patch · 17 files changed

+210/−151 lines, 17 filesdep +monoid-transformerdep ~event-listPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: monoid-transformer

Dependency ranges changed: event-list

API changes (from Hackage documentation)

Files

• midi.cabal +10/−5
• src/Sound/MIDI/File/Event.hs +5/−5
• src/Sound/MIDI/File/Event/Meta.hs +14/−14
• src/Sound/MIDI/File/Event/SystemExclusive.hs +4/−3
• src/Sound/MIDI/File/Save.hs +22/−23
• src/Sound/MIDI/Manufacturer.hs +4/−3
• src/Sound/MIDI/Message.hs +4/−4
• src/Sound/MIDI/Message/Channel.hs +8/−8
• src/Sound/MIDI/Message/Channel/Mode.hs +1/−1
• src/Sound/MIDI/Message/Channel/Voice.hs +4/−2
• src/Sound/MIDI/Message/System.hs +1/−1
• src/Sound/MIDI/Message/System/Common.hs +6/−5
• src/Sound/MIDI/Message/System/Exclusive.hs +6/−5
• src/Sound/MIDI/Message/System/RealTime.hs +1/−1
• src/Sound/MIDI/Monoid.hs +26/−0
• src/Sound/MIDI/Writer/Basic.hs +57/−41
• src/Sound/MIDI/Writer/Status.hs +37/−30

@@ -1,5 +1,5 @@ Name:             midi-Version:          0.1.3.2+Version:          0.1.4 License:          GPL License-File:     LICENSE Author:           Henning Thielemann <haskell@henning-thielemann.de>@@ -25,7 +25,7 @@ Source-Repository this   type:     darcs   location: http://darcs.haskell.org/midi/-  tag:      0.1.3.2+  tag:      0.1.4  Flag splitBase   description: Choose the new smaller, split-up base package.@@ -35,10 +35,12 @@   default:     False  Library-  Build-Depends: event-list >=0.0.6 && < 0.1, non-negative>=0.0.1 && <0.1+  Build-Depends: event-list >=0.0.9 && < 0.1, non-negative>=0.0.1 && <0.1   Build-Depends: explicit-exception >=0.1 && <0.2   Build-Depends: bytestring >=0.9.0.1 && <0.10, binary >=0.4.2 && <0.5-  Build-Depends: transformers >=0.0.1 && <0.2, QuickCheck >=1 && <2+  Build-Depends: transformers >=0.0.1 && <0.2+  Build-Depends: monoid-transformer >=0.0.1 && <0.1+  Build-Depends: QuickCheck >=1 && <2   If flag(splitBase)     Build-Depends: base >= 2, random >=1 && <2   Else@@ -67,7 +69,6 @@     -- exports ByteList data type     Sound.MIDI.IO   Other-Modules:-    Sound.MIDI.Bit     -- Parser class and general parser functions     Sound.MIDI.Parser.Class     Sound.MIDI.Parser.Restricted@@ -79,8 +80,12 @@     Sound.MIDI.Parser.File     Sound.MIDI.Parser.Stream     Sound.MIDI.Parser.ByteString+    -- output basics     Sound.MIDI.Writer.Basic     Sound.MIDI.Writer.Status+    -- utilities+    Sound.MIDI.Bit+    Sound.MIDI.Monoid     Sound.MIDI.String     Sound.MIDI.Utility 

@@ -29,12 +29,12 @@ import qualified Sound.MIDI.Parser.Status as StatusParser import qualified Sound.MIDI.Parser.Class  as Parser -import Control.Monad.Trans (lift, ) import Control.Monad (liftM, liftM2, )  import qualified Sound.MIDI.Writer.Status as StatusWriter import qualified Sound.MIDI.Writer.Basic  as Writer +import Sound.MIDI.Monoid ((+#+)) import Sound.MIDI.Utility (mapSnd)  @@ -110,9 +110,9 @@ into the raw data of a standard MIDI file. -} -put :: Writer.C writer => T -> StatusWriter.T writer ()+put :: Writer.C writer => T -> StatusWriter.T writer put e =    case e of-      MIDIEvent       m -> lift (ChannelMsg.put m)-      MetaEvent       m -> StatusWriter.clear >> lift (MetaEvent.put  m)-      SystemExclusive m -> StatusWriter.clear >> lift (SysEx.put      m)+      MIDIEvent       m -> StatusWriter.lift (ChannelMsg.put m)+      MetaEvent       m -> StatusWriter.clear +#+ StatusWriter.lift (MetaEvent.put  m)+      SystemExclusive m -> StatusWriter.clear +#+ StatusWriter.lift (SysEx.put      m)

@@ -18,6 +18,8 @@ import qualified Sound.MIDI.Writer.Basic as Writer import qualified Sound.MIDI.Bit as Bit +import Sound.MIDI.Monoid ((+#+))+ import qualified Numeric.NonNegative.Wrapper as NonNeg import Sound.MIDI.IO (ByteList, listCharFromByte, listByteFromChar, ) @@ -206,9 +208,9 @@   -put :: Writer.C writer => T -> writer ()+put :: Writer.C writer => T -> writer put ev =-   Writer.putByte 255 >>+   Writer.putByte 255 +#+    case ev of      SequenceNum num  -> putInt    0 2 num      TextEvent s      -> putStr    1 s@@ -235,24 +237,22 @@      Unknown typ s    -> putByteList typ s  -putByteList :: Writer.C writer => Int -> ByteList -> writer ()+putByteList :: Writer.C writer => Int -> ByteList -> writer putByteList code bytes =-   do-      Writer.putIntAsByte code-      Writer.putLenByteList bytes+   Writer.putIntAsByte code +#++   Writer.putLenByteList bytes -putInt :: Writer.C writer => Int -> Int -> Int -> writer ()+putInt :: Writer.C writer => Int -> Int -> Int -> writer putInt code numBytes x =-   do-      Writer.putIntAsByte code-      Writer.putVar $ fromIntegral numBytes-      Writer.putByteList $-         map fromIntegral $ Bit.someBytes numBytes x+   Writer.putIntAsByte code +#++   Writer.putVar (fromIntegral numBytes) +#++   Writer.putByteList+      (map fromIntegral $ Bit.someBytes numBytes x) -putStr :: Writer.C writer => Int -> String -> writer ()+putStr :: Writer.C writer => Int -> String -> writer putStr code =    putByteList code . listByteFromChar -putList :: Writer.C writer => Int -> [Int] -> writer ()+putList :: Writer.C writer => Int -> [Int] -> writer putList code =    putByteList code . map fromIntegral

@@ -7,6 +7,7 @@ import qualified Sound.MIDI.Parser.Class as Parser  import qualified Sound.MIDI.Writer.Basic as Writer+import Sound.MIDI.Monoid ((+#+))  import Control.Monad (liftM, ) @@ -37,8 +38,8 @@       0xF7 -> liftM Escape  $ getBigN =<< getVar       _ -> Parser.giveUp "SystemExclusive: unkown message type" -put :: Writer.C writer => T -> writer ()+put :: Writer.C writer => T -> writer put sysex =    case sysex of-      Regular bytes -> Writer.putByte 0xF0 >> Writer.putLenByteList bytes-      Escape  bytes -> Writer.putByte 0xF7 >> Writer.putLenByteList bytes+      Regular bytes -> Writer.putByte 0xF0 +#+ Writer.putLenByteList bytes+      Escape  bytes -> Writer.putByte 0xF7 +#+ Writer.putLenByteList bytes

@@ -19,9 +19,12 @@  import qualified Sound.MIDI.Writer.Status as StatusWriter import qualified Sound.MIDI.Writer.Basic  as Writer+import qualified Sound.MIDI.Monoid as M+import Sound.MIDI.Monoid ((+#+)) -import Control.Monad.Trans.Reader (ask, )-import Control.Monad.Trans (lift, )+import qualified Data.Monoid.Reader      as Reader+import qualified Data.Monoid.Transformer as Trans+ import Sound.MIDI.IO (ByteList, writeBinaryFile, )  import qualified Data.ByteString.Lazy as B@@ -78,43 +81,39 @@   -put :: Writer.C writer => MIDIFile.T -> StatusWriter.T writer ()+put :: Writer.C writer => MIDIFile.T -> StatusWriter.T writer put (MIDIFile.Cons mft divisn trks) =-  do-    putChunk "MThd" $ lift $-       do-          Writer.putInt 2 (fromEnum mft) -- format (type 0, 1 or 2)-          Writer.putInt 2 (length trks)  -- number of tracks to come-          putDivision divisn             -- time unit-    mapM_ putTrack trks+   (putChunk "MThd" $ StatusWriter.lift $+      Writer.putInt 2 (fromEnum mft) +#+ -- format (type 0, 1 or 2)+      Writer.putInt 2 (length trks)  +#+ -- number of tracks to come+      putDivision divisn)                 -- time unit+   +#+ M.concatMap putTrack trks -putDivision :: Writer.C writer => Division -> writer ()+putDivision :: Writer.C writer => Division -> writer putDivision (Ticks nticks) =    Writer.putInt 2 (NonNeg.toNumber nticks) putDivision (SMPTE mode nticks) =-   do-      Writer.putIntAsByte (256-mode)-      Writer.putIntAsByte nticks+   Writer.putIntAsByte (256-mode) +#++   Writer.putIntAsByte nticks -putTrack :: Writer.C writer => Track -> StatusWriter.T writer ()+putTrack :: Writer.C writer => Track -> StatusWriter.T writer putTrack trk =    putChunk "MTrk" $-   EventList.mapM_ (lift . Writer.putVar) Event.put $+   EventList.concatMapMonoid (StatusWriter.lift . Writer.putVar) Event.put $    EventList.snoc trk 0 (Event.MetaEvent MetaEvent.EndOfTrack)    putChunk :: Writer.C writer =>-   String -> StatusWriter.T writer () -> StatusWriter.T writer ()+   String -> StatusWriter.T writer -> StatusWriter.T writer putChunk tag m =-   do-      lift $ putTag tag-      compress <- StatusWriter.Cons ask-      lift $ Writer.putLengthBlock 4 $-         StatusWriter.toWriter compress m+   StatusWriter.lift (putTag tag) +#++   StatusWriter.Cons (Reader.Cons $ \compress ->+      Trans.lift $ Writer.putLengthBlock 4 $+         StatusWriter.toWriter compress m)  -putTag :: Writer.C writer => String -> writer ()+putTag :: Writer.C writer => String -> writer putTag tag@(_:_:_:_:[]) = Writer.putStr tag putTag tag =    error ("SaveMIDI.putChunk: Chunk name " ++ tag ++

@@ -52,6 +52,7 @@ import qualified Sound.MIDI.Parser.Class as Parser  import qualified Sound.MIDI.Writer.Basic as Writer+import Sound.MIDI.Monoid ((+#+))  import Control.Monad (liftM2, ) @@ -356,11 +357,11 @@         then liftM2 Extended getByte getByte         else return $ Short subId -put :: Writer.C writer => T -> writer ()+put :: Writer.C writer => T -> writer put subId =    case subId of      Short n -> Writer.putByte n      Extended hi lo ->-        Writer.putByte 0 >>-        Writer.putByte hi >>+        Writer.putByte 0 +#++        Writer.putByte hi +#+         Writer.putByte lo

@@ -20,12 +20,12 @@  import qualified Sound.MIDI.Writer.Status as StatusWriter import qualified Sound.MIDI.Writer.Basic  as Writer+import Sound.MIDI.Monoid ((+#+))  import qualified Sound.MIDI.Parser.Report as Report  import qualified Control.Monad.Exception.Asynchronous as Async -import Control.Monad.Trans (lift, ) import Control.Monad (liftM, )  import qualified Data.ByteString.Lazy as B@@ -67,17 +67,17 @@   -put :: Writer.C writer => T -> writer ()+put :: Writer.C writer => T -> writer put msg =    case msg of       Channel s -> Channel.put s       System  s -> System.put  s -putWithStatus :: Writer.C writer => T -> StatusWriter.T writer ()+putWithStatus :: Writer.C writer => T -> StatusWriter.T writer putWithStatus msg =    case msg of       Channel s -> Channel.putWithStatus s-      System  s -> StatusWriter.clear >> lift (System.put s)+      System  s -> StatusWriter.clear +#+ StatusWriter.lift (System.put s)  toByteString :: T -> B.ByteString toByteString =

@@ -22,13 +22,14 @@ import Sound.MIDI.Parser.Status    (Channel, fromChannel,   toChannel, ) -import Control.Monad.Trans (lift, ) import Control.Monad (liftM, liftM2, when, )  import qualified Sound.MIDI.Writer.Status as StatusWriter import qualified Sound.MIDI.Writer.Basic  as Writer import qualified Sound.MIDI.Bit as Bit +import Sound.MIDI.Monoid ((+#+))+ import Sound.MIDI.Utility ({-checkRange,-} mapSnd, ) -- import Data.Ix (Ix) @@ -108,18 +109,17 @@      else liftM Voice (Voice.get code firstData)  -put :: Writer.C writer => T -> writer ()+put :: Writer.C writer => T -> writer put = StatusWriter.toWriterWithoutStatus . putWithStatus -putWithStatus :: Writer.C writer => T -> StatusWriter.T writer ()+putWithStatus :: Writer.C writer => T -> StatusWriter.T writer putWithStatus (Cons c e) =    case e of       Voice v -> Voice.putWithStatus (putChannel c) v-      Mode  m -> putChannel c 11 >> lift (Mode.put m)+      Mode  m -> putChannel c 11 +#+ StatusWriter.lift (Mode.put m)  -- | output a channel + message code-putChannel :: Writer.C writer => Channel -> Int -> StatusWriter.T writer ()+putChannel :: Writer.C writer => Channel -> Int -> StatusWriter.T writer putChannel chan code =-   do b <- StatusWriter.change (Just (code, chan))-      when b $ lift $-         Writer.putIntAsByte (16*code + fromChannel chan)+   StatusWriter.change (Just (code, chan)) $+      Writer.putIntAsByte (16*code + fromChannel chan)

@@ -94,7 +94,7 @@       ("Invalid value for " ++ name ++ ": " ++ show value)  -put :: Writer.C writer => T -> writer ()+put :: Writer.C writer => T -> writer put mode =    let (code, value) = toControllerValue mode    in  Writer.putByteList [code, value]

@@ -47,6 +47,8 @@ import qualified Sound.MIDI.Writer.Basic  as Writer import qualified Sound.MIDI.Bit as Bit +import Sound.MIDI.Monoid ((+#+))+ import Data.Ix (Ix) import Sound.MIDI.Utility (checkRange,           quantityRandomR, boundedQuantityRandom, chooseQuantity,@@ -425,10 +427,10 @@   putWithStatus :: Writer.C writer =>-   (Int -> StatusWriter.T writer ()) -> T -> StatusWriter.T writer ()+   (Int -> StatusWriter.T writer) -> T -> StatusWriter.T writer putWithStatus putChan e =    let putC code bytes =-          putChan code >>+          putChan code +#+           StatusWriter.fromWriter (Writer.putByteList (map fromIntegral bytes))    in  case e of           NoteOff        p  v  -> putC  8 [fromPitch p, fromVelocity v]

@@ -51,7 +51,7 @@              else Parser.giveUp ("invalid System message code " ++ show code)  -put :: Writer.C writer => T -> writer ()+put :: Writer.C writer => T -> writer put msg =    case msg of       Exclusive s -> Exclusive.put s

@@ -12,6 +12,7 @@ import Control.Monad (liftM, liftM2, )  import qualified Sound.MIDI.Writer.Basic as Writer+import Sound.MIDI.Monoid ((+#+))  import qualified Sound.MIDI.Bit as Bit @@ -54,19 +55,19 @@       0xF6 -> return TuneRequest       _    -> Parser.giveUp ("invalid System Common code:" ++ show code) -put :: Writer.C writer => T -> writer ()+put :: Writer.C writer => T -> writer put msg =    case msg of       TimeCodeQuarterFrame nibble value ->-         Writer.putByte 0xF1 >>+         Writer.putByte 0xF1 +#+          Writer.putIntAsByte (Bit.shiftL 4 (fromEnum nibble) + value)       SongPositionPointer pos ->-         Writer.putByte 0xF2 >>+         Writer.putByte 0xF2 +#+             let (msb,lsb) = Bit.splitAt 7 pos-            in  Writer.putIntAsByte lsb >>+            in  Writer.putIntAsByte lsb +#+                 Writer.putIntAsByte msb       SongSelect song ->-         Writer.putByte 0xF3 >>+         Writer.putByte 0xF3 +#+          Writer.putIntAsByte song       TuneRequest ->          Writer.putByte 0xF6

@@ -12,6 +12,7 @@ import qualified Sound.MIDI.Parser.Class as Parser  import qualified Sound.MIDI.Writer.Basic as Writer+import Sound.MIDI.Monoid ((+#+))  import Control.Monad.Trans (MonadTrans, lift, ) import qualified Control.Monad.Exception.Asynchronous as Async@@ -63,18 +64,18 @@ {- | It is not checked whether SysEx messages contain only 7-bit values. -}-put :: Writer.C writer => T -> writer ()+put :: Writer.C writer => T -> writer put sysex =    case sysex of       Commercial manu body ->-         Manufacturer.put manu >>+         Manufacturer.put manu +#+          Writer.putByteList body       NonCommercial body ->-         Manufacturer.put Manufacturer.nonCommercial >>+         Manufacturer.put Manufacturer.nonCommercial +#+          Writer.putByteList body       NonRealTime (NonRealTimeCons body) ->-         Manufacturer.put Manufacturer.nonRealTime >>+         Manufacturer.put Manufacturer.nonRealTime +#+          Writer.putByteList body       RealTime (RealTimeCons body) ->-         Manufacturer.put Manufacturer.realTime >>+         Manufacturer.put Manufacturer.realTime +#+          Writer.putByteList body

@@ -36,7 +36,7 @@       0xFF -> return Reset       _    -> Parser.giveUp ("unknown System Real Time message code " ++ show code) -put :: Writer.C writer => T -> writer ()+put :: Writer.C writer => T -> writer put msg =    case msg of       TimingClock   -> Writer.putByte 0xF8

@@ -0,0 +1,26 @@+module Sound.MIDI.Monoid where++import Data.Monoid (Monoid, mappend, mconcat, )+import Prelude hiding (concatMap, )++++infixr 5 +#+++(+#+) :: Monoid m => m -> m -> m+(+#+) = mappend+++genAppend :: (Monoid m) =>+   (m -> a) -> (a -> m) -> a -> a -> a+genAppend cons decons x y =+   cons $ mappend (decons x) (decons y)++genConcat :: (Monoid m) =>+   (m -> a) -> (a -> m) -> [a] -> a+genConcat cons decons =+   cons . concatMap decons++concatMap :: (Monoid m) =>+   (a -> m) -> [a] -> m+concatMap f = mconcat . map f

@@ -3,19 +3,25 @@ import qualified Numeric.NonNegative.Wrapper as NonNeg  import qualified Sound.MIDI.Bit as Bit-import Data.Bits ((.|.)) import qualified Sound.MIDI.IO as MIO+import qualified Sound.MIDI.Monoid as M+import qualified Data.Monoid as Monoid++import Data.Bits ((.|.)) import Sound.MIDI.IO (listByteFromChar, )-import Control.Monad.Trans.Writer (Writer, execWriter, tell, )+import Data.Monoid (Monoid, mempty, mappend, mconcat, )+import Sound.MIDI.Monoid ((+#+), genAppend, genConcat, )+ import Control.Monad.Trans.Reader (ReaderT, runReaderT, ask, ) import Control.Monad.Trans (lift, )+ import Data.List (genericLength, ) import Data.Word (Word8, ) import Data.Char (chr, )  import qualified Data.ByteString.Lazy as B-import qualified Data.Binary as Binary-import Data.Binary.Put (PutM, runPut, putLazyByteString, )+import qualified Data.Binary.Builder as Builder+import Data.Binary.Builder (Builder, fromLazyByteString, )  import Control.Exception (bracket, ) import qualified System.IO as IO@@ -26,45 +32,54 @@   -class Monad m => C m where-   putByte :: Word8 -> m ()+class Monoid m => C m where+   putByte :: Word8 -> m    {- |    @putLengthBlock n writeBody@    write @n@ bytes indicating the number of bytes written by @writeBody@    and then it runs @writeBody@.    -}-   putLengthBlock :: Int -> m () -> m ()+   putLengthBlock :: Int -> m -> m  -newtype ByteList a =-   ByteList {unByteList :: Writer MIO.ByteList a}+-- differences list+newtype ByteList =+   ByteList {unByteList :: Monoid.Endo MIO.ByteList} -instance Monad ByteList where-   return = ByteList . return-   x >>= y = ByteList $ unByteList . y =<< unByteList x+instance Monoid ByteList where+   mempty = ByteList mempty+   mappend = genAppend ByteList unByteList+   mconcat = genConcat ByteList unByteList  instance C ByteList where-   putByte = ByteList . tell . (:[])+   putByte = ByteList . Monoid.Endo . (:)    putLengthBlock n writeBody =       let body = runByteList writeBody-      in  putInt n (length body) >> putByteList body+      in  putInt n (length body) `mappend`+          putByteListSpec body  -- we could call 'writeBody' but this would recompute the data  -runByteList :: ByteList () -> MIO.ByteList-runByteList = execWriter . unByteList+-- | 'putByteList' specialised to 'ByteList'+putByteListSpec :: MIO.ByteList -> ByteList+putByteListSpec = ByteList . Monoid.Endo . (++)  +runByteList :: ByteList -> MIO.ByteList+runByteList = flip Monoid.appEndo [] . unByteList  -newtype ByteString a =-   ByteString {unByteString :: PutM a} -instance Monad ByteString where-   return = ByteString . return-   x >>= y = ByteString $ unByteString . y =<< unByteString x +newtype ByteString =+   ByteString {unByteString :: Builder}++instance Monoid ByteString where+   mempty = ByteString $ mempty+   mappend = genAppend ByteString unByteString+   mconcat = genConcat ByteString unByteString+ instance C ByteString where-   putByte = ByteString . Binary.putWord8+   putByte = ByteString . Builder.singleton    putLengthBlock n writeBody =       let body = runByteString writeBody           len = B.length body@@ -72,21 +87,22 @@              if len >= div (256^n) 2                then error "Chunk too large"                else fromIntegral len-      in  putInt n errLen >> ByteString (putLazyByteString body)+      in  putInt n errLen +#+ ByteString (fromLazyByteString body)  -runByteString :: ByteString () -> B.ByteString-runByteString = runPut . unByteString+runByteString :: ByteString -> B.ByteString+runByteString = Builder.toLazyByteString . unByteString    -newtype SeekableFile a =-   SeekableFile {unSeekableFile :: ReaderT Handle IO a}+newtype SeekableFile =+   SeekableFile {unSeekableFile :: ReaderT Handle IO ()} -instance Monad SeekableFile where-   return = SeekableFile . return-   x >>= y = SeekableFile $ unSeekableFile . y =<< unSeekableFile x+instance Monoid SeekableFile where+   mempty = SeekableFile $ return ()+   mappend x y = SeekableFile $ unSeekableFile x >> unSeekableFile y+   mconcat xs  = SeekableFile $ mapM_ unSeekableFile xs  instance C SeekableFile where    putByte c =@@ -110,36 +126,36 @@          IO.hSetPosn contPos  -runSeekableFile :: FilePath -> SeekableFile () -> IO ()+runSeekableFile :: FilePath -> SeekableFile -> IO () runSeekableFile name w =    bracket       (openBinaryFile name WriteMode)       hClose       (flip runSeekableHandle w) -runSeekableHandle :: Handle -> SeekableFile () -> IO ()+runSeekableHandle :: Handle -> SeekableFile -> IO () runSeekableHandle h w =    runReaderT (unSeekableFile w) h    -putInt :: C writer => Int -> Int -> writer ()+putInt :: C writer => Int -> Int -> writer putInt a = putByteList . map fromIntegral . Bit.someBytes a -putStr :: C writer => String -> writer ()+putStr :: C writer => String -> writer putStr = putByteList . listByteFromChar -putIntAsByte :: C writer => Int -> writer ()+putIntAsByte :: C writer => Int -> writer putIntAsByte x = putByte $ fromIntegral x -putByteList :: C writer => MIO.ByteList -> writer ()-putByteList = mapM_ putByte+putByteList :: C writer => MIO.ByteList -> writer+putByteList = M.concatMap putByte -putLenByteList :: C writer => MIO.ByteList -> writer ()+putLenByteList :: C writer => MIO.ByteList -> writer putLenByteList bytes =-   do putVar (genericLength bytes)-      putByteList bytes+   putVar (genericLength bytes) +#++   putByteList bytes  {- | Numbers of variable size are represented by sequences of 7-bit blocks@@ -148,7 +164,7 @@ (0) that this is the last block. -} -putVar :: C writer => NonNeg.Integer -> writer ()+putVar :: C writer => NonNeg.Integer -> writer putVar n =    let bytes = map fromIntegral $ Bit.toBase 128 n    in  case bytes of

@@ -1,57 +1,64 @@-module Sound.MIDI.Writer.Status where+module Sound.MIDI.Writer.Status (+   module Sound.MIDI.Writer.Status,+   lift,+   ) where  -- import qualified Sound.MIDI.Writer.Basic as Writer  import Sound.MIDI.Parser.Status (Channel) -import Control.Monad.Trans.State  (StateT, evalStateT, get, put, )-import Control.Monad.Trans.Reader (ReaderT, runReaderT, ask, )-import Control.Monad.Trans  (MonadTrans, lift, )+import qualified Data.Monoid.State       as State+import qualified Data.Monoid.Reader      as Reader+import qualified Data.Monoid.Transformer as Trans+import Data.Monoid.Transformer (lift, ) +import Data.Monoid (Monoid, mempty, mappend, mconcat, )+import Sound.MIDI.Monoid (genAppend, genConcat, ) + type Status = Maybe (Int,Channel)  {- | The ReaderT Bool handles whether running status should be respected (True) or ignored (False). -}-newtype T writer a =-   Cons {decons :: ReaderT Bool (StateT (Maybe Status) writer) a}+newtype T writer =+   Cons {decons :: Reader.T Bool (State.T (Maybe Status) writer)}  -instance Monad writer => Monad (T writer) where-   return = Cons . return-   x >>= y = Cons $ decons . y =<< decons x+instance Monoid writer => Monoid (T writer) where+   mempty = Cons $ mempty+   mappend = genAppend Cons decons+   mconcat = genConcat Cons decons --- | returns 'True' if status must be submitted (e.g. because it was changed)-change :: (Monad writer) => Status -> T writer Bool-change x = Cons $-   do b <- ask-      if not b-        then return True-        else-           lift $-           let mx = Just x-           in  do my <- get-                  put mx-                  return (mx/=my)+{- |+Given a writer that emits a status, generate a stateful writer,+that decides whether to run the status emittor.+-}+change :: (Monoid writer) => Status -> writer -> T writer+change x emit =+   Cons $+   Reader.Cons $ \b ->+   State.Cons $ \my ->+      let mx = Just x+      in  (if not b || mx/=my then emit else mempty, mx) -clear :: (Monad writer) => T writer ()-clear = Cons $ lift $ put Nothing+clear :: (Monoid writer) => T writer+clear = Cons $ lift $ State.put Nothing  -instance MonadTrans T where+instance Trans.C T where    lift = fromWriter -fromWriter :: (Monad writer) => writer a -> T writer a+fromWriter :: (Monoid writer) => writer -> T writer fromWriter = Cons . lift . lift -toWriter :: (Monad writer) => Bool -> T writer a -> writer a-toWriter withStatus w =-   evalStateT (runReaderT (decons w) withStatus) Nothing+toWriter :: (Monoid writer) => Bool -> T writer -> writer+toWriter withStatus =+   State.evaluate Nothing . flip Reader.run withStatus . decons -toWriterWithStatus :: (Monad writer) => T writer a -> writer a+toWriterWithStatus :: (Monoid writer) => T writer -> writer toWriterWithStatus = toWriter True -toWriterWithoutStatus :: (Monad writer) => T writer a -> writer a+toWriterWithoutStatus :: (Monoid writer) => T writer -> writer toWriterWithoutStatus = toWriter False