module Language.KURE.Term
( Term(..)
, Walker(..)
, extractR
, promoteR
, extractU
, promoteU
, topdownR
, bottomupR
, alltdR
, downupR
, innermostR
, foldU
) where
import Language.KURE.RewriteMonad
import Language.KURE.Translate
import Language.KURE.Rewrite
import Language.KURE.Combinators
import Control.Monad
import Data.Monoid
class Term exp where
type Generic exp
select :: Generic exp -> Maybe exp
inject :: exp -> Generic exp
class (Monoid dec,Monad m,Term exp) => Walker m dec exp where
allR :: Rewrite m dec (Generic exp) -> Rewrite m dec exp
crushU :: (Monoid result) => Translate m dec (Generic exp) result -> Translate m dec exp result
extractR :: (Monad m, Term exp, Monoid dec) => Rewrite m dec (Generic exp) -> Rewrite m dec exp
extractR rr = rewrite $ \ e -> transparently $ do
e' <- apply rr (inject e)
case select e' of
Nothing -> fail "extractR"
Just r -> return r
extractU :: (Monad m, Term exp, Monoid dec) => Translate m dec (Generic exp) r -> Translate m dec exp r
extractU rr = translate $ \ e -> transparently $ apply rr (inject e)
promoteR :: (Monad m, Term exp, Monoid dec) => Rewrite m dec exp -> Rewrite m dec (Generic exp)
promoteR rr = rewrite $ \ e -> transparently $ do
case select e of
Nothing -> fail "promoteR"
Just e' -> do
r <- apply rr e'
return (inject r)
promoteU :: (Monad m, Term exp, Monoid dec) => Translate m dec exp r -> Translate m dec (Generic exp) r
promoteU rr = translate $ \ e -> transparently $ do
case select e of
Nothing -> fail "promoteI"
Just e' -> apply rr e'
topdownR :: (e ~ Generic e, Walker m dec e) => Rewrite m dec (Generic e) -> Rewrite m dec (Generic e)
topdownR s = s >-> allR (topdownR s)
bottomupR :: (e ~ Generic e, Walker m dec e) => Rewrite m dec (Generic e) -> Rewrite m dec (Generic e)
bottomupR s = allR (bottomupR s) >-> s
alltdR :: (e ~ Generic e, Walker m dec e) => Rewrite m dec (Generic e) -> Rewrite m dec (Generic e)
alltdR s = s <+ allR (alltdR s)
downupR :: (e ~ Generic e, Walker m dec e) => Rewrite m dec (Generic e) -> Rewrite m dec (Generic e)
downupR s = s >-> allR (downupR s) >-> s
innermostR :: (e ~ Generic e, Walker m dec e) => Rewrite m dec (Generic e) -> Rewrite m dec (Generic e)
innermostR s = bottomupR (tryR (s >-> innermostR s))
foldU :: (e ~ Generic e, Walker m dec e, Monoid r) => Translate m dec (Generic e) r -> Translate m dec (Generic e) r
foldU s = concatT [ s, crushU (foldU s) ]