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 (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 :: 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 :: 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 (m :: * -> *) a. Monad m => a -> m a
return ()) UserMessage -> parser ()
forall (parser :: * -> *). C parser => UserMessage -> parser ()
warn Maybe UserMessage
me
      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 :: Fragile parser a -> Partial parser [a]
zeroOrMore Fragile parser a
p =
   let go :: Partial parser [a]
go =
         parser Bool
forall (parser :: * -> *). EndCheck parser => parser Bool
isEnd parser Bool -> (Bool -> Partial parser [a]) -> Partial parser [a]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
b ->
            if Bool
b
              then PossiblyIncomplete [a] -> Partial 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
                      ((a -> PossiblyIncomplete [a] -> PossiblyIncomplete [a])
-> Fragile parser a
-> Partial (Fragile parser) [a]
-> Partial (Fragile 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 (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 (Partial parser [a] -> Partial (Fragile parser) [a]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Partial parser [a]
go))
   in  Partial parser [a]
go


zeroOrMoreInc :: EndCheck parser =>
   Partial (Fragile parser) a -> Partial parser [a]
zeroOrMoreInc :: Partial (Fragile parser) a -> Partial parser [a]
zeroOrMoreInc Partial (Fragile parser) a
p =
   let go :: Partial parser [a]
go =
         parser Bool
forall (parser :: * -> *). EndCheck parser => parser Bool
isEnd parser Bool -> (Bool -> Partial parser [a]) -> Partial parser [a]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
b ->
            if Bool
b
              then PossiblyIncomplete [a] -> Partial 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 Partial parser [a]
go)
   in  Partial parser [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 :: (a -> Bool) -> Fragile parser a -> Partial parser [a]
until a -> Bool
c Fragile parser a
p =
   let go :: Partial parser [a]
go =
         parser Bool
forall (parser :: * -> *). EndCheck parser => parser Bool
isEnd parser Bool -> (Bool -> Partial parser [a]) -> Partial parser [a]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
b ->
            if Bool
b
              then
                Exceptional UserMessage [a] -> Partial parser [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (Exceptional UserMessage [a] -> Partial parser [a])
-> Exceptional UserMessage [a] -> Partial parser [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 (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] -> Partial parser [a]
forall a b. (a -> b) -> a -> b
$
                   Fragile parser a
p Fragile parser a
-> (a -> Partial (Fragile parser) [a])
-> Partial (Fragile parser) [a]
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 (Fragile 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 (Fragile parser) [a] -> Partial (Fragile parser) [a]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (([a] -> [a])
-> Exceptional UserMessage [a] -> Exceptional UserMessage [a]
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 (Fragile parser) [a]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Partial parser [a]
go)
   in  Partial parser [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 :: 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 (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 :: PossiblyIncomplete [a]
emptyList = [a] -> PossiblyIncomplete [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 :: Partial (Fragile parser) a
-> Partial parser [a] -> Partial (Fragile parser) [a]
appendIncomplete Partial (Fragile parser) a
p Partial parser [a]
ps =
   do ~(Async.Exceptional Maybe UserMessage
me a
x) <- Partial (Fragile parser) a
p
      Partial parser [a] -> Partial (Fragile parser) [a]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Partial parser [a] -> Partial (Fragile parser) [a])
-> Partial parser [a] -> Partial (Fragile 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 (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 (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 :: Partial (Fragile parser) [a] -> Partial parser [a]
absorbException =
   (UserMessage -> Partial parser [a])
-> Partial (Fragile parser) [a] -> Partial parser [a]
forall (m :: * -> *) e a.
Monad m =>
(e -> m a) -> ExceptionalT e m a -> m a
Sync.resolveT (\UserMessage
errMsg -> Exceptional UserMessage [a] -> Partial parser [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (Exceptional UserMessage [a] -> Partial parser [a])
-> Exceptional UserMessage [a] -> Partial parser [a]
forall a b. (a -> b) -> a -> b
$ UserMessage -> [a] -> Exceptional UserMessage [a]
forall e a. e -> a -> Exceptional e a
Async.broken UserMessage
errMsg [])