{-# LANGUAGE CPP #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE PolyKinds #-}
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
#if !MIN_VERSION_base(4,13,0)
import qualified Control.Monad.Fail
import Control.Monad.Fail (MonadFail)
#endif
import Control.Monad.IO.Class
import Control.Category
import Control.Arrow
import Language.KURE.MonadCatch
newtype Transform c m a b = Transform {
Transform c m a b -> c -> a -> m b
applyT :: c -> a -> m b}
type Translate c m a b = Transform c m a b
transform :: (c -> a -> m b) -> Transform c m a b
transform :: (c -> a -> m b) -> Transform c m a b
transform = (c -> a -> m b) -> Transform c m a b
forall k c (m :: k -> *) a (b :: k).
(c -> a -> m b) -> Transform c m a b
Transform
{-# INLINE transform #-}
translate :: (c -> a -> m b) -> Translate c m a b
translate :: (c -> a -> m b) -> Translate c m a b
translate = (c -> a -> m b) -> Translate c m a b
forall k c a (m :: k -> *) (b :: k).
(c -> a -> m b) -> Transform c m a b
transform
{-# INLINE translate #-}
{-# DEPRECATED translate "Please use 'transform' instead." #-}
type Rewrite c m a = Transform c m a a
rewrite :: (c -> a -> m a) -> Rewrite c m a
rewrite :: (c -> a -> m a) -> Rewrite c m a
rewrite = (c -> a -> m a) -> Rewrite c m a
forall k c a (m :: k -> *) (b :: k).
(c -> a -> m b) -> Transform c m a b
transform
{-# INLINE rewrite #-}
applyR :: Rewrite c m a -> c -> a -> m a
applyR :: Rewrite c m a -> c -> a -> m a
applyR = Rewrite c m a -> c -> a -> m a
forall c k (m :: k -> *) a (b :: k).
Transform c m a b -> c -> a -> m b
applyT
{-# INLINE applyR #-}
apply :: Transform c m a b -> c -> a -> m b
apply :: Transform c m a b -> c -> a -> m b
apply = Transform c m a b -> c -> a -> m b
forall c k (m :: k -> *) a (b :: k).
Transform c m a b -> c -> a -> m b
applyT
{-# INLINE apply #-}
{-# DEPRECATED apply "Please use 'applyT' instead." #-}
contextfreeT :: (a -> m b) -> Transform c m a b
contextfreeT :: (a -> m b) -> Transform c m a b
contextfreeT a -> m b
f = (c -> a -> m b) -> Transform c m a b
forall k c a (m :: k -> *) (b :: k).
(c -> a -> m b) -> Transform c m a b
transform (\ c
_ -> a -> m b
f)
{-# INLINE contextfreeT #-}
contextonlyT :: (c -> m b) -> Transform c m a b
contextonlyT :: (c -> m b) -> Transform c m a b
contextonlyT c -> m b
f = (c -> a -> m b) -> Transform c m a b
forall k c a (m :: k -> *) (b :: k).
(c -> a -> m b) -> Transform c m a b
transform (\ c
c a
_ -> c -> m b
f c
c)
{-# INLINE contextonlyT #-}
constT :: m b -> Transform c m a b
constT :: m b -> Transform c m a b
constT = (a -> m b) -> Transform c m a b
forall k a (m :: k -> *) (b :: k) c.
(a -> m b) -> Transform c m a b
contextfreeT ((a -> m b) -> Transform c m a b)
-> (m b -> a -> m b) -> m b -> Transform c m a b
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. m b -> a -> m b
forall a b. a -> b -> a
const
{-# INLINE constT #-}
effectfreeT :: Monad m => (c -> a -> b) -> Transform c m a b
effectfreeT :: (c -> a -> b) -> Transform c m a b
effectfreeT c -> a -> b
f = (c -> a -> m b) -> Transform c m a b
forall k c a (m :: k -> *) (b :: k).
(c -> a -> m b) -> Transform c m a b
transform ( \ c
c a
a -> b -> m b
forall (m :: * -> *) a. Monad m => a -> m a
return (c -> a -> b
f c
c a
a))
{-# INLINE effectfreeT #-}
instance Functor m => Functor (Transform c m a) where
fmap :: (b -> d) -> Transform c m a b -> Transform c m a d
fmap :: (b -> d) -> Transform c m a b -> Transform c m a d
fmap b -> d
f Transform c m a b
t = (c -> a -> m d) -> Transform c m a d
forall k c a (m :: k -> *) (b :: k).
(c -> a -> m b) -> Transform c m a b
transform (\ c
c -> (b -> d) -> m b -> m d
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> d
f (m b -> m d) -> (a -> m b) -> a -> m d
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Transform c m a b -> c -> a -> m b
forall c k (m :: k -> *) a (b :: k).
Transform c m a b -> c -> a -> m b
applyT Transform c m a b
t c
c)
{-# INLINE fmap #-}
instance Applicative m => Applicative (Transform c m a) where
pure :: b -> Transform c m a b
pure :: b -> Transform c m a b
pure = m b -> Transform c m a b
forall k (m :: k -> *) (b :: k) c a. m b -> Transform c m a b
constT (m b -> Transform c m a b) -> (b -> m b) -> b -> Transform c m a b
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. b -> m b
forall (f :: * -> *) a. Applicative f => a -> f a
pure
{-# INLINE pure #-}
(<*>) :: Transform c m a (b -> d) -> Transform c m a b -> Transform c m a d
Transform c m a (b -> d)
tf <*> :: Transform c m a (b -> d) -> Transform c m a b -> Transform c m a d
<*> Transform c m a b
tb = (c -> a -> m d) -> Transform c m a d
forall k c a (m :: k -> *) (b :: k).
(c -> a -> m b) -> Transform c m a b
transform (\ c
c a
a -> Transform c m a (b -> d) -> c -> a -> m (b -> d)
forall c k (m :: k -> *) a (b :: k).
Transform c m a b -> c -> a -> m b
applyT Transform c m a (b -> d)
tf c
c a
a m (b -> d) -> m b -> m d
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Transform c m a b -> c -> a -> m b
forall c k (m :: k -> *) a (b :: k).
Transform c m a b -> c -> a -> m b
applyT Transform c m a b
tb c
c a
a)
{-# INLINE (<*>) #-}
instance Alternative m => Alternative (Transform c m a) where
empty :: Transform c m a b
empty :: Transform c m a b
empty = m b -> Transform c m a b
forall k (m :: k -> *) (b :: k) c a. m b -> Transform c m a b
constT m b
forall (f :: * -> *) a. Alternative f => f a
empty
{-# INLINE empty #-}
(<|>) :: Transform c m a b -> Transform c m a b -> Transform c m a b
Transform c m a b
t1 <|> :: Transform c m a b -> Transform c m a b -> Transform c m a b
<|> Transform c m a b
t2 = (c -> a -> m b) -> Transform c m a b
forall k c a (m :: k -> *) (b :: k).
(c -> a -> m b) -> Transform c m a b
transform (\ c
c a
a -> Transform c m a b -> c -> a -> m b
forall c k (m :: k -> *) a (b :: k).
Transform c m a b -> c -> a -> m b
applyT Transform c m a b
t1 c
c a
a m b -> m b -> m b
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Transform c m a b -> c -> a -> m b
forall c k (m :: k -> *) a (b :: k).
Transform c m a b -> c -> a -> m b
applyT Transform c m a b
t2 c
c a
a)
{-# INLINE (<|>) #-}
instance Monad m => Monad (Transform c m a) where
return :: b -> Transform c m a b
return :: b -> Transform c m a b
return = m b -> Transform c m a b
forall k (m :: k -> *) (b :: k) c a. m b -> Transform c m a b
constT (m b -> Transform c m a b) -> (b -> m b) -> b -> Transform c m a b
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. b -> m b
forall (m :: * -> *) a. Monad m => a -> m a
return
{-# INLINE return #-}
(>>=) :: Transform c m a b -> (b -> Transform c m a d) -> Transform c m a d
Transform c m a b
t >>= :: Transform c m a b -> (b -> Transform c m a d) -> Transform c m a d
>>= b -> Transform c m a d
f = (c -> a -> m d) -> Transform c m a d
forall k c a (m :: k -> *) (b :: k).
(c -> a -> m b) -> Transform c m a b
transform ((c -> a -> m d) -> Transform c m a d)
-> (c -> a -> m d) -> Transform c m a d
forall a b. (a -> b) -> a -> b
$ \ c
c a
a -> do b
b <- Transform c m a b -> c -> a -> m b
forall c k (m :: k -> *) a (b :: k).
Transform c m a b -> c -> a -> m b
applyT Transform c m a b
t c
c a
a
Transform c m a d -> c -> a -> m d
forall c k (m :: k -> *) a (b :: k).
Transform c m a b -> c -> a -> m b
applyT (b -> Transform c m a d
f b
b) c
c a
a
{-# INLINE (>>=) #-}
#if !MIN_VERSION_base(4,13,0)
fail :: String -> Transform c m a b
fail = constT . fail
{-# INLINE fail #-}
#endif
instance MonadFail m => MonadFail (Transform c m a) where
fail :: String -> Transform c m a b
fail :: String -> Transform c m a b
fail = m b -> Transform c m a b
forall k (m :: k -> *) (b :: k) c a. m b -> Transform c m a b
constT (m b -> Transform c m a b)
-> (String -> m b) -> String -> Transform c m a b
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> m b
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
{-# INLINE 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 :: Transform c m a b
-> (String -> Transform c m a b) -> Transform c m a b
catchM Transform c m a b
t1 String -> Transform c m a b
t2 = (c -> a -> m b) -> Transform c m a b
forall k c a (m :: k -> *) (b :: k).
(c -> a -> m b) -> Transform c m a b
transform ((c -> a -> m b) -> Transform c m a b)
-> (c -> a -> m b) -> Transform c m a b
forall a b. (a -> b) -> a -> b
$ \ c
c a
a -> Transform c m a b -> c -> a -> m b
forall c k (m :: k -> *) a (b :: k).
Transform c m a b -> c -> a -> m b
applyT Transform c m a b
t1 c
c a
a m b -> (String -> m b) -> m b
forall (m :: * -> *) a.
MonadCatch m =>
m a -> (String -> m a) -> m a
`catchM` \ String
msg -> Transform c m a b -> c -> a -> m b
forall c k (m :: k -> *) a (b :: k).
Transform c m a b -> c -> a -> m b
applyT (String -> Transform c m a b
t2 String
msg) c
c a
a
{-# INLINE catchM #-}
instance MonadPlus m => MonadPlus (Transform c m a) where
mzero :: Transform c m a b
mzero :: Transform c m a b
mzero = m b -> Transform c m a b
forall k (m :: k -> *) (b :: k) c a. m b -> Transform c m a b
constT m b
forall (m :: * -> *) a. MonadPlus m => m a
mzero
{-# INLINE mzero #-}
mplus :: Transform c m a b -> Transform c m a b -> Transform c m a b
mplus :: Transform c m a b -> Transform c m a b -> Transform c m a b
mplus Transform c m a b
t1 Transform c m a b
t2 = (c -> a -> m b) -> Transform c m a b
forall k c a (m :: k -> *) (b :: k).
(c -> a -> m b) -> Transform c m a b
transform ((c -> a -> m b) -> Transform c m a b)
-> (c -> a -> m b) -> Transform c m a b
forall a b. (a -> b) -> a -> b
$ \ c
c a
a -> Transform c m a b -> c -> a -> m b
forall c k (m :: k -> *) a (b :: k).
Transform c m a b -> c -> a -> m b
applyT Transform c m a b
t1 c
c a
a m b -> m b -> m b
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Transform c m a b -> c -> a -> m b
forall c k (m :: k -> *) a (b :: k).
Transform c m a b -> c -> a -> m b
applyT Transform c m a b
t2 c
c a
a
{-# INLINE mplus #-}
instance MonadIO m => MonadIO (Transform c m a) where
liftIO :: IO b -> Transform c m a b
liftIO :: IO b -> Transform c m a b
liftIO = m b -> Transform c m a b
forall k (m :: k -> *) (b :: k) c a. m b -> Transform c m a b
constT (m b -> Transform c m a b)
-> (IO b -> m b) -> IO b -> Transform c m a b
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. IO b -> m b
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
{-# INLINE liftIO #-}
instance Monad m => Category (Transform c m) where
id :: Transform c m a a
id :: Transform c m a a
id = (a -> m a) -> Transform c m a a
forall k a (m :: k -> *) (b :: k) c.
(a -> m b) -> Transform c m a b
contextfreeT a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return
{-# INLINE id #-}
(.) :: Transform c m b d -> Transform c m a b -> Transform c m a d
Transform c m b d
t2 . :: Transform c m b d -> Transform c m a b -> Transform c m a d
. Transform c m a b
t1 = (c -> a -> m d) -> Transform c m a d
forall k c a (m :: k -> *) (b :: k).
(c -> a -> m b) -> Transform c m a b
transform (\ c
c -> Transform c m a b -> c -> a -> m b
forall c k (m :: k -> *) a (b :: k).
Transform c m a b -> c -> a -> m b
applyT Transform c m a b
t1 c
c (a -> m b) -> (b -> m d) -> a -> m d
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Transform c m b d -> c -> b -> m d
forall c k (m :: k -> *) a (b :: k).
Transform c m a b -> c -> a -> m b
applyT Transform c m b d
t2 c
c)
{-# INLINE (.) #-}
instance Monad m => Arrow (Transform c m) where
arr :: (a -> b) -> Transform c m a b
arr :: (a -> b) -> Transform c m a b
arr a -> b
f = (a -> m b) -> Transform c m a b
forall k a (m :: k -> *) (b :: k) c.
(a -> m b) -> Transform c m a b
contextfreeT (b -> m b
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> m b) -> (a -> b) -> a -> m b
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> b
f)
{-# INLINE arr #-}
first :: Transform c m a b -> Transform c m (a,z) (b,z)
first :: Transform c m a b -> Transform c m (a, z) (b, z)
first Transform c m a b
t = (c -> (a, z) -> m (b, z)) -> Transform c m (a, z) (b, z)
forall k c a (m :: k -> *) (b :: k).
(c -> a -> m b) -> Transform c m a b
transform ((c -> (a, z) -> m (b, z)) -> Transform c m (a, z) (b, z))
-> (c -> (a, z) -> m (b, z)) -> Transform c m (a, z) (b, z)
forall a b. (a -> b) -> a -> b
$ \ c
c (a
a,z
z) -> (b -> (b, z)) -> m b -> m (b, z)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (\ b
b -> (b
b,z
z)) (Transform c m a b -> c -> a -> m b
forall c k (m :: k -> *) a (b :: k).
Transform c m a b -> c -> a -> m b
applyT Transform c m a b
t c
c a
a)
{-# INLINE first #-}
second :: Transform c m a b -> Transform c m (z,a) (z,b)
second :: Transform c m a b -> Transform c m (z, a) (z, b)
second Transform c m a b
t = (c -> (z, a) -> m (z, b)) -> Transform c m (z, a) (z, b)
forall k c a (m :: k -> *) (b :: k).
(c -> a -> m b) -> Transform c m a b
transform ((c -> (z, a) -> m (z, b)) -> Transform c m (z, a) (z, b))
-> (c -> (z, a) -> m (z, b)) -> Transform c m (z, a) (z, b)
forall a b. (a -> b) -> a -> b
$ \ c
c (z
z,a
a) -> (b -> (z, b)) -> m b -> m (z, b)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (\ b
b -> (z
z,b
b)) (Transform c m a b -> c -> a -> m b
forall c k (m :: k -> *) a (b :: k).
Transform c m a b -> c -> a -> m b
applyT Transform c m a b
t c
c a
a)
{-# INLINE second #-}
(***) :: Transform c m a1 b1 -> Transform c m a2 b2 -> Transform c m (a1,a2) (b1,b2)
Transform c m a1 b1
t1 *** :: Transform c m a1 b1
-> Transform c m a2 b2 -> Transform c m (a1, a2) (b1, b2)
*** Transform c m a2 b2
t2 = (c -> (a1, a2) -> m (b1, b2)) -> Transform c m (a1, a2) (b1, b2)
forall k c a (m :: k -> *) (b :: k).
(c -> a -> m b) -> Transform c m a b
transform ((c -> (a1, a2) -> m (b1, b2)) -> Transform c m (a1, a2) (b1, b2))
-> (c -> (a1, a2) -> m (b1, b2)) -> Transform c m (a1, a2) (b1, b2)
forall a b. (a -> b) -> a -> b
$ \ c
c (a1
a,a2
b) -> (b1 -> b2 -> (b1, b2)) -> m b1 -> m b2 -> m (b1, b2)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,) (Transform c m a1 b1 -> c -> a1 -> m b1
forall c k (m :: k -> *) a (b :: k).
Transform c m a b -> c -> a -> m b
applyT Transform c m a1 b1
t1 c
c a1
a) (Transform c m a2 b2 -> c -> a2 -> m b2
forall c k (m :: k -> *) a (b :: k).
Transform c m a b -> c -> a -> m b
applyT Transform c m a2 b2
t2 c
c a2
b)
{-# INLINE (***) #-}
(&&&) :: Transform c m a b1 -> Transform c m a b2 -> Transform c m a (b1,b2)
Transform c m a b1
t1 &&& :: Transform c m a b1
-> Transform c m a b2 -> Transform c m a (b1, b2)
&&& Transform c m a b2
t2 = (c -> a -> m (b1, b2)) -> Transform c m a (b1, b2)
forall k c a (m :: k -> *) (b :: k).
(c -> a -> m b) -> Transform c m a b
transform ((c -> a -> m (b1, b2)) -> Transform c m a (b1, b2))
-> (c -> a -> m (b1, b2)) -> Transform c m a (b1, b2)
forall a b. (a -> b) -> a -> b
$ \ c
c a
a -> (b1 -> b2 -> (b1, b2)) -> m b1 -> m b2 -> m (b1, b2)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,) (Transform c m a b1 -> c -> a -> m b1
forall c k (m :: k -> *) a (b :: k).
Transform c m a b -> c -> a -> m b
applyT Transform c m a b1
t1 c
c a
a) (Transform c m a b2 -> c -> a -> m b2
forall c k (m :: k -> *) a (b :: k).
Transform c m a b -> c -> a -> m b
applyT Transform c m a b2
t2 c
c a
a)
{-# INLINE (&&&) #-}
instance MonadPlus m => ArrowZero (Transform c m) where
zeroArrow :: Transform c m a b
zeroArrow :: Transform c m a b
zeroArrow = Transform c m a b
forall (m :: * -> *) a. MonadPlus m => m a
mzero
{-# INLINE zeroArrow #-}
instance MonadPlus m => ArrowPlus (Transform c m) where
(<+>) :: Transform c m a b -> Transform c m a b -> Transform c m a b
<+> :: Transform c m a b -> Transform c m a b -> Transform c m a b
(<+>) = Transform c m a b -> Transform c m a b -> Transform c m a b
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus
{-# INLINE (<+>) #-}
instance Monad m => ArrowApply (Transform c m) where
app :: Transform c m (Transform c m a b, a) b
app :: Transform c m (Transform c m a b, a) b
app = (c -> (Transform c m a b, a) -> m b)
-> Transform c m (Transform c m a b, a) b
forall k c a (m :: k -> *) (b :: k).
(c -> a -> m b) -> Transform c m a b
transform (\ c
c (Transform c m a b
t,a
a) -> Transform c m a b -> c -> a -> m b
forall c k (m :: k -> *) a (b :: k).
Transform c m a b -> c -> a -> m b
applyT Transform c m a b
t c
c a
a)
{-# INLINE app #-}
instance (Applicative m, Semigroup b) => Semigroup (Transform c m a b) where
(<>) :: Transform c m a b -> Transform c m a b -> Transform c m a b
<> :: Transform c m a b -> Transform c m a b -> Transform c m a b
(<>) = (b -> b -> b)
-> Transform c m a b -> Transform c m a b -> Transform c m a b
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 b -> b -> b
forall a. Semigroup a => a -> a -> a
(<>)
{-# INLINE (<>) #-}
instance (Monad m, Monoid b) => Monoid (Transform c m a b) where
mempty :: Transform c m a b
mempty :: Transform c m a b
mempty = b -> Transform c m a b
forall (m :: * -> *) a. Monad m => a -> m a
return b
forall a. Monoid a => a
mempty
{-# INLINE mempty #-}