module CSPM.Interpreter.PrepareAST
(
prepareAST
)
where
import Language.CSPM.AST as AST
import qualified Language.CSPM.Frontend as Frontend
import CSPM.Interpreter.Types (INT)
import CSPM.Interpreter.PatternCompiler (compilePattern)
import Data.Generics.Schemes (everywhere)
import Data.Generics.Aliases (mkT)
import Data.Generics.Basics (Data)
type IModule = Frontend.ModuleFromRenaming
prepareAST :: Frontend.ModuleFromRenaming -> Module INT
prepareAST = compilePattern . replaceFunCase . addFreeNames
replaceFunCase :: IModule -> IModule
replaceFunCase ast = everywhere (mkT compFC) ast
where
compFC :: FunCase -> FunCase
compFC (FunCase args expr)= FunCaseI (concat args) expr
compFC (FunCaseI _ _)
= error "Internal Error : Did not expect FunCaseI in parse result"
addFreeNames :: IModule -> IModule
addFreeNames ast = everywhere trans ast
where
trans :: Data a => a-> a
trans = mkT mkExp
fn :: LExp -> LExp
fn expr = setNode expr
$ ExprWithFreeNames (Frontend.computeFreeNames expr) expr
mkExp :: Exp -> Exp
mkExp expr = case expr of
Let decls e
-> LetI decls (Frontend.computeFreeNames (decls,expr)) e
Lambda p e
-> LambdaI (Frontend.computeFreeNames (p,e)) p e
PrefixExp c f p
-> PrefixI (Frontend.computeFreeNames (c,f,p) ) c f p
ProcSharing s a b
-> ProcSharing s (fn a) (fn b)
ProcAParallel l r a b
-> ProcAParallel l r (fn a) (fn b)
ProcLinkParallel l a b
-> ProcLinkParallel l (fn a) (fn b)
ProcRenaming r gen p
-> ProcRenaming r gen $ fn p
ProcRepSequence l p
-> ProcRepSequence l $ fn p
ProcRepInternalChoice l p
-> ProcRepInternalChoice l $ fn p
ProcRepInterleave l p
-> ProcRepInterleave l $ fn p
ProcRepExternalChoice l p
-> ProcRepExternalChoice l $ fn p
ProcRepAParallel l a p
-> ProcRepAParallel l a $ fn p
ProcRepLinkParallel l e p
-> ProcRepLinkParallel l e $ fn p
ProcRepSharing l e p
-> ProcRepSharing l e $ fn p
CallBuiltIn x@(unLabel -> BuiltIn bi) [[a,b]]
-> let constr = CallBuiltIn x in case bi of
F_Sequential -> constr [[fn a,fn b]]
F_Interrupt -> constr [[fn a,fn b]]
F_ExtChoice -> constr [[fn a,fn b]]
F_Timeout -> constr [[fn a,fn b]]
F_IntChoice -> constr [[fn a,fn b]]
F_Interleave -> constr [[fn a,fn b]]
F_Hiding -> constr [[fn a,b]]
_ -> constr [[a,b]]
Fun2 x@(unLabel -> BuiltIn bi) a b
-> let constr = Fun2 x in case bi of
F_Sequential -> constr (fn a) (fn b)
F_Interrupt -> constr (fn a) (fn b)
F_ExtChoice -> constr (fn a) (fn b)
F_Timeout -> constr (fn a) (fn b)
F_IntChoice -> constr (fn a) (fn b)
F_Interleave -> constr (fn a) (fn b)
F_Hiding -> constr (fn a) b
F_Guard -> constr a (fn b)
_ -> constr a b
other -> other