INCLUDE "ExecutionPlan.ag" INCLUDE "Patterns.ag" INCLUDE "Expression.ag" INCLUDE "HsToken.ag" imports { import ExecutionPlan import Pretty import PPUtil import Options import Data.Maybe import Debug.Trace import System.IO import System.Directory import TokenDef import HsToken import qualified Data.Set as Set import qualified Data.Map as Map } ATTR ExecutionPlan ENonterminals ENonterminal EProductions EProduction [ importBlocks : PP_Doc pragmaBlocks : String textBlocks : PP_Doc moduleHeader : {String -> String -> String -> Bool -> String} mainFile : String optionsLine : String mainName : String | | ] ------------------------------------------------------------------------------- -- Options ------------------------------------------------------------------------------- ATTR ExecutionPlan ENonterminals ENonterminal EProductions EProduction ERules ERule EChildren EChild Visits Visit [ options : {Options} | | ] ATTR EProductions EProduction [ rename : {Bool} | | ] SEM ENonterminal | ENonterminal prods.rename = rename @lhs.options ------------------------------------------------------------------------------- -- Default output ------------------------------------------------------------------------------- ATTR ExecutionPlan [ | | output : {PP_Doc} ] SEM ExecutionPlan | ExecutionPlan lhs.output = @nonts.output ATTR ENonterminal ENonterminals [ wrappers : {Set.Set NontermIdent} | | output USE {>-<} {empty} : {PP_Doc} ] SEM ExecutionPlan | ExecutionPlan nonts.wrappers = @wrappers SEM ENonterminal | ENonterminal lhs.output = ("-- " ++ getName @nt ++ " " ++ replicate (60 - length (getName @nt)) '-') >-< (if dataTypes @lhs.options then "-- data" >-< @loc.datatype >-< "" else empty) >-< (if @nt `Set.member` @lhs.wrappers then "-- wrapper" >-< @loc.wr_inh >-< @loc.wr_syn >-< @loc.wrapper >-< "" else empty) >-< (if folds @lhs.options then "-- cata" >-< @loc.sem_nt >-< "" else empty) >-< (if semfuns @lhs.options then "-- semantic domain" >-< @loc.t_init >-< @loc.t_states >-< @loc.k_states >-< @prods.t_visits >-< @prods.sem_prod >-< "" else empty) ------------------------------------------------------------------------------- -- Nonterminal datatype ------------------------------------------------------------------------------- ATTR ENonterminal ENonterminals [ typeSyns : {TypeSyns} derivings : {Derivings} | | ] SEM ExecutionPlan | ExecutionPlan nonts.typeSyns = @typeSyns nonts.derivings = @derivings SEM ENonterminal | ENonterminal loc.datatype = case lookup @nt @lhs.typeSyns of Nothing -> "data" >#< @nt >#< (vlist $ ("=" >#< head @prods.datatype) : (map ("|" >#<) $ tail @prods.datatype)) >#< @loc.derivings Just (List t) -> "type" >#< @nt >#< "=" >#< "[" >#< show t >#< "]" Just (Maybe t) -> "type" >#< @nt >#< "=" >#< "Maybe" >#< show t Just (Tuple ts) -> "type" >#< @nt >#< "=" >#< pp_parens (ppCommas $ map (show . snd) ts) Just (Either l r) -> "type" >#< @nt >#< "=" >#< "Either" >#< show l >#< show r Just (Map k v) -> "type" >#< @nt >#< "=" >#< "Data.Map.Map" >#< pp_parens (show k) >#< show v Just (IntMap t) -> "type" >#< @nt >#< "=" >#< "Data.IntMap.IntMap" >#< show t -- Just x -> error $ "Type " ++ show x ++ " is not supported" loc.derivings = case Map.lookup @nt @lhs.derivings of Nothing -> empty Just s -> if Set.null s then empty else "deriving" >#< (pp_parens $ ppCommas $ map pp $ Set.toList s) ATTR EProduction [ | | datatype : {PP_Doc} ] ATTR EProductions [ | | datatype USE {:} {[]} : {[PP_Doc]} ] SEM EProduction | EProduction lhs.datatype = conname @lhs.rename @lhs.nt @con >#< ppSpaced @children.datatype ATTR EChild [ nt : {NontermIdent} | | datatype : {PP_Doc} ] ATTR EChildren [ nt : {NontermIdent} | | datatype USE {:} {[]} : {[PP_Doc]} ] SEM EChild | EChild lhs.datatype = if isJust @virtual then empty else @loc.addStrict $ pp_parens $ typeToHaskellString (Just @lhs.nt) [] @tp loc.addStrict = \x -> if strictData @lhs.options then "!" >|< x else x ------------------------------------------------------------------------------- -- Nonterminal semantic function ------------------------------------------------------------------------------- SEM ENonterminal | ENonterminal loc.fsemname = \x -> "sem_" ++ show x loc.semname = @loc.fsemname @nt loc.frecarg = \t x -> case t of NT nt _ -> pp_parens (@fsemname nt >#< x) _ -> pp x loc.sem_nt = @loc.semname >#< "::" >#< @nt >#< "->" >#< @loc.t_type >-< case lookup @nt @lhs.typeSyns of Nothing -> @prods.sem_nt Just (List t) -> @loc.semname >#< "list" >#< "=" >#< "Prelude.foldr" >#< @loc.semname >|< "_Cons" >#< @loc.semname >|< "_Nil" >#< case t of NT nt _ -> pp_parens ("Prelude.map" >#< @fsemname nt >#< "list") _ -> pp "list" Just (Maybe t) -> @loc.semname >#< "Prelude.Nothing" >#< "=" >#< @loc.semname >|< "_Nothing" >-< @loc.semname >#< pp_parens ("Prelude.Just just") >#< "=" >#< @loc.semname >|< "_Just" >#< @frecarg t "just" Just (Tuple ts) -> @loc.semname >#< pp_parens (ppCommas $ map fst ts) >#< "=" >#< @loc.semname >|< "_Tuple" >#< ppSpaced (map (\t -> @frecarg (snd t) (show $ fst t)) ts) Just (Either l r) -> @loc.semname >#< "(Prelude.Left left)" >#< "=" >#< @loc.semname >|< "_Left" >#< @frecarg l "left" >-< @loc.semname >#< "(Prelude.Right right)" >#< "=" >#< @loc.semname >|< "_Right" >#< @frecarg r "right" Just (Map k v) -> @loc.semname >#< "m" >#< "=" >#< "Data.Map.foldrWithKey" >#< @loc.semname >|< "_Entry" >#< @loc.semname >|< "_Nil" >#< case v of NT nt _ -> pp_parens ("Data.Map.map" >#< @fsemname nt >#< "m") _ -> pp "m" Just (IntMap v) -> @loc.semname >#< "m" >#< "=" >#< "Data.IntMap.foldWithKey" >#< @loc.semname >|< "_Entry" >#< @loc.semname >|< "_Nil" >#< case v of NT nt _ -> pp_parens ("Data.IntMap.map" >#< @fsemname nt >#< "m") _ -> pp "m" -- Just x -> error $ "Type " ++ show x ++ " is not supported yet" -- TODO: other typeSyns ATTR EProduction EProductions [ | | sem_nt USE {>-<} {empty} : {PP_Doc} ] SEM EProduction | EProduction lhs.sem_nt = "sem_" >|< @lhs.nt >#< "(" >#< conname @lhs.rename @lhs.nt @con >#< ppSpaced @children.argnames >#< ")" >#< "=" >#< "sem_" >|< @lhs.nt >|< "_" >|< @con >#< ppSpaced @children.argnamesw ATTR EChild [ | | argnamesw : { PP_Doc } ] ATTR EChildren [ | | argnamesw USE {:} {[]} : {[PP_Doc]} ] SEM EChild | EChild lhs.argnamesw = if isJust @virtual then empty else if isNonterminal @tp then "(" >#< "sem_" >|< extractNonterminal @tp >#< "field_" >|< @name >#< ")" else text $ locname @name ------------------------------------------------------------------------------- -- Types of attributes ------------------------------------------------------------------------------- ATTR ExecutionPlan ENonterminals ENonterminal [ inhmap : {Map.Map NontermIdent Attributes} synmap : {Map.Map NontermIdent Attributes} | | ] ATTR EProductions EProduction Visits Visit [ inhmap : {Attributes} synmap : {Attributes} | | ] SEM ENonterminal | ENonterminal (Just prods.inhmap) = Map.lookup @nt @lhs.inhmap (Just prods.synmap) = Map.lookup @nt @lhs.synmap ------------------------------------------------------------------------------- -- State datatypes ------------------------------------------------------------------------------- {type VisitStateState = (VisitIdentifier,StateIdentifier, StateIdentifier)} ATTR Visit [ | | allvisits : { VisitStateState }] ATTR Visits [ | | allvisits USE {:} {[]} : {[VisitStateState]}] ATTR EProduction EProductions [ | | allvisits: {[VisitStateState]}] SEM Visit | Visit lhs.allvisits = (@ident, @from, @to) SEM EProductions | Cons lhs.allvisits = @hd.allvisits -- just pick the first production | Nil lhs.allvisits = error "Every nonterminal should have at least 1 production" -- type of tree in a given state s SEM ENonterminal | ENonterminal loc.outedges = Set.fromList $ map (\(_,f,_) -> f) @prods.allvisits loc.inedges = Set.fromList $ map (\(_,_,t) -> t) @prods.allvisits loc.allstates = Set.insert @initial $ @loc.inedges `Set.union` @loc.outedges loc.t_type = "T_" ++ show @nt loc.t_init = "type" >#< @loc.t_type >#< "=" >#< @loc.t_type >|< "_s" >|< @initial loc.t_states = vlist $ map (\st -> let nt_st = @nt >|< "_s" >|< st t_st = "T_" >|< nt_st k_st = "K_" >|< nt_st c_st = "C_" >|< nt_st inv_st = "inv_" >|< nt_st in "data" >#< t_st >#< "where" >#< c_st >#< "::" >#< "{" >#< inv_st >#< "::" >#< "!" >|< pp_parens ("forall t." >#< k_st >#< "t" >#< "->" >#< "t") >#< "}" >#< "->" >#< t_st ) $ Set.toList @loc.allstates -- type of a key which identifies a visit v from state s SEM ENonterminal | ENonterminal loc.k_type = "K_" ++ show @nt loc.k_states = vlist $ map (\st -> let nt_st = @nt >|< "_s" >|< st k_st = "K_" >|< nt_st outg = filter (\(v,f,t) -> f == st) @prods.allvisits visitlist = vlist $ map (\(v,f,t) -> @loc.k_type >|< "_v" >|< v >#< "::" >#< k_st >#< @loc.t_type >|< "_v" >|< v ) outg in "data" >#< k_st >#< "k" >#< "where" >-< indent 3 visitlist) $ Set.toList @loc.allstates -- type of a visit v, with continuation as new state s ATTR Visit Visits EProduction EProductions [ nt : {NontermIdent} | | t_visits USE {>-<} {empty} : {PP_Doc} ] SEM EProductions | Cons lhs.t_visits = @hd.t_visits -- just pick the first production SEM ENonterminal | ENonterminal prods.nt = @nt SEM Visit | Visit lhs.t_visits = "type" >#< "T_" >|< @lhs.nt >|< "_v" >|< @ident >#< "=" >#< @loc.inhpart >#< "Identity" >#< "(" >#< @loc.synpart >#< "T_" >|< @lhs.nt >|< "_s" >|< @to >#< ")" loc.inhpart = if Set.null @inh then empty else (ppSpaced $ map (\i -> (\x -> pp_parens x >#< "->") $ typeToHaskellString (Just @lhs.nt) [] $ fromJust $ Map.lookup i @lhs.inhmap) $ Set.toList @inh) loc.synpart = if Set.null @syn then empty else (ppCommas $ map (\i -> typeToHaskellString (Just @lhs.nt) [] $ fromJust $ Map.lookup i @lhs.synmap) $ Set.toList @syn) >#< "," ------------------------------------------------------------------------------- -- Inh and Syn wrappers ------------------------------------------------------------------------------- SEM ENonterminal | ENonterminal loc.wr_inh = @loc.genwrap "Inh" @loc.wr_inhs loc.wr_syn = @loc.genwrap "Syn" @loc.wr_syns loc.genwrap = \nm attr -> "data" >#< nm >|< "_" >|< @nt >#< "=" >#< nm >|< "_" >|< @nt >#< "{" >#< (ppCommas $ map (\(i,t) -> i >|< "_" >|< nm >|< "_" >|< @nt >#< "::" >#< typeToHaskellString (Just @nt) [] t) attr) >#< "}" loc.wr_inhs = Map.toList $ fromJust $ Map.lookup @nt @lhs.inhmap loc.wr_syns = Map.toList $ fromJust $ Map.lookup @nt @lhs.synmap loc.inhlist = map (lhsname True . fst) @loc.wr_inhs loc.synlist = map (lhsname False . fst) @loc.wr_syns loc.wrapname = "wrap_" ++ show @nt loc.inhname = "Inh_" ++ show @nt loc.synname = "Syn_" ++ show @nt loc.wrapper = (@loc.wrapname >#< "::" >#< @loc.t_type >#< "->" >#< @loc.inhname >#< "->" >#< @loc.synname) >-< (@loc.wrapname >#< "sem" >#< "(" >#< @loc.inhname >#< ppSpaced @loc.inhlist >#< ")" >#< "=") >-< indent 3 (case @initialv of -- case where there are no inherited or synthesized attributes Nothing -> @loc.synname >#< " { }" Just initv -> "let" >#< "(" >#< ppCommas @loc.synlist >#< "," >#< "_" >#< ")" >#< "=" >#< "Control.Monad.Identity.runIdentity" >#< pp_parens ("inv_" >|< @nt >|< "_s" >|< @initial >#< "sem" >#< @loc.k_type >|< "_v" >|< initv >#< ppSpaced @loc.inhlist) >-< "in " >#< "(" >#< @loc.synname >#< ppSpaced @loc.synlist >#< ")") ------------------------------------------------------------------------------- -- Production semantic functions ------------------------------------------------------------------------------- ATTR EProduction [ | | sem_prod : {PP_Doc} ] ATTR EProductions [ | | sem_prod USE {>-<} {empty} : {PP_Doc} ] ATTR EProduction EProductions [ initial : {StateIdentifier} allstates : {Set.Set StateIdentifier} | | ] SEM ENonterminal | ENonterminal prods.initial = @initial prods.allstates = @loc.allstates ATTR EChild [ | | argtps : { PP_Doc } argnames : { PP_Doc } ] ATTR EChildren [ | | argtps USE {:} {[]} : { [PP_Doc] } argnames USE {:} {[]} : { [PP_Doc] } ] SEM EChild | EChild lhs.argtps = if isJust @virtual then empty else if isNonterminal @tp then ("T_" >|< extractNonterminal @tp) >#< "->" else (text $ show @tp) >#< "->" loc.argnames = if isJust @virtual then empty else if isNonterminal @tp then "field_" >|< @name else text $ locname @name SEM EProduction | EProduction loc.args = @children.argnames loc.semname = "sem_" ++ show @lhs.nt ++ "_" ++ show @con loc.sem_prod = @loc.semname >#< "::" >#< ppSpaced @children.argtps >#< "T_" >|< @lhs.nt >-< @loc.semname >#< ppSpaced @loc.args >#< "=" >#< "st" >|< @lhs.initial >#< "where" >-< (indent 3 $ vlist @loc.statefns >-< @rules.sem_rules) loc.statefns = map (\st -> "st" >|< st >#< @loc.stargs st >#< "=" >#< "C_" >|< @lhs.nt >|< "_s" >|< st >#< "k" >|< st >#< "where" >-< indent 3 (@loc.stks st >-< @loc.stvs st) ) $ Set.toList @lhs.allstates loc.stargs = \st -> ppSpaced $ Set.toList $ maybe Set.empty id $ Map.lookup st @visits.intramap loc.stks = \st -> "k" >|< st >#< "::" >#< "K_" >|< @lhs.nt >|< "_s" >|< st >#< "t" >#< "->" >#< "t" >-< vlist (map (\(v,f,t) -> "k" >|< st >#< "K_" >|< @lhs.nt >|< "_v" >|< v >#< "=" >#< "v" >|< v) $ @loc.stvisits st) >-< if null (@loc.stvisits st) then "k" >|< st >#< "_" >#< "=" >#< "error \"unreachable\"" else empty loc.stvisits = \st -> filter (\(v,f,t) -> f == st) @visits.allvisits loc.stvs = \st -> vlist $ map snd $ filter (\(f,pp) -> f == st) @visits.sem_visit visits.mrules = @rules.mrules ------------------------------------------------------------------------------- -- Visit semantic functions ------------------------------------------------------------------------------- ATTR Visit [ | | sem_visit : { (StateIdentifier,PP_Doc) } ] ATTR Visits [ | | sem_visit USE {:} {[]} : { [(StateIdentifier,PP_Doc)] } ] SEM Visit | Visit lhs.sem_visit = (@from, "v" >|< @ident >#< "::" >#< "T_" >|< @lhs.nt >|< "_v" >|< @ident >-< "v" >|< @ident >#< (@loc.inhargs _LHS True) >#< "=" >#< "do" >-< indent 3 @loc.sem_steps) loc.inhargs = \chn inh -> ppSpaced $ map (\arg -> attrname inh chn arg) $ Set.toList @inh loc.synargs = ppSpaced $ map (\arg -> attrname False _LHS arg >#< ",") $ Set.toList @syn loc.nextargs = ppSpaced $ Set.toList $ maybe Set.empty id $ Map.lookup @to @lhs.allintramap loc.sem_steps = @steps.sem_steps >-< "return" >#< "(" >#< @loc.synargs >#< "st" >|< @to >#< @loc.nextargs >#< ")" ATTR Visits Visit VisitStep VisitSteps [ mrules : {Map.Map Identifier PP_Doc} | | ] ATTR VisitStep VisitSteps [ | | sem_steps USE {>-<} {empty} : {PP_Doc} ] SEM VisitStep | Sem lhs.sem_steps = maybe (error $ "Rule " ++ show @name ++ " not found") id $ Map.lookup @name @lhs.mrules | ChildIntro lhs.sem_steps = maybe (error $ "Child " ++ show @child ++ " not found") id $ Map.lookup @child @lhs.childintros | ChildVisit lhs.sem_steps = (maybe (error $ "Visit " ++ show @visit ++ " not found") id $ Map.lookup @visit @lhs.allchildvisit) $ @child -- Child introduction ATTR EChild EChildren [ | | childintros USE {`Map.union`} {Map.empty} : {Map.Map Identifier PP_Doc} ] ATTR Visits Visit VisitSteps VisitStep [ childintros : {Map.Map Identifier PP_Doc} | | ] SEM EProduction | EProduction visits.childintros = @children.childintros SEM EChild | EChild lhs.childintros = Map.singleton @name $ locname @name >#< "<-" >#< "return" >#< "$" >#< if isJust @virtual then "sem_" >|< extractNonterminal @tp >#< instname @name else "field_" >|< @name -- keep a list of all rules that are used ATTR Visit Visits VisitSteps VisitStep [ | | usedrules USE {`Set.union`} {Set.empty} : {Set.Set Identifier} ] ATTR ERules ERule [ usedrules : {Set.Set Identifier} | | ] SEM VisitStep | Sem lhs.usedrules = Set.singleton @name SEM EProduction | EProduction rules.usedrules = @visits.usedrules -- rules ATTR ERules ERule [ | | sem_rules USE {>-<} {empty} : {PP_Doc} mrules USE {`Map.union`} {Map.empty} : {Map.Map Identifier PP_Doc} ] SEM ERule | ERule lhs.sem_rules = if Set.member @name @lhs.usedrules then (@name >#< "=" >#< (if Set.null @rhs.attrs then empty else "\\" >|< @loc.attrlst >#< "->") >#< @rhs.semfunc) else empty loc.attrlst = ppSpaced $ Set.toList @rhs.attrs lhs.mrules = Map.singleton @name $ @loc.addbang @pattern.sem_lhs >#< "<-" >#< "return" >#< "$" >#< @name >#< @loc.attrlst pattern.addtilde = \x -> if cases @lhs.options then x else "~" >|< x loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x -- pattern and expression semantics ATTR Pattern [ | | sem_lhs : { PP_Doc } ] ATTR Patterns [ | | sem_lhs USE {:} {[]} : {[PP_Doc]} ] ATTR Pattern Patterns [ addtilde : {PP_Doc -> PP_Doc} | | ] ATTR Pattern Patterns [ | | attrs USE {`Set.union`} {Set.empty} : {Set.Set String} ] SEM Pattern | Alias lhs.sem_lhs = text $ attrname False @field @attr -- todo: alias lhs.attrs = Set.singleton $ attrname False @field @attr | Product lhs.sem_lhs = @lhs.addtilde $ pp_block "(" ")" "," @pats.sem_lhs pats.addtilde = id | Constr lhs.sem_lhs = @lhs.addtilde $ pp_parens $ @name >#< hv_sp @pats.sem_lhs pats.addtilde = id | Underscore lhs.sem_lhs = text "_" | Irrefutable lhs.sem_lhs = text "~" >|< pp_parens @pat.sem_lhs pat.addtilde = id ATTR HsToken Expression [ | | attrs USE {`Set.union`} {Set.empty} : {Set.Set String} ] SEM HsToken | AGLocal lhs.attrs = Set.singleton $ locname @var | AGField lhs.attrs = Set.singleton $ attrname True @field @attr ATTR Expression [ | | semfunc : {PP_Doc} ] SEM Expression | Expression lhs.attrs = Set.unions $ map (\tok -> attrs_Syn_HsToken (wrap_HsToken (sem_HsToken tok) Inh_HsToken)) @tks lhs.semfunc = vlist $ showTokens $ map (\tok -> tok_Syn_HsToken (wrap_HsToken (sem_HsToken tok) Inh_HsToken)) @tks -- child visit map ATTR Visit Visits EProduction EProductions ENonterminal ENonterminals [ allchildvisit : {Map.Map VisitIdentifier (Identifier -> PP_Doc)} | | childvisit USE {`Map.union`} {Map.empty} : {Map.Map VisitIdentifier (Identifier -> PP_Doc)} ] ATTR VisitSteps VisitStep [ allchildvisit : {Map.Map VisitIdentifier (Identifier -> PP_Doc)} | | ] SEM ExecutionPlan | ExecutionPlan nonts.allchildvisit = @nonts.childvisit SEM Visit | Visit lhs.childvisit = Map.singleton @ident $ \chn -> @loc.addbang ("(" >#< ppSpaced ( map (\x -> attrname True chn x >#< ",") $ Set.toList @syn) >#< locname chn >#< ")") >#< "<-" >#< "inv_" >|< @lhs.nt >|< "_s" >|< @from >#< locname chn >#< "K_" >|< @lhs.nt >|< "_v" >|< @ident >#< @loc.inhargs chn False loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x ------------------------------------------------------------------------------- -- Intra attributes ------------------------------------------------------------------------------- { uwSetUnion :: (Ord a, Ord b) => Map.Map a (Set.Set b) -> Map.Map a (Set.Set b) -> Map.Map a (Set.Set b) uwSetUnion = Map.unionWith Set.union } ATTR Visit Visits [ allintramap : {Map.Map StateIdentifier (Set.Set String)} | | intramap USE {`uwSetUnion`} {Map.empty} : {Map.Map StateIdentifier (Set.Set String)} ] ATTR Visit Visits [ terminaldefs : {Set.Set String} | | ] ATTR EChild EChildren [ | | terminaldefs USE {`Set.union`} {Set.empty} : {Set.Set String} ] SEM EChild | EChild lhs.terminaldefs = if isJust @virtual || isNonterminal @tp then Set.empty else Set.singleton $ locname @name SEM EProduction | EProduction visits.allintramap = @visits.intramap visits.terminaldefs = @children.terminaldefs SEM Visit | Visit lhs.intramap = Map.singleton @from $ (@loc.uses `Set.union` @loc.nextintra) `Set.difference` @loc.defs loc.nextintra = maybe Set.empty id $ Map.lookup @to @lhs.allintramap loc.uses = @steps.uses loc.defs = @steps.defs `Set.union` (Set.map (lhsname True) @inh) `Set.union` @lhs.terminaldefs ATTR ERule ERules [ | | ruledefs USE {`uwSetUnion`} {Map.empty} : {Map.Map Identifier (Set.Set String)} ruleuses USE {`uwSetUnion`} {Map.empty} : {Map.Map Identifier (Set.Set String)} ] ATTR Visit Visits VisitSteps VisitStep [ ruledefs : {Map.Map Identifier (Set.Set String)} ruleuses : {Map.Map Identifier (Set.Set String)} | | ] SEM ERule | ERule lhs.ruledefs = Map.singleton @name @pattern.attrs lhs.ruleuses = Map.singleton @name @rhs.attrs SEM EProduction | EProduction visits.ruledefs = @rules.ruledefs visits.ruleuses = @rules.ruleuses ATTR Visit Visits EProduction EProductions ENonterminal ENonterminals [ | | visitdefs USE {`uwSetUnion`} {Map.empty} : {Map.Map VisitIdentifier (Set.Set Identifier)} visituses USE {`uwSetUnion`} {Map.empty} : {Map.Map VisitIdentifier (Set.Set Identifier)} ] SEM Visit | Visit lhs.visitdefs = Map.singleton @ident @syn lhs.visituses = Map.singleton @ident @inh ATTR Visit Visits VisitSteps VisitStep EProduction EProductions ENonterminal ENonterminals [ avisitdefs : {Map.Map VisitIdentifier (Set.Set Identifier)} avisituses : {Map.Map VisitIdentifier (Set.Set Identifier)} | | ] SEM ExecutionPlan | ExecutionPlan nonts.avisitdefs = @nonts.visitdefs nonts.avisituses = @nonts.visituses ATTR VisitSteps VisitStep [ | | defs USE {`Set.union`} {Set.empty} : {Set.Set String} uses USE {`Set.union`} {Set.empty} : {Set.Set String} ] SEM VisitStep | Sem lhs.defs = maybe (error "Rule not found") id $ Map.lookup @name @lhs.ruledefs lhs.uses = maybe (error "Rule not found") id $ Map.lookup @name @lhs.ruleuses | ChildIntro lhs.defs = Set.singleton $ locname @child | ChildVisit lhs.defs = maybe (error "Visit not found") (Set.map $ attrname True @child) $ Map.lookup @visit @lhs.avisitdefs lhs.uses = Set.insert (locname @child) $ maybe (error "Visit not found") (Set.map $ attrname False @child) $ Map.lookup @visit @lhs.avisituses ------------------------------------------------------------------------------- -- Pretty printing of haskell code ------------------------------------------------------------------------------- SEM HsTokens [ || tks : {[(Pos,String)]} ] | Cons lhs.tks = @hd.tok : @tl.tks | Nil lhs.tks = [] SEM HsToken | AGLocal loc.tok = (@pos,locname @var) SEM HsToken [ || tok:{(Pos,String)}] | AGField loc.addTrace = case @rdesc of Just d -> \x -> "(trace " ++ show (d ++ " -> " ++ show @field ++ "." ++ show @attr) ++ " (" ++ x ++ "))" Nothing -> id lhs.tok = (@pos, @loc.addTrace $ attrname True @field @attr) | HsToken lhs.tok = (@pos, @value) | CharToken lhs.tok = (@pos, if null @value then "" else showCharShort (head @value) ) | StrToken lhs.tok = (@pos, showStrShort @value) | Err lhs.tok = (@pos, "") ------------------------------------------------------------------------------- -- Alternative code generation (sepsemmods) ------------------------------------------------------------------------------- ATTR ExecutionPlan [ | | genIO : {IO ()} ] SEM ExecutionPlan | ExecutionPlan lhs.genIO = do @loc.genMainModule @loc.genCommonModule @nonts.genProdIO loc.mainModuleFile = @lhs.mainFile ++ ".hs" loc.genMainModule = writeModule @loc.mainModuleFile ( [ pp $ "{-# LANGUAGE Rank2Types, GADTs, EmptyDataDecls #-}" , pp $ @lhs.pragmaBlocks , pp $ @lhs.optionsLine , pp $ @lhs.moduleHeader @lhs.mainName "" "" False , pp $ "import Control.Monad.Identity" , pp $ "import " ++ @lhs.mainName ++ "_common" ] ++ @nonts.imports ++ @nonts.appendMain ) loc.commonFile = @lhs.mainFile ++ "_common.hs" loc.genCommonModule = writeModule @loc.commonFile ( [ pp $ "{-# LANGUAGE Rank2Types, GADTs, EmptyDataDecls #-}" , pp $ @lhs.pragmaBlocks , pp $ @lhs.optionsLine , pp $ @lhs.moduleHeader @lhs.mainName "_common" "" True , pp $ "import Control.Monad.Identity" , @lhs.importBlocks , @lhs.textBlocks ] ++ @nonts.appendCommon ) ATTR ENonterminal [ | | appendCommon, appendMain : { PP_Doc } ] ATTR ENonterminals [ | | appendCommon, appendMain USE {:} {[]} : {[PP_Doc]} ] SEM ENonterminal | ENonterminal lhs.appendMain = (if @nt `Set.member` @lhs.wrappers then @loc.wr_inh >-< @loc.wr_syn >-< @loc.wrapper else empty) >-< @loc.sem_nt lhs.appendCommon = (if dataTypes @lhs.options then @loc.datatype else empty) >-< @loc.t_init >-< @loc.t_states >-< @loc.k_states >-< @prods.t_visits ATTR EProduction EProductions ENonterminal ENonterminals [ | | imports USE {++} {[]} : {[PP_Doc]} genProdIO USE {>>} {return ()} : {IO ()} ] SEM EProduction | EProduction lhs.imports = [pp $ "import " ++ @loc.moduleName] loc.moduleName = @lhs.mainName ++ @loc.suffix loc.suffix = "_" ++ show @lhs.nt ++ "_" ++ show @con loc.outputfile = @lhs.mainFile ++ @loc.suffix ++ ".hs" lhs.genProdIO = writeModule @loc.outputfile [ pp "{-# LANGUAGE Rank2Types, GADTs, EmptyDataDecls #-}" , pp $ @lhs.pragmaBlocks , pp $ @lhs.optionsLine , pp $ @lhs.moduleHeader @lhs.mainName @loc.suffix @loc.semname True , pp $ "import Control.Monad.Identity" , pp $ "import " ++ @lhs.mainName ++ "_common" , @loc.sem_prod ] { renderDocs :: [PP_Doc] -> String renderDocs pps = foldr (.) id (map (\d -> (disp d 50000) . ( '\n':) ) pps) "" writeModule :: FilePath -> [PP_Doc] -> IO () writeModule path docs = do bExists <- doesFileExist path if bExists then do input <- readFile path seq (length input) (return ()) if input /= output then dumpIt else return () else dumpIt where output = renderDocs docs dumpIt = writeFile path output }