module Sound.MIDI.Parser.Class
   (EndCheck, isEnd,
    C, getByte, skip,
    warn, warnIf, warnIncomplete, Exc.giveUp, Exc.try,
    until, zeroOrMore, zeroOrMoreInc, replicate,
    emptyList, PossiblyIncomplete, UserMessage,
    Fragile, Partial,
    {- for debugging
    absorbException, appendIncomplete,
    -}
    ) where


import Sound.MIDI.Parser.Report (UserMessage)
import qualified Sound.MIDI.Parser.Exception as Exc
import qualified Control.Monad.Exception.Asynchronous as Async
import qualified Control.Monad.Exception.Synchronous  as Sync

import Control.Monad.Trans.Class (lift, )
import Control.Monad.Trans.State (StateT, )
import Control.Monad (liftM, liftM2, when, )

import Data.Word (Word8)

import qualified Numeric.NonNegative.Wrapper as NonNeg

import Prelude hiding (replicate, until, )



class Monad parser => EndCheck parser where
   isEnd   :: parser Bool

-- would be probably better placed in Parser.Status
instance EndCheck parser => EndCheck (StateT st parser) where
   isEnd :: StateT st parser Bool
isEnd = parser Bool -> StateT st parser Bool
forall (m :: * -> *) a. Monad m => m a -> StateT st m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (parser Bool -> StateT st parser Bool)
-> parser Bool -> StateT st parser Bool
forall a b. (a -> b) -> a -> b
$ parser Bool
forall (parser :: * -> *). EndCheck parser => parser Bool
isEnd


class EndCheck parser => C parser where
   getByte :: Fragile parser Word8
   skip    :: NonNeg.Integer -> Fragile parser ()
   warn    :: UserMessage -> parser ()


{- |
@PossiblyIncomplete@ represents a value like a list
that can be the result of an incomplete parse.
The case of an incomplete parse is indicated by @Just message@.

It is not possible to merge this functionality in the parser monad,
because then it is not possible to define monadic binding.
-}
type PossiblyIncomplete a = Async.Exceptional UserMessage a


type Fragile parser   = Sync.ExceptionalT UserMessage parser
type Partial  parser a = parser (PossiblyIncomplete a)


warnIf :: C parser => Bool -> UserMessage -> parser ()
warnIf :: forall (parser :: * -> *).
C parser =>
Bool -> UserMessage -> parser ()
warnIf Bool
b UserMessage
msg = Bool -> parser () -> parser ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
b (UserMessage -> parser ()
forall (parser :: * -> *). C parser => UserMessage -> parser ()
warn UserMessage
msg)

{- |
Emit a warning if a value is said to be incomplete.
Be careful using this function,
because an incomplete value often means
that subsequent parse actions will process data from the wrong position.
Only use this function if you
either know that the parse is complete also if the parsed value is incomplete
or if there are no subsequent parse actions to run.

This function cannot fail.
-}
warnIncomplete :: C parser => PossiblyIncomplete a -> parser a
warnIncomplete :: forall (parser :: * -> *) a.
C parser =>
PossiblyIncomplete a -> parser a
warnIncomplete ~(Async.Exceptional Maybe UserMessage
me a
a) =
   do parser ()
-> (UserMessage -> parser ()) -> Maybe UserMessage -> parser ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> parser ()
forall a. a -> parser a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) UserMessage -> parser ()
forall (parser :: * -> *). C parser => UserMessage -> parser ()
warn Maybe UserMessage
me
      a -> parser a
forall a. a -> parser a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a


{- |
This function will never fail.
If the element parser fails somewhere,
a prefix of the complete list is returned
along with the error message.
-}
zeroOrMore :: EndCheck parser =>
   Fragile parser a -> Partial parser [a]
zeroOrMore :: forall (parser :: * -> *) a.
EndCheck parser =>
Fragile parser a -> Partial parser [a]
zeroOrMore Fragile parser a
p =
   let go :: parser (PossiblyIncomplete [a])
go =
         parser Bool
forall (parser :: * -> *). EndCheck parser => parser Bool
isEnd parser Bool
-> (Bool -> parser (PossiblyIncomplete [a]))
-> parser (PossiblyIncomplete [a])
forall a b. parser a -> (a -> parser b) -> parser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
b ->
            if Bool
b
              then PossiblyIncomplete [a] -> parser (PossiblyIncomplete [a])
forall a. a -> parser a
forall (m :: * -> *) a. Monad m => a -> m a
return PossiblyIncomplete [a]
forall a. PossiblyIncomplete [a]
emptyList
              else Partial (ExceptionalT UserMessage parser) [a]
-> parser (PossiblyIncomplete [a])
forall (parser :: * -> *) a.
Monad parser =>
Partial (Fragile parser) [a] -> Partial parser [a]
absorbException
                      ((a -> PossiblyIncomplete [a] -> PossiblyIncomplete [a])
-> Fragile parser a
-> Partial (ExceptionalT UserMessage parser) [a]
-> Partial (ExceptionalT UserMessage parser) [a]
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (\ a
x -> ([a] -> [a]) -> PossiblyIncomplete [a] -> PossiblyIncomplete [a]
forall a b.
(a -> b) -> Exceptional UserMessage a -> Exceptional UserMessage b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:)) Fragile parser a
p (parser (PossiblyIncomplete [a])
-> Partial (ExceptionalT UserMessage parser) [a]
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptionalT UserMessage m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift parser (PossiblyIncomplete [a])
go))
   in  parser (PossiblyIncomplete [a])
go


zeroOrMoreInc :: EndCheck parser =>
   Partial (Fragile parser) a -> Partial parser [a]
zeroOrMoreInc :: forall (parser :: * -> *) a.
EndCheck parser =>
Partial (Fragile parser) a -> Partial parser [a]
zeroOrMoreInc Partial (Fragile parser) a
p =
   let go :: parser (PossiblyIncomplete [a])
go =
         parser Bool
forall (parser :: * -> *). EndCheck parser => parser Bool
isEnd parser Bool
-> (Bool -> parser (PossiblyIncomplete [a]))
-> parser (PossiblyIncomplete [a])
forall a b. parser a -> (a -> parser b) -> parser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
b ->
            if Bool
b
              then PossiblyIncomplete [a] -> parser (PossiblyIncomplete [a])
forall a. a -> parser a
forall (m :: * -> *) a. Monad m => a -> m a
return PossiblyIncomplete [a]
forall a. PossiblyIncomplete [a]
emptyList
              else Partial (Fragile parser) [a] -> parser (PossiblyIncomplete [a])
forall (parser :: * -> *) a.
Monad parser =>
Partial (Fragile parser) [a] -> Partial parser [a]
absorbException
                      (Partial (Fragile parser) a
-> parser (PossiblyIncomplete [a]) -> Partial (Fragile parser) [a]
forall (parser :: * -> *) a.
Monad parser =>
Partial (Fragile parser) a
-> Partial parser [a] -> Partial (Fragile parser) [a]
appendIncomplete Partial (Fragile parser) a
p parser (PossiblyIncomplete [a])
go)
   in  parser (PossiblyIncomplete [a])
go


{- |
Parse until an element is found, which matches a condition.
The terminating element is consumed by the parser
but not appended to the result list.
If the end of the input is reached without finding the terminating element,
then an Incomplete exception (Just errorMessage) is signaled.
-}
until :: EndCheck parser =>
   (a -> Bool) -> Fragile parser a -> Partial parser [a]
until :: forall (parser :: * -> *) a.
EndCheck parser =>
(a -> Bool) -> Fragile parser a -> Partial parser [a]
until a -> Bool
c Fragile parser a
p =
   let go :: parser (Exceptional UserMessage [a])
go =
         parser Bool
forall (parser :: * -> *). EndCheck parser => parser Bool
isEnd parser Bool
-> (Bool -> parser (Exceptional UserMessage [a]))
-> parser (Exceptional UserMessage [a])
forall a b. parser a -> (a -> parser b) -> parser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
b ->
            if Bool
b
              then
                Exceptional UserMessage [a] -> parser (Exceptional UserMessage [a])
forall a. a -> parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exceptional UserMessage [a]
 -> parser (Exceptional UserMessage [a]))
-> Exceptional UserMessage [a]
-> parser (Exceptional UserMessage [a])
forall a b. (a -> b) -> a -> b
$ UserMessage -> [a] -> Exceptional UserMessage [a]
forall e a. e -> a -> Exceptional e a
Async.broken
                   UserMessage
"Parser.until: unexpected end of input" []
              else
                Partial (ExceptionalT UserMessage parser) [a]
-> parser (Exceptional UserMessage [a])
forall (parser :: * -> *) a.
Monad parser =>
Partial (Fragile parser) [a] -> Partial parser [a]
absorbException (Partial (ExceptionalT UserMessage parser) [a]
 -> parser (Exceptional UserMessage [a]))
-> Partial (ExceptionalT UserMessage parser) [a]
-> parser (Exceptional UserMessage [a])
forall a b. (a -> b) -> a -> b
$
                   Fragile parser a
p Fragile parser a
-> (a -> Partial (ExceptionalT UserMessage parser) [a])
-> Partial (ExceptionalT UserMessage parser) [a]
forall a b.
ExceptionalT UserMessage parser a
-> (a -> ExceptionalT UserMessage parser b)
-> ExceptionalT UserMessage parser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
x ->
                     if a -> Bool
c a
x
                       then Exceptional UserMessage [a]
-> Partial (ExceptionalT UserMessage parser) [a]
forall a. a -> ExceptionalT UserMessage parser a
forall (m :: * -> *) a. Monad m => a -> m a
return Exceptional UserMessage [a]
forall a. PossiblyIncomplete [a]
emptyList
                       else (Exceptional UserMessage [a] -> Exceptional UserMessage [a])
-> Partial (ExceptionalT UserMessage parser) [a]
-> Partial (ExceptionalT UserMessage parser) [a]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (([a] -> [a])
-> Exceptional UserMessage [a] -> Exceptional UserMessage [a]
forall a b.
(a -> b) -> Exceptional UserMessage a -> Exceptional UserMessage b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:)) (parser (Exceptional UserMessage [a])
-> Partial (ExceptionalT UserMessage parser) [a]
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptionalT UserMessage m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift parser (Exceptional UserMessage [a])
go)
   in  parser (Exceptional UserMessage [a])
go


{- |
This function will never fail.
It may however return a list that is shorter than requested.
-}
replicate ::
   C parser =>
   NonNeg.Int ->
   Partial (Fragile parser) a ->
   Partial parser [a]
replicate :: forall (parser :: * -> *) a.
C parser =>
Int -> Partial (Fragile parser) a -> Partial parser [a]
replicate Int
m Partial (Fragile parser) a
p =
   let go :: t -> Partial parser [a]
go t
n =
         if t
nt -> t -> Bool
forall a. Eq a => a -> a -> Bool
==t
0
           then PossiblyIncomplete [a] -> Partial parser [a]
forall a. a -> parser a
forall (m :: * -> *) a. Monad m => a -> m a
return PossiblyIncomplete [a]
forall a. PossiblyIncomplete [a]
emptyList
           else Partial (Fragile parser) [a] -> Partial parser [a]
forall (parser :: * -> *) a.
Monad parser =>
Partial (Fragile parser) [a] -> Partial parser [a]
absorbException
                   (Partial (Fragile parser) a
-> Partial parser [a] -> Partial (Fragile parser) [a]
forall (parser :: * -> *) a.
Monad parser =>
Partial (Fragile parser) a
-> Partial parser [a] -> Partial (Fragile parser) [a]
appendIncomplete Partial (Fragile parser) a
p (t -> Partial parser [a]
go (t
nt -> t -> t
forall a. Num a => a -> a -> a
-t
1)))
   in  Int -> Partial parser [a]
forall {t}. (Eq t, Num t) => t -> Partial parser [a]
go Int
m


emptyList :: PossiblyIncomplete [a]
emptyList :: forall a. PossiblyIncomplete [a]
emptyList = [a] -> Exceptional UserMessage [a]
forall a e. a -> Exceptional e a
Async.pure []

{- |
The first parser may fail, but the second one must not.
-}
appendIncomplete ::
   Monad parser =>
   Partial (Fragile parser) a ->
   Partial parser [a] ->
   Partial (Fragile parser) [a]
appendIncomplete :: forall (parser :: * -> *) a.
Monad parser =>
Partial (Fragile parser) a
-> Partial parser [a] -> Partial (Fragile parser) [a]
appendIncomplete Partial (ExceptionalT UserMessage parser) a
p Partial parser [a]
ps =
   do ~(Async.Exceptional Maybe UserMessage
me a
x) <- Partial (ExceptionalT UserMessage parser) a
p
      Partial parser [a] -> Partial (ExceptionalT UserMessage parser) [a]
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptionalT UserMessage m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Partial parser [a]
 -> Partial (ExceptionalT UserMessage parser) [a])
-> Partial parser [a]
-> Partial (ExceptionalT UserMessage parser) [a]
forall a b. (a -> b) -> a -> b
$ (Exceptional UserMessage [a] -> Exceptional UserMessage [a])
-> Partial parser [a] -> Partial parser [a]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (([a] -> [a])
-> Exceptional UserMessage [a] -> Exceptional UserMessage [a]
forall a b.
(a -> b) -> Exceptional UserMessage a -> Exceptional UserMessage b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:)) (Partial parser [a] -> Partial parser [a])
-> Partial parser [a] -> Partial parser [a]
forall a b. (a -> b) -> a -> b
$
         Partial parser [a]
-> (UserMessage -> Partial parser [a])
-> Maybe UserMessage
-> Partial parser [a]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Partial parser [a]
ps (\UserMessage
_ -> Exceptional UserMessage [a] -> Partial parser [a]
forall a. a -> parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe UserMessage -> [a] -> Exceptional UserMessage [a]
forall e a. Maybe e -> a -> Exceptional e a
Async.Exceptional Maybe UserMessage
me [])) Maybe UserMessage
me

absorbException ::
   Monad parser =>
   Partial (Fragile parser) [a] ->
   Partial parser [a]
absorbException :: forall (parser :: * -> *) a.
Monad parser =>
Partial (Fragile parser) [a] -> Partial parser [a]
absorbException =
   (UserMessage -> parser (PossiblyIncomplete [a]))
-> ExceptionalT UserMessage parser (PossiblyIncomplete [a])
-> parser (PossiblyIncomplete [a])
forall (m :: * -> *) e a.
Monad m =>
(e -> m a) -> ExceptionalT e m a -> m a
Sync.resolveT (\UserMessage
errMsg -> PossiblyIncomplete [a] -> parser (PossiblyIncomplete [a])
forall a. a -> parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (PossiblyIncomplete [a] -> parser (PossiblyIncomplete [a]))
-> PossiblyIncomplete [a] -> parser (PossiblyIncomplete [a])
forall a b. (a -> b) -> a -> b
$ UserMessage -> [a] -> PossiblyIncomplete [a]
forall e a. e -> a -> Exceptional e a
Async.broken UserMessage
errMsg [])