module Language.KURE.Transform
(
Transform, Translate
, Rewrite
, applyT, applyR, apply
, transform, translate
, rewrite
, contextfreeT
, contextonlyT
, constT
, effectfreeT
) where
import Prelude hiding (id, (.))
import Control.Applicative
import Control.Monad
import Control.Monad.IO.Class
import Control.Category
import Control.Arrow
#if __GLASGOW_HASKELL__ <= 708
import Data.Monoid
#endif
#if __GLASGOW_HASKELL__ >= 708
import Data.Typeable
#endif
import Language.KURE.MonadCatch
newtype Transform c m a b = Transform {
applyT :: c -> a -> m b}
#if __GLASGOW_HASKELL__ >= 708
deriving Typeable
#endif
type Translate c m a b = Transform c m a b
transform :: (c -> a -> m b) -> Transform c m a b
transform = Transform
translate :: (c -> a -> m b) -> Translate c m a b
translate = transform
type Rewrite c m a = Transform c m a a
rewrite :: (c -> a -> m a) -> Rewrite c m a
rewrite = transform
applyR :: Rewrite c m a -> c -> a -> m a
applyR = applyT
apply :: Transform c m a b -> c -> a -> m b
apply = applyT
contextfreeT :: (a -> m b) -> Transform c m a b
contextfreeT f = transform (\ _ -> f)
contextonlyT :: (c -> m b) -> Transform c m a b
contextonlyT f = transform (\ c _ -> f c)
constT :: m b -> Transform c m a b
constT = contextfreeT . const
effectfreeT :: Monad m => (c -> a -> b) -> Transform c m a b
effectfreeT f = transform ( \ c a -> return (f c a))
instance Functor m => Functor (Transform c m a) where
fmap :: (b -> d) -> Transform c m a b -> Transform c m a d
fmap f t = transform (\ c -> fmap f . applyT t c)
instance Applicative m => Applicative (Transform c m a) where
pure :: b -> Transform c m a b
pure = constT . pure
(<*>) :: Transform c m a (b -> d) -> Transform c m a b -> Transform c m a d
tf <*> tb = transform (\ c a -> applyT tf c a <*> applyT tb c a)
instance Alternative m => Alternative (Transform c m a) where
empty :: Transform c m a b
empty = constT empty
(<|>) :: Transform c m a b -> Transform c m a b -> Transform c m a b
t1 <|> t2 = transform (\ c a -> applyT t1 c a <|> applyT t2 c a)
instance Monad m => Monad (Transform c m a) where
return :: b -> Transform c m a b
return = constT . return
(>>=) :: Transform c m a b -> (b -> Transform c m a d) -> Transform c m a d
t >>= f = transform $ \ c a -> do b <- applyT t c a
applyT (f b) c a
fail :: String -> Transform c m a b
fail = constT . fail
instance MonadCatch m => MonadCatch (Transform c m a) where
catchM :: Transform c m a b -> (String -> Transform c m a b) -> Transform c m a b
catchM t1 t2 = transform $ \ c a -> applyT t1 c a `catchM` \ msg -> applyT (t2 msg) c a
instance MonadPlus m => MonadPlus (Transform c m a) where
mzero :: Transform c m a b
mzero = constT mzero
mplus :: Transform c m a b -> Transform c m a b -> Transform c m a b
mplus t1 t2 = transform $ \ c a -> applyT t1 c a `mplus` applyT t2 c a
instance MonadIO m => MonadIO (Transform c m a) where
liftIO :: IO b -> Transform c m a b
liftIO = constT . liftIO
instance Monad m => Category (Transform c m) where
id :: Transform c m a a
id = contextfreeT return
(.) :: Transform c m b d -> Transform c m a b -> Transform c m a d
t2 . t1 = transform (\ c -> applyT t1 c >=> applyT t2 c)
instance Monad m => Arrow (Transform c m) where
arr :: (a -> b) -> Transform c m a b
arr f = contextfreeT (return . f)
first :: Transform c m a b -> Transform c m (a,z) (b,z)
first t = transform $ \ c (a,z) -> liftM (\ b -> (b,z)) (applyT t c a)
second :: Transform c m a b -> Transform c m (z,a) (z,b)
second t = transform $ \ c (z,a) -> liftM (\ b -> (z,b)) (applyT t c a)
(***) :: Transform c m a1 b1 -> Transform c m a2 b2 -> Transform c m (a1,a2) (b1,b2)
t1 *** t2 = transform $ \ c (a,b) -> liftM2 (,) (applyT t1 c a) (applyT t2 c b)
(&&&) :: Transform c m a b1 -> Transform c m a b2 -> Transform c m a (b1,b2)
t1 &&& t2 = transform $ \ c a -> liftM2 (,) (applyT t1 c a) (applyT t2 c a)
instance MonadPlus m => ArrowZero (Transform c m) where
zeroArrow :: Transform c m a b
zeroArrow = mzero
instance MonadPlus m => ArrowPlus (Transform c m) where
(<+>) :: Transform c m a b -> Transform c m a b -> Transform c m a b
(<+>) = mplus
instance Monad m => ArrowApply (Transform c m) where
app :: Transform c m (Transform c m a b, a) b
app = transform (\ c (t,a) -> applyT t c a)
instance (Monad m, Monoid b) => Monoid (Transform c m a b) where
mempty :: Transform c m a b
mempty = return mempty
mappend :: Transform c m a b -> Transform c m a b -> Transform c m a b
mappend = liftM2 mappend