Stream.hs

module Sound.MIDI.Parser.Stream
   (T(..), run, runIncomplete, runPartial,
    ByteList(..),
    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)
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)
-}