packages feed

midi 0.1.1 → 0.1.2

raw patch · 25 files changed

+407/−431 lines, 25 filesdep +explicit-exception

Dependencies added: explicit-exception

Files

midi.cabal view
@@ -1,5 +1,5 @@ Name:             midi-Version:          0.1.1+Version:          0.1.2 License:          GPL License-File:     LICENSE Author:           Henning Thielemann <haskell@henning-thielemann.de>@@ -29,6 +29,7 @@  Library   Build-Depends: event-list >=0.0.6 && < 0.1, non-negative>=0.0.1 && <0.1+  Build-Depends: explicit-exception >=0.0.1 && <0.1   Build-Depends: bytestring >=0.9.0.1 && <0.10, binary >=0.4.2 && <0.5   Build-Depends: mtl >=1 && <2, QuickCheck >=1 && <2   If flag(splitBase)@@ -66,7 +67,8 @@     -- Parser class and general parser functions     Sound.MIDI.Parser.Class     Sound.MIDI.Parser.Restricted-    Sound.MIDI.Parser.State+    Sound.MIDI.Parser.Exception+    Sound.MIDI.Parser.Warning     Sound.MIDI.Parser.Primitive     Sound.MIDI.Parser.Status     -- concrete Parsers
src/Sound/MIDI/File/Event.hs view
@@ -84,7 +84,7 @@  -- * serialization -get :: Parser.C parser => StatusParser.T parser T+get :: Parser.C parser => Parser.Fallible (StatusParser.T parser) T get =    StatusParser.lift get1 >>= \tag ->    if tag < 0xF0@@ -101,7 +101,7 @@ last event and the current event.  Parse a time and an event, ignoring System Exclusive messages. -}-getTrackEvent :: Parser.C parser => StatusParser.T parser TrackEvent+getTrackEvent :: Parser.C parser => Parser.Fallible (StatusParser.T parser) TrackEvent getTrackEvent  =  liftM2 (,) (StatusParser.lift getVar) get
src/Sound/MIDI/File/Event/Meta.hs view
@@ -156,11 +156,11 @@  -- * serialization -get :: Parser.C parser => parser T+get :: Parser.C parser => Parser.Fallible parser T get =    do code <- get1       len  <- getVar-      let parse = ParserRestricted.run len+      let parse = ParserRestricted.runFallible len       let returnText cons = liftM (cons . listCharFromByte) $ getBigN len       case code of          000 -> parse $ liftM SequenceNum get2
src/Sound/MIDI/File/Event/SystemExclusive.hs view
@@ -30,7 +30,7 @@      deriving (Show, Eq, Ord)  -get :: Parser.C parser => Int -> parser T+get :: Parser.C parser => Int -> Parser.Fallible parser T get tag =    case tag of       0xF0 -> liftM Regular $ getBigN =<< getVar
src/Sound/MIDI/File/Load.hs view
@@ -29,22 +29,22 @@ -- import qualified Sound.MIDI.Bit as Bit import           Sound.MIDI.String (unlinesS) import           Sound.MIDI.Parser.Primitive-import           Sound.MIDI.Parser.Class (PossiblyIncomplete, ) import qualified Sound.MIDI.Parser.Class as Parser-import qualified Sound.MIDI.Parser.Restricted as ParserRestricted-import qualified Sound.MIDI.Parser.ByteString as ParserByteString-import qualified Sound.MIDI.Parser.Stream as ParserStream-import qualified Sound.MIDI.Parser.File   as ParserFile-import qualified Sound.MIDI.Parser.State  as ParserState+import qualified Sound.MIDI.Parser.Restricted as RestrictedParser+import qualified Sound.MIDI.Parser.ByteString as ByteStringParser+import qualified Sound.MIDI.Parser.Stream as StreamParser+import qualified Sound.MIDI.Parser.File   as FileParser import qualified Sound.MIDI.Parser.Status as StatusParser import qualified Sound.MIDI.Parser.Report as Report import qualified Control.Monad.State as State-import Control.Monad (liftM, liftM2, when, )+import Control.Monad.Trans (lift, )+import Control.Monad (liftM, liftM2, )  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 Sound.MIDI.Utility (mapSnd, ) import Data.List (genericReplicate, genericLength, ) import Data.Maybe (catMaybes, ) @@ -54,22 +54,22 @@ Warnings are written to standard error output and an error is signaled by a user exception. This function will not be appropriate in GUI applications.-For these, use 'fromByteList' instead.+For these, use 'maybeFromByteString' instead. -} fromFile :: FilePath -> IO MIDIFile.T fromFile =-   ParserFile.runIncompleteFile parse+   FileParser.runIncompleteFile parse   {- fromFile :: FilePath -> IO MIDIFile.T fromFile filename =    do report <- fmap maybeFromByteList $ readBinaryFile filename-      mapM_ (hPutStrLn stderr . ("MIDI.File.Load warning: " ++)) (ParserStream.warnings report)+      mapM_ (hPutStrLn stderr . ("MIDI.File.Load warning: " ++)) (StreamParser.warnings report)       either          (ioError . userError . ("MIDI.File.Load error: " ++))          return-         (ParserStream.result report)+         (StreamParser.result report) -}  {- |@@ -86,12 +86,12 @@ maybeFromByteList ::    ByteList -> Report.T MIDIFile.T maybeFromByteList =-   ParserStream.runIncomplete parse . ParserStream.ByteList+   StreamParser.runIncomplete parse . StreamParser.ByteList  maybeFromByteString ::    B.ByteString -> Report.T MIDIFile.T maybeFromByteString =-   ParserByteString.runIncomplete parse+   ByteStringParser.runIncomplete parse   @@ -102,32 +102,30 @@ 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 (PossiblyIncomplete MIDIFile.T)+parse :: Parser.C parser => Parser.Partial (Parser.Fallible parser) MIDIFile.T parse =    getChunk >>= \ (typ, hdLen) ->       case typ of         "MThd" ->            do (format, nTracks, division) <--                 ParserRestricted.run hdLen getHeader-              ~(me, tracks) <--                 Parser.zeroOrMoreInc-                    (do (me0,track) <- getTrackChunk-{--                        let trackNoEOT = track--}-                        trackNoEOT <--                           maybe (return Nothing) (liftM Just . removeEndOfTrack) track-                        return (me0, trackNoEOT))-              let n = genericLength tracks-              Parser.force $ when (n /= nTracks) $-                 Parser.warn ("header says " ++ show nTracks ++-                    " tracks, but " ++ show n ++ " tracks were found")-              return (me, MIDIFile.Cons format division $ catMaybes tracks)-        _ -> Parser.warn ("found Alien chunk <" ++ typ ++ ">") >>+                 RestrictedParser.runFallible hdLen getHeader+              excTracks <-+                 lift $ Parser.zeroOrMoreInc+                    (getTrackChunk >>= Async.mapM (lift . liftMaybe removeEndOfTrack))+              flip Async.mapM excTracks $ \tracks ->+                 do let n = genericLength tracks+                    lift $ Parser.warnIf (n /= nTracks)+                       ("header says " ++ show nTracks +++                        " tracks, but " ++ show n ++ " tracks were found")+                    return (MIDIFile.Cons format division $ catMaybes tracks)+        _ -> lift (Parser.warn ("found Alien chunk <" ++ typ ++ ">")) >>              Parser.skip hdLen >>              parse  +liftMaybe :: Monad m => (a -> m b) -> Maybe a -> m (Maybe b)+liftMaybe f = maybe (return Nothing) (liftM Just . f)+ {- | There are two ways to mark the end of the track: The end of the event list and the meta event 'EndOfTrack'.@@ -143,12 +141,12 @@       (\(initEvents, lastEvent) ->           let (eots, track) =                  EventList.partition isEndOfTrack initEvents-          in  do Parser.force $ when+          in  do Parser.warnIf                     (not $ EventList.null eots)-                    (Parser.warn "EndOfTrack inside a track")-                 Parser.force $ when+                    "EndOfTrack inside a track"+                 Parser.warnIf                     (not $ isEndOfTrack $ snd lastEvent)-                    (Parser.warn "Track does not end with EndOfTrack")+                    "Track does not end with EndOfTrack"                  return track)       (EventList.viewR xs) @@ -180,23 +178,23 @@ four bytes for the size of the coming data, and the data itself. -}-getChunk :: Parser.C parser => parser (String, NonNeg.Integer)+getChunk :: Parser.C parser => Parser.Fallible parser (String, NonNeg.Integer) getChunk =    liftM2 (,)       (getString 4)  -- chunk type: header or track       (getNByteCardinal 4)                      -- chunk body -getTrackChunk :: Parser.C parser => parser (PossiblyIncomplete (Maybe Track))+getTrackChunk :: Parser.C parser => Parser.Partial (Parser.Fallible parser) (Maybe Track) getTrackChunk =    do (typ, len) <- getChunk       if typ=="MTrk"-        then liftM (mapSnd Just) $-             ParserRestricted.run len $+        then liftM (fmap Just) $ lift $+             RestrictedParser.run len $              StatusParser.run getTrack-        else Parser.warn ("found Alien chunk <" ++ typ ++ "> in track section") >>+        else lift (Parser.warn ("found Alien chunk <" ++ typ ++ "> in track section")) >>              Parser.skip len >>-             return (Nothing, Nothing)+             return (Async.pure Nothing)   @@ -205,7 +203,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 (MIDIFile.Type, NonNeg.Int, Division)+getHeader :: Parser.C parser => Parser.Fallible parser (MIDIFile.Type, NonNeg.Int, Division) getHeader =    do       format   <- makeEnum =<< get2@@ -217,7 +215,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 Division+getDivision :: Parser.C parser => Parser.Fallible parser Division getDivision =    do       x <- get1@@ -231,11 +229,11 @@ A track is a series of events.  Parse a track, stopping when the size is zero. -}-getTrack :: Parser.C parser => StatusParser.T parser (PossiblyIncomplete MIDIFile.Track)+getTrack :: Parser.C parser => Parser.Partial (StatusParser.T parser) MIDIFile.Track getTrack =    liftM-      (mapSnd EventList.fromPairList)-      (ParserState.zeroOrMore Event.getTrackEvent)+      (fmap EventList.fromPairList)+      (Parser.zeroOrMore Event.getTrackEvent)   @@ -251,7 +249,7 @@  showChunks :: ByteList -> String showChunks mf =-  showMR getChunks (\(me,cs) ->+  showMR (lift getChunks) (\(Async.Exceptional me cs) ->      unlinesS (map pp cs) .      maybe id (\e -> showString ("incomplete chunk list: " ++ e ++ "\n")) me) mf ""  where@@ -261,8 +259,8 @@     showMR getHeader shows contents   pp ("MTrk",contents) =     showString "Track:\n" .-    showMR (StatusParser.run getTrack)-        (\(me,track) str ->+    showMR (lift $ StatusParser.run getTrack)+        (\(Async.Exceptional me track) str ->             EventList.foldr                MIDIFile.showTime                (\e -> MIDIFile.showEvent e . showString "\n")@@ -276,9 +274,9 @@     showString "\n"  -showMR :: ParserStream.T ParserStream.ByteList a -> (a->ShowS) -> ByteList -> ShowS+showMR :: Parser.Fallible (StreamParser.T StreamParser.ByteList) a -> (a->ShowS) -> ByteList -> ShowS showMR m pp contents =-  let report = ParserStream.run m (ParserStream.ByteList contents)+  let report = StreamParser.run m (StreamParser.ByteList contents)   in  unlinesS (map showString $ Report.warnings report) .       either showString pp (Report.result report) @@ -297,7 +295,7 @@  -} getChunks ::-   Parser.C parser => parser (PossiblyIncomplete [(String, ByteList)])+   Parser.C parser => Parser.Partial parser [(String, ByteList)] getChunks =    Parser.zeroOrMore $       do (typ, len) <- getChunk
src/Sound/MIDI/Manufacturer.hs view
@@ -349,7 +349,7 @@  -- * serialization -get :: Parser.C parser => parser T+get :: Parser.C parser => Parser.Fallible parser T get =    do subId <- getByte       if subId == 0
src/Sound/MIDI/Message.hs view
@@ -14,8 +14,7 @@ import qualified Sound.MIDI.Message.System  as System  import qualified Sound.MIDI.Parser.Status as StatusParser-import           Sound.MIDI.Parser.Class (PossiblyIncomplete, )-import qualified Sound.MIDI.Parser.Class as Parser+import qualified Sound.MIDI.Parser.Class  as Parser import           Sound.MIDI.Parser.Primitive (get1) import qualified Sound.MIDI.Parser.ByteString as ParserByteString @@ -24,20 +23,20 @@  import qualified Sound.MIDI.Parser.Report as Report +import qualified Control.Monad.Exception.Asynchronous as Async+ import Control.Monad.Trans (lift, ) import Control.Monad (liftM, )  import qualified Data.ByteString.Lazy as B -import Sound.MIDI.Utility (mapSnd, ) - data T =      Channel Channel.T    | System  System.T  -get :: Parser.C parser => parser T+get :: Parser.C parser => Parser.Fallible parser T get =    get1 >>= \code ->    if code >= 0xF0@@ -45,7 +44,7 @@      else liftM Channel $ (uncurry Channel.get (Channel.decodeStatus code) =<< get1) --     else liftM Channel $ StatusParser.run (Channel.getWithStatus code) -getWithStatus :: Parser.C parser => StatusParser.T parser T+getWithStatus :: Parser.C parser => Parser.Fallible (StatusParser.T parser) T getWithStatus =    StatusParser.lift get1 >>= \code ->    if code >= 0xF0@@ -54,12 +53,12 @@      else liftM Channel $ Channel.getWithStatus code  getIncompleteWithStatus ::-   Parser.C parser => StatusParser.T parser (PossiblyIncomplete T)+   Parser.C parser => Parser.Partial (Parser.Fallible (StatusParser.T parser)) T getIncompleteWithStatus =    StatusParser.lift get1 >>= \code ->    if code >= 0xF0-     then liftM (mapSnd System) $ StatusParser.lift $ System.getIncomplete code-     else liftM ((,) Nothing . Channel) $ Channel.getWithStatus code+     then liftM (fmap System) $ StatusParser.lift $ System.getIncomplete code+     else liftM (Async.pure . Channel) $ Channel.getWithStatus code  maybeFromByteString :: B.ByteString -> Report.T T maybeFromByteString =
src/Sound/MIDI/Message/Channel.hs view
@@ -20,9 +20,9 @@ import           Sound.MIDI.Parser.Primitive import qualified Sound.MIDI.Parser.Class as Parser import Sound.MIDI.Parser.Status-   (lift,-    Channel, fromChannel,   toChannel, )+   (Channel, fromChannel,   toChannel, ) +import Control.Monad.Trans (lift, ) import Control.Monad (liftM, liftM2, when, )  import qualified Sound.MIDI.Writer.Status as StatusWriter@@ -74,17 +74,17 @@ (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 -> StatusParser.T parser T+getWithStatus :: Parser.C parser => Int -> Parser.Fallible (StatusParser.T parser) T getWithStatus tag =    do (status@(code, channel), firstData) <-          if tag < 0x80            then maybe-                   (lift $ Parser.giveUp "messages wants to repeat status byte, but there was no status yet")+                   (Parser.giveUp "messages wants to repeat status byte, but there was no status yet")                    (\cc -> return (cc,tag))                       =<< StatusParser.get-           else liftM ((,) $ decodeStatus tag) $ lift get1+           else liftM ((,) $ decodeStatus tag) $ StatusParser.lift get1       StatusParser.set (Just status)-      lift $ get code channel firstData+      StatusParser.lift $ get code channel firstData  -- | for internal use decodeStatus :: Int -> (Int, Channel)@@ -97,7 +97,7 @@ the code, channel and first data byte must be determined by the caller. -}-get :: Parser.C parser => Int -> Channel -> Int -> parser T+get :: Parser.C parser => Int -> Channel -> Int -> Parser.Fallible parser T get code channel firstData =    liftM (Cons channel) $    if code == 11 && firstData >= 0x78
src/Sound/MIDI/Message/Channel/Mode.hs view
@@ -12,12 +12,14 @@  import Sound.MIDI.Parser.Report (UserMessage, ) +import qualified Control.Monad.Exception.Asynchronous as Async import Sound.MIDI.Utility (toMaybe, )+import Control.Monad.Trans (lift, )+import Control.Monad (liftM, )  import Test.QuickCheck (Arbitrary(arbitrary), ) import qualified Test.QuickCheck as QC -import Control.Monad (liftM, )   data T =@@ -46,13 +48,15 @@  -- * serialization -get :: Parser.C parser => Int -> parser T+get :: Parser.C parser => Int -> Parser.Fallible parser T get mode =    do x <- get1-      let (w, msg) = fromControllerValue (mode,x)-      maybe (return ()) Parser.warn w-      return msg+      lift $ Parser.warnIncomplete $ uncurry Async.Exceptional $ fromControllerValue (mode,x) +{- |+This function is also used in alsa-midi,+we could give it the result type @Parser.PossiblyIncomplete T@ otherwise.+-} fromControllerValue :: Integral a => (a, a) -> (Maybe UserMessage, T) fromControllerValue (mode,x) =    case mode of
src/Sound/MIDI/Message/Channel/Voice.hs view
@@ -409,7 +409,7 @@  -- * serialization -get :: Parser.C parser => Int -> Int -> parser T+get :: Parser.C parser => Int -> Int -> Parser.Fallible parser T get code firstData =    let pitch  = toPitch firstData        getVel = liftM toVelocity get1
src/Sound/MIDI/Message/System.hs view
@@ -10,14 +10,14 @@ import qualified Sound.MIDI.Message.System.RealTime  as RealTime  -- import           Sound.MIDI.Parser.Primitive-import           Sound.MIDI.Parser.Class (PossiblyIncomplete, ) import qualified Sound.MIDI.Parser.Class as Parser  import qualified Sound.MIDI.Writer.Basic as Writer +import qualified Control.Monad.Exception.Asynchronous as Async+ import Control.Monad (liftM, ) -import Sound.MIDI.Utility (mapSnd, )   data T =@@ -26,7 +26,7 @@    | RealTime  RealTime.T  -get :: Parser.C parser => Int -> parser T+get :: Parser.C parser => Int -> Parser.Fallible parser T get code =    if code == 0xF0      then liftM Exclusive Exclusive.get@@ -38,16 +38,16 @@              then liftM RealTime $ RealTime.get code              else Parser.giveUp ("invalid System message code " ++ show code) -getIncomplete :: Parser.C parser => Int -> parser (PossiblyIncomplete T)+getIncomplete :: Parser.C parser => Int -> Parser.Partial (Parser.Fallible parser) T getIncomplete code =    if code == 0xF0-     then liftM (mapSnd Exclusive) Exclusive.getIncomplete+     then liftM (fmap Exclusive) Exclusive.getIncomplete      else        if code >= 0xF1 && code <= 0xF6-         then liftM ((,) Nothing . Common) $ Common.get code+         then liftM (Async.pure . Common) $ Common.get code          else            if code >= 0xF8 && code <= 0xFF-             then liftM ((,) Nothing . RealTime) $ RealTime.get code+             then liftM (Async.pure . RealTime) $ RealTime.get code              else Parser.giveUp ("invalid System message code " ++ show code)
src/Sound/MIDI/Message/System/Common.hs view
@@ -8,7 +8,8 @@ import           Sound.MIDI.Parser.Primitive import qualified Sound.MIDI.Parser.Class as Parser -import Control.Monad (liftM, liftM2, when, )+import Control.Monad.Trans (lift, )+import Control.Monad (liftM, liftM2, )  import qualified Sound.MIDI.Writer.Basic as Writer @@ -38,15 +39,15 @@  -- * serialization -get :: Parser.C parser => Int -> parser T+get :: Parser.C parser => Int -> Parser.Fallible parser T get code =    case code of       0xF1 ->          do dat <- get1             let (nib, value)  = Bit.splitAt 4 dat             let (msb, nibble) = Bit.splitAt 3 nib-            when (msb/=0)-               (Parser.warn "TimeCodeQuarterFrame: most significant bit must 0")+            lift $ Parser.warnIf (msb/=0)+               "TimeCodeQuarterFrame: most significant bit must 0"             return $ TimeCodeQuarterFrame (toEnum nibble) value       0xF2 -> liftM2 (\lsb msb -> SongPositionPointer (lsb + Bit.shiftL 7 msb)) get1 get1       0xF3 -> liftM SongSelect get1
src/Sound/MIDI/Message/System/Exclusive.hs view
@@ -9,12 +9,12 @@ import Sound.MIDI.IO (ByteList)  import           Sound.MIDI.Parser.Primitive-import           Sound.MIDI.Parser.Class (PossiblyIncomplete, ) import qualified Sound.MIDI.Parser.Class as Parser  import qualified Sound.MIDI.Writer.Basic as Writer --- import Control.Monad (liftM, liftM2, when, )+import Control.Monad.Trans (MonadTrans, lift, )+import qualified Control.Monad.Exception.Asynchronous as Async  import Data.Maybe (fromMaybe, ) @@ -39,22 +39,26 @@  -- * serialization -get :: Parser.C parser => parser T+get :: Parser.C parser => Parser.Fallible parser T get =-   do (err, sysex) <- getIncomplete+   do (Async.Exceptional err sysex) <- getIncomplete       maybe (return sysex) Parser.giveUp err -getIncomplete :: Parser.C parser => parser (PossiblyIncomplete T)+getIncomplete :: Parser.C parser => Parser.Partial (Parser.Fallible parser) T getIncomplete =    do manu <- Manufacturer.get-      (err, body) <- Parser.until (0xf7 ==) getByte-      return $ ((,) err) $-        fromMaybe (Commercial manu body) $-        lookup manu $-           (Manufacturer.nonCommercial, NonCommercial body) :-           (Manufacturer.nonRealTime,   NonRealTime $ NonRealTimeCons body) :-           (Manufacturer.realTime,      RealTime    $ RealTimeCons body) :-           []+      incBody <- lift getBody+      return $ flip fmap incBody $ \body ->+         fromMaybe (Commercial manu body) $+         lookup manu $+            (Manufacturer.nonCommercial, NonCommercial body) :+            (Manufacturer.nonRealTime,   NonRealTime $ NonRealTimeCons body) :+            (Manufacturer.realTime,      RealTime    $ RealTimeCons body) :+            []++getBody :: Parser.C parser => Parser.Partial parser ByteList+getBody = Parser.until (0xf7 ==) getByte+  {- | It is not checked whether SysEx messages contain only 7-bit values.
src/Sound/MIDI/Message/System/RealTime.hs view
@@ -25,7 +25,7 @@  -- * serialization -get :: Parser.C parser => Int -> parser T+get :: Parser.C parser => Int -> Parser.Fallible parser T get code =    case code of       0xF8 -> return TimingClock
src/Sound/MIDI/Parser/ByteString.hs view
@@ -10,12 +10,17 @@ import qualified Data.Binary.Get as Binary import Data.Binary.Get (Get, runGet, ) -import Control.Monad (liftM, when, )+import Control.Monad.Trans (lift, ) +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.Report as Report+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)@@ -25,7 +30,7 @@   -newtype T a = Cons {decons :: Get (Report.T a)}+newtype T a = Cons {decons :: Warning.T Get a}   {-@@ -35,12 +40,13 @@ -}  -run :: T a -> B.ByteString -> Report.T a+run :: Parser.Fallible T a -> B.ByteString -> Report.T a run parser input =-   flip runGet input $ decons $+   flip runGet input $ Warning.run $ decons $ Exception.run $       (do a <- parser-          end <- Parser.isEnd-          when (not end) (warn "unparsed data left over")+          lift $+             Parser.isEnd >>= \end ->+                Parser.warnIf (not end) "unparsed data left over"           return a)  {- |@@ -49,50 +55,44 @@ and thus further parsing is not possible. -} runIncomplete ::-   T (PossiblyIncomplete a) -> B.ByteString -> Report.T a+   Parser.Partial (Parser.Fallible T) a -> B.ByteString -> Report.T a runIncomplete parser input =    flip run input $-      do (me,x) <- parser-         maybe (return ()) warn me-         return x+      lift . Parser.warnIncomplete =<< parser   fromGet :: Get a -> T a fromGet p =-   Cons $ liftM (\a -> Report.Cons [] (Right a)) p+   Cons $ lift p   instance Monad T where-   return x = fromGet $ return x-   x >>= y  = Cons $-      decons x >>= \ a ->-         case Report.result a of-            Left err -> return (Report.Cons (Report.warnings a) (Left err))-            Right ar ->-               decons (y ar) >>= \ b ->-                  return (b{Report.warnings = Report.warnings a ++ Report.warnings b})+   return = Cons . return+   x >>= y = Cons $ decons . y =<< decons x ++instance Parser.EndCheck T where+   isEnd = fromGet Binary.isEmpty+ instance Parser.C T where-   isEnd   = fromGet Binary.isEmpty --   getByte = fromGet Binary.getWord8--- a get getMabybeWord8 would be nice in order to avoid double-checking+-- a get getMaybeWord8 would be nice in order to avoid double-checking    getByte =-      do end <- fromGet Binary.isEmpty+      do end <- lift $ fromGet Binary.isEmpty          if end-           then giveUp "unexpected end of ByteString"-           else fromGet Binary.getWord8-   skip n  =+           then Parser.giveUp "unexpected end of ByteString"+           else lift $ fromGet Binary.getWord8++   skip n =       let toSize x =             let y = if x > fromIntegral (maxBound `asTypeOf` y)                       then error "skip: number too big"                       else fromIntegral x             in  y-      in  fromGet $ skip $ toSize $ NonNeg.toNumber n-   warn    = warn-   giveUp  = giveUp-   try     = try-   force   = force+      in  lift $ fromGet $ skip $ toSize $ NonNeg.toNumber n +   warn = Cons . Warning.warn+ {- | In contrast to Binary.skip this one does not fail badly and it works with Int64. I hope that it is not too inefficient.@@ -100,30 +100,3 @@ skip :: Int64 -> Get () skip n = Binary.getLazyByteString n >> return () -- Binary.skip n--warn :: String -> T ()-warn text =-   Cons $ return $ Report.Cons [text] (Right ())--giveUp :: String -> T a-giveUp text =-   Cons $ return $ Report.Cons [] (Left text)--try :: T a -> T (Either UserMessage a)-try =-   Cons . liftM (\r -> r{Report.result = Right (Report.result r)}) . decons---{- |-Wadler's force function--'force' guarantees that the parser does not fail.-Thus it makes parsing more lazy.-However if the original parser fails though,-then we get an unrecoverable /irrefutable pattern/ error on 'Just'.--}-force :: T a -> T a-force p =-   Cons $-     do ~(Report.Cons w ~(Right x)) <- decons p-        return (Report.Cons w (Right x))
src/Sound/MIDI/Parser/Class.hs view
@@ -1,39 +1,47 @@ module Sound.MIDI.Parser.Class-   (C, isEnd, getByte,-    warn, giveUp, try,-    force, zeroOrMore, zeroOrMoreInc, until, replicate, skip,-    PossiblyIncomplete, UserMessage,+   (EndCheck, isEnd,+    C, getByte, skip,+    warn, warnIf, warnIncomplete, Exc.giveUp, Exc.try,+    until, zeroOrMore, zeroOrMoreInc, replicate,+    emptyList, PossiblyIncomplete, UserMessage,+    Fallible, Partial,     {- for debugging-    handleMsg, appendIncomplete,+    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 (liftM, liftM2, )+import Control.Monad.Trans (lift, )+import Control.Monad.State (StateT, )+import Control.Monad (liftM, liftM2, when, )  import Data.Word (Word8)  import qualified Numeric.NonNegative.Wrapper as NonNeg -import Sound.MIDI.Utility (mapSnd, )- import Prelude hiding (replicate, until, )   -class Monad parser => C parser where+class Monad parser => EndCheck parser where    isEnd   :: parser Bool-   getByte :: parser Word8-   skip    :: NonNeg.Integer -> parser ()-   warn    :: UserMessage -> parser ()-   giveUp  :: UserMessage -> parser a-   try     :: parser a -> parser (Either UserMessage a)-   force   :: parser a -> parser a +-- 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.@@ -41,51 +49,60 @@  It is not possible to merge this functionality in the parser monad, because then it is not possible to define monadic binding.--In the future it should be replaced by-'Control.Monad.Exception.Asynchronous.Exceptional'-from the explicit-exception package. -}-type PossiblyIncomplete a = (Maybe UserMessage, a)+type PossiblyIncomplete a = Async.Exceptional UserMessage a  +type Fallible parser   = Sync.ExceptionalT UserMessage parser+type Partial  parser a = parser (PossiblyIncomplete a) -{--zeroOrMore   :: T s a -> T s [a]-zeroOrMore p = force $ oneOrMore p `mplus` return [] -oneOrMore    :: T s a -> T s [a]-oneOrMore p = liftM2 (:) p (zeroOrMore p)+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 :: C parser =>-   parser a -> parser (PossiblyIncomplete [a])+zeroOrMore :: EndCheck parser =>+   Fallible parser a -> Partial parser [a] zeroOrMore p =    let go =-         force $ isEnd >>= \b ->+         isEnd >>= \b ->             if b-              then return (Nothing, [])-              else handleMsg-                      (\errMsg -> (Just errMsg, []))-                      (liftM2 (\ x ~(e,xs) -> (e,x:xs)) p go)+              then return emptyList+              else absorbException+                      (liftM2 (\ x -> fmap (x:)) p (lift go))    in  go  -zeroOrMoreInc :: C parser =>-   parser (PossiblyIncomplete a) -> parser (PossiblyIncomplete [a])+zeroOrMoreInc :: EndCheck parser =>+   Partial (Fallible parser) a -> Partial parser [a] zeroOrMoreInc p =    let go =-         force $ isEnd >>= \b ->+         isEnd >>= \b ->             if b-              then return (Nothing, [])-              else handleMsg-                      (\errMsg -> (Just errMsg, []))+              then return emptyList+              else absorbException                       (appendIncomplete p go)    in  go @@ -95,23 +112,23 @@ 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 signalled.+then an Incomplete exception (Just errorMessage) is signaled. -}-until :: C parser =>-   (a -> Bool) -> parser a -> parser (PossiblyIncomplete [a])+until :: EndCheck parser =>+   (a -> Bool) -> Fallible parser a -> Partial parser [a] until c p =    let go =-         force $ isEnd >>= \b ->+         isEnd >>= \b ->             if b               then-                return (Just "Parser.until: unexpected end of input", [])+                return $ Async.broken+                   "Parser.until: unexpected end of input" []               else-                handleMsg-                   (\errMsg -> (Just errMsg, [])) $+                absorbException $                    p >>= \x ->                      if c x-                       then return (Nothing, [])-                       else liftM (mapSnd (x:)) go+                       then return emptyList+                       else liftM (fmap (x:)) (lift go)    in  go  @@ -122,35 +139,36 @@ replicate ::    C parser =>    NonNeg.Int ->-   parser (PossiblyIncomplete a) ->-   parser (PossiblyIncomplete [a])+   Partial (Fallible parser) a ->+   Partial parser [a] replicate m p =    let go n =-         force $-            if n==0-              then return (Nothing, [])-              else handleMsg-                      (\errMsg -> (Just errMsg, []))-                      (appendIncomplete p (go (n-1)))+         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 ::-   C parser =>-   parser (PossiblyIncomplete a) ->-   parser (PossiblyIncomplete [a]) ->-   parser (PossiblyIncomplete [a])+   Monad parser =>+   Partial (Fallible parser) a ->+   Partial parser [a] ->+   Partial (Fallible parser) [a] appendIncomplete p ps =-   do ~(me, x) <- p-      liftM (mapSnd (x:)) $ force $-         maybe ps (\_ -> return (me,[])) me+   do ~(Async.Exceptional me x) <- p+      lift $ liftM (fmap (x:)) $+         maybe ps (\_ -> return (Async.Exceptional me [])) me -handleMsg ::-   C parser =>-   (UserMessage -> a) -> parser a -> parser a-handleMsg handler action =-   liftM-      (either handler id)-      (try action)+absorbException ::+   Monad parser =>+   Partial (Fallible parser) [a] ->+   Partial parser [a]+absorbException =+   Sync.resolveT (\errMsg -> return $ Async.broken errMsg [])
+ src/Sound/MIDI/Parser/Exception.hs view
@@ -0,0 +1,24 @@+{- |+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
src/Sound/MIDI/Parser/File.hs view
@@ -5,10 +5,12 @@ import qualified Sound.MIDI.Parser.Class as Parser import Sound.MIDI.Parser.Class (UserMessage, PossiblyIncomplete, ) -import Control.Monad.Reader (ReaderT(ReaderT, runReaderT), ask, liftM, lift, )+import Control.Monad.Reader (ReaderT(runReaderT), ask, liftM, lift, )  import qualified System.IO.Error as IOE import qualified Control.Exception as Exc+import qualified Control.Monad.Exception.Asynchronous as Async+import qualified Control.Monad.Exception.Synchronous  as Sync  import qualified System.IO as IO import qualified Sound.MIDI.IO as MIO@@ -21,16 +23,17 @@ newtype T a = Cons {decons :: ReaderT IO.Handle IO a}  -runFile :: T a -> FilePath -> IO a+runFile :: Parser.Fallible T a -> FilePath -> IO a runFile p name =    Exc.bracket       (IO.openBinaryFile name IO.ReadMode)       IO.hClose       (runHandle p) -runHandle :: T a -> IO.Handle -> IO a+runHandle :: Parser.Fallible T a -> IO.Handle -> IO a runHandle p h =-   runReaderT (decons p) h+   do exc <- runReaderT (decons (Sync.tryT p)) h+      Sync.resolve (IOE.ioError . IOE.userError) (fmap return exc)   @@ -39,13 +42,13 @@ we cannot know where the current file position is, we omit the @runIncompleteHandle@ variant. -}-runIncompleteFile :: T (PossiblyIncomplete a) -> FilePath -> IO a+runIncompleteFile :: Parser.Partial (Parser.Fallible T) a -> FilePath -> IO a runIncompleteFile p name =    Exc.bracket       (IO.openBinaryFile name IO.ReadMode)       IO.hClose       (\h ->-          do (me,a) <- runHandle p h+          do (Async.Exceptional me a) <- runHandle p h              maybe (return ())                  (\msg -> putStrLn $ "could not parse MIDI file completely: " ++ msg) me              return a)@@ -59,14 +62,16 @@ fromIO :: (IO.Handle -> IO a) -> T a fromIO act = Cons $ lift . act =<< ask -instance Parser.C T where+fallibleFromIO :: (IO.Handle -> IO a) -> Parser.Fallible T a+fallibleFromIO act =+   Sync.ExceptionalT . Cons . lift .+      fmap (Sync.mapException show . Sync.fromEither) . IOE.try . act+          =<< lift (Cons ask)++instance Parser.EndCheck T where    isEnd   = fromIO IO.hIsEOF-   getByte = fromIO $ liftM (fromIntegral . ord) . IO.hGetChar-   skip n  = fromIO $ \h -> IO.hSeek h IO.RelativeSeek (NonNeg.toNumber n)++instance Parser.C T where+   getByte = fallibleFromIO $ liftM (fromIntegral . ord) . IO.hGetChar+   skip n  = fallibleFromIO $ \h -> IO.hSeek h IO.RelativeSeek (NonNeg.toNumber n)    warn    = Cons . lift . (\msg -> putStrLn ("warning: " ++ msg))-   giveUp  = Cons . lift . IOE.ioError . IOE.userError-   try p   =-      Cons $ ReaderT $ \h ->-         liftM (either (Left . show) Right) $-         IOE.try $ runReaderT (decons p) h-   force p = p
src/Sound/MIDI/Parser/Primitive.hs view
@@ -24,20 +24,20 @@ {- | 'getByte' gets a single byte from the input. -}-getByte :: Parser.C parser => parser Word8+getByte :: Parser.C parser => Parser.Fallible parser Word8 getByte = Parser.getByte   {- | @getN n@ returns n characters (bytes) from the input. -}-getN :: Parser.C parser => NonNeg.Int -> parser ByteList+getN :: Parser.C parser => NonNeg.Int -> Parser.Fallible parser ByteList getN n = replicateM (NonNeg.toNumber n) getByte -getString :: Parser.C parser => NonNeg.Integer -> parser String+getString :: Parser.C parser => NonNeg.Integer -> Parser.Fallible parser String getString n = liftM listCharFromByte (getBigN n) -getBigN :: Parser.C parser => NonNeg.Integer -> parser ByteList+getBigN :: Parser.C parser => NonNeg.Integer -> Parser.Fallible parser ByteList getBigN n =    sequence $    Bit.replicateBig@@ -51,22 +51,22 @@ 4-byte numbers from the input (respectively), convert the base-256 data into a single number, and return. -}-get1 :: Parser.C parser => parser Int+get1 :: Parser.C parser => Parser.Fallible parser Int get1 = liftM fromIntegral getByte -getNByteInt :: Parser.C parser => NonNeg.Int -> parser Int+getNByteInt :: Parser.C parser => NonNeg.Int -> Parser.Fallible parser Int getNByteInt n =    liftM Bit.fromBytes (replicateM (NonNeg.toNumber n) get1) -get2, get3, get4 :: Parser.C parser => parser Int+get2, get3, get4 :: Parser.C parser => Parser.Fallible parser Int get2 = getNByteInt 2 get3 = getNByteInt 3 get4 = getNByteInt 4 -getByteAsCardinal :: Parser.C parser => parser NonNeg.Integer+getByteAsCardinal :: Parser.C parser => Parser.Fallible parser NonNeg.Integer getByteAsCardinal = liftM fromIntegral getByte -getNByteCardinal :: Parser.C parser => NonNeg.Int -> parser NonNeg.Integer+getNByteCardinal :: Parser.C parser => NonNeg.Int -> Parser.Fallible parser NonNeg.Integer getNByteCardinal n =    liftM Bit.fromBytes (replicateM (NonNeg.toNumber n) getByteAsCardinal) @@ -79,7 +79,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 NonNeg.Integer+getVar :: Parser.C parser => Parser.Fallible parser NonNeg.Integer getVar =    liftM (Bit.fromBase (2^(7::Int)) . map fromIntegral) getVarBytes @@ -87,7 +87,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 [Word8]+getVarBytes :: Parser.C parser => Parser.Fallible parser [Word8] getVarBytes =    do       digit <- getByte@@ -96,12 +96,12 @@         else return [digit]  -getEnum :: (Parser.C parser, Enum enum, Bounded enum) => parser enum+getEnum :: (Parser.C parser, Enum enum, Bounded enum) => Parser.Fallible parser enum getEnum = makeEnum =<< get1 -makeEnum :: (Parser.C parser, Enum enum, Bounded enum) => Int -> parser enum+makeEnum :: (Parser.C parser, Enum enum, Bounded enum) => Int -> Parser.Fallible parser enum makeEnum n =-   let go :: (Parser.C parser, Enum a) => a -> a -> parser a+   let go :: (Parser.C parser, Enum a) => a -> a -> Parser.Fallible parser a        go lower upper =           if fromEnum lower <= n && n <= fromEnum upper             then return (toEnum n)
src/Sound/MIDI/Parser/Restricted.hs view
@@ -4,13 +4,14 @@ where the length of a part is fixed by a length specification. -} module Sound.MIDI.Parser.Restricted-   (T(..), run, ) where+   (T(..), run, runFallible, ) where  import qualified Sound.MIDI.Parser.Class as Parser -import Control.Monad.State-   (StateT(StateT, runStateT), mapStateT,-    get, put, liftM, lift, when, )+import qualified Control.Monad.Exception.Synchronous  as Sync+import qualified Control.Monad.Trans as Trans+import qualified Control.Monad.State as State+import Control.Monad.State (StateT(runStateT), gets, get, put, when, )  import qualified Numeric.NonNegative.Wrapper as NonNeg @@ -21,13 +22,21 @@    NonNeg.Integer -> T parser a -> parser a run maxLen p =    do (x,remaining) <- runStateT (decons p) maxLen-      Parser.force $ when+      Parser.warnIf          (remaining>0)-         (Parser.warn ("unparsed bytes left in part (" ++ show remaining ++ " bytes)"))+         ("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)  +lift :: Monad parser => Parser.Fallible parser a -> Parser.Fallible (T parser) a+lift = Sync.mapExceptionalT State.lift+++ newtype T parser a =    Cons {decons :: StateT NonNeg.Integer parser a} @@ -35,12 +44,28 @@    return = Cons . return    x >>= y = Cons $ decons . y =<< decons x -instance Parser.C parser => Parser.C (T parser) where+instance Trans.MonadTrans T where+   lift = Cons . State.lift+++getRemaining :: Monad parser => Parser.Fallible (T parser) NonNeg.Integer+getRemaining = Trans.lift $ Cons get++putRemaining :: Monad parser => NonNeg.Integer -> Parser.Fallible (T parser) ()+putRemaining = Trans.lift . Cons . put+++instance Parser.EndCheck parser => Parser.EndCheck (T parser) where    isEnd =-     Cons $ get >>= \remaining ->-       if remaining==0 then return True else lift Parser.isEnd+     {- if remaining>0 then we do not check+        whether there are actually more bytes in the stream+        because that will be catched anyway on the next getByte or skip -}+     Cons (gets (0==))+--       if remaining==0 then return True else lift Parser.isEnd++instance Parser.C parser => Parser.C (T parser) where    getByte =-     Cons $ get >>= \remaining ->+     getRemaining >>= \remaining ->        do when (remaining==0)              (lift $ Parser.giveUp "unexpected end of part") {- in principle not necessary, because Parser.getByte must check for remaining bytes@@ -48,23 +73,14 @@           when end              (lift $ Parser.giveUp "part longer than container") -}-          put (remaining-1)+          putRemaining (remaining-1)           lift Parser.getByte+    skip n =-     Cons $ get >>= \remaining ->+     getRemaining >>= \remaining ->        if n>remaining          then lift $ Parser.giveUp "skip beyond end of part"-         else put (remaining-n) >> lift (Parser.skip n)-   warn   = Cons . lift . Parser.warn-   -- giveUp = Cons . lift . giveUp-   giveUp errMsg =-      Cons $ StateT $ \remain ->-         Parser.skip remain >> Parser.giveUp errMsg-   try (Cons st) =-      Cons $ StateT $ \remain0 ->-         liftM (either-                 (\errMsg -> (Left errMsg, 0))-                 (\(x,remain1) -> (Right x, remain1))) $-         Parser.try (runStateT st remain0)-   force (Cons st) =-      Cons $ mapStateT Parser.force st+         else putRemaining (remaining-n) >>+              lift (Parser.skip n)++   warn = Cons . Trans.lift . Parser.warn
− src/Sound/MIDI/Parser/State.hs 
@@ -1,56 +0,0 @@-{- |-Very similar to "Sound.MIDI.Parser".--}-module Sound.MIDI.Parser.State-   (T, zeroOrMore, StateT(..), ) where--import qualified Sound.MIDI.Parser.Class as Parser--import Control.Monad.State (StateT(..), mapStateT, liftM, liftM2, lift, )---type T st parser = StateT st parser---force :: Parser.C parser =>-   T st parser a -> T st parser a-force = mapStateT Parser.force--zeroOrMore :: Parser.C parser =>-   T st parser a -> T st parser (Parser.PossiblyIncomplete [a])-zeroOrMore p =-   let go =-         force $ isEnd >>= \b ->-            if b-              then return (Nothing, [])-              else handleMsg-                      (\errMsg -> (Just errMsg, []))-                      (liftM2 (\ x ~(e,xs) -> (e,x:xs)) p go)-   in  go--{--zeroOrMore :: T st [byte] a -> T st [byte] [a]-zeroOrMore p =-   let go =-         isEnd >>= \b ->-            if b-              then return []-              else liftM2 (:) p go-   in  go--}--{- |-In case of an exception, the handler restores the old state.--}-handleMsg :: Parser.C parser =>-   (Parser.UserMessage -> a) -> T st parser a -> T st parser a-handleMsg handler action =-   StateT $ \s ->-      liftM-         (either (\e -> (handler e, s)) id)-         (Parser.try (runStateT action s))---isEnd :: Parser.C parser =>-   T st parser Bool-isEnd = lift $ Parser.isEnd
src/Sound/MIDI/Parser/Status.hs view
@@ -4,12 +4,13 @@ The running state consists of a message code and the message channel. -} module Sound.MIDI.Parser.Status-   (T, Status, set, get, run, State.lift,+   (T, Status, set, get, run, lift,     Channel, fromChannel,   toChannel, ) where -import qualified Sound.MIDI.Parser.State as ParserState+import qualified Sound.MIDI.Parser.Class as Parser -import Control.Monad.State (evalStateT, )+import qualified Control.Monad.Exception.Synchronous  as Sync+import Control.Monad.State (StateT, evalStateT, ) import qualified Control.Monad.State as State  import Sound.MIDI.Utility (checkRange, )@@ -25,19 +26,23 @@ the parser must keep track of the type and channel of the most recent MIDI Event. This is done by managing a 'Status' in the parser. -}-type T parser a = ParserState.T Status parser a+type T parser = StateT Status parser  type Status = Maybe (Int,Channel)  -set :: Monad parser => Status -> T parser ()-set = State.put+set :: Monad parser => Status -> Parser.Fallible (T parser) ()+set = State.lift . State.put -get :: Monad parser => T parser Status-get = State.get+get :: Monad parser => Parser.Fallible (T parser) Status+get = State.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 = Sync.mapExceptionalT State.lift   -- * Channel definition
src/Sound/MIDI/Parser/Stream.hs view
@@ -1,17 +1,22 @@ module Sound.MIDI.Parser.Stream    (T(..), run, runIncomplete, runPartial,     ByteList(..),-    PossiblyIncomplete, UserMessage, processReport, ) where+    PossiblyIncomplete, UserMessage, ) where   import Control.Monad.State    (State(runState), evalState,     get, put, liftM, when, )+import Control.Monad.Trans (lift, )  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)@@ -27,20 +32,22 @@ 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 :: State str (Report.T a)}+newtype T str a =+   Cons {decons :: Warning.T (State str) a}   -runPartial :: T str a -> str -> (Report.T a, str)+runPartial :: Parser.Fallible (T str) a -> str -> (Report.T a, str) runPartial parser input =-   flip runState input (decons parser)+   flip runState input $ Warning.run $ decons $ Exception.run parser -run :: ByteStream str => T str a -> str -> Report.T a+run :: ByteStream str => Parser.Fallible (T str) a -> str -> Report.T a run parser input =-   flip evalState input $ decons $+   flip evalState input $ Warning.run $ decons $ Exception.run $       (do a <- parser-          end <- Parser.isEnd-          Parser.force $ when (not end) (warn "unparsed data left over")+          lift $+             Parser.isEnd >>= \end ->+                Parser.warnIf (not end) "unparsed data left over"           return a)  {- |@@ -49,36 +56,23 @@ and thus further parsing is not possible. -} runIncomplete :: ByteStream str =>-   T str (PossiblyIncomplete a) -> str -> Report.T a+   Parser.Partial (Parser.Fallible (T str)) a -> str -> Report.T a runIncomplete parser input =    flip run input $-      do (me,x) <- parser-         Parser.force $ maybe (return ()) warn me-         return x+      lift . Parser.warnIncomplete =<< parser    fromState :: State str a -> T str a fromState p =-   Cons $ liftM (\a -> Report.Cons [] (Right a)) p+   Cons $ lift p   instance Monad (T str) where-   return x = fromState $ return x-   x >>= y  = Cons $-      decons x >>= \ a ->-         case Report.result a of-            Left err -> return (Report.Cons (Report.warnings a) (Left err))-            Right ar ->-               liftM (\b ->---                  b{Report.warnings = Report.warnings a ++ Report.warnings b}-                  -- more lazy-                  Report.Cons-                     (Report.warnings a ++ Report.warnings b)-                     (Report.result b)-                  ) $-               decons (y ar)+   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@@ -92,67 +86,27 @@          _ -> n    drop n (ByteList xs) = ByteList $ List.genericDrop n xs -instance ByteStream str => Parser.C (T str) where+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-         (giveUp "unexpected end of data")-         (\s ss -> fromState (put ss) >> return s) =<<-      fromState get+         (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 <- fromState get+      do s <- lift $ fromState get          switchL             (Parser.giveUp "skip past end of part")-            (\ _ rest -> fromState $ put rest)+            (\ _ rest -> lift $ fromState $ put rest)             (drop (n-1) s)-   warn   = warn-   giveUp = giveUp-   try    = try-   force  = force --warn :: String -> T str ()-warn text =-   Cons $ return $ Report.Cons [text] (Right ())--giveUp :: String -> T str a-giveUp text =-   Cons $ return $ Report.Cons [] (Left text)--try :: T str a -> T str (Either UserMessage a)-try =-   -- more lazy-   Cons .-   liftM (\r -> Report.Cons (Report.warnings r) (Right (Report.result r))) .-   -- liftM (\r -> r{Report.result = Right (Report.result r)}) .-   decons---{- |-Wadler's force function--'force' guarantees that the parser does not fail.-Thus it makes parsing more lazy.-However if the original parser fails though,-then we get an unrecoverable /irrefutable pattern/ error on 'Just'.--}-force :: T str a -> T str a-force p =-   Cons $-     do ~(Report.Cons w ~(Right x)) <- decons p-        return (Report.Cons w (Right x))---{- |-Emit all Report.warnings and throw the error from the report.--}-processReport :: Report.T a -> T str a-processReport report =-   mapM_ warn (Report.warnings report) >>-   either giveUp return (Report.result report)+   warn = Cons . Warning.warn   {-
+ src/Sound/MIDI/Parser/Warning.hs view
@@ -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.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]
test/Main.hs view
@@ -28,6 +28,7 @@ import qualified Data.List as List  import Sound.MIDI.Utility (viewR, dropMatch, )+import Control.Monad.Trans (lift, ) import Control.Monad (when, )  import System.Random (mkStdGen, randomR, )@@ -150,7 +151,7 @@ lazinessZeroOrMoreByteList :: NonNeg.Int -> Int -> Bool lazinessZeroOrMoreByteList pos byte =    let result =-          Report.result $ StreamParser.runIncomplete (Parser.zeroOrMore Parser.getByte) $+          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