diff --git a/midi.cabal b/midi.cabal
--- a/midi.cabal
+++ b/midi.cabal
@@ -1,14 +1,14 @@
 Name:             midi
-Version:          0.1.7.1
+Version:          0.2.2.6
 License:          GPL
 License-File:     LICENSE
 Author:           Henning Thielemann <haskell@henning-thielemann.de>
 Maintainer:       Henning Thielemann <haskell@henning-thielemann.de>
-Homepage:         http://www.haskell.org/haskellwiki/MIDI
+Homepage:         http://wiki.haskell.org/MIDI
 Category:         Sound, Music
-Tested-With:      GHC==6.4.1, GHC==6.8.2, GHC==6.10.4, GHC==6.12.3
-Tested-With:      GHC==7.0.4, GHC==7.2.1
-Cabal-Version:    >=1.6
+Tested-With:      GHC==7.0.4, GHC==7.2.2, GHC==7.4.2, GHC==7.6.3, GHC==7.8.4, GHC==7.10.1
+Tested-With:      GHC==8.4.1
+Cabal-Version:    1.14
 Build-Type:       Simple
 Synopsis:         Handling of MIDI messages and files
 Description:
@@ -25,40 +25,31 @@
   src/Sound/MIDI/Example/Tomatosalad.hs
 Source-Repository head
   type:     darcs
-  location: http://code.haskell.org/~thielema/midi/
+  location: https://hub.darcs.net/thielema/midi/
 
 Source-Repository this
   type:     darcs
-  location: http://code.haskell.org/~thielema/midi/
-  tag:      0.1.7.1
-
-Flag splitBase
-  description: Choose the new smaller, split-up base package.
-
-Flag buildTests
-  description: Build test executables
-  default:     False
+  location: https://hub.darcs.net/thielema/midi/
+  tag:      0.2.2.6
 
 Library
   Build-Depends:
-    event-list >=0.0.9 && < 0.2,
-    non-negative>=0.0.1 && <0.2,
-    explicit-exception >=0.1 && <0.2,
-    bytestring >=0.9.0.1 && <0.10,
-    binary >=0.4.2 && <0.6,
-    transformers >=0.2 && <0.3,
-    monoid-transformer >=0.0.1 && <0.1,
-    QuickCheck >=1 && <3
-  If flag(splitBase)
-    Build-Depends:
-      random >=1 && <2,
-      base >= 3 && <5
-  Else
-    Build-Depends:
-      base >= 1.0 && < 3
+    event-list >=0.0.9 && <0.2,
+    non-negative >=0.0.1 && <0.2,
+    semigroups >=0.1 && <1,
+    utility-ht >=0.0.10 && <0.1,
+    explicit-exception >=0.1 && <0.3,
+    bytestring >=0.9.0.1 && <0.13,
+    binary >=0.4.2 && <0.11,
+    transformers >=0.2 && <0.7,
+    monoid-transformer >=0.0.4 && <0.1,
+    QuickCheck >=2.1 && <3,
+    random >=1 && <2,
+    base >=4.11 && <5
 
+  Default-Language: Haskell2010
   GHC-Options:      -Wall
-  Hs-Source-Dirs:   src
+  Hs-Source-Dirs:   src, parser
   Exposed-Modules:
     Sound.MIDI.File
     Sound.MIDI.File.Event
@@ -76,8 +67,12 @@
     Sound.MIDI.Message.System.Common
     Sound.MIDI.Message.System.RealTime
     Sound.MIDI.Message.Class.Check
+    Sound.MIDI.Message.Class.Query
+    Sound.MIDI.Message.Class.Construct
+    Sound.MIDI.MachineControl
     Sound.MIDI.Controller
     Sound.MIDI.Manufacturer
+    Sound.MIDI.KeySignature
     Sound.MIDI.General
     -- exports ByteList data type
     Sound.MIDI.IO
@@ -101,17 +96,33 @@
     Sound.MIDI.Monoid
     Sound.MIDI.String
     Sound.MIDI.Utility
+    Sound.MIDI.Message.Class.Utility
     -- type definition
     Sound.MIDI.ControllerPrivate
     -- didactic example
     Sound.MIDI.Example.ControllerRamp
 
-Executable test
-  If !flag(buildTests)
-    Buildable:        False
-
--- this will put Cabal into an infinite loop sooner or later
---   Build-Depends:      midi
-  Hs-source-dirs:     src, test
+Test-Suite test
+  Type: exitcode-stdio-1.0
+  Build-Depends:
+    midi,
+    explicit-exception,
+    event-list,
+    non-negative,
+    utility-ht,
+    QuickCheck,
+    transformers,
+    bytestring,
+    base
+  Hs-source-dirs:     test, parser
   GHC-Options:        -Wall
+  Default-Language:   Haskell2010
   Main-Is: Main.hs
+  Other-Modules:
+    Example
+    Parser
+    Common
+    Sound.MIDI.Parser.Class
+    Sound.MIDI.Parser.Exception
+    Sound.MIDI.Parser.Stream
+    Sound.MIDI.Parser.Warning
diff --git a/parser/Sound/MIDI/Parser/Class.hs b/parser/Sound/MIDI/Parser/Class.hs
new file mode 100644
--- /dev/null
+++ b/parser/Sound/MIDI/Parser/Class.hs
@@ -0,0 +1,174 @@
+module Sound.MIDI.Parser.Class
+   (EndCheck, isEnd,
+    C, getByte, skip,
+    warn, warnIf, warnIncomplete, Exc.giveUp, Exc.try,
+    until, zeroOrMore, zeroOrMoreInc, replicate,
+    emptyList, PossiblyIncomplete, UserMessage,
+    Fragile, Partial,
+    {- for debugging
+    absorbException, appendIncomplete,
+    -}
+    ) where
+
+
+import Sound.MIDI.Parser.Report (UserMessage)
+import qualified Sound.MIDI.Parser.Exception as Exc
+import qualified Control.Monad.Exception.Asynchronous as Async
+import qualified Control.Monad.Exception.Synchronous  as Sync
+
+import Control.Monad.Trans.Class (lift, )
+import Control.Monad.Trans.State (StateT, )
+import Control.Monad (liftM, liftM2, when, )
+
+import Data.Word (Word8)
+
+import qualified Numeric.NonNegative.Wrapper as NonNeg
+
+import Prelude hiding (replicate, until, )
+
+
+
+class Monad parser => EndCheck parser where
+   isEnd   :: parser Bool
+
+-- would be probably better placed in Parser.Status
+instance EndCheck parser => EndCheck (StateT st parser) where
+   isEnd = lift $ isEnd
+
+
+class EndCheck parser => C parser where
+   getByte :: Fragile parser Word8
+   skip    :: NonNeg.Integer -> Fragile parser ()
+   warn    :: UserMessage -> parser ()
+
+
+{- |
+@PossiblyIncomplete@ represents a value like a list
+that can be the result of an incomplete parse.
+The case of an incomplete parse is indicated by @Just message@.
+
+It is not possible to merge this functionality in the parser monad,
+because then it is not possible to define monadic binding.
+-}
+type PossiblyIncomplete a = Async.Exceptional UserMessage a
+
+
+type Fragile parser   = Sync.ExceptionalT UserMessage parser
+type Partial  parser a = parser (PossiblyIncomplete a)
+
+
+warnIf :: C parser => Bool -> UserMessage -> parser ()
+warnIf b msg = when b (warn msg)
+
+{- |
+Emit a warning if a value is said to be incomplete.
+Be careful using this function,
+because an incomplete value often means
+that subsequent parse actions will process data from the wrong position.
+Only use this function if you
+either know that the parse is complete also if the parsed value is incomplete
+or if there are no subsequent parse actions to run.
+
+This function cannot fail.
+-}
+warnIncomplete :: C parser => PossiblyIncomplete a -> parser a
+warnIncomplete ~(Async.Exceptional me a) =
+   do maybe (return ()) warn me
+      return a
+
+
+{- |
+This function will never fail.
+If the element parser fails somewhere,
+a prefix of the complete list is returned
+along with the error message.
+-}
+zeroOrMore :: EndCheck parser =>
+   Fragile parser a -> Partial parser [a]
+zeroOrMore p =
+   let go =
+         isEnd >>= \b ->
+            if b
+              then return emptyList
+              else absorbException
+                      (liftM2 (\ x -> fmap (x:)) p (lift go))
+   in  go
+
+
+zeroOrMoreInc :: EndCheck parser =>
+   Partial (Fragile parser) a -> Partial parser [a]
+zeroOrMoreInc p =
+   let go =
+         isEnd >>= \b ->
+            if b
+              then return emptyList
+              else absorbException
+                      (appendIncomplete p go)
+   in  go
+
+
+{- |
+Parse until an element is found, which matches a condition.
+The terminating element is consumed by the parser
+but not appended to the result list.
+If the end of the input is reached without finding the terminating element,
+then an Incomplete exception (Just errorMessage) is signaled.
+-}
+until :: EndCheck parser =>
+   (a -> Bool) -> Fragile parser a -> Partial parser [a]
+until c p =
+   let go =
+         isEnd >>= \b ->
+            if b
+              then
+                return $ Async.broken
+                   "Parser.until: unexpected end of input" []
+              else
+                absorbException $
+                   p >>= \x ->
+                     if c x
+                       then return emptyList
+                       else liftM (fmap (x:)) (lift go)
+   in  go
+
+
+{- |
+This function will never fail.
+It may however return a list that is shorter than requested.
+-}
+replicate ::
+   C parser =>
+   NonNeg.Int ->
+   Partial (Fragile parser) a ->
+   Partial parser [a]
+replicate m p =
+   let go n =
+         if n==0
+           then return emptyList
+           else absorbException
+                   (appendIncomplete p (go (n-1)))
+   in  go m
+
+
+emptyList :: PossiblyIncomplete [a]
+emptyList = Async.pure []
+
+{- |
+The first parser may fail, but the second one must not.
+-}
+appendIncomplete ::
+   Monad parser =>
+   Partial (Fragile parser) a ->
+   Partial parser [a] ->
+   Partial (Fragile parser) [a]
+appendIncomplete p ps =
+   do ~(Async.Exceptional me x) <- p
+      lift $ liftM (fmap (x:)) $
+         maybe ps (\_ -> return (Async.Exceptional me [])) me
+
+absorbException ::
+   Monad parser =>
+   Partial (Fragile parser) [a] ->
+   Partial parser [a]
+absorbException =
+   Sync.resolveT (\errMsg -> return $ Async.broken errMsg [])
diff --git a/parser/Sound/MIDI/Parser/Exception.hs b/parser/Sound/MIDI/Parser/Exception.hs
new file mode 100644
--- /dev/null
+++ b/parser/Sound/MIDI/Parser/Exception.hs
@@ -0,0 +1,23 @@
+{- |
+Handling of exceptions.
+-}
+module Sound.MIDI.Parser.Exception where
+
+import qualified Sound.MIDI.Parser.Report as Report
+
+import qualified Control.Monad.Exception.Synchronous as Sync
+
+
+type T m = Sync.ExceptionalT Report.UserMessage m
+
+
+run :: Monad m =>
+   T m a -> m (Sync.Exceptional Report.UserMessage a)
+run = Sync.runExceptionalT
+
+
+giveUp :: Monad m => String -> T m a
+giveUp = Sync.throwT
+
+try :: Monad m => T m a -> m (Sync.Exceptional Report.UserMessage a)
+try = Sync.tryT
diff --git a/parser/Sound/MIDI/Parser/Stream.hs b/parser/Sound/MIDI/Parser/Stream.hs
new file mode 100644
--- /dev/null
+++ b/parser/Sound/MIDI/Parser/Stream.hs
@@ -0,0 +1,137 @@
+module Sound.MIDI.Parser.Stream
+   (T(..), run, runIncomplete, runPartial,
+    ByteList(..),
+    PossiblyIncomplete, UserMessage, ) where
+
+
+import Control.Monad.Trans.State
+   (State, runState, evalState, get, put, )
+import Control.Monad.Trans.Class (lift, )
+import Control.Monad (liftM, when, ap, )
+import Control.Applicative (Applicative, pure, (<*>), )
+
+import qualified Sound.MIDI.Parser.Report as Report
+import qualified Sound.MIDI.Parser.Class as Parser
+import Sound.MIDI.Parser.Class (UserMessage, PossiblyIncomplete, )
+import qualified Sound.MIDI.Parser.Exception as Exception
+import qualified Sound.MIDI.Parser.Warning   as Warning
+
+import qualified Sound.MIDI.IO as MIO
+
+import Data.Word (Word8)
+import qualified Data.List as List
+
+import qualified Numeric.NonNegative.Wrapper as NonNeg
+
+import Prelude hiding (replicate, until, drop, )
+
+
+
+{-
+Instead of using Report and write the monad instance manually,
+we could also use WriterT monad for warnings and ErrorT monad for failure handling.
+-}
+newtype T str a =
+   Cons {decons :: Warning.T (State str) a}
+
+
+
+runPartial :: Parser.Fragile (T str) a -> str -> (Report.T a, str)
+runPartial parser input =
+   flip runState input $ Warning.run $ decons $ Exception.run parser
+
+run :: ByteStream str => Parser.Fragile (T str) a -> str -> Report.T a
+run parser input =
+   flip evalState input $ Warning.run $ decons $ Exception.run $
+      (do a <- parser
+          lift $
+             Parser.isEnd >>= \end ->
+                Parser.warnIf (not end) "unparsed data left over"
+          return a)
+
+{- |
+Treat errors which caused an incomplete data structure as warnings.
+This is reasonable, because we do not reveal the remaining unparsed data
+and thus further parsing is not possible.
+-}
+runIncomplete :: ByteStream str =>
+   Parser.Partial (Parser.Fragile (T str)) a -> str -> Report.T a
+runIncomplete parser input =
+   flip run input $
+      lift . Parser.warnIncomplete =<< parser
+
+
+
+fromState :: State str a -> T str a
+fromState p =
+   Cons $ lift p
+
+
+instance Functor (T str) where
+   fmap = liftM
+
+instance Applicative (T str) where
+   pure = Cons . return
+   (<*>) = ap
+
+instance Monad (T str) where
+   return = pure
+   x >>= y = Cons $ decons . y =<< decons x
+
+
+class ByteStream str where
+   switchL :: a -> (Word8 -> str -> a) -> str -> a
+   drop :: NonNeg.Integer -> str -> str
+
+newtype ByteList = ByteList MIO.ByteList
+   deriving Show
+
+instance ByteStream ByteList where
+   switchL n j (ByteList xss) =
+      case xss of
+         (x:xs) -> j x (ByteList xs)
+         _ -> n
+   drop n (ByteList xs) = ByteList $ List.genericDrop n xs
+
+instance ByteStream str => Parser.EndCheck (T str) where
+   isEnd = fromState $ liftM (switchL True (\ _ _ -> False)) get
+
+instance ByteStream str => Parser.C (T str) where
+   getByte =
+      switchL
+         (Parser.giveUp "unexpected end of data")
+         (\s ss -> lift (fromState (put ss)) >> return s) =<<
+      lift (fromState get)
+
+{-
+   skip n = sequence_ (genericReplicate n Parser.getByte)
+-}
+   skip n = when (n>0) $
+      do s <- lift $ fromState get
+         switchL
+            (Parser.giveUp "skip past end of part")
+            (\ _ rest -> lift $ fromState $ put rest)
+            (drop (n-1) s)
+
+   warn = Cons . Warning.warn
+
+
+{-
+laziness problems:
+fst $ runPartial (Parser.try (undefined :: T ByteList String)) $ ByteList []
+fst $ runPartial (Monad.liftM2 (,) (return 'a') (Parser.try (return "bla" :: T ByteList String))) $ ByteList []
+fst $ runPartial (Monad.liftM2 (,) (return 'a') (Parser.handleMsg id undefined)) $ ByteList []
+evalState (sequence $ repeat $ return 'a') ""
+fst $ runPartial (sequence $ repeat $ return 'a') ""
+
+fmap snd $ Report.result $ fst $ runPartial (Parser.appendIncomplete (return (undefined,'a')) (return (undefined,"bc"))) (ByteList $ repeat 129)
+fmap snd $ Report.result $ fst $ runPartial ((return (undefined,'a'))) (ByteList $ repeat 129)
+fmap snd $ Report.result $ fst $ runPartial (Parser.zeroOrMoreInc (return (Nothing,'a'))) (ByteList $ repeat 129)
+fmap snd $ Report.result $ fst $ runPartial (Parser.zeroOrMoreInc (return (undefined,'a'))) (ByteList $ repeat 129)
+fmap snd $ Report.result $ fst $ runPartial (Parser.zeroOrMore Parser.getByte) (ByteList $ repeat 129)
+either error snd $ Report.result $ fst $ runPartial (Parser.zeroOrMore Parser.getByte) (ByteList $ repeat 129)
+Report.result $ run (Parser.zeroOrMore Parser.getByte) (ByteList $ repeat 129)
+Report.result $ runIncomplete (Parser.zeroOrMore Parser.getByte) (ByteList $ repeat 129)
+Report.result $ runIncomplete (Parser.replicate 1000000 (liftM ((,) Nothing) Parser.getByte)) (ByteList $ repeat 129)
+Report.result $ runIncomplete (Parser.until (128==) Parser.getByte) (ByteList $ repeat 129)
+-}
diff --git a/parser/Sound/MIDI/Parser/Warning.hs b/parser/Sound/MIDI/Parser/Warning.hs
new file mode 100644
--- /dev/null
+++ b/parser/Sound/MIDI/Parser/Warning.hs
@@ -0,0 +1,28 @@
+{- |
+Handling of warnings.
+-}
+module Sound.MIDI.Parser.Warning where
+
+import qualified Sound.MIDI.Parser.Report as Report
+
+import qualified Control.Monad.Exception.Synchronous as Sync
+import qualified Control.Monad.Trans.Writer as Writer
+
+
+type T m = Writer.WriterT [Report.UserMessage] m
+
+
+run :: Monad m =>
+   T m (Sync.Exceptional Report.UserMessage a) -> m (Report.T a)
+run act =
+   do (exc,warns) <- Writer.runWriterT act
+      return $ Report.Cons warns (Sync.toEither exc)
+
+{-
+run :: Monad m =>
+   T m a -> m (a, [Report.UserMessage])
+run = Writer.runWriterT
+-}
+
+warn :: Monad m => String -> T m ()
+warn text = Writer.tell [text]
diff --git a/src/Sound/MIDI/Bit.hs b/src/Sound/MIDI/Bit.hs
--- a/src/Sound/MIDI/Bit.hs
+++ b/src/Sound/MIDI/Bit.hs
@@ -14,8 +14,9 @@
 
 module Sound.MIDI.Bit where
 
-import Sound.MIDI.Utility (toMaybe, swap)
-import Data.Word(Word8)
+import Data.Maybe.HT (toMaybe, )
+import Data.Tuple.HT (swap, )
+import Data.Word  (Word8, )
 import qualified Data.List as List
 import qualified Data.Bits as Bits
 
diff --git a/src/Sound/MIDI/ControllerPrivate.hs b/src/Sound/MIDI/ControllerPrivate.hs
--- a/src/Sound/MIDI/ControllerPrivate.hs
+++ b/src/Sound/MIDI/ControllerPrivate.hs
@@ -5,7 +5,6 @@
           enumRandomR, boundedEnumRandom, chooseEnum, )
 
 import Test.QuickCheck (Arbitrary(arbitrary), )
-import qualified Test.QuickCheck as QC
 import System.Random (Random(random, randomR), )
 
 
diff --git a/src/Sound/MIDI/Example/ControllerRamp.hs b/src/Sound/MIDI/Example/ControllerRamp.hs
--- a/src/Sound/MIDI/Example/ControllerRamp.hs
+++ b/src/Sound/MIDI/Example/ControllerRamp.hs
@@ -3,20 +3,14 @@
 import qualified Sound.MIDI.File      as MidiFile
 import qualified Sound.MIDI.File.Save as Save
 
--- import qualified Sound.MIDI.File.Event.Meta as MetaEvent
 import qualified Sound.MIDI.File.Event      as Event
 
 import qualified Sound.MIDI.Message.Channel       as ChannelMsg
 import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg
 
--- import qualified Sound.MIDI.Parser.Report as Report
-
 import qualified Data.EventList.Relative.TimeBody as EventList
--- import Data.EventList.Relative.MixedBody ((/.), (./), )
 
 import qualified Data.ByteString.Lazy as B
-
--- import qualified Numeric.NonNegative.Wrapper as NonNeg
 
 
 
diff --git a/src/Sound/MIDI/Example/Tomatosalad.hs b/src/Sound/MIDI/Example/Tomatosalad.hs
--- a/src/Sound/MIDI/Example/Tomatosalad.hs
+++ b/src/Sound/MIDI/Example/Tomatosalad.hs
@@ -14,18 +14,12 @@
 import qualified Sound.MIDI.Message.Channel       as ChannelMsg
 import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg
 
--- import qualified Sound.MIDI.Parser.Report as Report
-
 import qualified Data.EventList.Relative.TimeMixed as EventListTM
 import qualified Data.EventList.Relative.BodyTime  as EventListBT
 import qualified Data.EventList.Relative.MixedTime as EventListMT
 import qualified Data.EventList.Relative.TimeBody  as EventList
--- import Data.EventList.Relative.MixedBody ((/.), (./), )
 
 import qualified Data.ByteString.Lazy as B
-
--- import qualified Numeric.NonNegative.Wrapper as NonNeg
-
 import Data.Tuple.HT (mapFst, )
 
 import qualified Control.Monad.Trans.State as State
diff --git a/src/Sound/MIDI/File.hs b/src/Sound/MIDI/File.hs
--- a/src/Sound/MIDI/File.hs
+++ b/src/Sound/MIDI/File.hs
@@ -4,19 +4,19 @@
 Taken from Haskore.
 -}
 
-module Sound.MIDI.File(
+module Sound.MIDI.File (
    T(..), Division(..), Track, Type(..),
    empty,
    ElapsedTime, fromElapsedTime, toElapsedTime,
    Tempo,       fromTempo,       toTempo,
    explicitNoteOff, implicitNoteOff,
-   getTracks, mergeTracks,
+   getTracks, mergeTracks, mapTrack,
    secondsFromTicks, ticksPerQuarterNote,
 
    showLines, changeVelocity, resampleTime,
    showEvent, showTime,
    sortEvents, progChangeBeforeSetTempo,
-  ) where
+   ) where
 
 import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg
 import qualified Sound.MIDI.Message.Channel as ChannelMsg
@@ -32,12 +32,11 @@
 import qualified Numeric.NonNegative.Wrapper as NonNegW
 import qualified Numeric.NonNegative.Class as NonNeg
 
-import Test.QuickCheck (Arbitrary(arbitrary), )
+import Test.QuickCheck (Arbitrary(arbitrary, shrink), )
 import qualified Test.QuickCheck as QC
 
 import qualified Control.Monad.Trans.State as MS
 import Control.Monad (liftM, liftM2, )
--- import Sound.MIDI.IO(ByteList)
 import Sound.MIDI.String (rightS, )
 
 import Data.Ratio((%))
@@ -77,12 +76,14 @@
                 []
          division <- arbitrary
          return (Cons typ division content)
+   shrink (Cons typ division tracks) =
+      map (Cons typ division) $ shrink tracks
 
 instance Arbitrary Division where
    arbitrary =
       QC.oneof $
-         liftM  (Ticks . (1+)) arbitrary :
-         liftM2 (\x y -> SMPTE (1+abs x) (1+abs y)) arbitrary arbitrary :
+         liftM  (Ticks . (1+) . flip mod 32767) arbitrary :
+         liftM2 (\x y -> SMPTE (1 + mod x 127) (1 + mod y 255)) arbitrary arbitrary :
          []
 
 
@@ -133,8 +134,14 @@
       Serial   -> EventList.concat tracks
 
 {- |
-Process and remove all @SetTempo@ events.
+Process and remove all 'MetaEvent.SetTempo' events.
 The result is an event list where the times are measured in seconds.
+
+Counterintuitively,
+a 'MetaEvent.SetTempo' event sets the tempo for @all@ tracks.
+This is important for Type-1 MIDI files (@Parallel@ tracks).
+Thus you should apply 'secondsFromTicks' to the result of 'mergeTracks'
+and not vice versa.
 -}
 secondsFromTicks ::
    Division ->
@@ -142,7 +149,7 @@
    EventList.T NonNegW.Rational Event.T
 secondsFromTicks division =
    EventList.catMaybes .
-   flip MS.evalState MetaEvent.defltST .
+   flip MS.evalState MetaEvent.defltTempo .
    EventList.mapM
       (\ticks -> do
          microsPerQN <- MS.get
diff --git a/src/Sound/MIDI/File/Event.hs b/src/Sound/MIDI/File/Event.hs
--- a/src/Sound/MIDI/File/Event.hs
+++ b/src/Sound/MIDI/File/Event.hs
@@ -35,7 +35,7 @@
 import qualified Sound.MIDI.Writer.Basic  as Writer
 
 import Sound.MIDI.Monoid ((+#+))
-import Sound.MIDI.Utility (mapSnd)
+import Data.Tuple.HT (mapSnd)
 
 
 import Test.QuickCheck (Arbitrary(arbitrary), )
@@ -83,7 +83,7 @@
 
 -- * serialization
 
-get :: Parser.C parser => Parser.Fallible (StatusParser.T parser) T
+get :: Parser.C parser => Parser.Fragile (StatusParser.T parser) T
 get =
    StatusParser.lift get1 >>= \tag ->
    if tag < 0xF0
@@ -100,7 +100,7 @@
 last event and the current event.  Parse a time and an event, ignoring
 System Exclusive messages.
 -}
-getTrackEvent :: Parser.C parser => Parser.Fallible (StatusParser.T parser) TrackEvent
+getTrackEvent :: Parser.C parser => Parser.Fragile (StatusParser.T parser) TrackEvent
 getTrackEvent  =  liftM2 (,) (StatusParser.lift getVar) get
 
 
@@ -109,9 +109,11 @@
 into the raw data of a standard MIDI file.
 -}
 
-put :: Writer.C writer => T -> StatusWriter.T writer
+put ::
+   (StatusWriter.Compression compress, Writer.C writer) =>
+   T -> StatusWriter.T compress writer
 put e =
    case e of
-      MIDIEvent       m -> StatusWriter.lift (ChannelMsg.put m)
+      MIDIEvent       m -> ChannelMsg.putWithStatus m
       MetaEvent       m -> StatusWriter.clear +#+ StatusWriter.lift (MetaEvent.put  m)
       SystemExclusive m -> StatusWriter.clear +#+ StatusWriter.lift (SysEx.put      m)
diff --git a/src/Sound/MIDI/File/Event/Meta.hs b/src/Sound/MIDI/File/Event/Meta.hs
--- a/src/Sound/MIDI/File/Event/Meta.hs
+++ b/src/Sound/MIDI/File/Event/Meta.hs
@@ -1,19 +1,20 @@
 module Sound.MIDI.File.Event.Meta (
    T(..),
-   Key(..), Scale(..),
    ElapsedTime, fromElapsedTime, toElapsedTime,
    Tempo,       fromTempo,       toTempo,
+   defltTempo,
    SMPTEHours, SMPTEMinutes, SMPTESeconds, SMPTEFrames, SMPTEBits,
-   defltST, defltDurT,
    get, put, ) where
 
 import Sound.MIDI.Message.Channel (Channel, toChannel, fromChannel, )
 
-import           Sound.MIDI.Parser.Primitive
+import qualified Sound.MIDI.KeySignature as KeySig
+
+import Sound.MIDI.Parser.Primitive (get1, get2, get3, getVar, getBigN, )
 import qualified Sound.MIDI.Parser.Class as Parser
 import qualified Sound.MIDI.Parser.Restricted as ParserRestricted
 
-import Control.Monad (liftM, liftM2, liftM4, liftM5, )
+import Control.Monad (liftM, liftM4, liftM5, )
 
 import qualified Sound.MIDI.Writer.Basic as Writer
 import qualified Sound.MIDI.Bit as Bit
@@ -23,14 +24,11 @@
 import qualified Numeric.NonNegative.Wrapper as NonNeg
 import Sound.MIDI.IO (ByteList, listCharFromByte, listByteFromChar, )
 
-import Data.Ix (Ix, index, )
 import Sound.MIDI.Utility
-         (arbitraryString, arbitraryByteList,
-          enumRandomR, boundedEnumRandom, chooseEnum, )
+         (arbitraryString, arbitraryByteList, )
 
 import Test.QuickCheck (Arbitrary(arbitrary), )
 import qualified Test.QuickCheck as QC
-import System.Random (Random(random, randomR), )
 
 import Prelude hiding (putStr, )
 
@@ -59,7 +57,7 @@
    | SetTempo Tempo
    | SMPTEOffset SMPTEHours SMPTEMinutes SMPTESeconds SMPTEFrames SMPTEBits
    | TimeSig Int Int Int Int
-   | KeySig Key Scale
+   | KeySig KeySig.T
    | SequencerSpecific ByteList
    | Unknown Int ByteList
      deriving (Show, Eq, Ord)
@@ -81,7 +79,7 @@
          liftM  (SetTempo . NonNeg.fromNumberMsg "Tempo always positive") (QC.choose (0,0xFFFFFF)) :
          liftM5 SMPTEOffset arbitraryByte arbitraryByte arbitraryByte arbitraryByte arbitraryByte :
          liftM4 TimeSig arbitraryByte arbitraryByte arbitraryByte arbitraryByte :
-         liftM2 KeySig arbitrary arbitrary :
+         liftM  KeySig arbitrary :
          liftM  SequencerSpecific arbitraryByteList :
 --         liftM  Unknown arbitrary arbitraryByteList :
          []
@@ -90,57 +88,6 @@
 arbitraryByte = QC.choose (0,0xFF::Int)
 
 
-{- |
-The following enumerated type lists all the keys in order of their key
-signatures from flats to sharps.
-(@Cf@ = 7 flats, @Gf@ = 6 flats ... @F@ = 1 flat, @C@ = 0 flats\/sharps,
-@G@ = 1 sharp, ... @Cs@ = 7 sharps.)
-Useful for transposition.
--}
-data Key = KeyCf | KeyGf | KeyDf | KeyAf | KeyEf | KeyBf | KeyF
-         | KeyC  | KeyG  | KeyD  | KeyA  | KeyE  | KeyB  | KeyFs | KeyCs
-             deriving (Show, Eq, Ord, Ix, Enum, Bounded)
-
-
-instance Random Key where
-   random  = boundedEnumRandom
-   randomR = enumRandomR
-
-instance Arbitrary Key where
-   arbitrary = chooseEnum
-
-
-
-{- |
-The Key Signature specifies a mode, either major or minor.
--}
-data Scale = Major | Minor
-            deriving (Show, Eq, Ord, Ix, Enum, Bounded)
-
-
-instance Random Scale where
-   random  = boundedEnumRandom
-   randomR = enumRandomR
-
-instance Arbitrary Scale where
-   arbitrary = chooseEnum
-
-
-
-{- |
-Default number of quarter notes in a second.
--}
-defltDurT :: ElapsedTime
-defltDurT = 2
-
-{- |
-The default SetTempo value, in microseconds per quarter note.
-This expresses the default of 120 beats per minute.
--}
-defltST :: Tempo
-defltST = div 1000000 (fromIntegral defltDurT)
-
-
 toElapsedTime :: Integer -> ElapsedTime
 toElapsedTime = NonNeg.fromNumberMsg "toElapsedTime"
 
@@ -154,15 +101,22 @@
 fromTempo :: Tempo -> Int
 fromTempo = NonNeg.toNumber
 
+{- |
+The default SetTempo value, in microseconds per quarter note.
+This expresses the default of 120 beats per minute.
+-}
+defltTempo :: Tempo
+defltTempo = 500000
 
 
+
 -- * serialization
 
-get :: Parser.C parser => Parser.Fallible parser T
+get :: Parser.C parser => Parser.Fragile parser T
 get =
    do code <- get1
       len  <- getVar
-      let parse = ParserRestricted.runFallible len
+      let parse = ParserRestricted.runFragile len
       let returnText cons = liftM (cons . listCharFromByte) $ getBigN len
       case code of
          000 -> parse $ liftM SequenceNum get2
@@ -193,21 +147,13 @@
                    b <- get1
                    return (TimeSig n d c b)
 
-         089 -> parse $
-                do
-                   sf <- get1
-                   sc <- getEnum
-                   return (KeySig (toKeyName sf) sc)
+         089 -> parse $ liftM KeySig KeySig.get
 
          127 -> liftM SequencerSpecific $ getBigN len
 
          _   -> liftM (Unknown code) $ getBigN len
 
-toKeyName :: Int -> Key
-toKeyName sf = toEnum (mod (sf+7) 15)
 
-
-
 put :: Writer.C writer => T -> writer
 put ev =
    Writer.putByte 255 +#+
@@ -227,11 +173,7 @@
      SMPTEOffset hr mn se fr ff
                       -> putList  84 [hr,mn,se,fr,ff]
      TimeSig n d c b  -> putList  88 [n,d,c,b]
-     KeySig sf mi     -> putList  89 [sf', fromEnum mi]
-                             where k = index (KeyCf,KeyCs) sf - 7
-                                   sf' = if k >= 0
-                                           then k
-                                           else 255+k
+     KeySig key       -> putList  89 $ KeySig.toBytes key
      SequencerSpecific codes
                       -> putByteList 127 codes
      Unknown typ s    -> putByteList typ s
diff --git a/src/Sound/MIDI/File/Event/SystemExclusive.hs b/src/Sound/MIDI/File/Event/SystemExclusive.hs
--- a/src/Sound/MIDI/File/Event/SystemExclusive.hs
+++ b/src/Sound/MIDI/File/Event/SystemExclusive.hs
@@ -31,7 +31,7 @@
      deriving (Show, Eq, Ord)
 
 
-get :: Parser.C parser => Int -> Parser.Fallible parser T
+get :: Parser.C parser => Int -> Parser.Fragile parser T
 get tag =
    case tag of
       0xF0 -> liftM Regular $ getBigN =<< getVar
diff --git a/src/Sound/MIDI/File/Load.hs b/src/Sound/MIDI/File/Load.hs
--- a/src/Sound/MIDI/File/Load.hs
+++ b/src/Sound/MIDI/File/Load.hs
@@ -12,10 +12,10 @@
 But it seems to be not sensible
 to re-use functionality from the @iff@ package.
 -}
-module Sound.MIDI.File.Load
-   (fromFile, fromByteList, maybeFromByteList, maybeFromByteString,
-    showFile, )
-      where
+module Sound.MIDI.File.Load (
+   fromFile, fromByteList, maybeFromByteList, maybeFromByteString,
+   showFile,
+   ) where
 
 import           Sound.MIDI.File
 import qualified Sound.MIDI.File as MIDIFile
@@ -26,7 +26,6 @@
 import qualified Numeric.NonNegative.Wrapper as NonNeg
 
 import Sound.MIDI.IO (ByteList, readBinaryFile, )
--- import qualified Sound.MIDI.Bit as Bit
 import           Sound.MIDI.String (unlinesS)
 import           Sound.MIDI.Parser.Primitive
 import qualified Sound.MIDI.Parser.Class as Parser
@@ -42,8 +41,6 @@
 import qualified Data.ByteString.Lazy as B
 
 import qualified Control.Monad.Exception.Asynchronous as Async
--- import qualified Control.Monad.Exception.Synchronous  as Sync
--- import System.IO (hPutStrLn, stderr, )
 import Data.List (genericReplicate, genericLength, )
 import Data.Maybe (catMaybes, )
 
@@ -101,13 +98,13 @@
 any non-header chunks that come before a header chunk.  The header tells us
 the number of tracks to come, which is passed to 'getTracks'.
 -}
-parse :: Parser.C parser => Parser.Partial (Parser.Fallible parser) MIDIFile.T
+parse :: Parser.C parser => Parser.Partial (Parser.Fragile parser) MIDIFile.T
 parse =
    getChunk >>= \ (typ, hdLen) ->
       case typ of
         "MThd" ->
            do (format, nTracks, division) <-
-                 RestrictedParser.runFallible hdLen getHeader
+                 RestrictedParser.runFragile hdLen getHeader
               excTracks <-
                  lift $ Parser.zeroOrMoreInc
                     (getTrackChunk >>= Async.mapM (lift . liftMaybe removeEndOfTrack))
@@ -177,14 +174,14 @@
 four bytes for the size of the coming data,
 and the data itself.
 -}
-getChunk :: Parser.C parser => Parser.Fallible parser (String, NonNeg.Integer)
+getChunk :: Parser.C parser => Parser.Fragile parser (String, NonNeg.Integer)
 getChunk =
    liftM2 (,)
       (getString 4)  -- chunk type: header or track
       (getNByteCardinal 4)
                      -- chunk body
 
-getTrackChunk :: Parser.C parser => Parser.Partial (Parser.Fallible parser) (Maybe Track)
+getTrackChunk :: Parser.C parser => Parser.Partial (Parser.Fragile parser) (Maybe Track)
 getTrackChunk =
    do (typ, len) <- getChunk
       if typ=="MTrk"
@@ -202,7 +199,7 @@
 the number of track chunks to come, and the smallest time division
 to be used in reading the rest of the file.
 -}
-getHeader :: Parser.C parser => Parser.Fallible parser (MIDIFile.Type, NonNeg.Int, Division)
+getHeader :: Parser.C parser => Parser.Fragile parser (MIDIFile.Type, NonNeg.Int, Division)
 getHeader =
    do
       format   <- makeEnum =<< get2
@@ -214,7 +211,7 @@
 The division is implemented thus: the most significant bit is 0 if it's
 in ticks per quarter note; 1 if it's an SMPTE value.
 -}
-getDivision :: Parser.C parser => Parser.Fallible parser Division
+getDivision :: Parser.C parser => Parser.Fragile parser Division
 getDivision =
    do
       x <- get1
@@ -273,7 +270,7 @@
     showString "\n"
 
 
-showMR :: Parser.Fallible (StreamParser.T StreamParser.ByteList) a -> (a->ShowS) -> ByteList -> ShowS
+showMR :: Parser.Fragile (StreamParser.T StreamParser.ByteList) a -> (a->ShowS) -> ByteList -> ShowS
 showMR m pp contents =
   let report = StreamParser.run m (StreamParser.ByteList contents)
   in  unlinesS (map showString $ Report.warnings report) .
diff --git a/src/Sound/MIDI/File/Save.hs b/src/Sound/MIDI/File/Save.hs
--- a/src/Sound/MIDI/File/Save.hs
+++ b/src/Sound/MIDI/File/Save.hs
@@ -19,11 +19,10 @@
 
 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 qualified Data.Monoid.Reader      as Reader
 import qualified Data.Monoid.Transformer as Trans
+import Data.Foldable (foldMap, )
 
 import Sound.MIDI.IO (ByteList, writeBinaryFile, )
 
@@ -81,13 +80,15 @@
 
 
 
-put :: Writer.C writer => MIDIFile.T -> StatusWriter.T writer
+put ::
+   (StatusWriter.Compression compress, Writer.C writer) =>
+   MIDIFile.T -> StatusWriter.T compress writer
 put (MIDIFile.Cons mft divisn 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
+   +#+ foldMap putTrack trks
 
 putDivision :: Writer.C writer => Division -> writer
 putDivision (Ticks nticks) =
@@ -96,7 +97,9 @@
    Writer.putIntAsByte (256-mode) +#+
    Writer.putIntAsByte nticks
 
-putTrack :: Writer.C writer => Track -> StatusWriter.T writer
+putTrack ::
+   (StatusWriter.Compression compress, Writer.C writer) =>
+   Track -> StatusWriter.T compress writer
 putTrack trk =
    putChunk "MTrk" $
    EventList.concatMapMonoid (StatusWriter.lift . Writer.putVar) Event.put $
@@ -104,13 +107,13 @@
 
 
 
-putChunk :: Writer.C writer =>
-   String -> StatusWriter.T writer -> StatusWriter.T writer
+putChunk ::
+   (StatusWriter.Compression compress, Writer.C writer) =>
+   String -> StatusWriter.T compress writer -> StatusWriter.T compress writer
 putChunk tag m =
    StatusWriter.lift (putTag tag) +#+
-   StatusWriter.Cons (Reader.Cons $ \compress ->
-      Trans.lift $ Writer.putLengthBlock 4 $
-         StatusWriter.toWriter compress m)
+   (StatusWriter.Cons $ Trans.lift $
+    Writer.putLengthBlock 4 $ StatusWriter.toWriter m)
 
 
 putTag :: Writer.C writer => String -> writer
diff --git a/src/Sound/MIDI/General.hs b/src/Sound/MIDI/General.hs
--- a/src/Sound/MIDI/General.hs
+++ b/src/Sound/MIDI/General.hs
@@ -11,8 +11,9 @@
 import           Data.Ix(Ix)
 import qualified Data.List as List
 
-import Sound.MIDI.Utility (mapSnd,
-          enumRandomR, boundedEnumRandom, chooseEnum, )
+import Sound.MIDI.Utility
+          (enumRandomR, boundedEnumRandom, chooseEnum, )
+import Data.Tuple.HT (mapSnd, )
 import Test.QuickCheck (Arbitrary(arbitrary), )
 import System.Random (Random(random,randomR), )
 
diff --git a/src/Sound/MIDI/IO.hs b/src/Sound/MIDI/IO.hs
--- a/src/Sound/MIDI/IO.hs
+++ b/src/Sound/MIDI/IO.hs
@@ -15,6 +15,7 @@
 type ByteList = [Word8]
 
 {- |
+FixMe:
 Hugs makes trouble here because it performs UTF-8 conversions.
 E.g. @[255]@ is output as @[195,191]@
 It would be easy to replace these routines by FastPackedString(fps).ByteList.Lazy,
diff --git a/src/Sound/MIDI/KeySignature.hs b/src/Sound/MIDI/KeySignature.hs
new file mode 100644
--- /dev/null
+++ b/src/Sound/MIDI/KeySignature.hs
@@ -0,0 +1,182 @@
+module Sound.MIDI.KeySignature (
+   T(..),
+   Accidentals(..), Mode(..), keyName,
+
+   cfMajor, gfMajor, dfMajor, afMajor, efMajor,
+   bfMajor, fMajor, cMajor, gMajor, dMajor, aMajor,
+   eMajor, bMajor, fsMajor, csMajor,
+   afMinor, efMinor, bfMinor, fMinor, cMinor,
+   gMinor, dMinor, aMinor, eMinor, bMinor, fsMinor,
+   csMinor, gsMinor, dsMinor, asMinor,
+
+   get, toBytes, ) where
+
+import Sound.MIDI.Parser.Primitive (getByte, getEnum, makeEnum, )
+import qualified Sound.MIDI.Parser.Class as Parser
+
+import Control.Monad (liftM2, )
+
+import Data.Ix (Ix, inRange, )
+import Sound.MIDI.Utility
+         (enumRandomR, boundedEnumRandom, chooseEnum, checkRange, )
+
+import Test.QuickCheck (Arbitrary(arbitrary), )
+import System.Random (Random(random, randomR), )
+
+import Data.Int (Int8, )
+
+import Prelude hiding (putStr, )
+
+
+
+data T = Cons Mode Accidentals
+   deriving (Eq, Ord)
+
+instance Show T where
+   showsPrec p (Cons mode accs) =
+      if inRange (minBound, maxBound) accs
+        then showString "KeySig." .
+             showString (keyName mode accs) . shows mode
+        else showParen (p>10) $
+             showString "KeySig.Cons " . shows mode .
+             showString " " . showsPrec 11 accs
+
+instance Arbitrary T where
+   arbitrary = liftM2 Cons arbitrary arbitrary
+
+{- |
+The Key Signature specifies a mode, either major or minor.
+-}
+data Mode = Major | Minor
+            deriving (Show, Eq, Ord, Ix, Enum, Bounded)
+
+
+instance Random Mode where
+   random  = boundedEnumRandom
+   randomR = enumRandomR
+
+instance Arbitrary Mode where
+   arbitrary = chooseEnum
+
+
+
+
+
+keyName :: Mode -> Accidentals -> String
+
+keyName Major (Accidentals (-7)) = "cf"
+keyName Major (Accidentals (-6)) = "gf"
+keyName Major (Accidentals (-5)) = "df"
+keyName Major (Accidentals (-4)) = "af"
+keyName Major (Accidentals (-3)) = "ef"
+keyName Major (Accidentals (-2)) = "bf"
+keyName Major (Accidentals (-1)) = "f"
+keyName Major (Accidentals   0)  = "c"
+keyName Major (Accidentals   1)  = "g"
+keyName Major (Accidentals   2)  = "d"
+keyName Major (Accidentals   3)  = "a"
+keyName Major (Accidentals   4)  = "e"
+keyName Major (Accidentals   5)  = "b"
+keyName Major (Accidentals   6)  = "fs"
+keyName Major (Accidentals   7)  = "cs"
+
+keyName Minor (Accidentals (-7)) = "af"
+keyName Minor (Accidentals (-6)) = "ef"
+keyName Minor (Accidentals (-5)) = "bf"
+keyName Minor (Accidentals (-4)) = "f"
+keyName Minor (Accidentals (-3)) = "c"
+keyName Minor (Accidentals (-2)) = "g"
+keyName Minor (Accidentals (-1)) = "d"
+keyName Minor (Accidentals   0)  = "a"
+keyName Minor (Accidentals   1)  = "e"
+keyName Minor (Accidentals   2)  = "b"
+keyName Minor (Accidentals   3)  = "fs"
+keyName Minor (Accidentals   4)  = "cs"
+keyName Minor (Accidentals   5)  = "gs"
+keyName Minor (Accidentals   6)  = "ds"
+keyName Minor (Accidentals   7)  = "as"
+
+keyName _ (Accidentals n) =
+   if n<0
+     then show (-n) ++ " flats"
+     else show n ++ " sharps"
+
+
+{- |
+Accidentals as used in key signature.
+-}
+newtype Accidentals = Accidentals Int
+           deriving (Show, Eq, Ord, Ix)
+
+instance Bounded Accidentals where
+   minBound = Accidentals (-7)
+   maxBound = Accidentals 7
+
+instance Enum Accidentals where
+   fromEnum (Accidentals n) = fromIntegral n
+   toEnum = checkRange "Accidentals" (Accidentals . fromIntegral)
+
+instance Random Accidentals where
+   random  = boundedEnumRandom
+   randomR = enumRandomR
+
+instance Arbitrary Accidentals where
+   arbitrary = chooseEnum
+
+
+
+
+major, minor :: Accidentals -> T
+major = Cons Major
+minor = Cons Minor
+
+cfMajor, gfMajor, dfMajor, afMajor, efMajor,
+  bfMajor, fMajor, cMajor, gMajor, dMajor, aMajor,
+  eMajor, bMajor, fsMajor, csMajor :: T
+
+afMinor, efMinor, bfMinor, fMinor, cMinor,
+  gMinor, dMinor, aMinor, eMinor, bMinor, fsMinor,
+  csMinor, gsMinor, dsMinor, asMinor :: T
+
+cfMajor = major (Accidentals (-7))
+gfMajor = major (Accidentals (-6))
+dfMajor = major (Accidentals (-5))
+afMajor = major (Accidentals (-4))
+efMajor = major (Accidentals (-3))
+bfMajor = major (Accidentals (-2))
+fMajor  = major (Accidentals (-1))
+cMajor  = major (Accidentals   0)
+gMajor  = major (Accidentals   1)
+dMajor  = major (Accidentals   2)
+aMajor  = major (Accidentals   3)
+eMajor  = major (Accidentals   4)
+bMajor  = major (Accidentals   5)
+fsMajor = major (Accidentals   6)
+csMajor = major (Accidentals   7)
+
+afMinor = minor (Accidentals (-7))
+efMinor = minor (Accidentals (-6))
+bfMinor = minor (Accidentals (-5))
+fMinor  = minor (Accidentals (-4))
+cMinor  = minor (Accidentals (-3))
+gMinor  = minor (Accidentals (-2))
+dMinor  = minor (Accidentals (-1))
+aMinor  = minor (Accidentals   0)
+eMinor  = minor (Accidentals   1)
+bMinor  = minor (Accidentals   2)
+fsMinor = minor (Accidentals   3)
+csMinor = minor (Accidentals   4)
+gsMinor = minor (Accidentals   5)
+dsMinor = minor (Accidentals   6)
+asMinor = minor (Accidentals   7)
+
+
+get :: (Parser.C parser) => Parser.Fragile parser T
+get = liftM2 (flip Cons) getAccidentals getEnum
+
+getAccidentals :: (Parser.C parser) => Parser.Fragile parser Accidentals
+getAccidentals =
+   makeEnum . fromIntegral . (id :: Int8 -> Int8) . fromIntegral =<< getByte
+
+toBytes :: T -> [Int]
+toBytes (Cons mi sf) = [fromEnum sf, fromEnum mi]
diff --git a/src/Sound/MIDI/MachineControl.hs b/src/Sound/MIDI/MachineControl.hs
new file mode 100644
--- /dev/null
+++ b/src/Sound/MIDI/MachineControl.hs
@@ -0,0 +1,198 @@
+module Sound.MIDI.MachineControl (
+   splitCommandList,
+
+   getCommand,
+   getCommands,
+
+   Command (
+      Stop,
+      Play,
+      DeferredPlay,
+      FastForward,
+      Rewind,
+      RecordStrobe,
+      RecordExit,
+      RecordPause,
+      Pause,
+      Eject,
+      Chase,
+      CommandErrorReset,
+      Reset,
+      Wait,
+      Resume
+      {-
+      I will export more constructors, when I am sure,
+      that their definition is reasonable.
+      -}
+      ),
+
+   runParser,
+
+   ) where
+
+import           Sound.MIDI.Parser.Primitive
+import qualified Sound.MIDI.Parser.Class as Parser
+import qualified Sound.MIDI.Parser.Stream as SP
+
+import Sound.MIDI.IO (ByteList, )
+
+import qualified Numeric.NonNegative.Wrapper as NonNeg
+
+import qualified Control.Monad.Trans.Writer as MW
+import qualified Control.Monad.Trans.State as MS
+import Control.Monad (liftM, liftM2, liftM3, )
+
+import Data.List (unfoldr, )
+import Data.Tuple.HT (mapFst, )
+import Data.Bool.HT (if', )
+import Data.Word (Word8, )
+import Data.Maybe (isNothing, catMaybes, )
+
+
+-- * serialization
+
+splitCommandList :: [Word8] -> [(Word8, [Word8])]
+splitCommandList =
+   unfoldr $ \xt ->
+      case xt of
+         [] -> Nothing
+         x:xs ->
+            Just $ (mapFst ((,) x)) $
+            if' (x==0 || x==0xF7) (xs, []) $
+            if' (0x40 <= x && x < 0x78)
+                   (case xs of
+                      [] -> ([], [])
+                      n:ys -> splitAt (fromIntegral n) ys) $
+            ([], xs)
+
+
+data Command =
+     Stop
+   | Play
+   | DeferredPlay
+   | FastForward
+   | Rewind
+   | RecordStrobe
+   | RecordExit
+   | RecordPause
+   | Pause
+   | Eject
+   | Chase
+   | CommandErrorReset
+   | Reset
+
+   | Write ByteList
+   | MaskedWrite ByteList
+   | Read ByteList
+   | Update ByteList
+   | Locate ByteList
+   | VariablePlay Word8 Word8 Word8
+   | Search Word8 Word8 Word8
+   | Shuttle Word8 Word8 Word8
+   | Step Word8
+   | AssignSystemMaster Word8
+   | GeneratorCommand Word8
+   | MIDITimeCodeCommand Word8
+   | Move Word8 Word8
+   | Add Word8 Word8 Word8
+   | Subtract Word8 Word8 Word8
+   | DropFrameAdjust Word8
+   | Procedure ByteList
+   | Event ByteList
+   | Group ByteList
+   | CommandSegment ByteList
+   | DeferredVariablePlay ByteList
+   | RecordStrobeVariable ByteList
+
+   | Wait
+   | Resume
+
+   | GenericNoData Word8
+   | GenericVariableLength Word8 ByteList
+   deriving (Show)
+
+
+{- |
+Read MIDI machine control commands
+until an F7 marker for SysEx end.
+-}
+getCommands :: Parser.C parser => Parser.Partial parser [Command]
+getCommands =
+   liftM (fmap catMaybes) $
+   Parser.until isNothing $ do
+      code <- getByte
+      if code == 0xF7
+        then return Nothing
+        else liftM Just $ getCommand code
+
+getCommand :: Parser.C parser => Word8 -> Parser.Fragile parser Command
+getCommand code =
+   let fetchMany f = liftM f $ getN . NonNeg.fromNumberMsg "Midi.get1" =<< get1
+       fetchN reqLen act = do
+          len <- get1
+          if len==reqLen
+            then act
+            else Parser.giveUp $
+                 "expect " ++ show reqLen ++
+                 " argument(s) for command " ++ show code ++
+                 ", but got " ++ show len
+       fetch1 f = fetchN 1 (liftM  f getByte)
+       fetch2 f = fetchN 2 (liftM2 f getByte getByte)
+       fetch3 f = fetchN 3 (liftM3 f getByte getByte getByte)
+
+   in  case code of
+          0x01 -> return Stop
+          0x02 -> return Play
+          0x03 -> return DeferredPlay
+          0x04 -> return FastForward
+          0x05 -> return Rewind
+          0x06 -> return RecordStrobe
+          0x07 -> return RecordExit
+          0x08 -> return RecordPause
+          0x09 -> return Pause
+          0x0A -> return Eject
+          0x0B -> return Chase
+          0x0C -> return CommandErrorReset
+          0x0D -> return Reset
+
+          0x40 -> fetchMany Write
+          0x41 -> fetchMany MaskedWrite
+          0x42 -> fetchMany Read
+          0x43 -> fetchMany Update
+          0x44 -> fetchMany Locate
+          0x45 -> fetch3 VariablePlay
+          0x46 -> fetch3 Search
+          0x47 -> fetch3 Shuttle
+          0x48 -> fetch1 Step
+          0x49 -> fetch1 AssignSystemMaster
+          0x4A -> fetch1 GeneratorCommand
+          0x4B -> fetch1 MIDITimeCodeCommand
+          0x4C -> fetch2 Move
+          0x4D -> fetch3 Add
+          0x4E -> fetch3 Subtract
+          0x4F -> fetch1 DropFrameAdjust
+          0x50 -> fetchMany Procedure
+          0x51 -> fetchMany Event
+          0x52 -> fetchMany Group
+          0x53 -> fetchMany CommandSegment
+          0x54 -> fetchMany DeferredVariablePlay
+          0x55 -> fetchMany RecordStrobeVariable
+
+          0x7C -> return Wait
+          0x7F -> return Resume
+
+          0x00 -> Parser.giveUp "encountered command zero"
+          0xF7 -> Parser.giveUp "end of SysEx" -- should be handled by the caller
+
+          _ ->
+             if' (0x40 <= code && code < 0x78)
+                (fetchMany $ GenericVariableLength code)
+                (return $ GenericNoData code)
+
+runParser ::
+   Parser.Partial (SP.T SP.ByteList) a ->
+   ByteList ->
+   (SP.PossiblyIncomplete a, [SP.UserMessage])
+runParser p =
+   MS.evalState (MW.runWriterT $ SP.decons p) .
+   SP.ByteList
diff --git a/src/Sound/MIDI/Manufacturer.hs b/src/Sound/MIDI/Manufacturer.hs
--- a/src/Sound/MIDI/Manufacturer.hs
+++ b/src/Sound/MIDI/Manufacturer.hs
@@ -350,7 +350,7 @@
 
 -- * serialization
 
-get :: Parser.C parser => Parser.Fallible parser T
+get :: Parser.C parser => Parser.Fragile parser T
 get =
    do subId <- getByte
       if subId == 0
diff --git a/src/Sound/MIDI/Message.hs b/src/Sound/MIDI/Message.hs
--- a/src/Sound/MIDI/Message.hs
+++ b/src/Sound/MIDI/Message.hs
@@ -34,9 +34,11 @@
 data T =
      Channel Channel.T
    | System  System.T
+-- Show instance requires Show instance of System.T
+--     deriving (Show)
 
 
-get :: Parser.C parser => Parser.Fallible parser T
+get :: Parser.C parser => Parser.Fragile parser T
 get =
    get1 >>= \code ->
    if code >= 0xF0
@@ -44,7 +46,7 @@
      else liftM Channel $ (uncurry Channel.get (Channel.decodeStatus code) =<< get1)
 --     else liftM Channel $ StatusParser.run (Channel.getWithStatus code)
 
-getWithStatus :: Parser.C parser => Parser.Fallible (StatusParser.T parser) T
+getWithStatus :: Parser.C parser => Parser.Fragile (StatusParser.T parser) T
 getWithStatus =
    StatusParser.lift get1 >>= \code ->
    if code >= 0xF0
@@ -53,7 +55,7 @@
      else liftM Channel $ Channel.getWithStatus code
 
 getIncompleteWithStatus ::
-   Parser.C parser => Parser.Partial (Parser.Fallible (StatusParser.T parser)) T
+   Parser.C parser => Parser.Partial (Parser.Fragile (StatusParser.T parser)) T
 getIncompleteWithStatus =
    StatusParser.lift get1 >>= \code ->
    if code >= 0xF0
@@ -73,7 +75,9 @@
       Channel s -> Channel.put s
       System  s -> System.put  s
 
-putWithStatus :: Writer.C writer => T -> StatusWriter.T writer
+putWithStatus ::
+   (StatusWriter.Compression compress, Writer.C writer) =>
+   T -> StatusWriter.T compress writer
 putWithStatus msg =
    case msg of
       Channel s -> Channel.putWithStatus s
diff --git a/src/Sound/MIDI/Message/Channel.hs b/src/Sound/MIDI/Message/Channel.hs
--- a/src/Sound/MIDI/Message/Channel.hs
+++ b/src/Sound/MIDI/Message/Channel.hs
@@ -19,8 +19,7 @@
 import qualified Sound.MIDI.Parser.Status as StatusParser
 import           Sound.MIDI.Parser.Primitive
 import qualified Sound.MIDI.Parser.Class as Parser
-import Sound.MIDI.Parser.Status
-   (Channel, fromChannel,   toChannel, )
+import Sound.MIDI.Parser.Status (Channel, fromChannel, toChannel, )
 
 import Control.Monad (liftM, liftM2, when, )
 
@@ -30,10 +29,9 @@
 
 import Sound.MIDI.Monoid ((+#+))
 
-import Sound.MIDI.Utility ({-checkRange,-} mapSnd, )
--- import Data.Ix (Ix)
+import Data.Tuple.HT (mapSnd, )
 
-import Test.QuickCheck (Arbitrary(arbitrary), )
+import Test.QuickCheck (Arbitrary(arbitrary, shrink), )
 import qualified Test.QuickCheck as QC
 
 
@@ -42,6 +40,7 @@
      messageChannel :: Channel,
      messageBody    :: Body
    }
+     -- ToDo: make nicer Show instance
      deriving (Show, Eq, Ord)
 
 data Body =
@@ -61,6 +60,11 @@
             (20, liftM Voice arbitrary) :
             ( 1, liftM Mode  arbitrary) :
             [])
+   shrink (Cons chan body) =
+      map (uncurry Cons) $
+      case body of
+         Voice v -> map (mapSnd Voice) $ shrink (chan, v)
+         Mode  m -> map (mapSnd Mode)  $ shrink (chan, m)
 
 
 -- * serialization
@@ -74,7 +78,7 @@
 (it's been nice enough to keep track of it for us),
 and the tag that we've already gotten is the first byte of data.
 -}
-getWithStatus :: Parser.C parser => Int -> Parser.Fallible (StatusParser.T parser) T
+getWithStatus :: Parser.C parser => Int -> Parser.Fragile (StatusParser.T parser) T
 getWithStatus tag =
    do (status@(code, channel), firstData) <-
          if tag < 0x80
@@ -97,7 +101,7 @@
 the code, channel and first data byte
 must be determined by the caller.
 -}
-get :: Parser.C parser => Int -> Channel -> Int -> Parser.Fallible parser T
+get :: Parser.C parser => Int -> Channel -> Int -> Parser.Fragile parser T
 get code channel firstData =
    liftM (Cons channel) $
    if code == 11 && firstData >= 0x78
@@ -111,14 +115,18 @@
 put :: Writer.C writer => T -> writer
 put = StatusWriter.toWriterWithoutStatus . putWithStatus
 
-putWithStatus :: Writer.C writer => T -> StatusWriter.T writer
+putWithStatus ::
+   (StatusWriter.Compression compress, Writer.C writer) =>
+   T -> StatusWriter.T compress writer
 putWithStatus (Cons c e) =
    case e of
       Voice v -> Voice.putWithStatus (putChannel c) v
       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 ::
+   (StatusWriter.Compression compress, Writer.C writer) =>
+   Channel -> Int -> StatusWriter.T compress writer
 putChannel chan code =
-   StatusWriter.change (Just (code, chan)) $
+   StatusWriter.change (code, chan) $
       Writer.putIntAsByte (16*code + fromChannel chan)
diff --git a/src/Sound/MIDI/Message/Channel/Mode.hs b/src/Sound/MIDI/Message/Channel/Mode.hs
--- a/src/Sound/MIDI/Message/Channel/Mode.hs
+++ b/src/Sound/MIDI/Message/Channel/Mode.hs
@@ -13,7 +13,7 @@
 import Sound.MIDI.Parser.Report (UserMessage, )
 
 import qualified Control.Monad.Exception.Asynchronous as Async
-import Sound.MIDI.Utility (toMaybe, )
+import Data.Maybe.HT (toMaybe, )
 import Control.Monad.Trans.Class (lift, )
 import Control.Monad (liftM, )
 
@@ -47,7 +47,7 @@
 
 -- * serialization
 
-get :: Parser.C parser => Int -> Parser.Fallible parser T
+get :: Parser.C parser => Int -> Parser.Fragile parser T
 get mode =
    do x <- get1
       lift $ Parser.warnIncomplete $ uncurry Async.Exceptional $ fromControllerValue (mode,x)
diff --git a/src/Sound/MIDI/Message/Channel/Voice.hs b/src/Sound/MIDI/Message/Channel/Voice.hs
--- a/src/Sound/MIDI/Message/Channel/Voice.hs
+++ b/src/Sound/MIDI/Message/Channel/Voice.hs
@@ -6,7 +6,7 @@
    ControllerValue, PitchBendRange, Pressure,
    isNote, isNoteOn, isNoteOff, zeroKey,
    explicitNoteOff, implicitNoteOff,
-   toFloatController,
+   realFromControllerValue,
 
    bankSelect, modulation, breathControl, footControl, portamentoTime,
    dataEntry, mainVolume, balance, panorama, expression,
@@ -35,7 +35,7 @@
    CtrlP.Controller, CtrlP.fromController, CtrlP.toController,
 
    increasePitch, subtractPitch, frequencyFromPitch,
-   maximumVelocity, normalVelocity, toFloatVelocity,
+   maximumVelocity, normalVelocity, realFromVelocity,
   ) where
 
 import qualified Sound.MIDI.ControllerPrivate as CtrlP
@@ -223,6 +223,14 @@
    minBound = Pitch   0
    maxBound = Pitch 127
 
+{- |
+ToDo:
+We have defined minBound = Velocity 0,
+but strictly spoken the minimum Velocity is 1,
+since Velocity zero means NoteOff.
+One can at least think of NoteOff with (Velocity 0),
+but I have never seen that.
+-}
 instance Bounded Velocity where
    minBound = Velocity   0
    maxBound = Velocity 127
@@ -249,33 +257,28 @@
 {- |
 The velocity of an ordinary key stroke and
 the maximum possible velocity.
-
-ToDo:
-This should be of type Velocity.
 -}
-normalVelocity, maximumVelocity :: Num quant => quant
-   -- Velocity
-normalVelocity  =  64
-maximumVelocity = 127
+normalVelocity, maximumVelocity :: Velocity
+normalVelocity  = Velocity 64
+maximumVelocity = maxBound
 
 {- |
-64 is given as default value by the MIDI specification
-and thus we map it to 1.
-0 is mapped to 0.
-All other values are interpolated linearly.
-
-ToDo:
 MIDI specification says,
 if velocity is simply mapped to amplitude,
 then this should be done by an exponential function.
-Thus we should be better map 'normalVelocity' to 0,
-'maximumVelocity' to 1,
-and 'minimumVelocity' to -1.
+Thus we map 'normalVelocity' (64) to 0,
+'maximumVelocity' (127) to 1,
+and 'minimumVelocity' (1) to -1.
+That is, normally you should write something like
+@amplitude = 2 ** realFromVelocity vel@ or @3 ** realFromVelocity vel@.
 -}
-toFloatVelocity :: (Integral a, Fractional b) => a -> b
-toFloatVelocity x = fromIntegral x / normalVelocity
+realFromVelocity :: (Fractional b) => Velocity -> b
+realFromVelocity (Velocity x) =
+   fromIntegral (x - fromVelocity normalVelocity) /
+   fromIntegral (fromVelocity maximumVelocity - fromVelocity normalVelocity)
 
-maximumControllerValue :: Num quant => quant
+
+maximumControllerValue :: Num a => a
 maximumControllerValue = 127
 
 {- |
@@ -283,8 +286,8 @@
 Maximum integral MIDI controller value 127 is mapped to 1.
 Minimum integral MIDI controller value 0 is mapped to 0.
 -}
-toFloatController :: (Integral a, Fractional b) => a -> b
-toFloatController x = fromIntegral x / maximumControllerValue
+realFromControllerValue :: (Integral a, Fractional b) => a -> b
+realFromControllerValue x = fromIntegral x / maximumControllerValue
 
 
 
@@ -403,7 +406,7 @@
 
 -- * serialization
 
-get :: Parser.C parser => Int -> Int -> Parser.Fallible parser T
+get :: Parser.C parser => Int -> Int -> Parser.Fragile parser T
 get code firstData =
    let pitch  = toPitch firstData
        getVel = liftM toVelocity get1
@@ -423,7 +426,8 @@
 
 
 putWithStatus :: Writer.C writer =>
-   (Int -> StatusWriter.T writer) -> T -> StatusWriter.T writer
+   (Int -> StatusWriter.T compress writer) ->
+   T -> StatusWriter.T compress writer
 putWithStatus putChan e =
    let putC code bytes =
           putChan code +#+
diff --git a/src/Sound/MIDI/Message/Class/Check.hs b/src/Sound/MIDI/Message/Class/Check.hs
--- a/src/Sound/MIDI/Message/Class/Check.hs
+++ b/src/Sound/MIDI/Message/Class/Check.hs
@@ -1,17 +1,41 @@
-module Sound.MIDI.Message.Class.Check where
+module Sound.MIDI.Message.Class.Check (
+   C(..),
+   noteExplicitOff,
+   noteImplicitOff,
+   controller,
+   liftMidi,
+   liftFile,
+   ) where
 
+import qualified Sound.MIDI.Message.Class.Utility as CU
+
 import Sound.MIDI.Message.Channel (Channel, )
 import Sound.MIDI.Message.Channel.Voice (Pitch, Velocity, Program, Controller, )
 
+import qualified Sound.MIDI.File.Event as FileEvent
 import qualified Sound.MIDI.Message as MidiMsg
 import qualified Sound.MIDI.Message.Channel as ChannelMsg
-import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg
 import qualified Sound.MIDI.Message.Channel.Mode as Mode
 
 import Control.Monad (guard, )
 
 
+{- |
+All methods have default implementations that return 'Nothing'.
+This helps implementing event data types
+that support only a subset of types of events.
+
+Maybe a better approach is to provide type classes
+for every type of event
+and make 'C' a subclass of all of them.
+-}
 class C event where
+   {- |
+   Warning: This returns note events as they are,
+   that is, a @NoteOff p 64@ might be encoded as such or as @NoteOn p 0@
+   depending on the content of @event@.
+   For normalized results you may use 'noteExplicitOff'.
+   -}
    note :: Channel -> event -> Maybe (Velocity, Pitch, Bool)
    program :: Channel -> event -> Maybe Program
    anyController :: Channel -> event -> Maybe (Controller, Int)
@@ -19,6 +43,35 @@
    channelPressure :: Channel -> event -> Maybe Int
    mode :: Channel -> event -> Maybe Mode.T
 
+   note _chan _ev = Nothing
+   program _chan _ev = Nothing
+   anyController _chan _ev = Nothing
+   pitchBend _chan _ev = Nothing
+   channelPressure _chan _ev = Nothing
+   mode _chan _ev = Nothing
+
+
+{- |
+Like 'note', but converts @NoteOn p 0@ to @NoteOff p 64@.
+See 'VoiceMsg.explicitNoteOff'.
+-}
+noteExplicitOff ::
+   (C event) =>
+   Channel -> event -> Maybe (Velocity, Pitch, Bool)
+noteExplicitOff chan e =
+   fmap CU.explicitNoteOff $ note chan e
+
+{- |
+Like 'note', but converts @NoteOff p 64@ to @NoteOn p 0@.
+See 'VoiceMsg.implicitNoteOff'.
+-}
+noteImplicitOff ::
+   (C event) =>
+   Channel -> event -> Maybe (Velocity, Pitch, Bool)
+noteImplicitOff chan e =
+   fmap CU.implicitNoteOff $ note chan e
+
+
 controller ::
    (C event) =>
    Channel -> Controller -> event -> Maybe Int
@@ -28,44 +81,20 @@
    return n
 
 
-instance C ChannelMsg.T where
-   note chan msg = do
-      guard (ChannelMsg.messageChannel msg  ==  chan)
-      ChannelMsg.Voice voice <- Just $ ChannelMsg.messageBody msg
-      case voice of
-         VoiceMsg.NoteOn  pitch velocity -> Just (velocity, pitch, True)
-         VoiceMsg.NoteOff pitch velocity -> Just (velocity, pitch, False)
-         _ -> Nothing
-
-   program chan msg = do
-      guard (ChannelMsg.messageChannel msg  ==  chan)
-      ChannelMsg.Voice (VoiceMsg.ProgramChange pgm) <-
-         Just $ ChannelMsg.messageBody msg
-      return pgm
-
-   anyController chan msg = do
-      guard (ChannelMsg.messageChannel msg  ==  chan)
-      ChannelMsg.Voice (VoiceMsg.Control ctrl val) <-
-         Just $ ChannelMsg.messageBody msg
-      return (ctrl, val)
-
-   pitchBend chan msg = do
-      guard (ChannelMsg.messageChannel msg  ==  chan)
-      ChannelMsg.Voice (VoiceMsg.PitchBend bend) <-
-         Just $ ChannelMsg.messageBody msg
-      return bend
-
-   channelPressure chan msg = do
-      guard (ChannelMsg.messageChannel msg  ==  chan)
-      ChannelMsg.Voice (VoiceMsg.MonoAftertouch pressure) <-
-         Just $ ChannelMsg.messageBody msg
-      return pressure
+lift ::
+   (Maybe ChannelMsg.Body -> Maybe a) ->
+   Channel -> ChannelMsg.T -> Maybe a
+lift act chan msg = do
+   guard (ChannelMsg.messageChannel msg  ==  chan)
+   act $ Just $ ChannelMsg.messageBody msg
 
-   mode chan msg = do
-      guard (ChannelMsg.messageChannel msg  ==  chan)
-      ChannelMsg.Mode m <-
-         Just $ ChannelMsg.messageBody msg
-      return m
+instance C ChannelMsg.T where
+   note = lift CU.note
+   program = lift CU.program
+   anyController = lift CU.anyController
+   pitchBend = lift CU.pitchBend
+   channelPressure = lift CU.channelPressure
+   mode = lift CU.mode
 
 
 liftMidi ::
@@ -83,3 +112,20 @@
    pitchBend = liftMidi pitchBend
    channelPressure = liftMidi channelPressure
    mode = liftMidi mode
+
+
+liftFile ::
+   (Channel -> ChannelMsg.T -> Maybe a) ->
+   (Channel -> FileEvent.T -> Maybe a)
+liftFile checkMsg chan msg =
+   case msg of
+      FileEvent.MIDIEvent midiMsg -> checkMsg chan midiMsg
+      _ -> Nothing
+
+instance C FileEvent.T where
+   note = liftFile note
+   program = liftFile program
+   anyController = liftFile anyController
+   pitchBend = liftFile pitchBend
+   channelPressure = liftFile channelPressure
+   mode = liftFile mode
diff --git a/src/Sound/MIDI/Message/Class/Construct.hs b/src/Sound/MIDI/Message/Class/Construct.hs
new file mode 100644
--- /dev/null
+++ b/src/Sound/MIDI/Message/Class/Construct.hs
@@ -0,0 +1,111 @@
+module Sound.MIDI.Message.Class.Construct where
+
+import qualified Sound.MIDI.Message.Class.Utility as CU
+
+import Sound.MIDI.Message.Channel (Channel, )
+import Sound.MIDI.Message.Channel.Voice (Pitch, Velocity, Program, Controller, )
+
+import qualified Sound.MIDI.File.Event as FileEvent
+import qualified Sound.MIDI.Message as MidiMsg
+import qualified Sound.MIDI.Message.Channel as ChannelMsg
+import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg
+import qualified Sound.MIDI.Message.Channel.Mode as Mode
+
+
+class C event where
+   {- |
+   Warning: This constructs a note events as is,
+   that is, a @NoteOff p 64@ is encoded as such
+   and will not be converted to @NoteOn p 0@.
+   If you want such a conversion, you may use 'noteImplicitOff'.
+   -}
+   note :: Channel -> (Velocity, Pitch, Bool) -> event
+   program :: Channel -> Program -> event
+   anyController :: Channel -> (Controller, Int) -> event
+   pitchBend :: Channel -> Int -> event
+   channelPressure :: Channel -> Int -> event
+   mode :: Channel -> Mode.T -> event
+
+
+liftChannel ::
+   (a -> ChannelMsg.Body) ->
+   (Channel -> a -> ChannelMsg.T)
+liftChannel makeMsg channel param =
+   ChannelMsg.Cons channel $ makeMsg param
+
+instance C ChannelMsg.T where
+   note =
+      liftChannel $ \(velocity, pitch, on) ->
+         ChannelMsg.Voice $
+         (if on then VoiceMsg.NoteOn else VoiceMsg.NoteOff) pitch velocity
+
+   program =
+      liftChannel $ \pgm ->
+         ChannelMsg.Voice $ VoiceMsg.ProgramChange pgm
+
+   anyController =
+      liftChannel $ \(ctrl, val) ->
+         ChannelMsg.Voice $ VoiceMsg.Control ctrl val
+
+   pitchBend =
+      liftChannel $ \bend ->
+         ChannelMsg.Voice $ VoiceMsg.PitchBend bend
+
+   channelPressure =
+      liftChannel $ \pressure ->
+         ChannelMsg.Voice $ VoiceMsg.MonoAftertouch pressure
+
+   mode =
+      liftChannel $ \m ->
+         ChannelMsg.Mode m
+
+
+{- |
+Like 'note', but converts @NoteOn p 0@ to @NoteOff p 64@.
+See 'VoiceMsg.explicitNoteOff'.
+-}
+noteExplicitOff ::
+   (C event) =>
+   Channel -> (Velocity, Pitch, Bool) -> event
+noteExplicitOff channel =
+   note channel . CU.explicitNoteOff
+
+{- |
+Like 'note', but converts @NoteOff p 64@ to @NoteOn p 0@.
+See 'VoiceMsg.implicitNoteOff'.
+-}
+noteImplicitOff ::
+   (C event) =>
+   Channel -> (Velocity, Pitch, Bool) -> event
+noteImplicitOff channel =
+   note channel . CU.implicitNoteOff
+
+
+liftMidi ::
+   (Channel -> a -> ChannelMsg.T) ->
+   (Channel -> a -> MidiMsg.T)
+liftMidi makeMsg channel msg =
+   MidiMsg.Channel $ makeMsg channel msg
+
+instance C MidiMsg.T where
+   note = liftMidi note
+   program = liftMidi program
+   anyController = liftMidi anyController
+   pitchBend = liftMidi pitchBend
+   channelPressure = liftMidi channelPressure
+   mode = liftMidi mode
+
+
+liftFile ::
+   (Channel -> a -> ChannelMsg.T) ->
+   (Channel -> a -> FileEvent.T)
+liftFile makeMsg channel msg =
+   FileEvent.MIDIEvent $ makeMsg channel msg
+
+instance C FileEvent.T where
+   note = liftFile note
+   program = liftFile program
+   anyController = liftFile anyController
+   pitchBend = liftFile pitchBend
+   channelPressure = liftFile channelPressure
+   mode = liftFile mode
diff --git a/src/Sound/MIDI/Message/Class/Query.hs b/src/Sound/MIDI/Message/Class/Query.hs
new file mode 100644
--- /dev/null
+++ b/src/Sound/MIDI/Message/Class/Query.hs
@@ -0,0 +1,120 @@
+module Sound.MIDI.Message.Class.Query (
+   C(..),
+   noteExplicitOff,
+   noteImplicitOff,
+   liftMidi,
+   liftFile,
+   ) where
+
+import qualified Sound.MIDI.Message.Class.Utility as CU
+
+import Sound.MIDI.Message.Channel (Channel, )
+import Sound.MIDI.Message.Channel.Voice (Pitch, Velocity, Program, Controller, )
+
+import qualified Sound.MIDI.File.Event as FileEvent
+import qualified Sound.MIDI.Message as MidiMsg
+import qualified Sound.MIDI.Message.Channel as ChannelMsg
+import qualified Sound.MIDI.Message.Channel.Mode as Mode
+
+import Data.Tuple.HT (mapSnd, )
+
+
+{- |
+All methods have default implementations that return 'Nothing'.
+This helps implementing event data types
+that support only a subset of types of events.
+
+Maybe a better approach is to provide type classes
+for every type of event
+and make 'C' a subclass of all of them.
+-}
+class C event where
+   {- |
+   Warning: This returns note events as they are,
+   that is, a @NoteOff p 64@ might be encoded as such or as @NoteOn p 0@
+   depending on the content of @event@.
+   For normalized results you may use 'noteExplicitOff'.
+   -}
+   note :: event -> Maybe (Channel, (Velocity, Pitch, Bool))
+   program :: event -> Maybe (Channel, Program)
+   anyController :: event -> Maybe (Channel, (Controller, Int))
+   pitchBend :: event -> Maybe (Channel, Int)
+   channelPressure :: event -> Maybe (Channel, Int)
+   mode :: event -> Maybe (Channel, Mode.T)
+
+   note _ev = Nothing
+   program _ev = Nothing
+   anyController _ev = Nothing
+   pitchBend _ev = Nothing
+   channelPressure _ev = Nothing
+   mode _ev = Nothing
+
+
+lift ::
+   (Maybe ChannelMsg.Body -> Maybe a) ->
+   ChannelMsg.T -> Maybe (Channel, a)
+lift act msg =
+   fmap ((,) (ChannelMsg.messageChannel msg)) $
+   act $ Just $ ChannelMsg.messageBody msg
+
+instance C ChannelMsg.T where
+   note = lift CU.note
+   program = lift CU.program
+   anyController = lift CU.anyController
+   pitchBend = lift CU.pitchBend
+   channelPressure = lift CU.channelPressure
+   mode = lift CU.mode
+
+{- |
+Like 'note', but converts @NoteOn p 0@ to @NoteOff p 64@.
+See 'VoiceMsg.explicitNoteOff'.
+-}
+noteExplicitOff ::
+   (C event) =>
+   event -> Maybe (Channel, (Velocity, Pitch, Bool))
+noteExplicitOff e =
+   fmap (mapSnd CU.explicitNoteOff) $ note e
+
+{- |
+Like 'note', but converts @NoteOff p 64@ to @NoteOn p 0@.
+See 'VoiceMsg.implicitNoteOff'.
+-}
+noteImplicitOff ::
+   (C event) =>
+   event -> Maybe (Channel, (Velocity, Pitch, Bool))
+noteImplicitOff e =
+   fmap (mapSnd CU.implicitNoteOff) $ note e
+
+
+liftMidi ::
+   (ChannelMsg.T -> Maybe (Channel, a)) ->
+   (MidiMsg.T -> Maybe (Channel, a))
+liftMidi checkMsg msg =
+   case msg of
+      MidiMsg.Channel chanMsg -> checkMsg chanMsg
+      _ -> Nothing
+
+instance C MidiMsg.T where
+   note = liftMidi note
+   program = liftMidi program
+   anyController = liftMidi anyController
+   pitchBend = liftMidi pitchBend
+   channelPressure = liftMidi channelPressure
+   mode = liftMidi mode
+
+
+liftFile ::
+   (ChannelMsg.T -> Maybe (Channel, a)) ->
+   (FileEvent.T -> Maybe (Channel, a))
+liftFile checkMsg msg =
+   case msg of
+      FileEvent.MIDIEvent midiMsg -> checkMsg midiMsg
+      _ -> Nothing
+
+instance C FileEvent.T where
+   note = liftFile note
+   program = liftFile program
+   anyController = liftFile anyController
+   pitchBend = liftFile pitchBend
+   channelPressure = liftFile channelPressure
+   mode = liftFile mode
diff --git a/src/Sound/MIDI/Message/Class/Utility.hs b/src/Sound/MIDI/Message/Class/Utility.hs
new file mode 100644
--- /dev/null
+++ b/src/Sound/MIDI/Message/Class/Utility.hs
@@ -0,0 +1,57 @@
+module Sound.MIDI.Message.Class.Utility where
+
+import Sound.MIDI.Message.Channel.Voice (Pitch, Velocity, Program, Controller, )
+
+import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg
+import qualified Sound.MIDI.Message.Channel.Mode as Mode
+import qualified Sound.MIDI.Message.Channel as ChannelMsg
+
+
+note :: Maybe ChannelMsg.Body -> Maybe (Velocity, Pitch, Bool)
+program :: Maybe ChannelMsg.Body -> Maybe Program
+anyController :: Maybe ChannelMsg.Body -> Maybe (Controller, Int)
+pitchBend :: Maybe ChannelMsg.Body -> Maybe Int
+channelPressure :: Maybe ChannelMsg.Body -> Maybe Int
+mode :: Maybe ChannelMsg.Body -> Maybe Mode.T
+
+note msg = do
+   ChannelMsg.Voice voice <- msg
+   case voice of
+      VoiceMsg.NoteOn  pitch velocity -> Just (velocity, pitch, True)
+      VoiceMsg.NoteOff pitch velocity -> Just (velocity, pitch, False)
+      _ -> Nothing
+
+program msg = do
+   ChannelMsg.Voice (VoiceMsg.ProgramChange pgm) <- msg
+   return pgm
+
+anyController msg = do
+   ChannelMsg.Voice (VoiceMsg.Control ctrl val) <- msg
+   return (ctrl, val)
+
+pitchBend msg = do
+   ChannelMsg.Voice (VoiceMsg.PitchBend bend) <- msg
+   return bend
+
+channelPressure msg = do
+   ChannelMsg.Voice (VoiceMsg.MonoAftertouch pressure) <- msg
+   return pressure
+
+mode msg = do
+   ChannelMsg.Mode m <- msg
+   return m
+
+
+explicitNoteOff ::
+   (Velocity, Pitch, Bool) -> (Velocity, Pitch, Bool)
+explicitNoteOff x@(v,p,b) =
+   if b && v == VoiceMsg.toVelocity 0
+     then (VoiceMsg.toVelocity 64, p, False)
+     else x
+
+implicitNoteOff ::
+   (Velocity, Pitch, Bool) -> (Velocity, Pitch, Bool)
+implicitNoteOff x@(v,p,b) =
+   if not b && v == VoiceMsg.toVelocity 64
+     then (VoiceMsg.toVelocity 0, p, True)
+     else x
diff --git a/src/Sound/MIDI/Message/System.hs b/src/Sound/MIDI/Message/System.hs
--- a/src/Sound/MIDI/Message/System.hs
+++ b/src/Sound/MIDI/Message/System.hs
@@ -9,7 +9,6 @@
 import qualified Sound.MIDI.Message.System.Common    as Common
 import qualified Sound.MIDI.Message.System.RealTime  as RealTime
 
--- import           Sound.MIDI.Parser.Primitive
 import qualified Sound.MIDI.Parser.Class as Parser
 
 import qualified Sound.MIDI.Writer.Basic as Writer
@@ -26,7 +25,7 @@
    | RealTime  RealTime.T
 
 
-get :: Parser.C parser => Int -> Parser.Fallible parser T
+get :: Parser.C parser => Int -> Parser.Fragile parser T
 get code =
    if code == 0xF0
      then liftM Exclusive Exclusive.get
@@ -38,7 +37,7 @@
              then liftM RealTime $ RealTime.get code
              else Parser.giveUp ("invalid System message code " ++ show code)
 
-getIncomplete :: Parser.C parser => Int -> Parser.Partial (Parser.Fallible parser) T
+getIncomplete :: Parser.C parser => Int -> Parser.Partial (Parser.Fragile parser) T
 getIncomplete code =
    if code == 0xF0
      then liftM (fmap Exclusive) Exclusive.getIncomplete
diff --git a/src/Sound/MIDI/Message/System/Common.hs b/src/Sound/MIDI/Message/System/Common.hs
--- a/src/Sound/MIDI/Message/System/Common.hs
+++ b/src/Sound/MIDI/Message/System/Common.hs
@@ -40,7 +40,7 @@
 
 -- * serialization
 
-get :: Parser.C parser => Int -> Parser.Fallible parser T
+get :: Parser.C parser => Int -> Parser.Fragile parser T
 get code =
    case code of
       0xF1 ->
diff --git a/src/Sound/MIDI/Message/System/Exclusive.hs b/src/Sound/MIDI/Message/System/Exclusive.hs
--- a/src/Sound/MIDI/Message/System/Exclusive.hs
+++ b/src/Sound/MIDI/Message/System/Exclusive.hs
@@ -14,7 +14,7 @@
 import qualified Sound.MIDI.Writer.Basic as Writer
 import Sound.MIDI.Monoid ((+#+))
 
-import Control.Monad.Trans.Class (MonadTrans, lift, )
+import qualified Control.Monad.Trans.Class as MT
 import qualified Control.Monad.Exception.Asynchronous as Async
 
 import Data.Maybe (fromMaybe, )
@@ -40,15 +40,15 @@
 
 -- * serialization
 
-get :: Parser.C parser => Parser.Fallible parser T
+get :: Parser.C parser => Parser.Fragile parser T
 get =
    do (Async.Exceptional err sysex) <- getIncomplete
       maybe (return sysex) Parser.giveUp err
 
-getIncomplete :: Parser.C parser => Parser.Partial (Parser.Fallible parser) T
+getIncomplete :: Parser.C parser => Parser.Partial (Parser.Fragile parser) T
 getIncomplete =
    do manu <- Manufacturer.get
-      incBody <- lift getBody
+      incBody <- MT.lift getBody
       return $ flip fmap incBody $ \body ->
          fromMaybe (Commercial manu body) $
          lookup manu $
diff --git a/src/Sound/MIDI/Message/System/RealTime.hs b/src/Sound/MIDI/Message/System/RealTime.hs
--- a/src/Sound/MIDI/Message/System/RealTime.hs
+++ b/src/Sound/MIDI/Message/System/RealTime.hs
@@ -5,7 +5,6 @@
    T(..), get, put,
    ) where
 
--- import           Sound.MIDI.Parser.Primitive
 import qualified Sound.MIDI.Parser.Class as Parser
 
 import qualified Sound.MIDI.Writer.Basic as Writer
@@ -25,7 +24,7 @@
 
 -- * serialization
 
-get :: Parser.C parser => Int -> Parser.Fallible parser T
+get :: Parser.C parser => Int -> Parser.Fragile parser T
 get code =
    case code of
       0xF8 -> return TimingClock
diff --git a/src/Sound/MIDI/Monoid.hs b/src/Sound/MIDI/Monoid.hs
--- a/src/Sound/MIDI/Monoid.hs
+++ b/src/Sound/MIDI/Monoid.hs
@@ -1,7 +1,9 @@
 module Sound.MIDI.Monoid where
 
-import Data.Monoid (Monoid, mappend, mconcat, )
-import Prelude hiding (concatMap, )
+import Data.Foldable (foldMap, )
+import Data.Monoid (Monoid, mappend, )
+import Data.Semigroup (Semigroup, sconcat, (<>))
+import Data.List.NonEmpty (NonEmpty, )
 
 
 
@@ -11,16 +13,17 @@
 (+#+) = mappend
 
 
-genAppend :: (Monoid m) =>
+genAppend :: (Semigroup m) =>
    (m -> a) -> (a -> m) -> a -> a -> a
 genAppend cons decons x y =
-   cons $ mappend (decons x) (decons y)
+   cons $ decons x <> decons y
 
 genConcat :: (Monoid m) =>
    (m -> a) -> (a -> m) -> [a] -> a
 genConcat cons decons =
-   cons . concatMap decons
+   cons . foldMap decons
 
-concatMap :: (Monoid m) =>
-   (a -> m) -> [a] -> m
-concatMap f = mconcat . map f
+nonEmptyConcat :: (Semigroup m) =>
+   (m -> a) -> (a -> m) -> NonEmpty a -> a
+nonEmptyConcat cons decons =
+   cons . sconcat . fmap decons
diff --git a/src/Sound/MIDI/Parser/ByteString.hs b/src/Sound/MIDI/Parser/ByteString.hs
--- a/src/Sound/MIDI/Parser/ByteString.hs
+++ b/src/Sound/MIDI/Parser/ByteString.hs
@@ -11,6 +11,8 @@
 import Data.Binary.Get (Get, runGet, )
 
 import Control.Monad.Trans.Class (lift, )
+import Control.Monad (liftM, ap, )
+import Control.Applicative (Applicative, pure, (<*>), )
 
 import qualified Sound.MIDI.Parser.Report as Report
 
@@ -19,10 +21,6 @@
 import qualified Sound.MIDI.Parser.Exception as Exception
 import qualified Sound.MIDI.Parser.Warning   as Warning
 
--- import qualified Control.Monad.Exception.Synchronous as Sync
-
--- import Data.Word (Word8)
-
 import Data.Int (Int64)
 import qualified Numeric.NonNegative.Wrapper as NonNeg
 
@@ -40,7 +38,7 @@
 -}
 
 
-run :: Parser.Fallible T a -> B.ByteString -> Report.T a
+run :: Parser.Fragile T a -> B.ByteString -> Report.T a
 run parser input =
    flip runGet input $ Warning.run $ decons $ Exception.run $
       (do a <- parser
@@ -55,7 +53,7 @@
 and thus further parsing is not possible.
 -}
 runIncomplete ::
-   Parser.Partial (Parser.Fallible T) a -> B.ByteString -> Report.T a
+   Parser.Partial (Parser.Fragile T) a -> B.ByteString -> Report.T a
 runIncomplete parser input =
    flip run input $
       lift . Parser.warnIncomplete =<< parser
@@ -66,8 +64,14 @@
    Cons $ lift p
 
 
+instance Functor T where
+   fmap = liftM
+
+instance Applicative T where
+   pure = Cons . return
+   (<*>) = ap
+
 instance Monad T where
-   return = Cons . return
    x >>= y = Cons $ decons . y =<< decons x
 
 
diff --git a/src/Sound/MIDI/Parser/Class.hs b/src/Sound/MIDI/Parser/Class.hs
deleted file mode 100644
--- a/src/Sound/MIDI/Parser/Class.hs
+++ /dev/null
@@ -1,174 +0,0 @@
-module Sound.MIDI.Parser.Class
-   (EndCheck, isEnd,
-    C, getByte, skip,
-    warn, warnIf, warnIncomplete, Exc.giveUp, Exc.try,
-    until, zeroOrMore, zeroOrMoreInc, replicate,
-    emptyList, PossiblyIncomplete, UserMessage,
-    Fallible, Partial,
-    {- for debugging
-    absorbException, appendIncomplete,
-    -}
-    ) where
-
-
-import Sound.MIDI.Parser.Report (UserMessage)
-import qualified Sound.MIDI.Parser.Exception as Exc
-import qualified Control.Monad.Exception.Asynchronous as Async
-import qualified Control.Monad.Exception.Synchronous  as Sync
-
-import Control.Monad.Trans.Class (lift, )
-import Control.Monad.Trans.State (StateT, )
-import Control.Monad (liftM, liftM2, when, )
-
-import Data.Word (Word8)
-
-import qualified Numeric.NonNegative.Wrapper as NonNeg
-
-import Prelude hiding (replicate, until, )
-
-
-
-class Monad parser => EndCheck parser where
-   isEnd   :: parser Bool
-
--- would be probably better placed in Parser.Status
-instance EndCheck parser => EndCheck (StateT st parser) where
-   isEnd = lift $ isEnd
-
-
-class EndCheck parser => C parser where
-   getByte :: Fallible parser Word8
-   skip    :: NonNeg.Integer -> Fallible parser ()
-   warn    :: UserMessage -> parser ()
-
-
-{- |
-@PossiblyIncomplete@ represents a value like a list
-that can be the result of an incomplete parse.
-The case of an incomplete parse is indicated by @Just message@.
-
-It is not possible to merge this functionality in the parser monad,
-because then it is not possible to define monadic binding.
--}
-type PossiblyIncomplete a = Async.Exceptional UserMessage a
-
-
-type Fallible parser   = Sync.ExceptionalT UserMessage parser
-type Partial  parser a = parser (PossiblyIncomplete a)
-
-
-warnIf :: C parser => Bool -> UserMessage -> parser ()
-warnIf b msg = when b (warn msg)
-
-{- |
-Emit a warning if a value is said to be incomplete.
-Be careful using this function,
-because an incomplete value often means
-that subsequent parse actions will process data from the wrong position.
-Only use this function if you
-either know that the parse is complete also if the parsed value is incomplete
-or if there are no subsequent parse actions to run.
-
-This function cannot fail.
--}
-warnIncomplete :: C parser => PossiblyIncomplete a -> parser a
-warnIncomplete ~(Async.Exceptional me a) =
-   do maybe (return ()) warn me
-      return a
-
-
-{- |
-This function will never fail.
-If the element parser fails somewhere,
-a prefix of the complete list is returned
-along with the error message.
--}
-zeroOrMore :: EndCheck parser =>
-   Fallible parser a -> Partial parser [a]
-zeroOrMore p =
-   let go =
-         isEnd >>= \b ->
-            if b
-              then return emptyList
-              else absorbException
-                      (liftM2 (\ x -> fmap (x:)) p (lift go))
-   in  go
-
-
-zeroOrMoreInc :: EndCheck parser =>
-   Partial (Fallible parser) a -> Partial parser [a]
-zeroOrMoreInc p =
-   let go =
-         isEnd >>= \b ->
-            if b
-              then return emptyList
-              else absorbException
-                      (appendIncomplete p go)
-   in  go
-
-
-{- |
-Parse until an element is found, which matches a condition.
-The terminating element is consumed by the parser
-but not appended to the result list.
-If the end of the input is reached without finding the terminating element,
-then an Incomplete exception (Just errorMessage) is signaled.
--}
-until :: EndCheck parser =>
-   (a -> Bool) -> Fallible parser a -> Partial parser [a]
-until c p =
-   let go =
-         isEnd >>= \b ->
-            if b
-              then
-                return $ Async.broken
-                   "Parser.until: unexpected end of input" []
-              else
-                absorbException $
-                   p >>= \x ->
-                     if c x
-                       then return emptyList
-                       else liftM (fmap (x:)) (lift go)
-   in  go
-
-
-{- |
-This function will never fail.
-It may however return a list that is shorter than requested.
--}
-replicate ::
-   C parser =>
-   NonNeg.Int ->
-   Partial (Fallible parser) a ->
-   Partial parser [a]
-replicate m p =
-   let go n =
-         if n==0
-           then return emptyList
-           else absorbException
-                   (appendIncomplete p (go (n-1)))
-   in  go m
-
-
-emptyList :: PossiblyIncomplete [a]
-emptyList = Async.pure []
-
-{- |
-The first parser may fail, but the second one must not.
--}
-appendIncomplete ::
-   Monad parser =>
-   Partial (Fallible parser) a ->
-   Partial parser [a] ->
-   Partial (Fallible parser) [a]
-appendIncomplete p ps =
-   do ~(Async.Exceptional me x) <- p
-      lift $ liftM (fmap (x:)) $
-         maybe ps (\_ -> return (Async.Exceptional me [])) me
-
-absorbException ::
-   Monad parser =>
-   Partial (Fallible parser) [a] ->
-   Partial parser [a]
-absorbException =
-   Sync.resolveT (\errMsg -> return $ Async.broken errMsg [])
diff --git a/src/Sound/MIDI/Parser/Exception.hs b/src/Sound/MIDI/Parser/Exception.hs
deleted file mode 100644
--- a/src/Sound/MIDI/Parser/Exception.hs
+++ /dev/null
@@ -1,24 +0,0 @@
-{- |
-Handling of exceptions.
--}
-module Sound.MIDI.Parser.Exception where
-
-import qualified Sound.MIDI.Parser.Report as Report
--- import qualified Sound.MIDI.Parser.Warning as Warning
-
-import qualified Control.Monad.Exception.Synchronous as Sync
-
-
-type T m = Sync.ExceptionalT Report.UserMessage m
-
-
-run :: Monad m =>
-   T m a -> m (Sync.Exceptional Report.UserMessage a)
-run = Sync.runExceptionalT
-
-
-giveUp :: Monad m => String -> T m a
-giveUp = Sync.throwT
-
-try :: Monad m => T m a -> m (Sync.Exceptional Report.UserMessage a)
-try = Sync.tryT
diff --git a/src/Sound/MIDI/Parser/File.hs b/src/Sound/MIDI/Parser/File.hs
--- a/src/Sound/MIDI/Parser/File.hs
+++ b/src/Sound/MIDI/Parser/File.hs
@@ -7,7 +7,8 @@
 
 import Control.Monad.Trans.Reader (ReaderT(runReaderT), ask, )
 import Control.Monad.Trans.Class (lift, )
-import Control.Monad (liftM, )
+import Control.Monad (liftM, ap, )
+import Control.Applicative (Applicative, pure, (<*>), )
 
 import qualified System.IO.Error as IOE
 import qualified Control.Exception as Exc
@@ -24,14 +25,14 @@
 newtype T a = Cons {decons :: ReaderT IO.Handle IO a}
 
 
-runFile :: Parser.Fallible T a -> FilePath -> IO a
+runFile :: Parser.Fragile T a -> FilePath -> IO a
 runFile p name =
    Exc.bracket
       (IO.openBinaryFile name IO.ReadMode)
       IO.hClose
       (runHandle p)
 
-runHandle :: Parser.Fallible T a -> IO.Handle -> IO a
+runHandle :: Parser.Fragile T a -> IO.Handle -> IO a
 runHandle p h =
    do exc <- runReaderT (decons (Sync.tryT p)) h
       Sync.resolve (IOE.ioError . IOE.userError) (fmap return exc)
@@ -43,7 +44,7 @@
 we cannot know where the current file position is,
 we omit the @runIncompleteHandle@ variant.
 -}
-runIncompleteFile :: Parser.Partial (Parser.Fallible T) a -> FilePath -> IO a
+runIncompleteFile :: Parser.Partial (Parser.Fragile T) a -> FilePath -> IO a
 runIncompleteFile p name =
    Exc.bracket
       (IO.openBinaryFile name IO.ReadMode)
@@ -56,23 +57,32 @@
 
 
 
+instance Functor T where
+   fmap = liftM
+
+instance Applicative T where
+   pure = Cons . return
+   (<*>) = ap
+
 instance Monad T where
-   return = Cons . return
    x >>= y = Cons $ decons . y =<< decons x
 
 fromIO :: (IO.Handle -> IO a) -> T a
 fromIO act = Cons $ lift . act =<< ask
 
-fallibleFromIO :: (IO.Handle -> IO a) -> Parser.Fallible T a
-fallibleFromIO act =
+ioeTry :: IO a -> IO (Either IOError a)
+ioeTry = Exc.try
+
+fragileFromIO :: (IO.Handle -> IO a) -> Parser.Fragile T a
+fragileFromIO act =
    Sync.ExceptionalT . Cons . lift .
-      fmap (Sync.mapException show . Sync.fromEither) . IOE.try . act
+      fmap (Sync.mapException show . Sync.fromEither) . ioeTry . act
           =<< lift (Cons ask)
 
 instance Parser.EndCheck T where
    isEnd   = fromIO IO.hIsEOF
 
 instance Parser.C T where
-   getByte = fallibleFromIO $ liftM (fromIntegral . ord) . IO.hGetChar
-   skip n  = fallibleFromIO $ \h -> IO.hSeek h IO.RelativeSeek (NonNeg.toNumber n)
+   getByte = fragileFromIO $ liftM (fromIntegral . ord) . IO.hGetChar
+   skip n  = fragileFromIO $ \h -> IO.hSeek h IO.RelativeSeek (NonNeg.toNumber n)
    warn    = Cons . lift . (\msg -> putStrLn ("warning: " ++ msg))
diff --git a/src/Sound/MIDI/Parser/Primitive.hs b/src/Sound/MIDI/Parser/Primitive.hs
--- a/src/Sound/MIDI/Parser/Primitive.hs
+++ b/src/Sound/MIDI/Parser/Primitive.hs
@@ -23,20 +23,20 @@
 {- |
 'getByte' gets a single byte from the input.
 -}
-getByte :: Parser.C parser => Parser.Fallible parser Word8
+getByte :: Parser.C parser => Parser.Fragile parser Word8
 getByte = Parser.getByte
 
 
 {- |
 @getN n@ returns n characters (bytes) from the input.
 -}
-getN :: Parser.C parser => NonNeg.Int -> Parser.Fallible parser ByteList
+getN :: Parser.C parser => NonNeg.Int -> Parser.Fragile parser ByteList
 getN n = replicateM (NonNeg.toNumber n) getByte
 
-getString :: Parser.C parser => NonNeg.Integer -> Parser.Fallible parser String
+getString :: Parser.C parser => NonNeg.Integer -> Parser.Fragile parser String
 getString n = liftM listCharFromByte (getBigN n)
 
-getBigN :: Parser.C parser => NonNeg.Integer -> Parser.Fallible parser ByteList
+getBigN :: Parser.C parser => NonNeg.Integer -> Parser.Fragile parser ByteList
 getBigN n =
    sequence $
    Bit.replicateBig
@@ -50,22 +50,22 @@
 4-byte numbers from the input (respectively), convert the base-256 data
 into a single number, and return.
 -}
-get1 :: Parser.C parser => Parser.Fallible parser Int
+get1 :: Parser.C parser => Parser.Fragile parser Int
 get1 = liftM fromIntegral getByte
 
-getNByteInt :: Parser.C parser => NonNeg.Int -> Parser.Fallible parser Int
+getNByteInt :: Parser.C parser => NonNeg.Int -> Parser.Fragile parser Int
 getNByteInt n =
    liftM Bit.fromBytes (replicateM (NonNeg.toNumber n) get1)
 
-get2, get3, get4 :: Parser.C parser => Parser.Fallible parser Int
+get2, get3, get4 :: Parser.C parser => Parser.Fragile parser Int
 get2 = getNByteInt 2
 get3 = getNByteInt 3
 get4 = getNByteInt 4
 
-getByteAsCardinal :: Parser.C parser => Parser.Fallible parser NonNeg.Integer
+getByteAsCardinal :: Parser.C parser => Parser.Fragile parser NonNeg.Integer
 getByteAsCardinal = liftM fromIntegral getByte
 
-getNByteCardinal :: Parser.C parser => NonNeg.Int -> Parser.Fallible parser NonNeg.Integer
+getNByteCardinal :: Parser.C parser => NonNeg.Int -> Parser.Fragile parser NonNeg.Integer
 getNByteCardinal n =
    liftM Bit.fromBytes (replicateM (NonNeg.toNumber n) getByteAsCardinal)
 
@@ -78,7 +78,7 @@
 If it's @0@, that byte is the last one.
 'getVar' gets a variable-length quantity from the input.
 -}
-getVar :: Parser.C parser => Parser.Fallible parser NonNeg.Integer
+getVar :: Parser.C parser => Parser.Fragile parser NonNeg.Integer
 getVar =
    liftM (Bit.fromBase (2^(7::Int)) . map fromIntegral) getVarBytes
 
@@ -86,7 +86,7 @@
 The returned list contains only bytes with the most significant bit cleared.
 These are digits of a 128-ary number.
 -}
-getVarBytes :: Parser.C parser => Parser.Fallible parser [Word8]
+getVarBytes :: Parser.C parser => Parser.Fragile parser [Word8]
 getVarBytes =
    do
       digit <- getByte
@@ -95,12 +95,12 @@
         else return [digit]
 
 
-getEnum :: (Parser.C parser, Enum enum, Bounded enum) => Parser.Fallible parser enum
+getEnum :: (Parser.C parser, Enum enum, Bounded enum) => Parser.Fragile parser enum
 getEnum = makeEnum =<< get1
 
-makeEnum :: (Parser.C parser, Enum enum, Bounded enum) => Int -> Parser.Fallible parser enum
+makeEnum :: (Parser.C parser, Enum enum, Bounded enum) => Int -> Parser.Fragile parser enum
 makeEnum n =
-   let go :: (Parser.C parser, Enum a) => a -> a -> Parser.Fallible parser a
+   let go :: (Parser.C parser, Enum a) => a -> a -> Parser.Fragile parser a
        go lower upper =
           if fromEnum lower <= n && n <= fromEnum upper
             then return (toEnum n)
diff --git a/src/Sound/MIDI/Parser/Restricted.hs b/src/Sound/MIDI/Parser/Restricted.hs
--- a/src/Sound/MIDI/Parser/Restricted.hs
+++ b/src/Sound/MIDI/Parser/Restricted.hs
@@ -4,7 +4,7 @@
 where the length of a part is fixed by a length specification.
 -}
 module Sound.MIDI.Parser.Restricted
-   (T(..), run, runFallible, ) where
+   (T(..), run, runFragile, ) where
 
 import qualified Sound.MIDI.Parser.Class as Parser
 
@@ -12,6 +12,7 @@
 import qualified Control.Monad.Trans.Class as Trans
 import Control.Monad.Trans.State (StateT(runStateT), gets, get, put, )
 import Control.Monad (when, )
+import Control.Applicative (Applicative, pure, (<*>), )
 
 import qualified Numeric.NonNegative.Wrapper as NonNeg
 
@@ -27,12 +28,12 @@
          ("unparsed bytes left in part (" ++ show remaining ++ " bytes)")
       return x
 
-runFallible :: Parser.C parser =>
-   NonNeg.Integer -> Parser.Fallible (T parser) a -> Parser.Fallible parser a
-runFallible len = Sync.mapExceptionalT (run len)
+runFragile :: Parser.C parser =>
+   NonNeg.Integer -> Parser.Fragile (T parser) a -> Parser.Fragile parser a
+runFragile len = Sync.mapExceptionalT (run len)
 
 
-lift :: Monad parser => Parser.Fallible parser a -> Parser.Fallible (T parser) a
+lift :: Monad parser => Parser.Fragile parser a -> Parser.Fragile (T parser) a
 lift = Sync.mapExceptionalT Trans.lift
 
 
@@ -40,18 +41,24 @@
 newtype T parser a =
    Cons {decons :: StateT NonNeg.Integer parser a}
 
+instance Functor parser => Functor (T parser) where
+   fmap f = Cons . fmap f . decons
+
+instance (Applicative parser, Monad parser) => Applicative (T parser) where
+   pure = Cons . pure
+   Cons f <*> Cons a = Cons $ f <*> a
+
 instance Monad parser => Monad (T parser) where
-   return = Cons . return
    x >>= y = Cons $ decons . y =<< decons x
 
 instance Trans.MonadTrans T where
    lift = Cons . Trans.lift
 
 
-getRemaining :: Monad parser => Parser.Fallible (T parser) NonNeg.Integer
+getRemaining :: Monad parser => Parser.Fragile (T parser) NonNeg.Integer
 getRemaining = Trans.lift $ Cons get
 
-putRemaining :: Monad parser => NonNeg.Integer -> Parser.Fallible (T parser) ()
+putRemaining :: Monad parser => NonNeg.Integer -> Parser.Fragile (T parser) ()
 putRemaining = Trans.lift . Cons . put
 
 
diff --git a/src/Sound/MIDI/Parser/Status.hs b/src/Sound/MIDI/Parser/Status.hs
--- a/src/Sound/MIDI/Parser/Status.hs
+++ b/src/Sound/MIDI/Parser/Status.hs
@@ -5,15 +5,19 @@
 -}
 module Sound.MIDI.Parser.Status
    (T, Status, set, get, run, lift,
-    Channel, fromChannel,   toChannel, ) where
+    Channel, fromChannel, toChannel, ) where
 
 import qualified Sound.MIDI.Parser.Class as Parser
 
 import qualified Control.Monad.Exception.Synchronous  as Sync
-import Control.Monad.Trans.State (StateT, evalStateT, )
 import qualified Control.Monad.Trans.State as State
 import qualified Control.Monad.Trans.Class as Trans
+import Control.Monad.Trans.State (StateT, evalStateT, )
+import Control.Monad (liftM, )
 
+import qualified Test.QuickCheck as QC
+import Test.QuickCheck (Arbitrary(arbitrary, shrink), )
+
 import Sound.MIDI.Utility (checkRange, )
 import Data.Ix (Ix)
 
@@ -32,17 +36,17 @@
 type Status = Maybe (Int,Channel)
 
 
-set :: Monad parser => Status -> Parser.Fallible (T parser) ()
+set :: Monad parser => Status -> Parser.Fragile (T parser) ()
 set = Trans.lift . State.put
 
-get :: Monad parser => Parser.Fallible (T parser) Status
+get :: Monad parser => Parser.Fragile (T parser) Status
 get = Trans.lift State.get
 
 run :: Monad parser => T parser a -> parser a
 run = flip evalStateT Nothing
 
 
-lift :: Monad parser => Parser.Fallible parser a -> Parser.Fallible (T parser) a
+lift :: Monad parser => Parser.Fragile parser a -> Parser.Fragile (T parser) a
 lift = Sync.mapExceptionalT Trans.lift
 
 
@@ -52,7 +56,7 @@
 This definition should be in Message.Channel,
 but this results in a cyclic import.
 -}
-newtype Channel     = Channel  {fromChannel  :: Int} deriving (Show, Eq, Ord, Ix)
+newtype Channel = Channel {fromChannel :: Int} deriving (Show, Eq, Ord, Ix)
 
 toChannel :: Int -> Channel
 toChannel = checkRange "Channel" Channel
@@ -64,3 +68,7 @@
 instance Bounded Channel where
    minBound = Channel  0
    maxBound = Channel 15
+
+instance Arbitrary Channel where
+   arbitrary = liftM toChannel $ QC.choose (0,15)
+   shrink = map (toChannel . flip mod 16) . shrink . fromChannel
diff --git a/src/Sound/MIDI/Parser/Stream.hs b/src/Sound/MIDI/Parser/Stream.hs
deleted file mode 100644
--- a/src/Sound/MIDI/Parser/Stream.hs
+++ /dev/null
@@ -1,130 +0,0 @@
-module Sound.MIDI.Parser.Stream
-   (T(..), run, runIncomplete, runPartial,
-    ByteList(..),
-    PossiblyIncomplete, UserMessage, ) where
-
-
-import Control.Monad.Trans.State
-   (State, runState, evalState, get, put, )
-import Control.Monad.Trans.Class (lift, )
-import Control.Monad (liftM, when, )
-
-import qualified Sound.MIDI.Parser.Report as Report
-import qualified Sound.MIDI.Parser.Class as Parser
-import Sound.MIDI.Parser.Class (UserMessage, PossiblyIncomplete, )
-import qualified Sound.MIDI.Parser.Exception as Exception
-import qualified Sound.MIDI.Parser.Warning   as Warning
-
--- import qualified Control.Monad.Exception.Synchronous as Sync
-
-import qualified Sound.MIDI.IO as MIO
-
-import Data.Word (Word8)
-import qualified Data.List as List
-
-import qualified Numeric.NonNegative.Wrapper as NonNeg
-
-import Prelude hiding (replicate, until, drop, )
-
-
-
-{-
-Instead of using Report and write the monad instance manually,
-we could also use WriterT monad for warnings and ErrorT monad for failure handling.
--}
-newtype T str a =
-   Cons {decons :: Warning.T (State str) a}
-
-
-
-runPartial :: Parser.Fallible (T str) a -> str -> (Report.T a, str)
-runPartial parser input =
-   flip runState input $ Warning.run $ decons $ Exception.run parser
-
-run :: ByteStream str => Parser.Fallible (T str) a -> str -> Report.T a
-run parser input =
-   flip evalState input $ Warning.run $ decons $ Exception.run $
-      (do a <- parser
-          lift $
-             Parser.isEnd >>= \end ->
-                Parser.warnIf (not end) "unparsed data left over"
-          return a)
-
-{- |
-Treat errors which caused an incomplete data structure as warnings.
-This is reasonable, because we do not reveal the remaining unparsed data
-and thus further parsing is not possible.
--}
-runIncomplete :: ByteStream str =>
-   Parser.Partial (Parser.Fallible (T str)) a -> str -> Report.T a
-runIncomplete parser input =
-   flip run input $
-      lift . Parser.warnIncomplete =<< parser
-
-
-
-fromState :: State str a -> T str a
-fromState p =
-   Cons $ lift p
-
-
-instance Monad (T str) where
-   return = Cons . return
-   x >>= y = Cons $ decons . y =<< decons x
-
-
-class ByteStream str where
-   switchL :: a -> (Word8 -> str -> a) -> str -> a
-   drop :: NonNeg.Integer -> str -> str
-
-newtype ByteList = ByteList MIO.ByteList
-
-instance ByteStream ByteList where
-   switchL n j (ByteList xss) =
-      case xss of
-         (x:xs) -> j x (ByteList xs)
-         _ -> n
-   drop n (ByteList xs) = ByteList $ List.genericDrop n xs
-
-instance ByteStream str => Parser.EndCheck (T str) where
-   isEnd = fromState $ liftM (switchL True (\ _ _ -> False)) get
-
-instance ByteStream str => Parser.C (T str) where
-   getByte =
-      switchL
-         (Parser.giveUp "unexpected end of data")
-         (\s ss -> lift (fromState (put ss)) >> return s) =<<
-      lift (fromState get)
-
-{-
-   skip n = sequence_ (genericReplicate n Parser.getByte)
--}
-   skip n = when (n>0) $
-      do s <- lift $ fromState get
-         switchL
-            (Parser.giveUp "skip past end of part")
-            (\ _ rest -> lift $ fromState $ put rest)
-            (drop (n-1) s)
-
-   warn = Cons . Warning.warn
-
-
-{-
-laziness problems:
-fst $ runPartial (Parser.try (undefined :: T ByteList String)) $ ByteList []
-fst $ runPartial (Monad.liftM2 (,) (return 'a') (Parser.try (return "bla" :: T ByteList String))) $ ByteList []
-fst $ runPartial (Monad.liftM2 (,) (return 'a') (Parser.handleMsg id undefined)) $ ByteList []
-evalState (sequence $ repeat $ return 'a') ""
-fst $ runPartial (sequence $ repeat $ return 'a') ""
-
-fmap snd $ Report.result $ fst $ runPartial (Parser.appendIncomplete (return (undefined,'a')) (return (undefined,"bc"))) (ByteList $ repeat 129)
-fmap snd $ Report.result $ fst $ runPartial ((return (undefined,'a'))) (ByteList $ repeat 129)
-fmap snd $ Report.result $ fst $ runPartial (Parser.zeroOrMoreInc (return (Nothing,'a'))) (ByteList $ repeat 129)
-fmap snd $ Report.result $ fst $ runPartial (Parser.zeroOrMoreInc (return (undefined,'a'))) (ByteList $ repeat 129)
-fmap snd $ Report.result $ fst $ runPartial (Parser.zeroOrMore Parser.getByte) (ByteList $ repeat 129)
-either error snd $ Report.result $ fst $ runPartial (Parser.zeroOrMore Parser.getByte) (ByteList $ repeat 129)
-Report.result $ run (Parser.zeroOrMore Parser.getByte) (ByteList $ repeat 129)
-Report.result $ runIncomplete (Parser.zeroOrMore Parser.getByte) (ByteList $ repeat 129)
-Report.result $ runIncomplete (Parser.replicate 1000000 (liftM ((,) Nothing) Parser.getByte)) (ByteList $ repeat 129)
-Report.result $ runIncomplete (Parser.until (128==) Parser.getByte) (ByteList $ repeat 129)
--}
diff --git a/src/Sound/MIDI/Parser/Warning.hs b/src/Sound/MIDI/Parser/Warning.hs
deleted file mode 100644
--- a/src/Sound/MIDI/Parser/Warning.hs
+++ /dev/null
@@ -1,28 +0,0 @@
-{- |
-Handling of warnings.
--}
-module Sound.MIDI.Parser.Warning where
-
-import qualified Sound.MIDI.Parser.Report as Report
-
-import qualified Control.Monad.Exception.Synchronous as Sync
-import qualified Control.Monad.Trans.Writer as Writer
-
-
-type T m = Writer.WriterT [Report.UserMessage] m
-
-
-run :: Monad m =>
-   T m (Sync.Exceptional Report.UserMessage a) -> m (Report.T a)
-run act =
-   do (exc,warns) <- Writer.runWriterT act
-      return $ Report.Cons warns (Sync.toEither exc)
-
-{-
-run :: Monad m =>
-   T m a -> m (a, [Report.UserMessage])
-run = Writer.runWriterT
--}
-
-warn :: Monad m => String -> T m ()
-warn text = Writer.tell [text]
diff --git a/src/Sound/MIDI/Utility.hs b/src/Sound/MIDI/Utility.hs
--- a/src/Sound/MIDI/Utility.hs
+++ b/src/Sound/MIDI/Utility.hs
@@ -2,39 +2,10 @@
 
 import qualified Test.QuickCheck as QC
 import System.Random (Random(randomR), RandomGen)
-import Data.Word(Word8)
-
-
-{-# INLINE mapFst #-}
-mapFst :: (a -> c) -> (a,b) -> (c,b)
-mapFst f ~(x,y) = (f x, y)
-
-{-# INLINE mapSnd #-}
-mapSnd :: (b -> d) -> (a,b) -> (a,d)
-mapSnd g ~(x,y) = (x, g y)
+import Data.Tuple.HT (mapFst, )
+import Data.Word (Word8, )
 
 
-{-# INLINE fst3 #-}
-fst3 :: (a,b,c) -> a
-fst3 (x,_,_) = x
-
-{-# INLINE snd3 #-}
-snd3 :: (a,b,c) -> b
-snd3 (_,x,_) = x
-
-{-# INLINE thd3 #-}
-thd3 :: (a,b,c) -> c
-thd3 (_,_,x) = x
-
-{-# INLINE toMaybe #-}
-toMaybe :: Bool -> a -> Maybe a
-toMaybe False _ = Nothing
-toMaybe True  x = Just x
-
-{-# INLINE swap #-}
-swap :: (a,b) -> (b,a)
-swap (a,b) = (b,a)
-
 {-# INLINE checkRange #-}
 checkRange :: (Bounded a, Ord a, Show a) =>
    String -> (Int -> a) -> Int -> a
@@ -44,28 +15,6 @@
          then y
          else error (typ ++ ": value " ++ show x ++ " outside range " ++
                      show ((minBound, maxBound) `asTypeOf` (y,y)))
-
-{-# INLINE viewR #-}
-viewR :: [a] -> Maybe ([a], a)
-viewR =
-   foldr (\x mxs -> Just (maybe ([],x) (mapFst (x:)) mxs)) Nothing
-
-{-# INLINE dropMatch #-}
-dropMatch :: [b] -> [a] -> [a]
-dropMatch xs ys =
-   snd $ head $
-   dropWhile (not . null . fst) $
-   zip (iterate (drop 1) xs) (iterate (drop 1) ys)
-
-{-# INLINE untilM #-}
-untilM :: Monad m => (a -> Bool) -> m a -> m a
-untilM p act =
-   let go =
-         act >>= \x ->
-            if p x
-              then return x
-              else go
-   in  go
 
 {-# INLINE loopM #-}
 loopM :: Monad m => (a -> Bool) -> m a -> (a -> m ()) -> m a
diff --git a/src/Sound/MIDI/Writer/Basic.hs b/src/Sound/MIDI/Writer/Basic.hs
--- a/src/Sound/MIDI/Writer/Basic.hs
+++ b/src/Sound/MIDI/Writer/Basic.hs
@@ -4,13 +4,14 @@
 
 import qualified Sound.MIDI.Bit as Bit
 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 Data.Monoid (Monoid, mempty, mappend, mconcat, )
-import Sound.MIDI.Monoid ((+#+), genAppend, genConcat, )
+import Sound.MIDI.Monoid ((+#+), genAppend, genConcat, nonEmptyConcat, )
+import Data.Foldable (foldMap, )
+import Data.Monoid (Monoid, mempty, mconcat, )
+import Data.Semigroup (Semigroup(sconcat, (<>)), )
 
 import Control.Monad.Trans.Reader (ReaderT, runReaderT, ask, )
 import Control.Monad.Trans.Class (lift, )
@@ -26,7 +27,6 @@
 import Control.Exception (bracket, )
 import qualified System.IO as IO
 import System.IO (openBinaryFile, hClose, hPutChar, Handle, IOMode(WriteMode))
--- import System.IO.Error (ioError, userError)
 
 import Prelude hiding (putStr, )
 
@@ -43,19 +43,21 @@
 
 
 -- differences list
-newtype ByteList =
-   ByteList {unByteList :: Monoid.Endo MIO.ByteList}
+newtype ByteList = ByteList {unByteList :: Monoid.Endo MIO.ByteList}
 
+instance Semigroup ByteList where
+   (<>) = genAppend ByteList unByteList
+   sconcat = nonEmptyConcat ByteList unByteList
+
 instance Monoid ByteList where
    mempty = ByteList mempty
-   mappend = genAppend ByteList unByteList
    mconcat = genConcat ByteList unByteList
 
 instance C ByteList where
    putByte = ByteList . Monoid.Endo . (:)
    putLengthBlock n writeBody =
       let body = runByteList writeBody
-      in  putInt n (length body) `mappend`
+      in  putInt n (length body) <>
           putByteListSpec body  -- we could call 'writeBody' but this would recompute the data
 
 
@@ -70,12 +72,14 @@
 
 
 
-newtype ByteString =
-   ByteString {unByteString :: Builder}
+newtype ByteString = ByteString {unByteString :: Builder}
 
+instance Semigroup ByteString where
+   (<>) = genAppend ByteString unByteString
+   sconcat = nonEmptyConcat ByteString unByteString
+
 instance Monoid ByteString where
    mempty = ByteString $ mempty
-   mappend = genAppend ByteString unByteString
    mconcat = genConcat ByteString unByteString
 
 instance C ByteString where
@@ -96,13 +100,14 @@
 
 
 
-newtype SeekableFile =
-   SeekableFile {unSeekableFile :: ReaderT Handle IO ()}
+newtype SeekableFile = SeekableFile {unSeekableFile :: ReaderT Handle IO ()}
 
+instance Semigroup SeekableFile where
+   x <> y = SeekableFile $ unSeekableFile x >> unSeekableFile y
+
 instance Monoid SeekableFile where
    mempty = SeekableFile $ return ()
-   mappend x y = SeekableFile $ unSeekableFile x >> unSeekableFile y
-   mconcat xs  = SeekableFile $ mapM_ unSeekableFile xs
+   mconcat = SeekableFile . mapM_ unSeekableFile
 
 instance C SeekableFile where
    putByte c =
@@ -150,7 +155,7 @@
 putIntAsByte x = putByte $ fromIntegral x
 
 putByteList :: C writer => MIO.ByteList -> writer
-putByteList = M.concatMap putByte
+putByteList = foldMap putByte
 
 putLenByteList :: C writer => MIO.ByteList -> writer
 putLenByteList bytes =
diff --git a/src/Sound/MIDI/Writer/Status.hs b/src/Sound/MIDI/Writer/Status.hs
--- a/src/Sound/MIDI/Writer/Status.hs
+++ b/src/Sound/MIDI/Writer/Status.hs
@@ -3,62 +3,74 @@
    lift,
    ) where
 
--- import qualified Sound.MIDI.Writer.Basic as Writer
-
 import Sound.MIDI.Parser.Status (Channel)
 
 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, )
+import qualified Data.Monoid.HT as MonoidHT
+import Data.Monoid (Monoid, mempty, mconcat, )
+import Data.Semigroup (Semigroup, sconcat, (<>), )
+import Sound.MIDI.Monoid (genAppend, genConcat, nonEmptyConcat, )
 
 
+data Uncompressed = Uncompressed
+
+newtype Compressed = Compressed Status
 type Status = Maybe (Int,Channel)
 
 {- |
-The ReaderT Bool handles
-whether running status should be respected (True) or ignored (False).
+'status' can be 'Uncompressed' for files ignoring the running status
+or 'Compressed' for files respecting the running status.
 -}
-newtype T writer =
-   Cons {decons :: Reader.T Bool (State.T (Maybe Status) writer)}
+newtype T compress writer = Cons {decons :: State.T compress writer}
 
 
-instance Monoid writer => Monoid (T writer) where
+instance Semigroup writer => Semigroup (T compress writer) where
+   (<>) = genAppend Cons decons
+   sconcat = nonEmptyConcat Cons decons
+
+instance Monoid writer => Monoid (T compress writer) where
    mempty = Cons $ mempty
-   mappend = genAppend Cons decons
    mconcat = genConcat Cons decons
 
-{- |
-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 :: (Monoid writer) => T writer
-clear = Cons $ lift $ State.put Nothing
+class Compression compress where
+   {- |
+   Given a writer that emits a status, generate a stateful writer,
+   that decides whether to run the status emittor.
+   -}
+   change :: (Monoid writer) => (Int, Channel) -> writer -> T compress writer
+   initState :: compress
 
+instance Compression Uncompressed where
+   change _ emit = Cons $ State.pure emit
+   initState = Uncompressed
 
-instance Trans.C T where
+instance Compression Compressed where
+   change x emit =
+      Cons $
+      State.Cons $ \(Compressed my) ->
+         let mx = Just x
+         in  (MonoidHT.when (mx/=my) emit, Compressed mx)
+   initState = Compressed Nothing
+
+clear :: (Compression compress, Monoid writer) => T compress writer
+clear = Cons $ State.put initState
+
+
+instance Trans.C (T compress) where
    lift = fromWriter
 
-fromWriter :: (Monoid writer) => writer -> T writer
-fromWriter = Cons . lift . lift
+fromWriter :: (Monoid writer) => writer -> T compress writer
+fromWriter = Cons . lift
 
-toWriter :: (Monoid writer) => Bool -> T writer -> writer
-toWriter withStatus =
-   State.evaluate Nothing . flip Reader.run withStatus . decons
+toWriter :: (Compression compress, Monoid writer) => T compress writer -> writer
+toWriter = State.evaluate initState . decons
 
-toWriterWithStatus :: (Monoid writer) => T writer -> writer
-toWriterWithStatus = toWriter True
+toWriterWithStatus :: (Monoid writer) => T Compressed writer -> writer
+toWriterWithStatus = toWriter
 
-toWriterWithoutStatus :: (Monoid writer) => T writer -> writer
-toWriterWithoutStatus = toWriter False
+toWriterWithoutStatus :: (Monoid writer) => T Uncompressed writer -> writer
+toWriterWithoutStatus = toWriter
diff --git a/test/Common.hs b/test/Common.hs
new file mode 100644
--- /dev/null
+++ b/test/Common.hs
@@ -0,0 +1,6 @@
+module Common where
+
+import qualified Test.QuickCheck as QC
+
+check :: QC.Testable prop => String -> prop -> IO ()
+check msg t = putStr (msg ++ ": ") >> QC.quickCheck t
diff --git a/test/Example.hs b/test/Example.hs
new file mode 100644
--- /dev/null
+++ b/test/Example.hs
@@ -0,0 +1,45 @@
+module Example where
+
+import qualified Sound.MIDI.File.Event.Meta as MetaEvent
+import qualified Sound.MIDI.File.Event      as Event
+import qualified Sound.MIDI.File            as MidiFile
+
+import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg
+import qualified Sound.MIDI.Message.Channel       as ChannelMsg
+
+import qualified Data.EventList.Relative.TimeBody as EventList
+import Data.EventList.Relative.MixedBody ((/.), (./), )
+
+
+empty :: MidiFile.T
+empty =
+   MidiFile.Cons MidiFile.Parallel (MidiFile.Ticks 10)
+      [EventList.empty]
+
+meta :: MidiFile.T
+meta =
+   MidiFile.Cons MidiFile.Parallel (MidiFile.Ticks 10)
+      [EventList.singleton 0 (Event.MetaEvent (MetaEvent.Lyric "foobarz"))]
+
+status :: MidiFile.T
+status =
+   let chan = ChannelMsg.toChannel 3
+       vel  = VoiceMsg.toVelocity 64
+   in  MidiFile.Cons MidiFile.Parallel (MidiFile.Ticks 10)
+          [0 /. Event.MIDIEvent (ChannelMsg.Cons chan (ChannelMsg.Voice (VoiceMsg.NoteOn (VoiceMsg.toPitch 20) vel))) ./
+           4 /. Event.MIDIEvent (ChannelMsg.Cons chan (ChannelMsg.Voice (VoiceMsg.NoteOn (VoiceMsg.toPitch 24) vel))) ./
+           4 /. Event.MIDIEvent (ChannelMsg.Cons chan (ChannelMsg.Voice (VoiceMsg.NoteOn (VoiceMsg.toPitch 27) vel))) ./
+           7 /. Event.MIDIEvent (ChannelMsg.Cons chan (ChannelMsg.Voice (VoiceMsg.NoteOff (VoiceMsg.toPitch 20) vel))) ./
+           4 /. Event.MIDIEvent (ChannelMsg.Cons chan (ChannelMsg.Voice (VoiceMsg.NoteOff (VoiceMsg.toPitch 24) vel))) ./
+           4 /. Event.MIDIEvent (ChannelMsg.Cons chan (ChannelMsg.Voice (VoiceMsg.NoteOff (VoiceMsg.toPitch 27) vel))) ./
+           EventList.empty]
+
+
+readAfterEnd :: MidiFile.T
+readAfterEnd =
+   let chan = ChannelMsg.toChannel 3
+       vel  = VoiceMsg.toVelocity 64
+       pit  = VoiceMsg.toPitch 22
+   in  MidiFile.Cons MidiFile.Mixed (MidiFile.Ticks 10)
+          [0 /. Event.MIDIEvent (ChannelMsg.Cons chan (ChannelMsg.Voice (VoiceMsg.NoteOff pit vel))) ./
+           EventList.empty]
diff --git a/test/Main.hs b/test/Main.hs
--- a/test/Main.hs
+++ b/test/Main.hs
@@ -1,72 +1,40 @@
 {-
 ToDo:
 
-check whether load of randomly corrupted files yields Parser errors rather than 'undefined'.
-
-Check parsing and serialization of MIDI messages.
+Check parsing and serialization of single MIDI messages.
 -}
 module Main where
 
+import qualified Example
+import qualified Parser
+
+import qualified Test.QuickCheck as QC
+import Common (check, )
+
 import qualified Sound.MIDI.File      as MidiFile
 import qualified Sound.MIDI.File.Load as Load
 import qualified Sound.MIDI.File.Save as Save
-
-import qualified Sound.MIDI.File.Event.Meta as MetaEvent
-import qualified Sound.MIDI.File.Event      as Event
+import qualified Sound.MIDI.File.Event as Event
 
-import qualified Sound.MIDI.Message.Channel       as ChannelMsg
 import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg
-
 import qualified Sound.MIDI.Parser.Report as Report
-import qualified Sound.MIDI.Parser.Class  as Parser
-import qualified Sound.MIDI.Parser.Stream as StreamParser
 
 import qualified Data.EventList.Relative.TimeBody as EventList
-import Data.EventList.Relative.MixedBody ((/.), (./), )
 
 import qualified Data.ByteString.Lazy as B
 import qualified Data.List as List
-
-import Sound.MIDI.Utility (viewR, dropMatch, )
-import Control.Monad.Trans.Class (lift, )
-import Control.Monad (when, )
-
-import System.Random (mkStdGen, randomR, )
-
-import qualified Numeric.NonNegative.Wrapper as NonNeg
-
-import Test.QuickCheck (quickCheck, )
+import qualified Data.List.HT as ListHT
+import qualified Data.List.Match as Match
+import Data.Int (Int64, )
+import Data.Ord.HT (comparing, )
 
--- import Debug.Trace (trace)
+import Control.Monad (liftM, when, )
 
 
 
 testMidiName :: FilePath
 testMidiName = "quickcheck-test.mid"
 
-exampleEmpty :: MidiFile.T
-exampleEmpty =
-   MidiFile.Cons MidiFile.Parallel (MidiFile.Ticks 10)
-      [EventList.empty]
-
-exampleMeta :: MidiFile.T
-exampleMeta =
-   MidiFile.Cons MidiFile.Parallel (MidiFile.Ticks 10)
-      [EventList.cons 0 (Event.MetaEvent (MetaEvent.Lyric "foobarz")) EventList.empty]
-
-exampleStatus :: MidiFile.T
-exampleStatus =
-   let chan = ChannelMsg.toChannel 3
-       vel  = VoiceMsg.toVelocity 64
-   in  MidiFile.Cons MidiFile.Parallel (MidiFile.Ticks 10)
-          [0 /. Event.MIDIEvent (ChannelMsg.Cons chan (ChannelMsg.Voice (VoiceMsg.NoteOn (VoiceMsg.toPitch 20) vel))) ./
-           4 /. Event.MIDIEvent (ChannelMsg.Cons chan (ChannelMsg.Voice (VoiceMsg.NoteOn (VoiceMsg.toPitch 24) vel))) ./
-           4 /. Event.MIDIEvent (ChannelMsg.Cons chan (ChannelMsg.Voice (VoiceMsg.NoteOn (VoiceMsg.toPitch 27) vel))) ./
-           7 /. Event.MIDIEvent (ChannelMsg.Cons chan (ChannelMsg.Voice (VoiceMsg.NoteOff (VoiceMsg.toPitch 20) vel))) ./
-           4 /. Event.MIDIEvent (ChannelMsg.Cons chan (ChannelMsg.Voice (VoiceMsg.NoteOff (VoiceMsg.toPitch 24) vel))) ./
-           4 /. Event.MIDIEvent (ChannelMsg.Cons chan (ChannelMsg.Voice (VoiceMsg.NoteOff (VoiceMsg.toPitch 27) vel))) ./
-           EventList.empty]
-
 runExample :: MidiFile.T -> IO ()
 runExample example =
    let bin    = Save.toByteString example
@@ -80,9 +48,28 @@
 -- provoke a test failure in order to see some examples of Arbitrary MIDI files
 checkArbitrary :: MidiFile.T -> Bool
 checkArbitrary (MidiFile.Cons _typ _division tracks) =
-   length (EventList.toPairList (EventList.concat tracks)) < 10
+   all ((< 10) . length . EventList.toPairList) tracks
 
 
+{- |
+Increase the probability of similar adjacent messages
+that can be compressed using the running status.
+-}
+newtype SortedFile = SortedFile {getSortedFile :: MidiFile.T}
+   deriving Show
+
+sortedFile :: MidiFile.T -> SortedFile
+sortedFile =
+   SortedFile .
+   MidiFile.mapTrack
+      (EventList.fromPairList .
+       List.sortBy (comparing snd) . EventList.toPairList)
+
+instance QC.Arbitrary SortedFile where
+   arbitrary = liftM sortedFile QC.arbitrary
+   shrink = map sortedFile . QC.shrink . getSortedFile
+
+
 saveLoadByteString :: MidiFile.T -> Bool
 saveLoadByteString midi =
    let bin    = Save.toByteString midi
@@ -97,6 +84,48 @@
        report = Report.Cons [] (Right (MidiFile.implicitNoteOff midi))
    in  struct == report
 
+compressionShortens :: MidiFile.T -> Bool
+compressionShortens midi =
+   B.length (Save.toByteString midi)
+   >=
+   B.length (Save.toCompressedByteString midi)
+
+
+{-
+This does not cover all cases of possible running status compression,
+but the most common ones.
+-}
+equalStatus :: Event.T -> Event.T -> Bool
+equalStatus x y =
+   case (Event.maybeVoice x, Event.maybeVoice y) of
+      (Just (ch0, ev0), Just (ch1, ev1)) ->
+         ch0 == ch1
+         &&
+         case (ev0, ev1) of
+            (VoiceMsg.Control _ _, VoiceMsg.Control _ _) -> True
+            _ ->
+               VoiceMsg.isNoteOn ev0 && VoiceMsg.isNoteOn ev1
+               ||
+               VoiceMsg.isNoteOff ev0 && VoiceMsg.isNoteOff ev1
+      _ -> False
+
+{-
+You may test manually with Example.status
+which is definitely compressible.
+-}
+compressible :: MidiFile.T -> Bool
+compressible =
+   any (or . ListHT.mapAdjacent equalStatus . EventList.getBodies) .
+   MidiFile.getTracks . MidiFile.implicitNoteOff
+
+compressionStrictlyShortens :: MidiFile.T -> QC.Property
+compressionStrictlyShortens midi =
+   compressible midi
+   QC.==>
+   B.length (Save.toByteString midi)
+   >
+   B.length (Save.toCompressedByteString midi)
+
 saveLoadMaybeByteList :: MidiFile.T -> Bool
 saveLoadMaybeByteList midi =
    let bin    = Save.toByteList midi
@@ -129,7 +158,7 @@
    let bin0 = Save.toCompressedByteString midi0
    in  case Load.maybeFromByteString bin0 of
           Report.Cons [] (Right midi1) ->
-               bin0 == Save.toByteString midi1
+               bin0 == Save.toCompressedByteString midi1
           _ -> False
 
 loadSaveByteList :: MidiFile.T -> Bool
@@ -148,14 +177,6 @@
        Load.fromByteList (bin++[undefined])
 
 
-lazinessZeroOrMoreByteList :: NonNeg.Int -> Int -> Bool
-lazinessZeroOrMoreByteList pos byte =
-   let result =
-          Report.result $ StreamParser.runIncomplete (lift (Parser.zeroOrMore Parser.getByte)) $
-          StreamParser.ByteList $ repeat $ fromIntegral byte
-       char = show result !! mod (NonNeg.toNumber pos) 1000
-   in  char == char
-
 lazinessByteList :: MidiFile.T -> Bool
 lazinessByteList (MidiFile.Cons typ divsn tracks00) =
    let tracks0 = filter (not . EventList.null) tracks00
@@ -165,10 +186,10 @@
        -}
        bin1 = init bin0 ++ [undefined]
        (MidiFile.Cons _ _ tracks1) = Load.fromByteList bin1
-   in  case viewR tracks0 of
+   in  case ListHT.viewR tracks0 of
           Just (initTracks0, lastTrack0) ->
              List.isPrefixOf initTracks0 tracks1 &&
-               let (lastTrack1:_) = dropMatch initTracks0 tracks1
+               let (lastTrack1:_) = Match.drop initTracks0 tracks1
                in  List.isPrefixOf
                       (init (EventList.toPairList lastTrack0))
                       (EventList.toPairList lastTrack1)
@@ -181,13 +202,16 @@
 
 {- |
 Check whether corruptions in a file are properly detected
-and do not trap into an errors.
+and do not trap into errors.
+
+Sometimes it may yield an error which is @binary@'s fault.
+See 'readAfterEnd'.
 -}
-corruptionByteString :: Int -> Int -> MidiFile.T -> Bool
-corruptionByteString seed replacement midi =
+corruptionByteString :: Int64 -> Int -> MidiFile.T -> Bool
+corruptionByteString pos replacement midi =
    let bin = Save.toByteString midi
-       n = fst $ randomR (0, fromIntegral $ B.length bin :: Int) (mkStdGen seed)
-       (pre, post) = B.splitAt (fromIntegral n) bin
+       n = mod pos (B.length bin + 1)
+       (pre, post) = B.splitAt n bin
        replaceByte = fromIntegral replacement
        corruptBin =
           B.append pre
@@ -199,9 +223,9 @@
           Report.Cons _ _ -> True
 
 corruptionByteList :: Int -> Int -> MidiFile.T -> Bool
-corruptionByteList seed replacement midi =
+corruptionByteList pos replacement midi =
    let bin = Save.toByteList midi
-       n = fst $ randomR (0, length bin) (mkStdGen seed)
+       n = mod pos (length bin + 1)
        (pre, post) = splitAt n bin
        corruptBin =
           pre ++ fromIntegral replacement :
@@ -209,29 +233,57 @@
    in  case Load.maybeFromByteList corruptBin of
           Report.Cons _ _ -> True
 
+{- |
+This demonstrates a problem of the @binary@ package.
+If the binary @Get@ parser reads past the end of the file,
+then @runGet@ yields an error not a parser failure.
+This example provokes the problem by setting the @MTrk@ length to 0,
+which makes the following data look like an alien chunk with large size.
+When skipping following data of this size, 'runGet' yields an 'error'.
+-}
+readAfterEnd :: IO ()
+readAfterEnd = do
+   let bin = Save.toByteString $ Example.readAfterEnd
+       fails =
+          filter
+             (\pos -> not $ corruptionByteString pos 0 Example.readAfterEnd)
+             [0 .. B.length bin]
+   when (not $ null fails) $
+      putStr $ " fails at positions " ++ show fails
+   putStrLn ""
 
+
 main :: IO ()
-main =
-   do runExample exampleEmpty
-      runExample exampleMeta
-      runExample exampleStatus
-      saveLoadFile exampleStatus >>= print
-      quickCheck saveLoadByteString
-      quickCheck saveLoadCompressedByteString
-      quickCheck saveLoadMaybeByteList
-      quickCheck saveLoadByteList
---      quickCheck saveLoadFile
-      quickCheck loadSaveByteString
-      quickCheck loadSaveCompressedByteString
-      quickCheck loadSaveByteList
+main = do
+   runExample Example.empty
+   runExample Example.meta
+   runExample Example.status
+   saveLoadFile Example.status >>= print
+   check "saveLoadByteString" saveLoadByteString
+   check "saveLoadCompressedByteString" saveLoadCompressedByteString
+   check "saveLoadCompressedByteString sorted"
+      (saveLoadCompressedByteString . getSortedFile)
+   check "saveLoadMaybeByteList" saveLoadMaybeByteList
+   check "saveLoadByteList" saveLoadByteList
+--   check "saveLoadFile" saveLoadFile
+   check "loadSaveByteString" loadSaveByteString
+   check "loadSaveCompressedByteString" loadSaveCompressedByteString
+   check "loadSaveCompressedByteString sorted"
+      (loadSaveCompressedByteString . getSortedFile)
+   check "loadSaveByteList" loadSaveByteList
 
-      quickCheck restrictionByteList
+   check "compressionShortens" compressionShortens
+   check "compressionStrictlyShortens"
+      (compressionStrictlyShortens . getSortedFile)
 
-      quickCheck lazinessZeroOrMoreByteList
-      quickCheck lazinessByteList
+   check "restrictionByteList" restrictionByteList
 
-      quickCheck corruptionByteList
-      quickCheck corruptionByteString
+   check "lazinessZeroOrMoreByteList" Parser.lazinessZeroOrMoreByteList
+   check "lazinessByteList" lazinessByteList
+
+   check "corruptionByteList" corruptionByteList
+   check "corruptionByteString" corruptionByteString
+   when False $ putStr "readAfterEnd" >> readAfterEnd
 
 {-
 laziness test:
diff --git a/test/Parser.hs b/test/Parser.hs
new file mode 100644
--- /dev/null
+++ b/test/Parser.hs
@@ -0,0 +1,19 @@
+module Parser where
+
+import qualified Sound.MIDI.Parser.Report as Report
+import qualified Sound.MIDI.Parser.Class  as Parser
+import qualified Sound.MIDI.Parser.Stream as StreamParser
+
+import Control.Monad.Trans.Class (lift, )
+
+import qualified Numeric.NonNegative.Wrapper as NonNeg
+
+
+lazinessZeroOrMoreByteList :: NonNeg.Int -> Int -> Bool
+lazinessZeroOrMoreByteList pos byte =
+   let result =
+          Report.result $
+          StreamParser.runIncomplete (lift (Parser.zeroOrMore Parser.getByte)) $
+          StreamParser.ByteList $ repeat $ fromIntegral byte
+       char = show result !! mod (NonNeg.toNumber pos) 1000
+   in  char == char