module Language.KURE.Combinators
(
(<+)
, (>->)
, failT
, readerT
, getDecsT
, mapDecsT
, pureT
, constT
, concatT
,
(.+)
, (!->)
, tryR
, changedR
, repeatR
, acceptR
, idR
, failR
,
(?)
, Failable(..)
) 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
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
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
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')