module Language.KURE.Combinators
(
(<+)
, (>->)
, failT
, readerT
, readEnvT
, mapEnvT
, writeEnvT
, pureT
, constT
, concatT
,
(.+)
, (!->)
, tryR
, changedR
, repeatR
, acceptR
, idR
, failR
,
tuple2R
, listR
, maybeR
, tuple2U
, listU
, maybeU
,
(?)
, Failable(..)
) where
import Language.KURE.RewriteMonad
import Language.KURE.Translate
import Language.KURE.Rewrite
import Data.Monoid
import Control.Monad
infixl 3 <+, >->, .+, !->
infixr 3 ?
(<+) :: (Monoid dec, Monad m) => Translate m dec a b -> Translate m dec a b -> Translate m dec a b
(<+) rr1 rr2 = transparently $ translate $ \ e -> apply rr1 e `catchM` (\ _ -> apply rr2 e)
(>->) :: (Monoid dec, Monad m) => Translate m dec a b -> Translate m dec b c -> Translate m dec a c
(>->) rr1 rr2 = transparently $ translate $ \ e -> chainM (apply rr1 e) ( \ _i e2 -> apply rr2 e2)
failT :: (Monad m, Monoid dec) => String -> Translate m dec a b
failT msg = translate $ \ _ -> failM msg
readerT :: (Monoid dec, Monad m) => (a -> Translate m dec a b) -> Translate m dec a b
readerT fn = transparently $ translate $ \ expA -> apply (fn expA) expA
readEnvT :: (Monad m, Monoid dec) => (dec -> Translate m dec a b) -> Translate m dec a b
readEnvT f = transparently $ translate $ \ e ->
do dec <- readEnvM
apply (f dec) e
writeEnvT :: (Monad m, Monoid dec) => dec -> Rewrite m dec a
writeEnvT dec = translate $ \ e -> do writeEnvM dec ; return e
mapEnvT :: (Monoid dec,Monad m) => (dec -> dec) -> Translate m dec a r -> Translate m dec a r
mapEnvT f_env rr = transparently $ translate $ \ e -> mapEnvM f_env (apply rr e)
pureT :: (Monad m,Monoid dec) => (a -> b) -> Translate m dec a b
pureT f = translate $ \ a -> return (f a)
constT :: (Monad m,Monoid dec) => b -> Translate m dec a b
constT = pureT . const
concatT :: (Monad m,Monoid dec,Monoid r) => [Translate m dec a r] -> Translate m dec a r
concatT ts = translate $ \ e -> do
rs <- sequence [ apply t e | t <- ts ]
return (mconcat rs)
(.+) :: (Monoid dec, Monad m) => Rewrite m dec a -> Rewrite m dec a -> Rewrite m dec a
(.+) a b = a `countTrans` (\ i -> if i == 0 then b else idR)
(!->) :: (Monoid dec, Monad m) => Rewrite m dec a -> Rewrite m dec a -> Rewrite m dec a
(!->) a b = a `countTrans` (\ i -> if i == 0 then idR else b)
tryR :: (Monoid dec, Monad m) => Rewrite m dec a -> Rewrite m dec a
tryR s = s <+ idR
changedR :: (Monoid dec,Monad m) => Rewrite m dec a -> Rewrite m dec a
changedR rr = rr .+ failR "unchanged"
repeatR :: (Monoid dec, Monad m) => Rewrite m dec a -> Rewrite m dec a
repeatR s = tryR (s >-> repeatR s)
acceptR :: (Monoid dec, Monad m) => (a -> Bool) -> Rewrite m dec a
acceptR fn = transparently $ translate $ \ expA ->
if fn expA
then return expA
else fail "accept failed"
idR :: (Monad m, Monoid dec) => Rewrite m dec exp
idR = transparently $ rewrite $ \ e -> return e
failR :: (Monad m, Monoid dec) => String -> Rewrite m dec a
failR = failT
tuple2R :: (Monoid dec, Monad m) => Rewrite m dec a -> Rewrite m dec b -> Rewrite m dec (a,b)
tuple2R rra rrb = transparently $ rewrite $ \ (a,b) -> liftM2 (,) (apply rra a) (apply rrb b)
listR :: (Monoid dec, Monad m) => Rewrite m dec a -> Rewrite m dec [a]
listR rr = transparently $ rewrite $ mapM (apply rr)
maybeR :: (Monoid dec, Monad m) => Rewrite m dec a -> Rewrite m dec (Maybe a)
maybeR rr = transparently $ rewrite $ \ e -> case e of
Just e' -> liftM Just (apply rr e')
Nothing -> return $ Nothing
tuple2U :: (Monoid dec, Monad m, Monoid r) => Translate m dec a r -> Translate m dec b r -> Translate m dec (a,b) r
tuple2U rra rrb = translate $ \ (a,b) -> liftM2 mappend (apply rra a) (apply rrb b)
listU :: (Monoid dec, Monad m, Monoid r) => Translate m dec a r -> Translate m dec [a] r
listU rr = translate $ liftM mconcat . mapM (apply rr)
maybeU :: (Monoid dec, Monad m, Monoid r) => Translate m dec a r -> Translate m dec (Maybe a) r
maybeU rr = translate $ \ e -> case e of
Just e' -> apply rr e'
Nothing -> return $ mempty
class Failable f where
failure :: String -> f a
instance (Monad m, Monoid dec) => Failable (Translate m dec a) where
failure msg = failT msg
instance (Monad m, Monoid dec) => Failable (RewriteM m dec) where
failure msg = fail msg
(?) :: (Failable f) => Bool -> f a -> f a
(?) False _rr = failure "(False ?)"
(?) True rr = rr
countTrans :: (Monoid dec, Monad m) => Rewrite m dec a -> (Int -> Rewrite m dec a) -> Rewrite m dec a
countTrans rr fn = transparently $ translate $ \ e ->
chainM (apply rr e)
(\ i e' -> apply (fn i) e')