Class.hs

module Sound.MIDI.Parser.Class
   (EndCheck, isEnd,
    C, getByte, skip,
    warn, warnIf, warnIncomplete, Exc.giveUp, Exc.try,
    until, zeroOrMore, zeroOrMoreInc, replicate,
    emptyList, PossiblyIncomplete, UserMessage,
    Fallible, 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 (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 = lift $ isEnd


class EndCheck parser => C parser where
   getByte :: Fallible parser Word8
   skip    :: NonNeg.Integer -> Fallible 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 Fallible parser   = Sync.ExceptionalT UserMessage parser
type Partial  parser a = parser (PossiblyIncomplete a)


warnIf :: C parser => Bool -> UserMessage -> parser ()
warnIf b msg = when b (warn 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 ~(Async.Exceptional me a) =
   do maybe (return ()) warn me
      return 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 =>
   Fallible parser a -> Partial parser [a]
zeroOrMore p =
   let go =
         isEnd >>= \b ->
            if b
              then return emptyList
              else absorbException
                      (liftM2 (\ x -> fmap (x:)) p (lift go))
   in  go


zeroOrMoreInc :: EndCheck parser =>
   Partial (Fallible parser) a -> Partial parser [a]
zeroOrMoreInc p =
   let go =
         isEnd >>= \b ->
            if b
              then return emptyList
              else absorbException
                      (appendIncomplete p go)
   in  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) -> Fallible parser a -> Partial parser [a]
until c p =
   let go =
         isEnd >>= \b ->
            if b
              then
                return $ Async.broken
                   "Parser.until: unexpected end of input" []
              else
                absorbException $
                   p >>= \x ->
                     if c x
                       then return emptyList
                       else liftM (fmap (x:)) (lift go)
   in  go


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


emptyList :: PossiblyIncomplete [a]
emptyList = Async.pure []

{- |
The first parser may fail, but the second one must not.
-}
appendIncomplete ::
   Monad parser =>
   Partial (Fallible parser) a ->
   Partial parser [a] ->
   Partial (Fallible parser) [a]
appendIncomplete p ps =
   do ~(Async.Exceptional me x) <- p
      lift $ liftM (fmap (x:)) $
         maybe ps (\_ -> return (Async.Exceptional me [])) me

absorbException ::
   Monad parser =>
   Partial (Fallible parser) [a] ->
   Partial parser [a]
absorbException =
   Sync.resolveT (\errMsg -> return $ Async.broken errMsg [])