ByteString.hs

{-
This module Sound.MIDI.Parser.Stream share significant portions of code.
-}
module Sound.MIDI.Parser.ByteString
   (T(..), run, runIncomplete, {- runPartial, -}
    PossiblyIncomplete, UserMessage, ) where


import qualified Data.ByteString.Lazy as B
import qualified Data.Binary.Get as Binary
import Data.Binary.Get (Get, runGet, )

import Control.Monad (liftM, when, )

import qualified Sound.MIDI.Parser.Class as Parser
import Sound.MIDI.Parser.Class (UserMessage, PossiblyIncomplete, )
import qualified Sound.MIDI.Parser.Report as Report

-- import Data.Word (Word8)

import Data.Int (Int64)
import qualified Numeric.NonNegative.Wrapper as NonNeg

import Prelude hiding (replicate, until, )



newtype T a = Cons {decons :: Get (Report.T a)}


{-
runPartial :: T a -> B.ByteString -> (Report.T a, B.ByteString)
runPartial parser input =
   flip runGetState input (decons parser)
-}


run :: T a -> B.ByteString -> Report.T a
run parser input =
   flip runGet input $ decons $
      (do a <- parser
          end <- Parser.isEnd
          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 ::
   T (PossiblyIncomplete a) -> B.ByteString -> Report.T a
runIncomplete parser input =
   flip run input $
      do (me,x) <- parser
         maybe (return ()) warn me
         return x


fromGet :: Get a -> T a
fromGet p =
   Cons $ liftM (\a -> Report.Cons [] (Right a)) 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})

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
   getByte =
      do end <- fromGet Binary.isEmpty
         if end
           then giveUp "unexpected end of ByteString"
           else 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 contrast to Binary.skip this one does not fail badly and it works with Int64.
I hope that it is not too inefficient.
-}
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))