module Language.KURE.Combinators.Transform
(
idR
, successT
, contextT
, exposeT
, liftContext
, readerT
, resultT
, catchesT
, mapT
, joinT
, guardT
, tryR
, andR
, orR
, (>+>)
, repeatR
, acceptR
, acceptWithFailMsgR
, accepterR
, changedR
, changedByR
, sideEffectR
, AnyR
, wrapAnyR
, unwrapAnyR
, OneR
, wrapOneR
, unwrapOneR
) where
import Prelude hiding (id, map, foldr, mapM)
import Control.Category ((>>>),id)
import Control.Applicative
import Control.Monad (liftM,ap)
import Data.Foldable
import Data.Traversable
import Language.KURE.Combinators.Arrow
import Language.KURE.Combinators.Monad
import Language.KURE.MonadCatch
import Language.KURE.Transform
idR :: Monad m => Rewrite c m a
idR = id
successT :: Monad m => Transform c m a ()
successT = return ()
contextT :: Monad m => Transform c m a c
contextT = transform (\ c _ -> return c)
exposeT :: Monad m => Transform c m a (c,a)
exposeT = transform (curry return)
liftContext :: (c -> c') -> Transform c' m a b -> Transform c m a b
liftContext f t = transform (applyT t . f)
mapT :: (Traversable t, Monad m) => Transform c m a b -> Transform c m (t a) (t b)
mapT t = transform (mapM . applyT t)
sideEffectR :: Monad m => (c -> a -> m ()) -> Rewrite c m a
sideEffectR f = transform f >> id
readerT :: (a -> Transform c m a b) -> Transform c m a b
readerT f = transform (\ c a -> applyT (f a) c a)
resultT :: (m b -> n d) -> Transform c m a b -> Transform c n a d
resultT f t = transform (\ c -> f . applyT t c)
andR :: (Foldable f, Monad m) => f (Rewrite c m a) -> Rewrite c m a
andR = serialise
(>+>) :: MonadCatch m => Rewrite c m a -> Rewrite c m a -> Rewrite c m a
r1 >+> r2 = unwrapAnyR (wrapAnyR r1 >>> wrapAnyR r2)
orR :: (Functor f, Foldable f, MonadCatch m) => f (Rewrite c m a) -> Rewrite c m a
orR = unwrapAnyR . andR . fmap wrapAnyR
acceptWithFailMsgR :: Monad m => (a -> Bool) -> String -> Rewrite c m a
acceptWithFailMsgR p msg = readerT $ \ a -> if p a then id else fail msg
acceptR :: Monad m => (a -> Bool) -> Rewrite c m a
acceptR p = acceptWithFailMsgR p "acceptR: predicate failed"
accepterR :: Monad m => Transform c m a Bool -> Rewrite c m a
accepterR t = ifM t idR (fail "accepterR: predicate failed")
tryR :: MonadCatch m => Rewrite c m a -> Rewrite c m a
tryR r = r <+ id
changedByR :: MonadCatch m => (a -> a -> Bool) -> Rewrite c m a -> Rewrite c m a
changedByR p r = readerT (\ a -> r >>> acceptWithFailMsgR (not . p a) "changedByR: value is unchanged")
changedR :: (MonadCatch m, Eq a) => Rewrite c m a -> Rewrite c m a
changedR = changedByR (==)
repeatR :: MonadCatch m => Rewrite c m a -> Rewrite c m a
repeatR r = let go = r >>> tryR go
in go
catchesT :: MonadCatch m => [Transform c m a b] -> Transform c m a b
catchesT = foldr (<+) (fail "catchesT failed")
joinT :: Transform c m (m a) a
joinT = contextfreeT id
guardT :: Monad m => Transform c m Bool ()
guardT = contextfreeT guardM
data PBool a = PBool !Bool a
instance Functor PBool where
fmap :: (a -> b) -> PBool a -> PBool b
fmap f (PBool b a) = PBool b (f a)
checkSuccessPBool :: Monad m => String -> m (PBool a) -> m a
checkSuccessPBool msg m = do PBool b a <- m
if b
then return a
else fail msg
newtype AnyR m a = AnyR (m (PBool a))
unAnyR :: AnyR m a -> m (PBool a)
unAnyR (AnyR mba) = mba
instance Monad m => Functor (AnyR m) where
fmap :: (a -> b) -> AnyR m a -> AnyR m b
fmap = liftM
instance Monad m => Applicative (AnyR m) where
pure :: a -> AnyR m a
pure = return
(<*>) :: AnyR m (a -> b) -> AnyR m a -> AnyR m b
(<*>) = ap
instance Monad m => Monad (AnyR m) where
return :: a -> AnyR m a
return = AnyR . return . PBool False
fail :: String -> AnyR m a
fail = AnyR . fail
(>>=) :: AnyR m a -> (a -> AnyR m d) -> AnyR m d
ma >>= f = AnyR $ do PBool b1 a <- unAnyR ma
PBool b2 d <- unAnyR (f a)
return (PBool (b1 || b2) d)
instance MonadCatch m => MonadCatch (AnyR m) where
catchM :: AnyR m a -> (String -> AnyR m a) -> AnyR m a
catchM ma f = AnyR (unAnyR ma `catchM` (unAnyR . f))
wrapAnyR :: MonadCatch m => Rewrite c m a -> Rewrite c (AnyR m) a
wrapAnyR r = rewrite $ \ c a -> AnyR $ (PBool True `liftM` applyR r c a) <+ return (PBool False a)
unwrapAnyR :: Monad m => Rewrite c (AnyR m) a -> Rewrite c m a
unwrapAnyR = resultT (checkSuccessPBool "anyR failed" . unAnyR)
newtype OneR m a = OneR (Bool -> m (PBool a))
unOneR :: OneR m a -> Bool -> m (PBool a)
unOneR (OneR mba) = mba
instance Monad m => Functor (OneR m) where
fmap :: (a -> b) -> OneR m a -> OneR m b
fmap = liftM
instance Monad m => Applicative (OneR m) where
pure :: a -> OneR m a
pure = return
(<*>) :: OneR m (a -> b) -> OneR m a -> OneR m b
(<*>) = ap
instance Monad m => Monad (OneR m) where
return :: a -> OneR m a
return a = OneR (\ b -> return (PBool b a))
fail :: String -> OneR m a
fail msg = OneR (\ _ -> fail msg)
(>>=) :: OneR m a -> (a -> OneR m d) -> OneR m d
ma >>= f = OneR $ \ b1 -> do PBool b2 a <- unOneR ma b1
unOneR (f a) b2
instance MonadCatch m => MonadCatch (OneR m) where
catchM :: OneR m a -> (String -> OneR m a) -> OneR m a
catchM (OneR g) f = OneR (\ b -> g b `catchM` (($ b) . unOneR . f))
wrapOneR :: MonadCatch m => Rewrite c m g -> Rewrite c (OneR m) g
wrapOneR r = rewrite $ \ c a -> OneR $ \ b -> if b
then return (PBool True a)
else (PBool True `liftM` applyR r c a) <+ return (PBool False a)
unwrapOneR :: Monad m => Rewrite c (OneR m) a -> Rewrite c m a
unwrapOneR = resultT (checkSuccessPBool "oneR failed" . ($ False) . unOneR)