module Language.Syntactic.Constructs.Binding.Optimize where
import Control.Monad.Writer
import Data.Set as Set
import Data.Typeable
import Language.Syntactic
import Language.Syntactic.Constructs.Binding
import Language.Syntactic.Constructs.Binding.HigherOrder
import Language.Syntactic.Constructs.Condition
import Language.Syntactic.Constructs.Construct
import Language.Syntactic.Constructs.Identity
import Language.Syntactic.Constructs.Literal
import Language.Syntactic.Constructs.Tuple
type ConstFolder dom = forall a . ASTF dom a -> a -> ASTF dom a
class Optimize sym
where
optimizeSym
:: Optimize' dom
=> ConstFolder dom
-> (sym sig -> AST dom sig)
-> sym sig
-> Args (AST dom) sig
-> Writer (Set VarId) (ASTF dom (DenResult sig))
optimizeSym = optimizeSymDefault
type Optimize' dom =
( Optimize dom
, EvalBind dom
, AlphaEq dom dom dom [(VarId,VarId)]
, ConstrainedBy dom Typeable
)
instance (Optimize sub1, Optimize sub2) => Optimize (sub1 :+: sub2)
where
optimizeSym constFold injecter (InjL a) = optimizeSym constFold (injecter . InjL) a
optimizeSym constFold injecter (InjR a) = optimizeSym constFold (injecter . InjR) a
optimizeM :: Optimize' dom
=> ConstFolder dom
-> ASTF dom a
-> Writer (Set VarId) (ASTF dom a)
optimizeM constFold = matchTrans (optimizeSym constFold Sym)
optimize :: Optimize' dom => ConstFolder dom -> ASTF dom a -> ASTF dom a
optimize constFold = fst . runWriter . optimizeM constFold
optimizeSymDefault :: Optimize' dom
=> ConstFolder dom
-> (sym sig -> AST dom sig)
-> sym sig
-> Args (AST dom) sig
-> Writer (Set VarId) (ASTF dom (DenResult sig))
optimizeSymDefault constFold injecter sym args = do
(args',vars) <- listen $ mapArgsM (optimizeM constFold) args
let result = appArgs (injecter sym) args'
value = evalBind result
if Set.null vars
then return $ constFold result value
else return result
instance Optimize dom => Optimize (dom :| p)
where
optimizeSym cf i (C s) args = optimizeSym cf (i . C) s args
instance Optimize dom => Optimize (dom :|| p)
where
optimizeSym cf i (C' s) args = optimizeSym cf (i . C') s args
instance Optimize Empty
where
optimizeSym = error "Not implemented: optimizeSym for Empty"
instance Optimize dom => Optimize (SubConstr1 c dom p)
where
optimizeSym cf i (SubConstr1 s) args = optimizeSym cf (i . SubConstr1) s args
instance Optimize dom => Optimize (SubConstr2 c dom pa pb)
where
optimizeSym cf i (SubConstr2 s) args = optimizeSym cf (i . SubConstr2) s args
instance Optimize Identity where
instance Optimize Construct where
instance Optimize Literal where
instance Optimize Tuple where
instance Optimize Select where
instance Optimize Let where
instance Optimize Condition
where
optimizeSym constFold injecter cond@Condition args@(c :* t :* e :* Nil)
| Set.null cVars = optimizeM constFold t_or_e
| alphaEq t e = optimizeM constFold t
| otherwise = optimizeSymDefault constFold injecter cond args
where
(c',cVars) = runWriter $ optimizeM constFold c
t_or_e = if evalBind c' then t else e
instance Optimize Variable
where
optimizeSym _ injecter var@(Variable v) Nil = do
tell (singleton v)
return (injecter var)
instance Optimize Lambda
where
optimizeSym constFold injecter lam@(Lambda v) (body :* Nil) = do
body' <- censor (delete v) $ optimizeM constFold body
return $ injecter lam :$ body'