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,
) 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
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 ()
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)
warnIncomplete :: C parser => PossiblyIncomplete a -> parser a
warnIncomplete ~(Async.Exceptional me a) =
do maybe (return ()) warn me
return a
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
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
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 (n1)))
in go m
emptyList :: PossiblyIncomplete [a]
emptyList = Async.pure []
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 [])