{- |
Parser which limits the input data to a given number of bytes.
We need this for parsing MIDI tracks and some MetaEvents,
where the length of a part is fixed by a length specification.
-}
module Sound.MIDI.Parser.Restricted
   (T(..), run, runFragile, ) where

import qualified Sound.MIDI.Parser.Class as Parser

import qualified Control.Monad.Exception.Synchronous  as Sync
import qualified Control.Monad.Trans.Class as Trans
import Control.Monad.Trans.State (StateT(runStateT), gets, get, put, )
import Control.Monad (when, )
import Control.Applicative (Applicative, pure, (<*>), )

import qualified Numeric.NonNegative.Wrapper as NonNeg

import Prelude hiding (replicate, until, )


run :: Parser.C parser =>
   NonNeg.Integer -> T parser a -> parser a
run :: Integer -> T parser a -> parser a
run Integer
maxLen T parser a
p =
   do (a
x,Integer
remaining) <- StateT Integer parser a -> Integer -> parser (a, Integer)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (T parser a -> StateT Integer parser a
forall (parser :: * -> *) a. T parser a -> StateT Integer parser a
decons T parser a
p) Integer
maxLen
      Bool -> UserMessage -> parser ()
forall (parser :: * -> *).
C parser =>
Bool -> UserMessage -> parser ()
Parser.warnIf
         (Integer
remainingInteger -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>Integer
0)
         (UserMessage
"unparsed bytes left in part (" UserMessage -> UserMessage -> UserMessage
forall a. [a] -> [a] -> [a]
++ Integer -> UserMessage
forall a. Show a => a -> UserMessage
show Integer
remaining UserMessage -> UserMessage -> UserMessage
forall a. [a] -> [a] -> [a]
++ UserMessage
" bytes)")
      a -> parser a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x

runFragile :: Parser.C parser =>
   NonNeg.Integer -> Parser.Fragile (T parser) a -> Parser.Fragile parser a
runFragile :: Integer -> Fragile (T parser) a -> Fragile parser a
runFragile Integer
len = (T parser (Exceptional UserMessage a)
 -> parser (Exceptional UserMessage a))
-> Fragile (T parser) a -> Fragile parser a
forall (m :: * -> *) e0 a (n :: * -> *) e1 b.
(m (Exceptional e0 a) -> n (Exceptional e1 b))
-> ExceptionalT e0 m a -> ExceptionalT e1 n b
Sync.mapExceptionalT (Integer
-> T parser (Exceptional UserMessage a)
-> parser (Exceptional UserMessage a)
forall (parser :: * -> *) a.
C parser =>
Integer -> T parser a -> parser a
run Integer
len)


lift :: Monad parser => Parser.Fragile parser a -> Parser.Fragile (T parser) a
lift :: Fragile parser a -> Fragile (T parser) a
lift = (parser (Exceptional UserMessage a)
 -> T parser (Exceptional UserMessage a))
-> Fragile parser a -> Fragile (T parser) a
forall (m :: * -> *) e0 a (n :: * -> *) e1 b.
(m (Exceptional e0 a) -> n (Exceptional e1 b))
-> ExceptionalT e0 m a -> ExceptionalT e1 n b
Sync.mapExceptionalT parser (Exceptional UserMessage a)
-> T parser (Exceptional UserMessage a)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift



newtype T parser a =
   Cons {T parser a -> StateT Integer parser a
decons :: StateT NonNeg.Integer parser a}

instance Functor parser => Functor (T parser) where
   fmap :: (a -> b) -> T parser a -> T parser b
fmap a -> b
f = StateT Integer parser b -> T parser b
forall (parser :: * -> *) a. StateT Integer parser a -> T parser a
Cons (StateT Integer parser b -> T parser b)
-> (T parser a -> StateT Integer parser b)
-> T parser a
-> T parser b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b) -> StateT Integer parser a -> StateT Integer parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (StateT Integer parser a -> StateT Integer parser b)
-> (T parser a -> StateT Integer parser a)
-> T parser a
-> StateT Integer parser b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. T parser a -> StateT Integer parser a
forall (parser :: * -> *) a. T parser a -> StateT Integer parser a
decons

instance (Applicative parser, Monad parser) => Applicative (T parser) where
   pure :: a -> T parser a
pure = StateT Integer parser a -> T parser a
forall (parser :: * -> *) a. StateT Integer parser a -> T parser a
Cons (StateT Integer parser a -> T parser a)
-> (a -> StateT Integer parser a) -> a -> T parser a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> StateT Integer parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
   Cons StateT Integer parser (a -> b)
f <*> :: T parser (a -> b) -> T parser a -> T parser b
<*> Cons StateT Integer parser a
a = StateT Integer parser b -> T parser b
forall (parser :: * -> *) a. StateT Integer parser a -> T parser a
Cons (StateT Integer parser b -> T parser b)
-> StateT Integer parser b -> T parser b
forall a b. (a -> b) -> a -> b
$ StateT Integer parser (a -> b)
f StateT Integer parser (a -> b)
-> StateT Integer parser a -> StateT Integer parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StateT Integer parser a
a

instance Monad parser => Monad (T parser) where
   return :: a -> T parser a
return = StateT Integer parser a -> T parser a
forall (parser :: * -> *) a. StateT Integer parser a -> T parser a
Cons (StateT Integer parser a -> T parser a)
-> (a -> StateT Integer parser a) -> a -> T parser a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> StateT Integer parser a
forall (m :: * -> *) a. Monad m => a -> m a
return
   T parser a
x >>= :: T parser a -> (a -> T parser b) -> T parser b
>>= a -> T parser b
y = StateT Integer parser b -> T parser b
forall (parser :: * -> *) a. StateT Integer parser a -> T parser a
Cons (StateT Integer parser b -> T parser b)
-> StateT Integer parser b -> T parser b
forall a b. (a -> b) -> a -> b
$ T parser b -> StateT Integer parser b
forall (parser :: * -> *) a. T parser a -> StateT Integer parser a
decons (T parser b -> StateT Integer parser b)
-> (a -> T parser b) -> a -> StateT Integer parser b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> T parser b
y (a -> StateT Integer parser b)
-> StateT Integer parser a -> StateT Integer parser b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< T parser a -> StateT Integer parser a
forall (parser :: * -> *) a. T parser a -> StateT Integer parser a
decons T parser a
x

instance Trans.MonadTrans T where
   lift :: m a -> T m a
lift = StateT Integer m a -> T m a
forall (parser :: * -> *) a. StateT Integer parser a -> T parser a
Cons (StateT Integer m a -> T m a)
-> (m a -> StateT Integer m a) -> m a -> T m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> StateT Integer m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift


getRemaining :: Monad parser => Parser.Fragile (T parser) NonNeg.Integer
getRemaining :: Fragile (T parser) Integer
getRemaining = T parser Integer -> Fragile (T parser) Integer
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift (T parser Integer -> Fragile (T parser) Integer)
-> T parser Integer -> Fragile (T parser) Integer
forall a b. (a -> b) -> a -> b
$ StateT Integer parser Integer -> T parser Integer
forall (parser :: * -> *) a. StateT Integer parser a -> T parser a
Cons StateT Integer parser Integer
forall (m :: * -> *) s. Monad m => StateT s m s
get

putRemaining :: Monad parser => NonNeg.Integer -> Parser.Fragile (T parser) ()
putRemaining :: Integer -> Fragile (T parser) ()
putRemaining = T parser () -> Fragile (T parser) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift (T parser () -> Fragile (T parser) ())
-> (Integer -> T parser ()) -> Integer -> Fragile (T parser) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT Integer parser () -> T parser ()
forall (parser :: * -> *) a. StateT Integer parser a -> T parser a
Cons (StateT Integer parser () -> T parser ())
-> (Integer -> StateT Integer parser ()) -> Integer -> T parser ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> StateT Integer parser ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put


instance Parser.EndCheck parser => Parser.EndCheck (T parser) where
   isEnd :: T parser Bool
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 -}
     StateT Integer parser Bool -> T parser Bool
forall (parser :: * -> *) a. StateT Integer parser a -> T parser a
Cons ((Integer -> Bool) -> StateT Integer parser Bool
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets (Integer
0Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
==))
--       if remaining==0 then return True else lift Parser.isEnd

instance Parser.C parser => Parser.C (T parser) where
   getByte :: Fragile (T parser) Word8
getByte =
     Fragile (T parser) Integer
forall (parser :: * -> *).
Monad parser =>
Fragile (T parser) Integer
getRemaining Fragile (T parser) Integer
-> (Integer -> Fragile (T parser) Word8)
-> Fragile (T parser) Word8
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Integer
remaining ->
       do Bool -> Fragile (T parser) () -> Fragile (T parser) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Integer
remainingInteger -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
==Integer
0)
             (Fragile parser () -> Fragile (T parser) ()
forall (parser :: * -> *) a.
Monad parser =>
Fragile parser a -> Fragile (T parser) a
lift (Fragile parser () -> Fragile (T parser) ())
-> Fragile parser () -> Fragile (T parser) ()
forall a b. (a -> b) -> a -> b
$ UserMessage -> Fragile parser ()
forall (m :: * -> *) a. Monad m => UserMessage -> T m a
Parser.giveUp UserMessage
"unexpected end of part")
{- in principle not necessary, because Parser.getByte must check for remaining bytes
          end <- lift Parser.isEnd
          when end
             (lift $ Parser.giveUp "part longer than container")
-}
          Integer -> Fragile (T parser) ()
forall (parser :: * -> *).
Monad parser =>
Integer -> Fragile (T parser) ()
putRemaining (Integer
remainingInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
1)
          Fragile parser Word8 -> Fragile (T parser) Word8
forall (parser :: * -> *) a.
Monad parser =>
Fragile parser a -> Fragile (T parser) a
lift Fragile parser Word8
forall (parser :: * -> *). C parser => Fragile parser Word8
Parser.getByte

   skip :: Integer -> Fragile (T parser) ()
skip Integer
n =
     Fragile (T parser) Integer
forall (parser :: * -> *).
Monad parser =>
Fragile (T parser) Integer
getRemaining Fragile (T parser) Integer
-> (Integer -> Fragile (T parser) ()) -> Fragile (T parser) ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Integer
remaining ->
       if Integer
nInteger -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>Integer
remaining
         then Fragile parser () -> Fragile (T parser) ()
forall (parser :: * -> *) a.
Monad parser =>
Fragile parser a -> Fragile (T parser) a
lift (Fragile parser () -> Fragile (T parser) ())
-> Fragile parser () -> Fragile (T parser) ()
forall a b. (a -> b) -> a -> b
$ UserMessage -> Fragile parser ()
forall (m :: * -> *) a. Monad m => UserMessage -> T m a
Parser.giveUp UserMessage
"skip beyond end of part"
         else Integer -> Fragile (T parser) ()
forall (parser :: * -> *).
Monad parser =>
Integer -> Fragile (T parser) ()
putRemaining (Integer
remainingInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
n) Fragile (T parser) ()
-> Fragile (T parser) () -> Fragile (T parser) ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
              Fragile parser () -> Fragile (T parser) ()
forall (parser :: * -> *) a.
Monad parser =>
Fragile parser a -> Fragile (T parser) a
lift (Integer -> Fragile parser ()
forall (parser :: * -> *). C parser => Integer -> Fragile parser ()
Parser.skip Integer
n)

   warn :: UserMessage -> T parser ()
warn = StateT Integer parser () -> T parser ()
forall (parser :: * -> *) a. StateT Integer parser a -> T parser a
Cons (StateT Integer parser () -> T parser ())
-> (UserMessage -> StateT Integer parser ())
-> UserMessage
-> T parser ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. parser () -> StateT Integer parser ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift (parser () -> StateT Integer parser ())
-> (UserMessage -> parser ())
-> UserMessage
-> StateT Integer parser ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UserMessage -> parser ()
forall (parser :: * -> *). C parser => UserMessage -> parser ()
Parser.warn