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 = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ 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 = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
b (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 forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) forall (parser :: * -> *). C parser => UserMessage -> parser ()
warn Maybe UserMessage
me
      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 =
         forall (parser :: * -> *). EndCheck parser => parser Bool
isEnd forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
b ->
            if Bool
b
              then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. PossiblyIncomplete [a]
emptyList
              else forall (parser :: * -> *) a.
Monad parser =>
Partial (Fragile parser) [a] -> Partial parser [a]
absorbException
                      (forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (\ a
x -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a
xforall a. a -> [a] -> [a]
:)) Fragile parser a
p (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 =
         forall (parser :: * -> *). EndCheck parser => parser Bool
isEnd forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
b ->
            if Bool
b
              then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. PossiblyIncomplete [a]
emptyList
              else forall (parser :: * -> *) a.
Monad parser =>
Partial (Fragile parser) [a] -> Partial parser [a]
absorbException
                      (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 =
         forall (parser :: * -> *). EndCheck parser => parser Bool
isEnd forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
b ->
            if Bool
b
              then
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall e a. e -> a -> Exceptional e a
Async.broken
                   UserMessage
"Parser.until: unexpected end of input" []
              else
                forall (parser :: * -> *) a.
Monad parser =>
Partial (Fragile parser) [a] -> Partial parser [a]
absorbException forall a b. (a -> b) -> a -> b
$
                   Fragile parser a
p forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
x ->
                     if a -> Bool
c a
x
                       then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. PossiblyIncomplete [a]
emptyList
                       else forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a
xforall a. a -> [a] -> [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
nforall a. Eq a => a -> a -> Bool
==t
0
           then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. PossiblyIncomplete [a]
emptyList
           else forall (parser :: * -> *) a.
Monad parser =>
Partial (Fragile parser) [a] -> Partial parser [a]
absorbException
                   (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
nforall a. Num a => a -> a -> a
-t
1)))
   in  forall {t}. (Eq t, Num t) => t -> Partial parser [a]
go Int
m


emptyList :: PossiblyIncomplete [a]
emptyList :: forall a. PossiblyIncomplete [a]
emptyList = 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
      forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a
xforall a. a -> [a] -> [a]
:)) forall a b. (a -> b) -> a -> b
$
         forall b a. b -> (a -> b) -> Maybe a -> b
maybe Partial parser [a]
ps (\UserMessage
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (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 =
   forall (m :: * -> *) e a.
Monad m =>
(e -> m a) -> ExceptionalT e m a -> m a
Sync.resolveT (\UserMessage
errMsg -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall e a. e -> a -> Exceptional e a
Async.broken UserMessage
errMsg [])