uuagc-0.9.39.0: src-ag/ExecutionPlan2Hs.ag
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
}