module Language.KURE.RewriteMonad
( RewriteM
, RewriteStatusM(..)
, runRewriteM
, failM
, catchM
, chainM
, liftQ
, markM
, transparently
, getDecsM
, mapDecsM
) where
import Control.Monad
import Data.Monoid
data RewriteM m dec exp =
RewriteM {
runRewriteM :: dec -> m (RewriteStatusM dec exp)
}
data IdStatus = EmptyId | IsId | NotId
instance Monoid IdStatus where
mempty = EmptyId
mappend EmptyId y = y
mappend x EmptyId = x
mappend IsId IsId = IsId
mappend _ _ = NotId
data RewriteStatusM dec exp
= RewriteReturnM exp !(Maybe dec) !IdStatus
| RewriteFailureM String
instance (Monoid dec,Monad m) => Monad (RewriteM m dec) where
return e = RewriteM $ \ _ -> return $ RewriteReturnM e Nothing EmptyId
(RewriteM m) >>= k = RewriteM $ \ dec -> do
r <- m dec
case r of
RewriteReturnM r1 ds ids -> do
r2 <- runRewriteM (k r1) dec
return $ case r2 of
RewriteReturnM e' ds' ids' -> RewriteReturnM e' (ds' `mappend` ds) (ids' `mappend` ids)
RewriteFailureM msg -> RewriteFailureM msg
RewriteFailureM msg -> return $ RewriteFailureM msg
fail msg = RewriteM $ \ _ -> return $ RewriteFailureM msg
instance (Monoid dec,Monad m) => Functor (RewriteM m dec) where
fmap f m = liftM f m
liftQ :: (Monad m,Monoid dec) => m a -> RewriteM m dec a
liftQ m = RewriteM $ \ _ -> do r <- m
return $ RewriteReturnM r mempty mempty
failM :: (Monad m, Monoid dec) => String -> RewriteM m dec a
failM msg = RewriteM $ \ _ -> return $ RewriteFailureM msg
catchM :: (Monad m) => RewriteM m dec a -> (String -> RewriteM m dec a) -> RewriteM m dec a
catchM (RewriteM m1) m2 = RewriteM $ \ dec -> do
r <- m1 dec
case r of
RewriteReturnM {} -> return r
RewriteFailureM msg -> runRewriteM (m2 msg) dec
chainM :: (Monoid dec,Monad m)
=> (RewriteM m dec b)
-> (Bool -> b -> RewriteM m dec c)
-> RewriteM m dec c
chainM m k = RewriteM $ \ dec -> do
r <- runRewriteM m dec
case r of
RewriteReturnM a ds ids ->
do r2 <- runRewriteM (k (isId ids) a) (case ds of
Nothing -> dec
Just ds2 -> ds2 `mappend` dec)
case r2 of
RewriteReturnM a' ds' ids' ->
return $ RewriteReturnM a' (ds' `mappend` ds) (ids' `mappend` ids)
RewriteFailureM msg -> return $ RewriteFailureM msg
RewriteFailureM msg -> return $ RewriteFailureM msg
where
isId NotId = False
isId _ = True
markM :: (Monad m) => RewriteM m dec a -> RewriteM m dec a
markM (RewriteM m) = RewriteM $ \ dec -> do
r <- m dec
case r of
RewriteReturnM a ds EmptyId -> return $ RewriteReturnM a ds NotId
RewriteReturnM a ds IsId -> return $ RewriteReturnM a ds EmptyId
RewriteReturnM a ds ids -> return $ RewriteReturnM a ds ids
RewriteFailureM msg -> return $ RewriteFailureM msg
transparently :: (Monad m) => RewriteM m dec a -> RewriteM m dec a
transparently (RewriteM m) = RewriteM $ \ dec -> do
r <- m dec
case r of
RewriteReturnM a ds EmptyId -> return $ RewriteReturnM a ds IsId
RewriteReturnM a ds ids -> return $ RewriteReturnM a ds ids
RewriteFailureM msg -> return $ RewriteFailureM msg
getDecsM :: (Monad m, Monoid dec) => RewriteM m dec dec
getDecsM = RewriteM $ \ dec -> return $ RewriteReturnM dec mempty mempty
mapDecsM :: (Monad m, Monoid dec) => (dec -> dec) -> RewriteM m dec a -> RewriteM m dec a
mapDecsM fn (RewriteM m) = RewriteM $ \ dec -> m (fn dec)