module Language.KURE.Combinators
(
(<+)
, (>->)
, failT
, (?)
, readerT
, getDecsT
, mapDecsT
, pureT
, constT
, concatT
,
(.+)
, (!->)
, tryR
, changedR
, repeatR
, acceptR
, idR
, failR
) where
import Language.KURE.RewriteMonad
import Language.KURE.Translate
import Language.KURE.Rewrite
import Data.Monoid
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 = translate $ \ e -> transparently $ 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 = translate $ \ e -> transparently $ 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
(?) :: (Monoid dec, Monad m) => Bool -> Translate m dec a b -> Translate m dec a b
(?) False _rr = failT "(False ?)"
(?) True rr = rr
readerT :: (Monoid dec, Monad m) => (a -> Translate m dec a b) -> Translate m dec a b
readerT fn = translate $ \ expA -> transparently $ apply (fn expA) expA
getDecsT :: (Monad m, Monoid dec) => (dec -> Translate m dec a b) -> Translate m dec a b
getDecsT f = translate $ \ e -> transparently $
do dec <- getDecsM
apply (f dec) e
mapDecsT :: (Monoid dec,Monad m) => (dec -> dec) -> Translate m dec a r -> Translate m dec a r
mapDecsT f_env rr = translate $ \ e -> mapDecsM 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 `wasId` (\ i -> if i then b else idR)
(!->) :: (Monoid dec, Monad m) => Rewrite m dec a -> Rewrite m dec a -> Rewrite m dec a
(!->) a b = a `wasId` (\ i -> if i 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 = translate $ \ expA -> transparently $
if fn expA
then return expA
else fail "accept failed"
idR :: (Monad m, Monoid dec) => Rewrite m dec exp
idR = rewrite $ \ e -> transparently $ return e
failR :: (Monad m, Monoid dec) => String -> Rewrite m dec a
failR = failT
wasId :: (Monoid dec, Monad m) => Rewrite m dec a -> (Bool -> Rewrite m dec a) -> Rewrite m dec a
wasId rr fn = translate $ \ e -> transparently $
chainM (apply rr e)
(\ i e' -> apply (fn i) e')