{-
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.Trans.Class (lift, )
import Control.Monad (liftM, 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 Data.Int (Int64)
import qualified Numeric.NonNegative.Wrapper as NonNeg

import Prelude hiding (replicate, until, )



newtype T a = Cons {T a -> T Get a
decons :: Warning.T Get a}


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


run :: Parser.Fragile T a -> B.ByteString -> Report.T a
run :: Fragile T a -> ByteString -> T a
run Fragile T a
parser ByteString
input =
   (Get (T a) -> ByteString -> T a) -> ByteString -> Get (T a) -> T a
forall a b c. (a -> b -> c) -> b -> a -> c
flip Get (T a) -> ByteString -> T a
forall a. Get a -> ByteString -> a
runGet ByteString
input (Get (T a) -> T a) -> Get (T a) -> T a
forall a b. (a -> b) -> a -> b
$ T Get (Exceptional UserMessage a) -> Get (T a)
forall (m :: * -> *) a.
Monad m =>
T m (Exceptional UserMessage a) -> m (T a)
Warning.run (T Get (Exceptional UserMessage a) -> Get (T a))
-> T Get (Exceptional UserMessage a) -> Get (T a)
forall a b. (a -> b) -> a -> b
$ T (Exceptional UserMessage a) -> T Get (Exceptional UserMessage a)
forall a. T a -> T Get a
decons (T (Exceptional UserMessage a)
 -> T Get (Exceptional UserMessage a))
-> T (Exceptional UserMessage a)
-> T Get (Exceptional UserMessage a)
forall a b. (a -> b) -> a -> b
$ Fragile T a -> T (Exceptional UserMessage a)
forall (m :: * -> *) a.
Monad m =>
T m a -> m (Exceptional UserMessage a)
Exception.run (Fragile T a -> T (Exceptional UserMessage a))
-> Fragile T a -> T (Exceptional UserMessage a)
forall a b. (a -> b) -> a -> b
$
      (do a
a <- Fragile T a
parser
          T () -> ExceptionalT UserMessage T ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (T () -> ExceptionalT UserMessage T ())
-> T () -> ExceptionalT UserMessage T ()
forall a b. (a -> b) -> a -> b
$
             T Bool
forall (parser :: * -> *). EndCheck parser => parser Bool
Parser.isEnd T Bool -> (Bool -> T ()) -> T ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
end ->
                Bool -> UserMessage -> T ()
forall (parser :: * -> *).
C parser =>
Bool -> UserMessage -> parser ()
Parser.warnIf (Bool -> Bool
not Bool
end) UserMessage
"unparsed data left over"
          a -> Fragile T a
forall (m :: * -> *) a. Monad m => a -> m a
return a
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 ::
   Parser.Partial (Parser.Fragile T) a -> B.ByteString -> Report.T a
runIncomplete :: Partial (Fragile T) a -> ByteString -> T a
runIncomplete Partial (Fragile T) a
parser ByteString
input =
   (Fragile T a -> ByteString -> T a)
-> ByteString -> Fragile T a -> T a
forall a b c. (a -> b -> c) -> b -> a -> c
flip Fragile T a -> ByteString -> T a
forall a. Fragile T a -> ByteString -> T a
run ByteString
input (Fragile T a -> T a) -> Fragile T a -> T a
forall a b. (a -> b) -> a -> b
$
      T a -> Fragile T a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (T a -> Fragile T a)
-> (PossiblyIncomplete a -> T a)
-> PossiblyIncomplete a
-> Fragile T a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PossiblyIncomplete a -> T a
forall (parser :: * -> *) a.
C parser =>
PossiblyIncomplete a -> parser a
Parser.warnIncomplete (PossiblyIncomplete a -> Fragile T a)
-> Partial (Fragile T) a -> Fragile T a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Partial (Fragile T) a
parser


fromGet :: Get a -> T a
fromGet :: Get a -> T a
fromGet Get a
p =
   T Get a -> T a
forall a. T Get a -> T a
Cons (T Get a -> T a) -> T Get a -> T a
forall a b. (a -> b) -> a -> b
$ Get a -> T Get a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Get a
p


instance Functor T where
   fmap :: (a -> b) -> T a -> T b
fmap = (a -> b) -> T a -> T b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM

instance Applicative T where
   pure :: a -> T a
pure = a -> T a
forall (m :: * -> *) a. Monad m => a -> m a
return
   <*> :: T (a -> b) -> T a -> T b
(<*>) = T (a -> b) -> T a -> T b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad T where
   return :: a -> T a
return = T Get a -> T a
forall a. T Get a -> T a
Cons (T Get a -> T a) -> (a -> T Get a) -> a -> T a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> T Get a
forall (m :: * -> *) a. Monad m => a -> m a
return
   T a
x >>= :: T a -> (a -> T b) -> T b
>>= a -> T b
y = T Get b -> T b
forall a. T Get a -> T a
Cons (T Get b -> T b) -> T Get b -> T b
forall a b. (a -> b) -> a -> b
$ T b -> T Get b
forall a. T a -> T Get a
decons (T b -> T Get b) -> (a -> T b) -> a -> T Get b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> T b
y (a -> T Get b) -> WriterT [UserMessage] Get a -> T Get b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< T a -> WriterT [UserMessage] Get a
forall a. T a -> T Get a
decons T a
x


instance Parser.EndCheck T where
   isEnd :: T Bool
isEnd = Get Bool -> T Bool
forall a. Get a -> T a
fromGet Get Bool
Binary.isEmpty

instance Parser.C T where
--   getByte = fromGet Binary.getWord8
-- a get getMaybeWord8 would be nice in order to avoid double-checking
   getByte :: Fragile T Word8
getByte =
      do Bool
end <- T Bool -> ExceptionalT UserMessage T Bool
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (T Bool -> ExceptionalT UserMessage T Bool)
-> T Bool -> ExceptionalT UserMessage T Bool
forall a b. (a -> b) -> a -> b
$ Get Bool -> T Bool
forall a. Get a -> T a
fromGet Get Bool
Binary.isEmpty
         if Bool
end
           then UserMessage -> Fragile T Word8
forall (m :: * -> *) a. Monad m => UserMessage -> T m a
Parser.giveUp UserMessage
"unexpected end of ByteString"
           else T Word8 -> Fragile T Word8
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (T Word8 -> Fragile T Word8) -> T Word8 -> Fragile T Word8
forall a b. (a -> b) -> a -> b
$ Get Word8 -> T Word8
forall a. Get a -> T a
fromGet Get Word8
Binary.getWord8

   skip :: Integer -> ExceptionalT UserMessage T ()
skip Integer
n =
      let toSize :: a -> a
toSize a
x =
            let y :: a
y = if a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a
forall a. Bounded a => a
maxBound a -> a -> a
forall a. a -> a -> a
`asTypeOf` a
y)
                      then UserMessage -> a
forall a. HasCallStack => UserMessage -> a
error UserMessage
"skip: number too big"
                      else a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
x
            in  a
y
      in  T () -> ExceptionalT UserMessage T ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (T () -> ExceptionalT UserMessage T ())
-> T () -> ExceptionalT UserMessage T ()
forall a b. (a -> b) -> a -> b
$ Get () -> T ()
forall a. Get a -> T a
fromGet (Get () -> T ()) -> Get () -> T ()
forall a b. (a -> b) -> a -> b
$ Int64 -> Get ()
skip (Int64 -> Get ()) -> Int64 -> Get ()
forall a b. (a -> b) -> a -> b
$ Integer -> Int64
forall a a. (Bounded a, Integral a, Integral a) => a -> a
toSize (Integer -> Int64) -> Integer -> Int64
forall a b. (a -> b) -> a -> b
$ Integer -> Integer
forall a. T a -> a
NonNeg.toNumber Integer
n

   warn :: UserMessage -> T ()
warn = T Get () -> T ()
forall a. T Get a -> T a
Cons (T Get () -> T ())
-> (UserMessage -> T Get ()) -> UserMessage -> T ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UserMessage -> T Get ()
forall (m :: * -> *). Monad m => UserMessage -> T m ()
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.
-}
skip :: Int64 -> Get ()
skip :: Int64 -> Get ()
skip Int64
n = Int64 -> Get ByteString
Binary.getLazyByteString Int64
n Get ByteString -> Get () -> Get ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> Get ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
-- Binary.skip n