module Sound.MIDI.Parser.Stream (T(..), run, runIncomplete, runPartial, ByteList(..), PossiblyIncomplete, UserMessage, processReport, ) where import Control.Monad.State (State(runState), evalState, get, put, 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.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 :: State str (Report.T a)} runPartial :: T str a -> str -> (Report.T a, str) runPartial parser input = flip runState input (decons parser) run :: ByteStream str => T str a -> str -> Report.T a run parser input = flip evalState input $ decons $ (do a <- parser end <- Parser.isEnd Parser.force $ when (not end) (warn "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 => T str (PossiblyIncomplete a) -> str -> Report.T a runIncomplete parser input = flip run input $ do (me,x) <- parser Parser.force $ maybe (return ()) warn me return x fromState :: State str a -> T str a fromState p = Cons $ liftM (\a -> Report.Cons [] (Right a)) 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) 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.C (T str) where isEnd = fromState $ liftM (switchL True (\ _ _ -> False)) get getByte = switchL (giveUp "unexpected end of data") (\s ss -> fromState (put ss) >> return s) =<< fromState get {- skip n = sequence_ (genericReplicate n Parser.getByte) -} skip n = when (n>0) $ do s <- fromState get switchL (Parser.giveUp "skip past end of part") (\ _ rest -> 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) {- 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) -}