module Language.Syntactic.Constructs.Decoration where
import Control.Monad.Identity
import Data.Tree
import Data.Proxy
import Language.Syntactic.Syntax
import Language.Syntactic.Interpretation.Equality
import Language.Syntactic.Interpretation.Evaluation
import Language.Syntactic.Interpretation.Render
data Decor info expr a
where
Decor
:: { decorInfo :: info (DenResult a)
, decorExpr :: expr a
}
-> Decor info expr a
instance WitnessCons dom => WitnessCons (Decor info dom)
where
witnessCons (Decor _ a) = witnessCons a
instance WitnessSat expr => WitnessSat (Decor info expr)
where
type SatContext (Decor info expr) = SatContext expr
witnessSat (Decor _ a) = witnessSat a
instance MaybeWitnessSat ctx dom => MaybeWitnessSat ctx (Decor info dom)
where
maybeWitnessSat ctx (Decor _ a) = maybeWitnessSat ctx a
instance ExprEq expr => ExprEq (Decor info expr)
where
exprEq a b = decorExpr a `exprEq` decorExpr b
exprHash = exprHash . decorExpr
instance Render expr => Render (Decor info expr)
where
renderPart args = renderPart args . decorExpr
render = render . decorExpr
instance ToTree expr => ToTree (Decor info expr)
where
toTreePart args = toTreePart args . decorExpr
instance Eval expr => Eval (Decor info expr)
where
evaluate = evaluate . decorExpr
injDecor :: (sub :<: sup, Signature a) =>
info (DenResult a) -> sub a -> AST (Decor info sup) a
injDecor info = Sym . Decor info . inj
prjDecor :: (sub :<: sup) =>
AST (Decor info sup) a -> Maybe (info (DenResult a), sub a)
prjDecor a = do
Sym (Decor info b) <- return a
c <- prj b
return (info, c)
injDecorCtx :: (sub ctx :<: sup, Signature a) =>
Proxy ctx -> info (DenResult a) -> sub ctx a -> AST (Decor info sup) a
injDecorCtx ctx info = Sym . Decor info . injCtx ctx
prjDecorCtx :: (sub ctx :<: sup)
=> Proxy ctx -> AST (Decor info sup) a
-> Maybe (info (DenResult a), sub ctx a)
prjDecorCtx ctx a = do
Sym (Decor info b) <- return a
c <- prjCtx ctx b
return (info, c)
getInfo :: AST (Decor info dom) a -> info (DenResult a)
getInfo (Sym (Decor info _)) = info
getInfo (f :$ _) = getInfo f
updateDecor :: forall info dom a .
(info a -> info a) -> ASTF (Decor info dom) a -> ASTF (Decor info dom) a
updateDecor f = runIdentity . transformNode update
where
update
:: (Signature b, a ~ DenResult b)
=> Decor info dom b
-> Args (AST (Decor info dom)) b
-> Identity (ASTF (Decor info dom) a)
update (Decor info a) args = Identity $ appArgs (Sym sym) args
where
sym = Decor (f info) a
liftDecor :: (expr a -> info (DenResult a) -> b) -> (Decor info expr a -> b)
liftDecor f (Decor info a) = f a info
collectInfo :: (forall a . info a -> b) -> AST (Decor info dom) a -> [b]
collectInfo coll (Sym (Decor info _)) = [coll info]
collectInfo coll (f :$ a) = collectInfo coll f ++ collectInfo coll a
toTreeDecor :: forall info dom a . (Render info, ToTree dom) =>
ASTF (Decor info dom) a -> Tree String
toTreeDecor a = mkTree [] a
where
mkTree :: [Tree String] -> AST (Decor info dom) b -> Tree String
mkTree args (Sym (Decor info expr)) = Node infoStr [toTreePart args expr]
where
infoStr = "<<" ++ render info ++ ">>"
mkTree args (f :$ a) = mkTree (mkTree [] a : args) f
showDecor :: (Render info, ToTree dom) => ASTF (Decor info dom) a -> String
showDecor = drawTree . toTreeDecor
drawDecor :: (Render info, ToTree dom) => ASTF (Decor info dom) a -> IO ()
drawDecor = putStrLn . showDecor
stripDecor :: AST (Decor info dom) a -> AST dom a
stripDecor (Sym (Decor _ a)) = Sym a
stripDecor (f :$ a) = stripDecor f :$ stripDecor a