diff --git a/src-ag/AG2AspectAG.ag b/src-ag/AG2AspectAG.ag deleted file mode 100644 --- a/src-ag/AG2AspectAG.ag +++ /dev/null @@ -1,857 +0,0 @@ -INCLUDE "AbstractSyntax.ag" -INCLUDE "Patterns.ag" -INCLUDE "Expression.ag" -INCLUDE "HsToken.ag" -INCLUDE "DistChildAttr.ag" - -imports -{ -import Options - -import Data.Char -import Data.List -import qualified Data.Map as Map -import qualified Data.Set as Set -import Data.Maybe - -import Pretty -import PPUtil -import UU.Scanner.Position - -import AbstractSyntax -import TokenDef -import CommonTypes - --- import Debug.Trace -} - -{ -pragmaAspectAG = pp "{-# LANGUAGE EmptyDataDecls, NoMonomorphismRestriction , TypeSynonymInstances, MultiParamTypeClasses, FlexibleContexts, FlexibleInstances #-}" - -} - -{ -ppName l = ppListSep "" "" "_" l -} - - -ATTR Grammar [ options : Options | | ] - - -ATTR Nonterminals Nonterminal Productions Production Children Child [ o_rename : Bool | | ] -SEM Grammar - | Grammar nonts.o_rename = rename @lhs.options - -ATTR Nonterminals Nonterminal Productions Production Children Child Rules Rule [ o_noGroup : {[String]} | | ] -SEM Grammar - | Grammar loc.o_noGroup = sort $ noGroup @lhs.options - nonts.o_noGroup = @loc.o_noGroup - -SEM Nonterminal - | Nonterminal loc.inhNoGroup = Map.filterWithKey (\att _ -> elem (getName att) @lhs.o_noGroup) @prods.prdInh - | Nonterminal loc.synNoGroup = Map.filterWithKey (\att _ -> elem (getName att) @lhs.o_noGroup) @syn - - -ATTR Productions Production Children Child Rules Rule [ inhNoGroup, synNoGroup : {[String]} | | ] -SEM Nonterminal - | Nonterminal prods.inhNoGroup = map show $ Map.keys @loc.inhNoGroup - | Nonterminal prods.synNoGroup = map show $ Map.keys @loc.synNoGroup - - -SEM Productions - | Cons hd.inhNoGroup = filter (flip Map.member @hd.prdInh . identifier) @lhs.inhNoGroup - - -ATTR Productions Production Children Child [ | | prdInh USE {`Map.union`} {Map.empty} : {Attributes} ] -SEM Child - | Child lhs.prdInh = @loc.inh - - -{ -type FieldMap = [(Identifier, Type)] -type DataTypes = Map.Map NontermIdent (Map.Map ConstructorIdent FieldMap) -} - -ATTR Grammar [ agi : {(Set NontermIdent, DataTypes, Map NontermIdent (Attributes, Attributes))} | | ] - - -ATTR Nonterminals Nonterminal Productions Production Children Child Rules Rule [ newAtts : { Attributes } | | ] - -SEM Grammar | Grammar loc.newAtts = case @lhs.agi of - (_,_,atts) -> ( Map.unions . (\(a,b) -> a++b) . unzip . Map.elems) atts - nonts.newAtts = @loc.newAtts - - -ATTR Nonterminals Nonterminal [ newProds : { DataTypes } | | ] -ATTR Productions Production [ newProds : { Map.Map ConstructorIdent FieldMap } | | ] - -SEM Grammar | Grammar loc.newProds = case @lhs.agi of - (_,prods,_) -> prods - nonts.newProds = @loc.newProds - - -SEM Nonterminal - | Nonterminal prods.newProds = case Map.lookup @nt @lhs.newProds of - Just prds -> prds - Nothing -> Map.empty - - -ATTR Nonterminals Nonterminal [ newNTs : {Set NontermIdent} | | ] - -ATTR Productions Production [ | | hasMoreProds USE { || } {False} : { Bool } ] - -SEM Production | Production lhs.hasMoreProds = not $ Map.member @con @lhs.newProds - -ATTR Nonterminals Nonterminal [ | | extendedNTs USE {`Set.union`} {Set.empty} : {Set NontermIdent} ] - -SEM Nonterminal | Nonterminal lhs.extendedNTs = if @prods.hasMoreProds - then Set.singleton @nt - else Set.empty - - -SEM Grammar | Grammar nonts.newNTs = case @lhs.agi of - (newNTs,_,_) -> Set.difference newNTs @nonts.extendedNTs - - - - - -ATTR Grammar Nonterminals Nonterminal Productions Production Children Child Rules Rule [ ext : {Maybe String} | | ] - - --- IMPORT - -ATTR Grammar [ | | imp USE {>-<} {empty} : PP_Doc ] - -SEM Grammar - | Grammar lhs . imp = "import Language.Grammars.AspectAG" >-< - "import Language.Grammars.AspectAG.Derive" >-< - "import Data.HList.Label4" >-< - "import Data.HList.TypeEqGeneric1" >-< - "import Data.HList.TypeCastGeneric1" >-< - maybe empty ("import qualified" >#<) @lhs.ext >-< - maybe empty (\ext -> "import" >#< ext >#< ppListSep "(" ")" "," (@nonts.ppDI ++ @nonts.ppLI ++ @loc.ppAI ++ @loc.ppANT)) @lhs.ext - --- CODE - -ATTR Grammar [ | | pp USE {>-<} {empty} : PP_Doc ] - -SEM Grammar - | Grammar lhs . pp = (if dataTypes @lhs.options - then "-- datatypes" >-< @nonts.ppD >-< - "-- labels" >-< @nonts.ppL - else empty) - - >-< - - (if folds @lhs.options - then "-- attributes" >-< @loc.ppA >-< - "-- rules" >-< @loc.ppR >-< - "-- catas" >-< @nonts.ppCata - - else empty) - - >-< - - - (if semfuns @lhs.options - then "-- semantic functions" >-< @nonts.ppSF - else empty) - - - >-< - - (if wrappers @lhs.options - then "-- wrappers" >-< @nonts.ppW - else empty) - - - --- data definitions - -SEM Nonterminal - | Nonterminal loc . ppNt = pp @nt - -SEM Production - | Production loc . ppProd = pp @con - loc . prodName = ppName [@lhs.ppNt, @loc.ppProd] - loc . conName = if @lhs.o_rename - then @loc.prodName - else @loc.ppProd -SEM Child - | Child loc . ppCh = pp @name - loc . ppTCh = ppShow @tp - loc . chName = ppName [@loc.ppCh, @lhs.ppNt, @lhs.ppProd] - - -ATTR Productions Production Rules Rule Children Child Expression [ ppNt : PP_Doc | | ] - -SEM Nonterminal - | Nonterminal prods . ppNt = @loc.ppNt - -ATTR Rules Rule Children Child Expression [ ppProd : PP_Doc | | ] - -SEM Production - | Production children . ppProd = @loc.ppProd - rules . ppProd = @loc.ppProd - - -ATTR Nonterminals Nonterminal [ derivs : {Derivings} | | ] - -SEM Grammar - | Grammar nonts . derivs = @derivings - - -ATTR Nonterminals Nonterminal Production [ | | ppD USE {>-<} {empty} : {PP_Doc} ppDI USE {++} {[]} : {[PP_Doc]} ] - -SEM Nonterminal - | Nonterminal lhs . ppD = - if (Set.member @nt @lhs.newNTs) - then case (lookup @nt @lhs.tSyns) of - -- if it's a data type - Nothing -> "data " >|< @loc.ppNt - >|< " = " >|< vlist_sep " | " @prods.ppDL >-< - case (Map.lookup @nt @lhs.derivs) of - Just ntds -> pp " deriving " >|< (ppListSep "(" ")" ", " $ Set.elems ntds) - Nothing -> empty -- uncommented for testing purposes - -- if it's a type synonym - Just tp -> "type " >|< @loc.ppNt >|< " = " >|< ppShow tp - else empty - - lhs . ppDI = - if (not $ Set.member @nt @lhs.newNTs) - then [ @loc.ppNt ] - else [ ] --- uncommented for testing purposes - -SEM Production - | Production lhs . ppD = @loc.conName >|< ppListSep " {" "}" ", " @children.ppDL - - -ATTR Productions Children Child [ | | ppDL : {[PP_Doc]} ] - -SEM Productions - | Cons lhs . ppDL = @hd.ppD : @tl.ppDL - | Nil lhs . ppDL = [] - -SEM Children - | Cons lhs . ppDL = @hd.ppDL ++ @tl.ppDL - | Nil lhs . ppDL = [] - -SEM Child - | Child lhs . ppDL = case @kind of - ChildSyntax -> [ @loc.chName >|< pp " :: " >|< @loc.ppTCh ] - _ -> [] - - - -ATTR Nonterminals Nonterminal [ tSyns : {TypeSyns} | | ] - -SEM Grammar - | Grammar nonts . tSyns = @typeSyns - - - - --- grammar labels - - -ATTR Nonterminals Nonterminal Productions Production Children Child [ | | ppL USE {>-<} {empty} : PP_Doc ppLI USE {++} {[]} : {[PP_Doc]} ] - -SEM Nonterminal - | Nonterminal loc . ntLabel = "nt_" >|< @loc.ppNt - - lhs . ppL = ( if (Set.member @nt @lhs.newNTs) - then @loc.ntLabel >|< " = proxy :: Proxy " >|< @loc.ppNt - else empty) >-< - @prods.ppL - - lhs . ppLI = ( if (not $ Set.member @nt @lhs.newNTs) - then [ @loc.ntLabel ] - else [ ]) ++ - @prods.ppLI - -SEM Production - | Production lhs . ppL = if (Map.member @con @lhs.newProds) - then @children.ppL - else empty - - lhs . ppLI = if (not $ Map.member @con @lhs.newProds) - then @children.ppLI - else [] - - -SEM Child - | Child loc . chLabel = "ch_" >|< @loc.chName - loc . chTLabel = "Ch_" >|< @loc.chName - lhs . ppL = "data " >|< @loc.chTLabel >|< "; " >|< @loc.chLabel >|< pp " = proxy :: " >|< - case @kind of - ChildSyntax -> "Proxy " >|< "(" >|< @loc.chTLabel >|< ", " >|< @loc.ppTCh >|< ")" - _ -> "SemType " >|< @loc.ppTCh >|< pp " nt => Proxy " >|< - "(" >|< @loc.chTLabel >|< ", nt)" - - lhs . ppLI = [ @loc.chLabel, @loc.chTLabel ] - - --- attributes - - -SEM Grammar - | Grammar loc . ppA = vlist (map defAtt (filterAtts @loc.newAtts @loc.o_noGroup)) >-< -- not grouped - defAtt "loc" >-< -- local - (case @lhs.ext of - Nothing -> defAtt "inh" >-< defAtt "syn" -- grouped - otherwise -> empty) >-< - @nonts.ppA -- record definitions - - loc . ppAI = - let atts = filterNotAtts @loc.newAtts @loc.o_noGroup - in (foldr (\a as -> attName a : as) [] atts) ++ - (foldr (\a as -> attTName a : as) [] atts) ++ - (case @lhs.ext of - Nothing -> [] - otherwise -> [ attName "inh", attName "syn", attTName "inh", attTName "syn" ]) ++ - @nonts.ppAI - - - loc . ppANT = - let atts = filterNotAtts @loc.newAtts @loc.o_noGroup - in (foldr (\a as -> ("nts_" >|< a) : as) [] atts) - -ATTR Nonterminals Nonterminal Productions Production [ | | ppA USE {>-<} {empty} : PP_Doc ] - -SEM Nonterminal - | Nonterminal lhs . ppA = ( if (Set.member @nt @lhs.newNTs) - then - defAttRec (pp "InhG") @loc.ppNt @inh @loc.inhNoGroup >-< - defAttRec (pp "SynG") @loc.ppNt @syn @loc.synNoGroup - else empty) >-< - @prods.ppA - -SEM Production - | Production lhs . ppA = defLocalAtts @loc.prodName (length @rules.locals) 1 $ sort @rules.locals - - -ATTR Nonterminals Nonterminal [ | | ppAI USE {++} {[]} : {[PP_Doc]} ] - -SEM Nonterminal - | Nonterminal lhs . ppAI = if (not $ Set.member @nt @lhs.newNTs) - then [ ppName [(pp "InhG"), @loc.ppNt ] >#< pp "(..)", ppName [(pp "SynG"), @loc.ppNt ] >#< pp "(..)" ] - else [ ] - -{ -filterAtts newAtts = filter (\att -> Map.member (identifier att) newAtts) -filterNotAtts newAtts = filter (\att -> not (Map.member (identifier att) newAtts)) - -defAtt att = "data " >|< attTName att >|< "; " >|< attName att >|< " = proxy :: Proxy " >|< attTName att -attName att = pp $ "att_" ++ att -attTName att = pp $ "Att_" ++ att - - -defAttRec recPref ppNt atts noGroup = - let recName = ppName [recPref, ppNt] - fields = ppCommas (map (\(a,t) -> ppName [pp a, recName ] >|< " ::" >|< ppShow t) (groupAtts atts noGroup)) - in - "data " >|< recName >|< " = " >|< recName >|< " { " >|< fields >|< " }" - -groupAtts atts noGroup = (Map.toAscList . Map.difference atts) noGroup - --- it defines selectors with the form: --- l1_nt_prod(x, _, .., _) = x --- ln_nt_prod(_, .., _, x) = x -defLocalAtts prodName total actual (l:ls) = ppName [pp l, prodName] >|< - ppListSep "(" ")" "," (replicate (actual-1) "_" ++ "x" : replicate (total-actual) "_") >|< - pp " = x" >-< - defLocalAtts prodName total (actual+1) ls -defLocalAtts _ _ _ [] = empty - -} - - -ATTR Rules Rule [ | | locals USE {++} {[]} : {[Identifier]} ] - - -SEM Rule - | Rule lhs . locals = if (show (fst @pattern.info) == "loc") - then [ snd @pattern.info ] - else [ ] - - -ATTR Pattern [ || info : {(Identifier, Identifier)} ] -SEM Pattern - | Alias lhs . info = (@field, @attr) - | Constr lhs . info = error "Pattern Constr undefined!!" - | Product lhs . info = error "Pattern Product undefined!!" - | Underscore lhs . info = error "Pattern Underscore undefined!!" - - - --- rules - -SEM Grammar - | Grammar loc . ppNtL = @nonts.ppNtL - loc . ppR = ntsList "group" @loc.ppNtL >-< - vlist (map (\att -> ntsList att (filterNts att @loc.ppNtL)) (filterAtts @newAtts @loc.o_noGroup)) >-< - @nonts.ppR - -{ -ntsList att ppNtL = "nts_" ++ att ++ " = " >|< ppListSep "" "" " .*. " ((map fst ppNtL) ++ [pp "hNil"]) - -filterNts att = filter ( Map.member (identifier att) . snd ) -} - -ATTR Nonterminals Nonterminal [ | | ppNtL USE {++} {[]} : {[(PP_Doc, Attributes)]} ] -- list of nonterminals and its attributes - -SEM Nonterminal - | Nonterminal lhs . ppNtL = [ ("nt_" >|< @nt, Map.union @inh @syn) ] - - - - -ATTR Productions Production [ newNT : {Bool} | | ] -ATTR Rules Rule [ newProd : {Bool} | | ] - -SEM Nonterminal - | Nonterminal prods . newNT = Set.member @nt @lhs.newNTs - - -ATTR Nonterminals Nonterminal Productions Production Children Child [ | | ppR USE {>-<} {empty} : PP_Doc ] -ATTR Productions Production [ | | ppRA USE {++} {[]} : {[PP_Doc]} ] - - - - -SEM Nonterminal - | Nonterminal lhs . ppR = pp "----" >|< pp @nt >-< @prods.ppR - -SEM Production - | Production loc . newProd = Map.member @con @lhs.newProds - loc . (ppR,ppRA) - = let (instR, instRA) = defInstRules @lhs.ppNt @con @lhs.newNT @loc.newProd - @children.ppR @rules.ppRL @children.idCL @rules.locals - (locR, locRA) = defLocRule @lhs.ppNt @con @lhs.newNT @loc.newProd - @children.ppR @rules.ppRL @lhs.inhNoGroup @lhs.synNoGroup @children.idCL @rules.locals - (inhGR, inhGRA) = defInhGRule @lhs.ppNt @loc.prodName @lhs.newNT @loc.newProd - @children.ppR @rules.ppRL @lhs.inhNoGroup @lhs.synNoGroup @children.idCL @rules.locals - (synGR, synGRA) = defSynGRule @lhs.ppNt @con @lhs.newNT @loc.newProd - @children.ppR @rules.ppRL @lhs.inhNoGroup @lhs.synNoGroup @children.idCL @rules.locals - (inhR, inhRA) = defInhRules @lhs.ppNt @loc.prodName @lhs.newNT @loc.newProd @lhs.newAtts - @children.ppR @rules.ppRL @lhs.inhNoGroup @lhs.synNoGroup @children.idCL @rules.locals - (synR, synRA) = defSynRules @lhs.ppNt @con @lhs.newNT @loc.newProd @lhs.newAtts - @children.ppR @rules.ppRL @lhs.inhNoGroup @lhs.synNoGroup @children.idCL @rules.locals - (inhMR, inhMRA) = modInhRules @lhs.ppNt @loc.prodName @lhs.newNT @loc.newProd @lhs.newAtts - @children.ppR @rules.ppRL @lhs.inhNoGroup @lhs.synNoGroup @children.idCL @rules.locals - (synMR, synMRA) = modSynRules @lhs.ppNt @con @lhs.newNT @loc.newProd @lhs.newAtts - @children.ppR @rules.ppRL @lhs.inhNoGroup @lhs.synNoGroup @children.idCL @rules.locals - in ( vlist [instR,locR,inhGR,synGR,inhR,synR,inhMR,synMR] - , instRA ++ locRA ++ inhGRA ++ synGRA ++ inhMRA ++ synMRA ++ inhRA ++ synRA) - - -SEM Child - | Child lhs . ppR = let chName = ppListSep "" "" "_" [pp @name, @lhs.ppNt, @lhs.ppProd] - in pp @name >|< " <- at ch_" >|< chName - - -{ -data PPRule = PPRule Identifier Identifier Bool ([(Identifier,Type)] -> [Identifier] -> PP_Doc) - -ppRule (field,attr) owrt def = PPRule field attr owrt def -ruleField (PPRule field _ _ _ ) = field -ruleAttr (PPRule _ attr _ _ ) = attr -ruleOwrt (PPRule _ _ owrt _ ) = owrt -ruleDef (PPRule _ _ _ def) = def - -} -ATTR Rules Rule [ | | ppRL : {[ PPRule ]} ] - -SEM Rules - | Cons lhs . ppRL = @hd.ppRL ++ @tl.ppRL - | Nil lhs . ppRL = [] - -SEM Rule - | Rule lhs . ppRL = if (not @explicit && not @lhs.newProd && not (Map.member (snd @pattern.info) @lhs.newAtts) ) - then [] - else [ ppRule @pattern.info @owrt (defRule @lhs.ppNt @pattern.info @lhs.o_noGroup @rhs.ppRE) ] - -{- -ATTR Expression [ | | ppRE : {Identifier -> [String] -> [String] -> [(Identifier,Type)] -> [Identifier] -> PP_Doc} ] -SEM Expression - | Expression lhs . ppRE = rhsRule @lhs.ppNt @lhs.ppProd @tks --} - -ATTR Expression [ | | ppRE : {[String] -> Identifier -> [(Identifier,Type)] -> [Identifier] -> PP_Doc} ] -SEM Expression - | Expression lhs . ppRE = rhsRule @lhs.ppNt @lhs.ppProd @tks - - -ATTR Children Child [ || idCL USE {++} {[]} : {[(Identifier,Type)]} ] -SEM Child - | Child lhs . idCL = [ (@name, removeDeforested @tp ) ] - - - - -{ - -defInhGRule ppNt prodName newNT newProd ch rules inhNoGroup synNoGroup chids locals = - let ppAtt = ppName [pp "inh", prodName] - ppR = ppAtt >|< pp " = inhdefM att_inh nts_group $" >-< - indent 4 "do " >-< - indent 5 "loc <- at loc" >-< - indent 5 "lhs <- at lhs" >-< - indent 5 ch >-< - indent 5 "return $" >-< - indent 6 (foldr (>-<) (pp "emptyRecord") (map (chGRule ppNt prodName rules inhNoGroup synNoGroup chids locals) chids)) - in if (newNT || (not newNT && newProd)) - then (ppR, [ ppAtt ]) - else (empty, []) - -chGRule ppNt prodName rules inhNoGroup synNoGroup chids locals (idCh,tp) = - let chName = ppName [pp "ch", pp idCh, prodName] - ppTp = ppShow tp - chRules = ppCommas $ mapGRuleDefs (== idCh) rules inhNoGroup synNoGroup chids locals - in if (isNonterminal tp) - then chName >|< ".=." >-< - indent 1 "InhG_" >|< ppShow tp >|< pp " {" >-< - indent 2 chRules >-< - indent 1 "} .*. " - else empty - - -defSynGRule ppNt prod newNT newProd ch rules inhNoGroup synNoGroup chids locals = - let ppAtt = ppName [pp "syn", ppNt, pp prod] - ppTAtt = "SynG_" >|< ppNt - ppR = ppAtt >|< pp " = syndefM att_syn $" >-< - indent 4 "do " >-< - indent 5 "loc <- at loc" >-< - indent 5 "lhs <- at lhs" >-< - indent 5 ch >-< - indent 5 "return $" >-< - indent 6 ppTAtt >|< pp " {" >-< - indent 7 (ppCommas $ mapGRuleDefs ((== "lhs") . show) rules inhNoGroup synNoGroup chids locals) >-< - indent 6 "}" - in if (newNT || (not newNT && newProd)) - then (ppR, [ ppAtt ]) - else (empty, []) - -defLocRule ppNt prod newNT newProd ch rules inhNoGroup synNoGroup chids locals = - let ppAtt = ppName [pp "loc", ppNt, pp prod] - ppTAtt = ppName [pp "Loc", ppNt, pp prod] - ppR = ppAtt >|< pp " = locdefM att_loc $" >-< - indent 4 "do " >-< - indent 5 "loc <- at loc" >-< - indent 5 "lhs <- at lhs" >-< - indent 5 ch >-< - indent 5 "return $" >-< - indent 6 (ppListSep "(" ")" "," $ mapLRuleDefs rules inhNoGroup synNoGroup chids locals) - in (ppR, [ ppAtt ]) - -defInstRules ppNt prod newNT newProd ch rules chids locals - = let ppAsp = ppName [pp "inst", ppNt, pp prod] - instRules = filter ((=="inst") . show . ruleField) rules - ppAtt att = ppListSep "`ext` " "" "_" [pp "inst_ch", pp att, ppNt, pp prod] - in ( ppAsp >|< pp " = emptyRule " >|< (map (ppAtt . ruleAttr) instRules) >-< - (vlist $ map (defInstRule ppNt prod ch chids locals) instRules) - , [ ppAsp ]) - - -defInstRule ppNt prod ch chids locals rule = - let ppAtt = ppName [pp "ch", pp (ruleAttr rule), ppNt, pp prod] - in pp "inst_" >|< ppAtt >|< pp " = instdefM " >|< ppAtt >|< pp " $" >-< - indent 4 "do " >-< - indent 5 "loc <- at loc" >-< - indent 5 "lhs <- at lhs" >-< - indent 5 ch >-< - indent 5 "return $" >-< - indent 6 ((ruleDef rule) chids locals) - - -defSynRules ppNt prod newNT newProd newAtts ch rules inhNoGroup synNoGroup chids locals - = let synRules = filter ( (=="lhs") . show . ruleField) rules - ngRules = filter ((flip elem synNoGroup) . getName . ruleAttr) synRules - (ppR, ppRA) = unzip $ map (defSynRule True ppNt prod newNT newProd newAtts ch chids locals) ngRules - in (vlist ppR, concat ppRA ) - -modSynRules ppNt prod newNT newProd newAtts ch rules inhNoGroup synNoGroup chids locals - = let synRules = filter ( (=="lhs") . show . ruleField) rules - ngRules = filter ((flip elem synNoGroup) . getName . ruleAttr) synRules - (ppR, ppRA) = unzip $ map (defSynRule False ppNt prod newNT newProd newAtts ch chids locals) ngRules - in (vlist ppR, concat ppRA ) - -defSynRule new ppNt prod newNT newProd newAtts ch chids locals rule = - let att = ruleAttr rule - newAtt = Map.member att newAtts - owrt = ruleOwrt rule - ppAtt = ppName [pp att, pp (if new then "syn" else "synM"), ppNt, pp prod] - ppR def = ppAtt >|< pp (" = " ++ def ++ " ") >|< attName (show att) >|< pp " $" >-< - indent 4 "do " >-< - indent 5 "loc <- at loc" >-< - indent 5 "lhs <- at lhs" >-< - indent 5 ch >-< - indent 5 "return $" >-< - indent 6 ((ruleDef rule) chids locals) - in - if new - then if (not owrt && (newNT || (not newNT && newProd) || newAtt)) - then (ppR "syndefM", [ ppAtt ]) - else (empty, []) - else if owrt - then (ppR "synmodM", [ ppAtt ]) - else (empty, []) - - - -defInhRules ppNt prodName newNT newProd newAtts ch rules inhNoGroup synNoGroup chids locals - = let ngRules = filter ((flip elem inhNoGroup) . getName . ruleAttr) rules - (ppR, ppRA) = unzip $ map (defInhRule True ppNt prodName newNT newProd newAtts ch ngRules inhNoGroup synNoGroup chids locals) inhNoGroup - in (vlist ppR, concat ppRA) - -modInhRules ppNt prodName newNT newProd newAtts ch rules inhNoGroup synNoGroup chids locals - = let ngRules = filter ((flip elem inhNoGroup) . getName . ruleAttr) rules - (ppR, ppRA) = unzip $ map (defInhRule False ppNt prodName newNT newProd newAtts ch ngRules inhNoGroup synNoGroup chids locals) inhNoGroup - in (vlist ppR, concat ppRA) - - -defInhRule new ppNt prodName newNT newProd newAtts ch rules inhNoGroup synNoGroup chids locals att = - let ppAtt = ppName [pp att, pp (if new then "inh" else "inhM"),prodName] - newAtt = Map.member (identifier att) newAtts - chRMaybe = map (chRule new ppNt prodName att rules inhNoGroup synNoGroup chids locals) chids - chR = [ x | (Just x) <- chRMaybe ] - ppR def = ppAtt >|< pp (" = " ++ def ++ " ") >|< attName att >|< " nts_" >|< att >|< " $" >-< - indent 4 "do " >-< - indent 5 "loc <- at loc" >-< - indent 5 "lhs <- at lhs" >-< - indent 5 ch >-< - indent 5 "return $" >-< - indent 6 (foldr (>-<) (pp "emptyRecord") chR) - in - if new - then if (newNT || (not newNT && newProd) || newAtt) - then (ppR "inhdefM", [ ppAtt ]) - else (empty, []) - else if (not . null) chR - then (ppR "inhmodM", [ ppAtt ]) - else (empty, []) - - -chRule new ppNt prodName att rules inhNoGroup synNoGroup chids locals (idCh,tp) = - let chName = ppName [pp "ch", pp idCh, prodName] - ppTp = ppShow tp - chRule = inhRuleDef new (== idCh) (== att) rules inhNoGroup synNoGroup chids locals -- it's supposed to be only one - in if (isNonterminal tp && (not . null) chRule) - then Just $ chName >|< ".=. (" >|< chRule >|< ") .*. " - else Nothing - - -mapLRuleDefs rules inhNoGroup synNoGroup chids locals - = map appSnd $ sortBy cmpField $ filter ((== "loc") . show . ruleField) rules - where cmpField r1 r2 = compare (ruleField r1) (ruleField r2) - appSnd rule = (ruleDef rule) chids locals - - -mapGRuleDefs filt rules inhNoGroup synNoGroup chids locals - = map appSnd $ sortBy cmpField $ filter (not . (flip elem inhNoGroup) . getName . ruleAttr) - $ filter (not . (flip elem synNoGroup) . getName . ruleAttr) - $ filter ( filt . ruleField) rules - where cmpField r1 r2 = compare (ruleField r1) (ruleField r2) - appSnd rule = (ruleDef rule) chids locals - -inhRuleDef new filt1 filt2 rules inhNoGroup synNoGroup chids locals - = map appSnd $ sortBy cmpField $ filter ( (== not new) . ruleOwrt) - $ filter ((flip elem inhNoGroup) . getName . ruleAttr) - $ filter ( filt2 . getName . ruleAttr) - $ filter ( filt1 . ruleField) rules - where cmpField r1 r2 = compare (ruleField r1) (ruleField r2) - appSnd rule = (ruleDef rule) chids locals - -defRule ppNt (field,att) noGroup rhs = \chids locals -> - let ppAtt = if (elem (getName att) noGroup) - then empty - else case (show field) of - "lhs" -> att >|< "_" >|< pp "SynG" >|< pp "_" >|< ppNt >|< " = " - "loc" -> empty - "inst" -> empty - otherwise -> att >|< "_" >|< pp "InhG" >|< pp "_" >|< - (maybe (error $ "lhs field " ++ show field ++" is not a child") - ppShow (lookup field chids)) - >|< " = " - in ppAtt >|< (rhs noGroup field chids locals) - - -rhsRule ppNt ppProd tks noGroup field chids locals = vlist . lines2PP . (map (token2PP ppNt ppProd field chids locals noGroup )) $ tks - - -lines2PP [] = [] -lines2PP xs = map line2PP . shiftLeft . getLines $ xs - - -token2PP ppNt ppProd field chids locals noGroup tk - = case tk of - AGLocal var pos _ -> (pos, if (elem var locals) - then (ppListSep "(" "" "_" [pp var, ppNt, ppProd]) >|< pp " (loc # att_loc)) " - else pp var) - AGField field attr pos _ -> let ppChT = maybe (error $ "rhs field " ++ show field ++ " is not a child") ppShow (lookup field chids) - ppAtt = case (show field) of - "lhs" -> attName "inh" - "loc" -> attName "loc" - otherwise -> attName "syn" - ppSubAtt = case (show field) of - "lhs" -> ppName [pp (getName attr), pp "InhG", ppNt] - "loc" -> ppName [pp (getName attr), ppNt, ppProd] - otherwise -> ppName [pp (getName attr), pp "SynG", ppChT] - in (pos, if ((elem (getName attr) noGroup) && ((show field) /= "loc")) - then pp "(" >|< pp (getName field) >|< " # " >|< attName (getName attr) >|< pp ")" - else pp "(" >|< ppSubAtt >|< " (" >|< pp (getName field) >|< " # " >|< ppAtt >|< ")) ") - HsToken value pos -> (pos, pp value) - CharToken value pos -> (pos, pp (show value)) - StrToken value pos -> (pos, pp (show value)) - Err mesg pos -> (pos, pp $ " ***" ++ mesg ++ "*** ") - -line2PP ts = let f (p,t) r = let ct = column p - in \c -> pp (spaces (ct-c)) >|< t >|< r (length (show t) +ct) - spaces x | x < 0 = "" - | otherwise = replicate x ' ' - in foldr f (pp . const "") ts 1 - -} - ----------------------------------------------------------------------------------------------------------------------------------------------- - - -{ -ppMacro (Macro con children) = "( atts_" >|< show con >|< ", " >|< ppListSep "" "" " <.> " ppChildren >|<")" - where ppChildren = map ppChild children - ppChild (RuleChild ch n) = chName ch >|< " ==> " >|< ppMacro n - ppChild (ChildChild ch n) = chName ch >|< " --> " >|< n - ppChild (ValueChild ch n) = chName ch >|< " ~~> " >|< n - chName ch = ppName [pp "ch", pp ch, pp con] -} - --- catamorphisms - -ATTR Nonterminals Nonterminal Productions Production [ | | ppCata USE {>-<} {empty} : PP_Doc ] - -SEM Nonterminal - | Nonterminal lhs . ppCata = "----" >|< @loc.ppNt >-< @prods.ppCata - - -SEM Production - | Production lhs . ppCata = - let extend = maybe [] - ( \ext -> if (@lhs.newNT || (not @lhs.newNT && @loc.newProd)) - then [] - else [ ext >|< ".atts_" >|< @loc.prodName ]) - @lhs.ext - macro = case @macro of - Nothing -> [] - Just macro -> [ "agMacro " >|< ppMacro macro ] - atts = sortBy (\a b -> compare (show a) (show b)) @loc.ppRA - in "atts_" >|< @loc.prodName >|< " = " >|< - ppListSep "" "" " `ext` " - (atts ++ macro ++ extend ) >-< - "semP_" >|< @loc.prodName >|< pp " = knit atts_" >|< @loc.prodName - -{ -ppNoGroupAtts syn noGroup = let synatts = Map.keys $ Map.filterWithKey (\att _ -> elem (getName att) noGroup) syn - in map (flip (>|<) "_inh") noGroup ++ map (flip (>|<) "_syn") synatts - -ruleName att prodName = ppName [att,prodName] - -elemNT a b = False -} - -ATTR Productions Production [ syn, inh : { Attributes } | | ] - -SEM Nonterminal - | Nonterminal prods . syn = @syn - prods . inh = @inh - - - --- semantic functions - -ATTR Nonterminals Nonterminal Productions Production [ | | ppSF USE {>-<} {empty} : PP_Doc ] -ATTR Productions Production [ | | ppSPF USE {>-<} {empty} : PP_Doc ] - - -SEM Nonterminal - | Nonterminal lhs . ppSF = - let inhAtts = attTypes @loc.inhNoGroup - synAtts = attTypes @loc.synNoGroup - in - "----" >|< @loc.ppNt >-< - "type T_" >|< @loc.ppNt >|< " = " >|< - "(Record " >|< - inhAtts >|< - "(HCons (LVPair (Proxy Att_inh) InhG_" >|< @loc.ppNt >|< ") HNil))" >|< - replicate (length inhAtts) ")" >|< " -> " >|< - "(Record " >|< - synAtts >|< - "(HCons (LVPair (Proxy Att_syn) SynG_" >|< @loc.ppNt >|< ") HNil))" >|< - replicate (length synAtts) ")" >-< - "-- instance SemType T_" >|< @loc.ppNt >|< " " >|< @loc.ppNt >-< - "-- sem_" >|< @loc.ppNt >|< " :: " >|< @loc.ppNt >|< " -> T_" >|< @loc.ppNt >-< - @prods.ppSPF -- >-< - -- @prods.ppSF - -{ -attTypes atts = map (\(a,t) -> "(HCons (LVPair (Proxy Att_" >|< a >|< ") " >|< ppShow t >|< ") ") $ Map.toAscList atts -} - - -SEM Production - | Production lhs . ppSF = - let chi = @children.ppCSF - ppPattern = case (show @con) of - -- hardcoded list support - "Cons" -> ppParams (ppListSep "" "" " : ") - "Nil" -> pp "[]" - -- general case - otherwise -> @loc.conName >|< " " >|< (ppParams ppSpaced) - - ppParams f = f $ map (((>|<) (pp "_")) . fst) chi - in "sem_" >|< @lhs.ppNt >|< " (" >|< ppPattern >|< ") = sem_" >|< @loc.prodName >|< - " (" >|< map (fst . snd) chi >|< "emptyRecord)" - lhs . ppSPF = - let chi = @children.ppCSF - ppParams f = f $ map (((>|<) (pp "_")) . fst) chi - in "sem_" >|< @lhs.ppNt >|< "_" >|< @con >#< ppParams ppSpaced >|< " = semP_" >|< @loc.prodName >|< - " (" >|< map (snd . snd) chi >|< "emptyRecord)" - - -ATTR Children Child [ | | ppCSF USE {++} {[]} : {[(Identifier,(PP_Doc,PP_Doc))]} ] - - -SEM Child - | Child lhs . ppCSF = - let - semC = if (isNonterminal @tp) - then "sem_" >|< ppShow @tp >|< " _" >|< @name - else "sem_Lit _" >|< @name - in case @kind of - ChildSyntax -> [(@name, ( @loc.chLabel >|< " .=. (" >|< semC >|< ") .*. " - , @loc.chLabel >|< " .=. _" >|< @name >|< " .*. "))] - _ -> [] - - - - --- wrappers - ---TODO: create the records Inh_nt and Syn_nt to wrap the attributes - -ATTR Nonterminals Nonterminal [ | | ppW USE {>-<} {empty} : PP_Doc ] - -SEM Nonterminal - | Nonterminal lhs . ppW = - ppName [pp "wrap", @loc.ppNt] >|< " sem " >|< attVars @inh >|< " = " >-< - " sem " >|< attFields @inh @loc.inhNoGroup @loc.ppNt - - -{ -attVars atts = map (\(a,_) -> "_" >|< a >|< " ") $ Map.toAscList atts -attFields atts noGroup ppNt = - let ng = map (\(a,_) -> attName (getName a) >|< " .=. _" >|< a >|< " .*. ") $ Map.toAscList noGroup - g = ppCommas $ map (\(a,_) -> ppName [pp a, pp "InhG",ppNt] >|< "= _" >|< a) $ Map.toAscList $ Map.difference atts noGroup - in "(" >|< ng >|< "att_inh .=. " >|< ppName [pp "InhG", ppNt] >|< " { " >|< g >|< " } .*. emptyRecord)" -} diff --git a/src-ag/AbstractSyntax.ag b/src-ag/AbstractSyntax.ag deleted file mode 100644 --- a/src-ag/AbstractSyntax.ag +++ /dev/null @@ -1,76 +0,0 @@ -imports -{ --- AbstractSyntax.ag imports -import Data.Set(Set) -import Data.Map(Map) -import Patterns (Pattern(..),Patterns) -import Expression (Expression(..)) -import Macro --marcos -import CommonTypes -import ErrorMessages -} - -DATA Grammar | Grammar typeSyns : {TypeSyns} - useMap : {UseMap} - derivings : {Derivings} - wrappers : {Set NontermIdent} - nonts : Nonterminals - pragmas : {PragmaMap} -- pragmas defined at a certain alternative - manualAttrOrderMap : {AttrOrderMap} -- manually enforced dependencies between attributes - paramMap : {ParamMap} - contextMap : {ContextMap} - quantMap : {QuantMap} - uniqueMap : {UniqueMap} - augmentsMap : {Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))} - aroundsMap : {Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))} - mergeMap : {Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier, [Identifier], Expression)))} - -TYPE Nonterminals = [Nonterminal] - -TYPE Productions = [Production] - -TYPE Children = [Child] - -TYPE Rules = [Rule] - -TYPE TypeSigs = [TypeSig] - -DATA Nonterminal | Nonterminal nt : {NontermIdent} - params : {[Identifier]} - inh : {Attributes} - syn : {Attributes} - prods : Productions - -DATA Production | Production con : {ConstructorIdent} - params : {[Identifier]} - constraints : {[Type]} - children : Children - rules : Rules - typeSigs : TypeSigs - macro : MaybeMacro --marcos - -DATA Child | Child name : {Identifier} - tp : {Type} - kind : {ChildKind} - -DATA Rule | Rule mbName : {Maybe Identifier} - pattern : Pattern - rhs : Expression - owrt : {Bool} - origin : String -- just for documentation (and maybe errors) - explicit : Bool -- True if this rule defined in the source code - pure : Bool -- True if this rule is pure (does not have side effects) - identity : Bool -- True if this rule is an identity rule - mbError : {Maybe Error} -- scheduling this rule yields the given error, if present - eager : Bool -- for ordered scheduling: use an eager semantics - -DATA TypeSig | TypeSig name : {Identifier} - tp : {Type} - -SET AllAbstractSyntax - = Grammar - Nonterminal Nonterminals - Production Productions - Child Children - Rule Rules - TypeSig TypeSigs diff --git a/src-ag/AbstractSyntaxDump.ag b/src-ag/AbstractSyntaxDump.ag deleted file mode 100644 --- a/src-ag/AbstractSyntaxDump.ag +++ /dev/null @@ -1,76 +0,0 @@ -INCLUDE "AbstractSyntax.ag" -INCLUDE "Patterns.ag" -INCLUDE "Expression.ag" - -imports -{ -import Data.List -import qualified Data.Map as Map - -import Pretty -import PPUtil - -import AbstractSyntax -import TokenDef -} - -ATTR AllPattern AllAbstractSyntax AllExpression [ | | pp USE {>-<} {empty} : PP_Doc ] - -SEM Grammar - | Grammar lhs . pp = ppNestInfo ["Grammar","Grammar"] [] - [ ppF "typeSyns" $ ppAssocL @typeSyns - , ppF "useMap" $ ppMap $ Map.map ppMap $ @useMap - , ppF "derivings" $ ppMap $ @derivings - , ppF "wrappers" $ ppShow $ @wrappers - , ppF "nonts" $ ppVList @nonts.ppL - ] [] - -SEM Nonterminal - | Nonterminal lhs . pp = ppNestInfo ["Nonterminal","Nonterminal"] (pp @nt : map pp @params) [ppF "inh" $ ppMap @inh, ppF "syn" $ ppMap @syn, ppF "prods" $ ppVList @prods.ppL] [] - -SEM Production - | Production lhs . pp = ppNestInfo ["Production","Production"] [pp @con] [ppF "children" $ ppVList @children.ppL,ppF "rules" $ ppVList @rules.ppL,ppF "typeSigs" $ ppVList @typeSigs.ppL] [] - -SEM Child - | Child lhs . pp = ppNestInfo ["Child","Child"] [pp @name, ppShow @tp] [ppF "kind" $ ppShow @kind] [] - -SEM Rule - | Rule lhs . pp = ppNestInfo ["Rule","Rule"] [ppShow @owrt, pp @origin] [ppF "pattern" $ @pattern.pp, ppF "rhs" $ @rhs.pp] [] - -SEM TypeSig - | TypeSig lhs . pp = ppNestInfo ["TypeSig","TypeSig"] [pp @name, ppShow @tp] [] [] - -SEM Pattern - | Constr lhs . pp = ppNestInfo ["Pattern","Constr"] [pp @name] [ppF "pats" $ ppVList @pats.ppL] [] - | Product lhs . pp = ppNestInfo ["Pattern","Product"] [ppShow @pos] [ppF "pats" $ ppVList @pats.ppL] [] - | Alias lhs . pp = ppNestInfo ["Pattern","Alias"] [pp @field, pp @attr] [ppF "pat" $ @pat.pp] [] - | Underscore lhs . pp = ppNestInfo ["Pattern","Underscore"] [ppShow @pos] [] [] - -SEM Expression - | Expression lhs . pp = ppNestInfo ["Expression","Expression"] [ppShow @pos] [ppF "txt" $ vlist . showTokens . tokensToStrings $ @tks] [] - -ATTR Productions Nonterminals Children Rules TypeSigs Patterns [ | | ppL: {[PP_Doc]} ] - -SEM Patterns - | Cons lhs . ppL = @hd.pp : @tl.ppL - | Nil lhs . ppL = [] - -SEM TypeSigs - | Cons lhs . ppL = @hd.pp : @tl.ppL - | Nil lhs . ppL = [] - -SEM Rules - | Cons lhs . ppL = @hd.pp : @tl.ppL - | Nil lhs . ppL = [] - -SEM Children - | Cons lhs . ppL = @hd.pp : @tl.ppL - | Nil lhs . ppL = [] - -SEM Productions - | Cons lhs . ppL = @hd.pp : @tl.ppL - | Nil lhs . ppL = [] - -SEM Nonterminals - | Cons lhs . ppL = @hd.pp : @tl.ppL - | Nil lhs . ppL = [] diff --git a/src-ag/Code.ag b/src-ag/Code.ag deleted file mode 100644 --- a/src-ag/Code.ag +++ /dev/null @@ -1,163 +0,0 @@ -imports -{ -import Patterns -import Data.Set(Set) -import qualified Data.Set as Set -import Data.Map(Map) -import qualified Data.Map as Map -} - -TYPE Exprs = [Expr] -TYPE Decls = [Decl] -TYPE Chunks = [Chunk] -TYPE DataAlts = [DataAlt] -TYPE CaseAlts = [CaseAlt] -TYPE Types = [Type] -TYPE NamedTypes = [NamedType] - -DATA Program | Program chunks : Chunks - ordered : Bool - -DATA Chunk | Chunk name : String - comment : Decl - info : Decls - dataDef : Decls - cataFun : Decls - semDom : Decls - semWrapper : Decls - semFunctions : Decls - semNames : {[String]} - -DATA Expr | Let decls : Decls - body : Expr - | Case expr : Expr - alts : CaseAlts - | Do stmts : Decls - body : Expr - | Lambda args : Exprs - body : Expr - | TupleExpr exprs : Exprs - | UnboxedTupleExpr exprs : Exprs - | App name : {String} - args : Exprs - | SimpleExpr txt : {String} - | TextExpr lns : {[String]} - | Trace txt : {String} - expr : Expr - | PragmaExpr onLeftSide : {Bool} - onNewLine : {Bool} - txt : {String} - expr : Expr - | LineExpr expr : Expr - | TypedExpr expr : Expr - tp : Type - | ResultExpr nt : String - expr : Expr - | InvokeExpr nt : String - expr : Expr - args : Exprs - | ResumeExpr nt : String - expr : Expr - left : Lhs - rhs : Expr - | SemFun nt : {String} - args : Exprs - body : Expr - -DATA CaseAlt | CaseAlt left : Lhs - expr : Expr - -DATA Decl | Decl left : Lhs - rhs : Expr - binds : {Set String} -- set of variable names bound by the left-hand side - uses : {Set String} -- set of variable names used by the right-hand side - | Bind left : Lhs - rhs : Expr - | BindLet left : Lhs - rhs : Expr - | Data name : {String} - params: {[String]} - alts : DataAlts - strict: Bool - derivings : {[String]} - | NewType name : {String} - params: {[String]} - con : {String} - tp : Type - | Type name : {String} - params: {[String]} - tp : Type - | TSig name : {String} - tp : Type - | Comment txt : {String} - | PragmaDecl txt : {String} - - | Resume monadic : {Bool} - nt : String - left : Lhs - rhs : Expr - | EvalDecl nt : String - left : Lhs - rhs : Expr - -DATA DataAlt | DataAlt name : {String} - args : Types - | Record name : {String} - args : NamedTypes - -DATA NamedType | Named strict: {Bool} - name : {String} - tp : Type - -DATA Type | Arr left : Type - right : Type - | CtxApp left : {[(String, [String])]} - right : Type - | QuantApp left : String - right : Type - | TypeApp func : Type - args : Types - | TupleType tps : Types - | UnboxedTupleType tps : Types - | List tp : Type - | SimpleType txt : {String} - | NontermType name : String - params : {[String]} - deforested : Bool - | TMaybe tp : Type - | TEither left : Type - right : Type - | TMap key : Type - value : Type - | TIntMap value : Type - | TSet tp : Type - | TIntSet - -DATA Lhs | Pattern3 pat3 : Pattern - | Pattern3SM pat3 : Pattern - | TupleLhs comps : {[String]} -- \ [Lhs] appears to be more sensible - | UnboxedTupleLhs comps : {[String]} -- / - | Fun name : {String} - args : Exprs - | Unwrap name : {String} sub : Lhs - -DERIVING Type : Show - -{ --- Unboxed tuples --- unbox Whether unboxed tuples are wanted or not --- inh The inherited attributes. --- If there are none, no unboxing can take place, --- because in that case the semantic function (a top-level identifier) would have an unboxed type. --- Of course we can't have an unboxed 1-tuple -mkTupleExpr :: Bool -> Bool -> Exprs -> Expr -mkTupleExpr unbox' noInh exprs | not unbox' || noInh || length exprs == 1 = TupleExpr exprs - | otherwise = UnboxedTupleExpr exprs -mkTupleType :: Bool -> Bool -> Types -> Type -mkTupleType unbox' noInh tps | not unbox' || noInh || length tps == 1 = TupleType tps - | otherwise = UnboxedTupleType tps -mkTupleLhs :: Bool -> Bool -> [String] -> Lhs -mkTupleLhs unbox' noInh comps | not unbox' || noInh || length comps == 1 = TupleLhs comps - | otherwise = UnboxedTupleLhs comps -} - diff --git a/src-ag/CodeSyntax.ag b/src-ag/CodeSyntax.ag deleted file mode 100644 --- a/src-ag/CodeSyntax.ag +++ /dev/null @@ -1,90 +0,0 @@ -imports -{ -import Patterns -import CommonTypes -import Data.Map(Map) -import Data.Set(Set) -} - -DATA CGrammar - | CGrammar typeSyns : {TypeSyns} - derivings : {Derivings} - wrappers : {Set NontermIdent} - nonts : CNonterminals - pragmas : {PragmaMap} - paramMap : {ParamMap} - contextMap: {ContextMap} - quantMap : {QuantMap} - aroundsMap: {Map NontermIdent (Map ConstructorIdent (Set Identifier))} - mergeMap : {Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier])))} - multivisit : {Bool} - -TYPE CNonterminals = [CNonterminal] - -DATA CNonterminal - | CNonterminal nt : NontermIdent - params : {[Identifier]} - inh : Attributes - syn : Attributes - prods : CProductions - inter : CInterface - -DATA CInterface - | CInterface seg:CSegments - -TYPE CSegments = [CSegment] - -DATA CSegment - | CSegment inh : Attributes - syn : Attributes - -TYPE CProductions = [CProduction] - -DATA CProduction - | CProduction con : ConstructorIdent - visits : CVisits - children : {[(Identifier,Type,ChildKind)]} - terminals : {[Identifier]} - -TYPE CVisits = [CVisit] - -DATA CVisit - | CVisit inh : Attributes - syn : Attributes - vss : Sequence -- sequence of "steps", where each "step" is either an attribute definition or a child visit - intra : Sequence -- how to glue the visits together (child visits are child-intra's, attr-defs are attr-intra's) - ordered : Bool -- indicates that vss is ordered - -TYPE Sequence = [CRule] - -DATA CRule - | CRule name : Identifier - isIn : Bool -- True iff there is a definition for an inherited attribute - hasCode : Bool -- True iff there is an RHS - nt : NontermIdent - con : ConstructorIdent - field : Identifier - childnt : {Maybe NontermIdent} -- Just n: 'field' of 'nt' and 'con' is a nonterminal 'n', Nothing: it is a terminal - tp : {Maybe Type} -- type of the attribute - pattern : Pattern -- only defined if 'isIn' is False - rhs : {[String]} -- empty string if 'hasCode' is False - defines : {Map Int (Identifier,Identifier,Maybe Type)} -- the attributes defined by this rule - owrt : {Bool} - origin : String -- just for documentation (and maybe errors) - uses : {Set (Identifier, Identifier)} - explicit : Bool -- True if this an explicit rule found in the source file - mbNamed : {Maybe Identifier} - | CChildVisit name : Identifier -- corresponding to the name of the child - nt : NontermIdent - nr : Int -- visit number - inh : Attributes - syn : Attributes - isLast : Bool -- indicates whether this is the last visit to this child - -SET AllCodeSyntax - = CGrammar - CNonterminal CNonterminals - CInterface CSegments CSegment - CProduction CProductions - CVisits CVisit - CRule diff --git a/src-ag/CodeSyntaxDump.ag b/src-ag/CodeSyntaxDump.ag deleted file mode 100644 --- a/src-ag/CodeSyntaxDump.ag +++ /dev/null @@ -1,103 +0,0 @@ -INCLUDE "CodeSyntax.ag" -INCLUDE "Patterns.ag" - -imports -{ -import Data.List -import qualified Data.Map as Map - -import Pretty -import PPUtil - -import CodeSyntax -} - -{ -ppChild :: (Identifier,Type,ChildKind) -> PP_Doc -ppChild (nm,tp,_) - = pp nm >#< "::" >#< pp (show tp) - -ppVertexMap :: Map Int (Identifier,Identifier,Maybe Type) -> PP_Doc -ppVertexMap m - = ppVList [ ppF (show k) $ ppAttr v | (k,v) <- Map.toList m ] - -ppAttr :: (Identifier,Identifier,Maybe Type) -> PP_Doc -ppAttr (fld,nm,mTp) - = pp fld >|< "." >|< pp nm >#< - case mTp of - Just tp -> pp "::" >#< show tp - Nothing -> empty - -ppBool :: Bool -> PP_Doc -ppBool True = pp "T" -ppBool False = pp "F" - -ppMaybeShow :: Show a => Maybe a -> PP_Doc -ppMaybeShow (Just x) = pp (show x) -ppMaybeShow Nothing = pp "_" - -ppStrings :: [String] -> PP_Doc -ppStrings = vlist -} - - -ATTR AllPattern AllCodeSyntax [ | | pp USE {>-<} {empty} : PP_Doc ] - -SEM CGrammar - | CGrammar lhs . pp = ppNestInfo ["CGrammar","CGrammar"] [] - [ ppF "typeSyns" $ ppAssocL @typeSyns - , ppF "derivings" $ ppMap $ @derivings - , ppF "nonts" $ ppVList @nonts.ppL - ] [] - -SEM CNonterminal - | CNonterminal lhs . pp = ppNestInfo ["CNonterminal","CNonterminal"] (pp @nt : map pp @params) [ppF "inh" $ ppMap @inh, ppF "syn" $ ppMap @syn, ppF "prods" $ ppVList @prods.ppL, ppF "inter" @inter.pp] [] - -SEM CInterface - | CInterface lhs . pp = ppNestInfo ["CInterface","CInterface"] [] [ppF "seg" $ ppVList @seg.ppL] [] - -SEM CSegment - | CSegment lhs . pp = ppNestInfo ["CSegment","CSegment"] [] [ppF "inh" $ ppMap @inh, ppF "syn" $ ppMap @syn] [] - -SEM CProduction - | CProduction lhs . pp = ppNestInfo ["CProduction","CProduction"] [pp @con] [ppF "visits" $ ppVList @visits.ppL, ppF "children" $ ppVList (map ppChild @children),ppF "terminals" $ ppVList (map ppShow @terminals)] [] - -SEM CVisit - | CVisit lhs . pp = ppNestInfo ["CVisit","CVisit"] [] [ppF "inh" $ ppMap @inh, ppF "syn" $ ppMap @syn, ppF "sequence" $ ppVList @vss.ppL, ppF "intra" $ ppVList @intra.ppL, ppF "ordered" $ ppBool @ordered] [] - -SEM CRule - | CRule lhs . pp = ppNestInfo ["CRule","CRule"] [pp @name] [ppF "isIn" $ ppBool @isIn, ppF "hasCode" $ ppBool @hasCode, ppF "nt" $ pp @nt, ppF "con" $ pp @con, ppF "field" $ pp @field, ppF "childnt" $ ppMaybeShow @childnt, ppF "tp" $ ppMaybeShow @tp, ppF "pattern" $ if @isIn then pp "" else @pattern.pp, ppF "rhs" $ ppStrings @rhs, ppF "defines" $ ppVertexMap @defines, ppF "owrt" $ ppBool @owrt, ppF "origin" $ pp @origin] [] - | CChildVisit lhs . pp = ppNestInfo ["CRule","CChildVisit"] [pp @name] [ppF "nt" $ pp @nt, ppF "nr" $ ppShow @nr, ppF "inh" $ ppMap @inh, ppF "syn" $ ppMap @syn, ppF "last" $ ppBool @isLast] [] - -SEM Pattern - | Constr lhs . pp = ppNestInfo ["Pattern","Constr"] [pp @name] [ppF "pats" $ ppVList @pats.ppL] [] - | Product lhs . pp = ppNestInfo ["Pattern","Product"] [ppShow @pos] [ppF "pats" $ ppVList @pats.ppL] [] - | Alias lhs . pp = ppNestInfo ["Pattern","Alias"] [pp @field, pp @attr] [ppF "pat" $ @pat.pp] [] - | Underscore lhs . pp = ppNestInfo ["Pattern","Underscore"] [ppShow @pos] [] [] - - -ATTR CNonterminals CSegments CProductions CVisits Sequence Patterns [ | | ppL: {[PP_Doc]} ] - -SEM Patterns - | Cons lhs . ppL = @hd.pp : @tl.ppL - | Nil lhs . ppL = [] - -SEM Sequence - | Cons lhs . ppL = @hd.pp : @tl.ppL - | Nil lhs . ppL = [] - -SEM CVisits - | Cons lhs . ppL = @hd.pp : @tl.ppL - | Nil lhs . ppL = [] - -SEM CProductions - | Cons lhs . ppL = @hd.pp : @tl.ppL - | Nil lhs . ppL = [] - -SEM CSegments - | Cons lhs . ppL = @hd.pp : @tl.ppL - | Nil lhs . ppL = [] - -SEM CNonterminals - | Cons lhs . ppL = @hd.pp : @tl.ppL - | Nil lhs . ppL = [] diff --git a/src-ag/ConcreteSyntax.ag b/src-ag/ConcreteSyntax.ag deleted file mode 100644 --- a/src-ag/ConcreteSyntax.ag +++ /dev/null @@ -1,132 +0,0 @@ -imports -{ -import UU.Scanner.Position (Pos) -import Patterns (Pattern) -import Expression (Expression) -import CommonTypes -import Macro --marcos -} - - -TYPE Elems = [Elem] - -TYPE Alts = [Alt] - -TYPE Fields = [Field] - -TYPE SemAlts = [SemAlt] - -TYPE SemDefs = [SemDef] - -DATA AG | AG elems : Elems - -DATA Elem | Data pos : {Pos} - contype : {ConstructorType} - ctx : {ClassContext} - names : NontSet - params : {[Identifier]} - attrs : Attrs - alts : Alts - ext : {Bool} - - | Type pos : {Pos} - ctx : {ClassContext} - name : {NontermIdent} - params : {[Identifier]} - type : {ComplexType} - - | Attr pos : {Pos} - ctx : {ClassContext} - names : NontSet - quants : {[String]} - attrs : Attrs - - | Sem pos : {Pos} - ctx : {ClassContext} - names : NontSet - attrs : Attrs - quants : {[String]} - alts : SemAlts - - | Txt pos : {Pos} - kind : {BlockKind} - mbNt : {Maybe NontermIdent} - lines : {[String]} - - | Set pos : {Pos} - name : {NontermIdent} - merge : Bool - set : NontSet - - | Deriving pos : {Pos} - set : NontSet - classes : {[NontermIdent]} - - | Wrapper pos : {Pos} - set : NontSet - - | Nocatas pos : {Pos} - set : NontSet - - | Pragma pos : {Pos} - names: {[NontermIdent]} - - | Module pos : {Pos} - name : {String} -- name of the haskell module - exports : {String} -- exports of the haskell module - imports : {String} -- imports to replicate to generated haskell modules - -DATA Attrs | Attrs pos : {Pos} - inh,chn,syn : {AttrNames} - -DATA Alt | Alt pos : {Pos} - names : ConstructorSet - tyvars : {[Identifier]} - fields : Fields - macro : MaybeMacro --marcos: macro extension - -DATA Field | FChild name : Identifier - tp : Type - | FCtx tps : {[Type]} - -DATA SemAlt | SemAlt pos : {Pos} - constructorSet : ConstructorSet - rules : SemDefs - -DATA SemDef | Def pos : Pos - mbName : {Maybe Identifier} - pattern: Pattern - rhs : {Expression} - owrt : {Bool} - pure : Bool - eager : Bool - | TypeDef pos : {Pos} - ident : {Identifier} - tp : Type - | UniqueDef ident : {Identifier} - ref : {Identifier} - | AugmentDef ident : {Identifier} - rhs : {Expression} - | AroundDef ident : {Identifier} - rhs : {Expression} - | MergeDef target : {Identifier} - nt : {Identifier} - sources : {[Identifier]} - rhs : {Expression} - | SemPragma names : {[NontermIdent]} - | AttrOrderBefore before : {[Occurrence]} - after : {[Occurrence]} - -DATA ConstructorSet | CName name : {ConstructorIdent} - | CUnion set1,set2 : ConstructorSet - | CDifference set1,set2 : ConstructorSet - | CAll - -DATA NontSet | NamedSet name : {NontermIdent} - | All - | Union set1,set2 : NontSet - | Intersect set1,set2 : NontSet - | Difference set1,set2 : NontSet - | Path from,to : {NontermIdent} - - diff --git a/src-ag/DeclBlocks.ag b/src-ag/DeclBlocks.ag deleted file mode 100644 --- a/src-ag/DeclBlocks.ag +++ /dev/null @@ -1,20 +0,0 @@ -imports -{ -import Code (Decl,Expr) -} - - -DATA DeclBlocksRoot - | DeclBlocksRoot - blocks : DeclBlocks - - -DATA DeclBlocks - | DeclBlock - defs : {[Decl]} - visit : {Decl} - next : DeclBlocks - | DeclTerminator - defs : {[Decl]} - result : {Expr} - diff --git a/src-ag/DefaultRules.ag b/src-ag/DefaultRules.ag deleted file mode 100644 --- a/src-ag/DefaultRules.ag +++ /dev/null @@ -1,821 +0,0 @@ --- 13 okt 2011: eliminated the "multiRule" transformation for all but the Kastens-code --- the SELF types are also eliminated in this phase: in a Type value, there should not be --- a Self constructor anymore. - -PRAGMA strictdata -PRAGMA optimize -PRAGMA bangpats -PRAGMA strictwrap - -INCLUDE "AbstractSyntax.ag" -INCLUDE "Patterns.ag" -INCLUDE "DistChildAttr.ag" - -imports -{ -import qualified Data.List -import qualified Data.Set as Set -import qualified Data.Map as Map -import Data.Map(Map) -import qualified Data.Sequence as Seq -import Data.Sequence(Seq,(><)) -import UU.Scanner.Position(noPos) -import Pretty -import Data.Maybe -import HsToken -import HsTokenScanner -import Data.List(intersperse) -import Data.Char - -import AbstractSyntax -import ErrorMessages - -import Options -} - -------------------------------------------------------------------------------- --- Passing down corresponding nonterminal and constructor names -------------------------------------------------------------------------------- -ATTR Rule Rules Child Children Production Productions TypeSigs TypeSig Pattern Patterns [ nt:NontermIdent | | ] -ATTR Rule Rules Child Children Pattern Patterns [ con:ConstructorIdent | | ] - -ATTR Productions Production Children Child TypeSigs TypeSig [ params : {[Identifier]} | | ] -SEM Nonterminal | Nonterminal - prods.params = @params - - -------------------------------------------------------------------------------- --- Distributing options -------------------------------------------------------------------------------- - -ATTR Grammar Nonterminals Nonterminal Productions Production Rules Rule - [ options:{Options} - constructorTypeMap : {Map NontermIdent ConstructorType} | | ] -ATTR Nonterminals Nonterminal Productions Production [ o_rename:{Bool} - cr:Bool {- copy rule -} - | | ] - -ATTR Children Child [ cr:Bool {- copy rule -} | | ] -SEM Grammar - | Grammar nonts.o_rename = rename @lhs.options - nonts.cr = modcopy @lhs.options - -------------------------------------------------------------------------------- --- Passing down the set of wrapper names -------------------------------------------------------------------------------- - -ATTR Nonterminals Nonterminal Productions Production [ wrappers : {Set NontermIdent} | | ] -SEM Grammar | Grammar - nonts.wrappers = @wrappers - -------------------------------------------------------------------------------- --- Type synonyms environment -------------------------------------------------------------------------------- -ATTR Nonterminals Nonterminal Productions Production [ typeSyns : {TypeSyns} | | ] - - -------------------------------------------------------------------------------- --- some auxiliary functions -------------------------------------------------------------------------------- -{ -fieldName n = '@' : getName n - -locName n = "@loc." ++ getName n - -attrName fld attr - | fld == _LOC = locName attr - | fld == _FIELD = fieldName attr - | otherwise = '@' : getName fld ++ "." ++ getName attr - -_ACHILD = Ident "(" noPos -- hack - -mkLocVar = AGField _LOC - -isRecordConstructor :: NontermIdent -> Map NontermIdent ConstructorType -> Bool -isRecordConstructor nt ctm = Map.lookup nt ctm == Just RecordConstructor - -buildConExpr ocaml clean conmap typeSyns rename nt con1 fs' - | nt `elem` map fst typeSyns = if ocaml then synonymMl - else if clean then synonymClean - else synonymHs - | otherwise = normalExpr - where fs = map fst fs' - con = getName con1 - tup = " " ++ buildTuple fs - args = " " ++ unwords fs - normalExpr = if clean && isRecordConstructor nt conmap - then "{" ++ con ++ "|" ++ - unwords (intersperse "," $ map (\(new, old) -> getName old ++ " = " ++ new) fs') - ++ "}" - else conname' ++ args - - conname' | rename = getName nt ++ "_" ++ getName con1 - | otherwise = getName con1 - - synonymHs | con == "Tuple" = buildTuple fs - | con == "Cons" = "(:)" ++ args - | con == "Nil" = case lookup nt typeSyns of - Just (Map _ _) -> "Data.Map.empty" - Just (IntMap _) -> "Data.IntMap.empty" - Just (OrdSet _) -> "Data.Set.empty" - Just IntSet -> "Data.IntSet.empty" - _ -> "[]" - | con == "Just" = "Just" ++ args - | con == "Nothing" = "Nothing" - | con == "Entry" = ( case lookup nt typeSyns of - Just (Map _ _) -> "Data.Map.insert" - Just (IntMap _) -> "Data.IntMap.insert" - Just (OrdSet _) -> "Data.Set.insert" - Just IntSet -> "Data.IntSet.insert" ) ++ args - | otherwise = normalExpr - - synonymMl | con == "Tuple" = buildTuple fs - | con == "Cons" = "(::)" ++ tup - | con == "Nil" = case lookup nt typeSyns of - Just (Map _ _) -> prefixMod nt "empty" - Just (IntMap _) -> prefixMod nt "empty" - Just (OrdSet _) -> prefixMod nt "empty" - Just IntSet -> prefixMod nt "empty" - _ -> "[]" - | con == "Just" = "Some" ++ tup - | con == "Nothing" = "None" - | con == "Entry" = ( case lookup nt typeSyns of - Just (Map _ _) -> prefixMod nt "add" - Just (IntMap _) -> prefixMod nt "add" - Just (OrdSet _) -> prefixMod nt "add" - Just IntSet -> prefixMod nt "add" ) ++ args - | otherwise = normalExpr - - synonymClean | con == "Tuple" = buildTuple fs - | con == "Cons" = "(\\x xs -> [x:xs])" ++ args - | con == "Nil" = case lookup nt typeSyns of - Just (Map _ _) -> "Data.Map.empty" - Just (IntMap _) -> "Data.IntMap.empty" - Just (OrdSet _) -> "Data.Set.empty" - Just IntSet -> "Data.IntSet.empty" - _ -> "[]" - | con == "Just" = "Just" ++ args - | con == "Nothing" = "Nothing" - | con == "Entry" = ( case lookup nt typeSyns of - Just (Map _ _) -> "Data.Map.insert" - Just (IntMap _) -> "Data.IntMap.insert" - Just (OrdSet _) -> "Data.Set.insert" - Just IntSet -> "Data.IntSet.insert" ) ++ args - | otherwise = normalExpr - - - prefixMod nt nm = "M_" ++ getName nt ++ "." ++ nm - -concatSeq = foldr (Seq.><) Seq.empty - -splitAttrs :: Map Identifier a -> [Identifier] -> ([(Identifier,a)],[Identifier]) -- a used as (String,String) -splitAttrs _ [] - = ([],[]) -splitAttrs useMap (n:rest) - = let (uses,normals) = splitAttrs useMap rest - in case Map.lookup n useMap of - Just x -> ((n,x):uses , normals ) - Nothing -> ( uses , n:normals ) - -removeDefined :: Set (Identifier,Identifier) -> (Identifier,Attributes) -> (Identifier,[Identifier]) -removeDefined defined (fld,as) - = ( fld - , [ a - | a <- Map.keys as - , not (Set.member (fld,a) defined) - ] - ) - -} - -------------------------------------------------------------------------------- --- Errors -------------------------------------------------------------------------------- - -ATTR Grammar Nonterminals Nonterminal Productions Production - Child Children Rule Rules Pattern Patterns - [ | | errors USE {Seq.><} {Seq.empty}:{Seq Error} ] - -------------------------------------------------------------------------------- --- Set of all defined nonterminals -------------------------------------------------------------------------------- - -ATTR Nonterminals Nonterminal [ || collect_nts USE {`Set.union`} {Set.empty} : {Set NontermIdent} ] -SEM Nonterminal - | Nonterminal lhs.collect_nts = Set.singleton @nt - -ATTR Nonterminals Nonterminal Productions Production [ nonterminals : {Set NontermIdent} || ] -SEM Grammar - | Grammar nonts.nonterminals = @nonts.collect_nts - -------------------------------------------------------------------------------- --- Pass down the lhs-attributes and the USE's to each alternative of a nonterminal -------------------------------------------------------------------------------- - -ATTR Nonterminals Nonterminal [ useMap : {UseMap} || ] -ATTR Productions Production [ inh, syn, inhOrig, synOrig : {Attributes} useMap : {Map Identifier (String,String,String)}|| ] - -SEM Nonterminal - | Nonterminal prods.inh = @loc.inh1 - prods.syn = @loc.syn1 - prods.inhOrig = @inh - prods.synOrig = @syn - prods.useMap = Map.findWithDefault Map.empty @nt @lhs.useMap - -SEM Production - | Production rules.con = @con - children.con = @con -SEM Child - | Child lhs . name = @name -SEM Grammar - | Grammar nonts . useMap = @useMap -SEM Grammar - | Grammar nonts . typeSyns = @typeSyns -SEM Nonterminal - | Nonterminal prods . nt = @nt - -SEM Child [ | | name:{Identifier} inherited,synthesized:{Attributes} ] - | Child lhs.inherited = @loc.inh1 - lhs.synthesized = if @name `Set.member` @lhs.merged - then Map.empty - else @loc.syn1 - -SEM Children [ | | inputs,outputs:{[(Identifier, Attributes)]} ] - | Cons lhs.inputs = (@hd.name, @hd.inherited) : @tl.inputs - .outputs = (@hd.name, @hd.synthesized) : @tl.outputs - | Nil lhs.inputs = [] - .outputs = [] - - - -------------------------------------------------------------------------------- --- Implementation of Use-rule and Copy-rule -------------------------------------------------------------------------------- - -{ - - - -deprecatedCopyRuleError nt con fld a - = let mesg = - "In the definitions for alternative" - >#< getName con - >#< "of nonterminal" - >#< getName nt - >|< "," - >-< "the value of field" - >#< getName a - >#< "is copied by a copy-rule." - >-< "Copying the value of a field using a copy-rule is deprecated" - >-< "Please add the following lines to your code:" - >-< ( "SEM" - >#< getName nt - >-< indent 2 ( "|" - >#< getName con - >#< getName fld - >#< "." - >#< a - >#< "=" - >#< "@" - >|< a - ) - ) - in CustomError True (getPos a) mesg - - -missingRuleErrorExpr clean nt con fld a - = (if clean then "abort" else "error") - ++ " \"missing rule: " - ++ show nt ++ "." ++ show con ++ "." - ++ show fld ++ "." ++ show a ++ "\"" - -makeRule :: (Identifier,Identifier) -> Expression -> String -> Bool -> Maybe Error -> Rule -makeRule (f1,a1) expr origin identity mbDelayedError - = Rule Nothing - (Alias f1 a1 (Underscore noPos)) - expr - False - origin - False - True - identity - mbDelayedError - False - - -useRule :: Options -> Set Identifier -> [(Identifier,Attributes)] -> (Identifier,(String,String,String)) -> Rule -useRule opts locals ch_outs (n,(op,e,pos)) - = let elems = [ fld - | (fld,as) <- ch_outs - , Map.member n as - ] - - isOp [] = False - isOp (c:cs) - | isSpace c = isOp cs - | isAlpha c = case dropWhile isAlpha cs of - ('.':cs2) -> isOp cs2 -- fully qualified name, drop prefix - _ -> False - | c == '(' = False - | otherwise = True - - tks | Set.member n locals = [mkLocVar n noPos Nothing] - | null elems = lexTokens opts noPos e - | otherwise = lexTokens opts noPos str - where - opExpr l r - | isOp op = l ++ " " ++ op ++ " " ++ r -- takes the associativity of the operator - | otherwise = "(" ++ op ++ " " ++ l ++ " " ++ r ++ ")" -- associates to the right - str = foldr1 opExpr (map (flip attrName n) elems) - - in makeRule (_LHS,n) - (Expression noPos tks) - ("use rule " ++ pos) - False - Nothing - - -selfRule :: Bool -> Identifier -> [HsToken] -> Rule -selfRule lhsNecLoc attr tks - = makeRule (if lhsNecLoc then _LHS else _LOC,attr) - (Expression noPos tks) - "self rule" - False - Nothing - - - - -concatRE rsess = let (rss,ess) = unzip rsess - in (concat rss, concatSeq ess) - - -copyRule :: Options -> Set NontermIdent -> Identifier -> Identifier -> Bool -> Set Identifier -> (Map Identifier Identifier, (Identifier,[Identifier])) -> ([Rule], Seq Error) -copyRule options wrappers nt con modcopy locals (env,(fld,as)) - = concatRE (map copyRu as) - - where - copyRu a - = ( [ makeRule (fld,a) - (Expression noPos tks) - (cruletxt sel) - True - mbDelayedErr - ] - , err - ) - - where - sel - | not modcopy - && Set.member a locals = Just _LOC - | otherwise = Map.lookup a env - - (tks,err,mbDelayedErr) - = case sel of - Nothing -> let tks = [HsToken (missingRuleErrorExpr (clean options) nt con fld a) noPos] - err = MissingRule nt con fld a - in if nt `Set.member` wrappers && kennedyWarren options - then (tks, Seq.empty, Just err) -- yield error only if the rule is actually scheduled; for kennedyWarren code gen only - else (tks, Seq.singleton err, Nothing) - Just f - | f == _ACHILD -> ( [AGLocal a noPos Nothing] - , Seq.singleton (deprecatedCopyRuleError nt con fld a) - , Nothing - ) - | otherwise -> ( [AGField f a noPos Nothing] - , Seq.empty - , Nothing - ) - - cruletxt sel - | local = "copy rule (from local)" - | deprChild = "deprecated child copy" - | Set.member a locals && nonlocal = "modified copy rule" - | incoming && outgoing = "copy rule (chain)" - | incoming = "copy rule (down)" - | outgoing = "copy rule (up)" - | otherwise = "copy rule (chain)" - where outgoing = fld == _LHS - incoming = maybe False (== _LHS) sel - nonlocal = maybe False (/= _LOC) sel - local = maybe False (== _LOC) sel - deprChild = maybe False (== _ACHILD) sel -} - - - - -SEM Production - | Production - - lhs.errors = @children.errors >< @errs >< @rules.errors >< @loc.orderErrs - - loc.(newRls, errs) - = - let locals = @rules.locals - initenv = Map.fromList ( [ (a,_ACHILD) -- _ACHILD is used to mark identifiers in the environment that are terminals - | (a,_,_) <- @children.fields - ] - ++ attrs(_LHS, @lhs.inh) - ++ [ (a,_LOC) - | a <- Set.toList locals - ] - ) - - attrs (n,as) = [ (a,n) | a <- Map.keys as ] - - envs = scanl (flip Map.union) - initenv - (map (Map.fromList . attrs ) @children.outputs) - - child_envs = init envs - lhs_env = last envs - - (selfAttrs, normalAttrs) - = Map.partitionWithKey (\k _ -> maybe False isSELFNonterminal $ Map.lookup k @lhs.synOrig) @lhs.syn - - (_,undefAttrs) - = removeDefined @rules.definedAttrs (_LHS, normalAttrs) - - (useAttrs,others) - = splitAttrs @lhs.useMap undefAttrs - - (rules1, errors1) - = concatRE $ map (copyRule @lhs.options @lhs.wrappers @lhs.nt @con @lhs.cr locals) - (zip envs (map (removeDefined @rules.definedAttrs) @children.inputs)) - - uRules - = map (useRule @lhs.options locals @children.outputs) useAttrs - - -- creates a loc.xxx if there is a synthesized attr xxx of type SELF and no - -- loc.xxx exists yet. If there exists a terminal yyy and a local loc.yyy, then - -- the local is chosen as value for the terminal. - selfLocRules - = [ selfRule False attr $ - lexTokens @lhs.options noPos $ -- building a string and lexing it again is not so nice... but practical here - constructor [(childSelf attr nm tp, nm) | (nm,tp,virt) <- @children.fields, childExists virt] - | attr <- Map.keys selfAttrs - , not (Set.member attr locals) - ] - where - childSelf self nm tp - = case tp of NT nt _ _ -> attrName nm self - _ | nm `Set.member` locals -> locName nm - | otherwise -> fieldName nm - constructor fs - = buildConExpr (ocaml @lhs.options) (clean @lhs.options) @lhs.constructorTypeMap @lhs.typeSyns @lhs.o_rename @lhs.nt @con fs - - childExists ChildAttr = False - childExists _ = True - - selfRules - = [ selfRule True attr [mkLocVar attr noPos Nothing] - | attr <- Map.keys selfAttrs - , not (Set.member (_LHS,attr) @rules.definedAttrs) - ] - - (rules5, errs5) - = copyRule @lhs.options - @lhs.wrappers - @lhs.nt - @con - @lhs.cr - locals - (lhs_env, (_LHS, others)) - in (uRules++selfLocRules++selfRules++rules5++rules1, errors1> [Rule] -> [Rule] -addAugments (_, exprs) rules - | null exprs = rules -addAugments (syn, exprs) rules - = [rule] ++ funRules ++ map modify rules - where - rule = Rule Nothing (Alias _LHS syn (Underscore noPos)) rhs False "augmented rule" False True False Nothing False - rhs = Expression noPos tks - tks = [ HsToken "foldr ($) " noPos, mkLocVar substSyn noPos Nothing, HsToken " [" noPos] ++ funs ++ [HsToken "]" noPos] - funs = intersperse (HsToken ", " noPos) (map (\n -> mkLocVar n noPos Nothing) funNames) - - substSyn = Ident (show syn ++ "_augmented_syn") (getPos syn) - funNames = zipWith (\i _ -> Ident (show syn ++ "_augmented_f" ++ show i) (getPos syn)) [1..] exprs - funRules = zipWith (\name expr -> Rule Nothing (Alias _LOC name (Underscore noPos)) expr False "augment function" False True False Nothing False) funNames exprs - - modify (Rule mbNm pat rhs owrt origin expl pure identity mbErr eager) - | containsSyn pat = Rule mbNm (modifyPat pat) rhs owrt origin expl pure identity mbErr eager - modify r = r - - containsSyn (Constr _ pats) = any containsSyn pats - containsSyn (Product _ pats) = any containsSyn pats - containsSyn (Irrefutable pat) = containsSyn pat - containsSyn (Alias field attr pat) = (field == _LHS && attr == syn) || containsSyn pat - containsSyn _ = False - - modifyPat (Constr name pats) = Constr name (map modifyPat pats) - modifyPat (Product pos pats) = Product pos (map modifyPat pats) - modifyPat (Irrefutable pat) = Irrefutable (modifyPat pat) - modifyPat (Alias field attr pat) - | field == _LHS && attr == syn = Alias _LOC substSyn (modifyPat pat) - | otherwise = Alias field attr (modifyPat pat) - modifyPat p = p - --- adds the additional rules needed for around, which creates a sequence of --- rules that form a function that each transforms the semantics of a child --- before attaching the child. --- The rule defines a local attribute "_around" and is dependent --- on this attribute. -addArounds :: (Identifier, [Expression]) -> [Rule] -> [Rule] -addArounds (_, exprs) rules | null exprs = rules -addArounds (child, exprs) rules - = [rule] ++ funRules ++ rules - where - rule = Rule Nothing (Alias _LOC childLoc (Underscore noPos)) rhs False "around rule" False True False Nothing False - rhs = Expression noPos tks - tks = [ HsToken "\\s -> foldr ($) s " noPos, HsToken " [" noPos] ++ funs ++ [HsToken "]" noPos] - funs = intersperse (HsToken ", " noPos) (map (\n -> mkLocVar n noPos Nothing) funNames) - - childLoc = Ident (show child ++ "_around") (getPos child) - funNames = zipWith (\i _ -> Ident (show child ++ "_around_f" ++ show i) (getPos child)) [1..] exprs - funRules = zipWith (\name expr -> Rule Nothing (Alias _LOC name (Underscore noPos)) expr False "around function" False True False Nothing False) funNames exprs - --- adds the additional rules needed for merging. --- It produces for each merging child a rule with local attribute: "_merged". --- this rules takes the semantics of the first children and feeds it to the function --- represented by this attribute. This attribute then defines the semantics for --- the merging child. -addMerges :: (Identifier, (Identifier,[Identifier],Expression)) -> [Rule] -> [Rule] -addMerges (target,(_,_,expr)) rules - = rule : rules - where - rule = Rule Nothing (Alias _LOC childLoc (Underscore noPos)) expr False "merge rule" False True False Nothing False - childLoc = Ident (show target ++ "_merge") (getPos target) -} - - -ATTR Rule Rules Pattern Patterns - [ | | locals USE {`Set.union`} {Set.empty} : {Set Identifier} - definedAttrs USE {`Set.union`} {Set.empty} : {Set (Identifier,Identifier)} - ] - - -SEM Pattern - | Alias lhs.definedAttrs = Set.insert (@field,@attr) @pat.definedAttrs - .locals = if @field == _LOC - then Set.insert @attr @pat.locals - else @pat.locals - -SEM Children [ | | fields : {[(Identifier,Type,ChildKind)]} ] - | Cons lhs.fields = @hd.field : @tl.fields - | Nil lhs.fields = [] - -SEM Child [ | | field : { (Identifier,Type,ChildKind) } ] - | Child lhs.field = (@name,@tp,@kind) - -------------------------------------------------------------------------------- --- -------------------------------------------------------------------------------- -ATTR Rule Pattern Patterns [ || containsVars USE {||} {False} : Bool ] - -SEM Pattern - | Alias lhs.containsVars = True - -ATTR Rule [ | | isPure : Bool ] -SEM Rule | Rule lhs.isPure = @pure - -------------------------------------------------------------------------------- --- Eliminate SELF types -------------------------------------------------------------------------------- - -SEM Nonterminal | Nonterminal - loc.inh1 = Map.map (elimSelfId @nt @params) @inh - loc.syn1 = Map.map (elimSelfId @nt @params) @syn - -SEM Child | Child - (loc.nt, loc.params) = case @tp of - NT nt params _ -> (nt, params) - Self -> error ("The type of child " ++ show @name ++ " should not be a Self type.") - Haskell t -> (identifier t, []) -- should be ignored because the child is a terminal - loc.inh1 = Map.map (elimSelfStr @loc.nt @loc.params) @loc.inh - loc.syn1 = Map.map (elimSelfStr @loc.nt @loc.params) @loc.syn - -SEM TypeSig | TypeSig - loc.tp1 = elimSelfId @lhs.nt @lhs.params @tp - -{ -elimSelfId :: NontermIdent -> [Identifier] -> Type -> Type -elimSelfId nt args Self = NT nt (map getName args) False -elimSelfId _ _ tp = tp - -elimSelfStr :: NontermIdent -> [String] -> Type -> Type -elimSelfStr nt args Self = NT nt args False -elimSelfStr _ _ tp = tp -} - -------------------------------------------------------------------------------- --- Reconstructing the tree -------------------------------------------------------------------------------- - -ATTR Nonterminals Nonterminal Productions Production Rules Rule [ | uniq:Int | ] - -SEM Grammar - | Grammar nonts.uniq = 1 - -ATTR Grammar Nonterminals Nonterminal Productions - Production Children Child Rules Rule Pattern Patterns TypeSigs TypeSig - [ | | output:SELF ] - -ATTR Rule [ | | outputs:Rules ] - -SEM Nonterminal | Nonterminal - lhs.output = Nonterminal @nt @params @loc.inh1 @loc.syn1 @prods.output - -SEM Production - | Production - loc.extra1 = foldr addAugments (@rules.output ++ @newRls) (Map.assocs @loc.augmentsIn) - loc.extra2 = foldr addArounds @loc.extra1 (Map.assocs @loc.aroundsIn) - loc.extra3 = foldr addMerges @loc.extra2 (Map.assocs @loc.mergesIn) - lhs.output = Production @con @params @constraints @children.output @loc.extra3 @typeSigs.output @macro - -SEM Child | Child - lhs.output = Child @name @tp @kind - -SEM TypeSig | TypeSig - lhs.output = TypeSig @name @loc.tp1 - -SEM Rules - | Cons lhs.output = if @hd.containsVars && @hd.isPure then @hd.outputs ++ @tl.output else @tl.output - -- remove rules that define nothing and do not have side effects - -SEM Rule - | Rule (loc.output1, loc.mbAlias) = mkRuleAlias @loc.output - (loc.outputs, lhs.uniq) = if needsMultiRules @lhs.options -- check if this works for UHC - then multiRule @loc.output1 @lhs.uniq - else ([@loc.output1], @lhs.uniq) - lhs.outputs = maybe [] return @loc.mbAlias ++ @loc.outputs - -{ --- When a rule has a name, create an alias for a rule --- and a modified rule that refers to the alias --- Thus it removes rule names from rules -mkRuleAlias :: Rule -> (Rule, Maybe Rule) -mkRuleAlias r@(Rule Nothing _ _ _ _ _ _ _ _ _) = (r, Nothing) -mkRuleAlias (Rule (Just nm) pat expr owrt origin expl pure identity mbErr eager) = (r', Just alias) where - alias = Rule Nothing (Alias _LOC (Ident ("_rule_" ++ show nm) pos) (Underscore pos)) expr owrt origin expl pure identity mbErr eager - pos = getPos nm - expr' = Expression pos tks - tks = [mkLocVar (Ident ("_rule_" ++ show nm) pos) pos (Just ("Indirection to rule " ++ show nm))] - r' = Rule Nothing pat expr' owrt origin False True identity Nothing False -} - - --- Work towards removing the need of the "multiRule". --- It's currently only needed for the Kastens code generation -{ -needsMultiRules :: Options -> Bool -needsMultiRules opts = (visit opts || withCycle opts) && not (kennedyWarren opts) -} - -{ -{- -multiRule replaces - loc.(a,b) = e -by - loc.tup1 = e - loc.(a,_) = @loc.tup1 - loc.(_,b) = @loc.tup1 -It needs to thread a unique number for inventing names for the tuples. - -It also works for nested tuples: - loc.(a,(b,c)) = e -becomes - loc.tup1 = e - loc.(a,_) = @loc.tup1 - loc.(_,tup2) = @loc.tup1 - loc.(b,_) = @loc.tup2 - loc.(_,c) = @loc.tup2 --} - -multiRule :: Rule -> Int -> ([Rule], Int) -multiRule (Rule _ pat expr owrt origin expl pure identity mbErr eager) uniq - = let f :: Bool -> (Pattern->Pattern) -> Expression -> Pattern -> Int -> (Pattern, ([Rule], Int)) - f expl' w e (Product pos pats) n - = let freshName = Ident ("_tup" ++ show n) pos - freshExpr = Expression pos freshTks - freshTks = [AGField _LOC freshName pos Nothing] - freshPat = Alias _LOC freshName (Underscore pos) - a = length pats - 1 - us b p = Product pos (replicate (a-b) (Underscore pos) ++ [p] ++ replicate b (Underscore pos)) - g :: Pattern -> ([Pattern],[Rule],Int) -> ([Pattern],[Rule],Int) - g p (xs1,rs1,n1) = let (x2,(rs2,n2)) = f False (us (length xs1)) freshExpr p n1 - in (x2:xs1, rs2++rs1, n2) - (xs9,rs9,n9) = foldr g ([], [], n+1) pats - in ( freshPat - , ( Rule Nothing (w freshPat) e owrt origin expl' True False mbErr eager : rs9 - , n9 - ) - ) - f expl' w e p n - = ( p - , ( [Rule Nothing (w p) e owrt origin expl' True False mbErr eager] - , n - ) - ) - in snd (f expl id expr pat uniq) - -} - -------------------------------------------------------------------------------- --- Check the order definitions -------------------------------------------------------------------------------- - -ATTR Nonterminals Nonterminal Productions Production [ manualAttrOrderMap : {AttrOrderMap} | | ] - -SEM Grammar - | Grammar - nonts.manualAttrOrderMap = @manualAttrOrderMap - -ATTR Rules Rule [ | | ruleNames USE {`Set.union`} {Set.empty} : {Set Identifier} ] - -SEM Rule | Rule lhs.ruleNames = case @mbName of - Nothing -> Set.empty - Just nm -> Set.singleton nm - -SEM Production - | Production - loc.orderDeps = Set.toList $ Map.findWithDefault Set.empty @con $ Map.findWithDefault Map.empty @lhs.nt @lhs.manualAttrOrderMap - - loc.orderErrs - = let chldOutMap = Map.fromList [ (k, Map.keysSet s) | (k,s) <- @children.outputs ] - chldInMap = Map.fromList [ (k, Map.keysSet s) | (k,s) <- @children.inputs ] - - -- a local attribute - -- or an inherited attribute of the production - -- or an out-attribute of a child - isInAttribute :: Identifier -> Identifier -> [Error] - isInAttribute fld nm - | fld == _LOC = if nm `Set.member` @rules.locals - then [] - else [UndefAttr @lhs.nt @con fld nm False] - | fld == _LHS = if nm `Map.member` @lhs.inh - then [] - else [UndefAttr @lhs.nt @con fld nm False] - | otherwise = if nm `Set.member` (Map.findWithDefault Set.empty fld chldOutMap) - then [] - else [UndefAttr @lhs.nt @con fld nm False] - - -- a local attribute - -- or a synthesized attribute of the production - -- or an in-attribute of a child - isOutAttribute :: Identifier -> Identifier -> [Error] - isOutAttribute fld nm - | fld == _LOC = if nm `Set.member` @rules.locals - then [] - else [UndefAttr @lhs.nt @con fld nm True] - | fld == _LHS = if nm `Map.member` @lhs.syn - then [] - else [UndefAttr @lhs.nt @con fld nm True] - | otherwise = if nm `Set.member` (Map.findWithDefault Set.empty fld chldInMap) - then [] - else [UndefAttr @lhs.nt @con fld nm True] - - existsRule nm = if nm `Set.member` @rules.ruleNames - then [] - else [MissingNamedRule @lhs.nt @con nm] - - checkIn (OccAttr fld nm) = isInAttribute fld nm - checkIn (OccRule nm) = existsRule nm - checkOut (OccAttr fld nm) = isOutAttribute fld nm - checkOut (OccRule nm) = existsRule nm - in Seq.fromList . concat $ - [ checkIn occA ++ checkOut occB - | (Dependency occA occB) <- @loc.orderDeps - ] - -------------------------------------------------------------------------------- --- Decompose augment -------------------------------------------------------------------------------- - -ATTR Nonterminals Nonterminal [ augmentsIn : {Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))} | | ] -ATTR Productions Production [ augmentsIn : {Map ConstructorIdent (Map Identifier [Expression])} | | ] - -SEM Grammar | Grammar nonts.augmentsIn = @augmentsMap -SEM Nonterminal | Nonterminal loc.augmentsIn = Map.findWithDefault Map.empty @nt @lhs.augmentsIn -SEM Production | Production loc.augmentsIn = Map.findWithDefault Map.empty @con @lhs.augmentsIn - -ATTR Nonterminals Nonterminal [ aroundsIn : {Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))} | | ] -ATTR Productions Production [ aroundsIn : {Map ConstructorIdent (Map Identifier [Expression])} | | ] - -SEM Grammar | Grammar nonts.aroundsIn = @aroundsMap -SEM Nonterminal | Nonterminal loc.aroundsIn = Map.findWithDefault Map.empty @nt @lhs.aroundsIn -SEM Production | Production loc.aroundsIn = Map.findWithDefault Map.empty @con @lhs.aroundsIn - -ATTR Nonterminals Nonterminal [ mergesIn : {Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier],Expression)))} | | ] -ATTR Productions Production [ mergesIn : {Map ConstructorIdent (Map Identifier (Identifier,[Identifier],Expression))} | | ] -ATTR Children Child [ merged : {Set Identifier} | | ] - -SEM Grammar | Grammar nonts.mergesIn = @mergeMap -SEM Nonterminal | Nonterminal loc.mergesIn = Map.findWithDefault Map.empty @nt @lhs.mergesIn -SEM Production | Production loc.mergesIn = Map.findWithDefault Map.empty @con @lhs.mergesIn - loc.merged = Set.fromList [ c | (_,cs,_) <- Map.elems @loc.mergesIn, c <- cs ] diff --git a/src-ag/Desugar.ag b/src-ag/Desugar.ag deleted file mode 100644 --- a/src-ag/Desugar.ag +++ /dev/null @@ -1,332 +0,0 @@ -PRAGMA strictdata -PRAGMA optimize -PRAGMA bangpats -PRAGMA strictwrap - -INCLUDE "AbstractSyntax.ag" -INCLUDE "Patterns.ag" -INCLUDE "Expression.ag" -INCLUDE "HsToken.ag" -INCLUDE "DistChildAttr.ag" - - -imports -{ -import qualified Data.Set as Set -import qualified Data.Map as Map -import Data.Map(Map) -import qualified Data.Sequence as Seq -import Data.Sequence(Seq,(><)) -import UU.Scanner.Position(Pos(..)) -import Data.Maybe -import Data.List(intersperse) - -import AbstractSyntax -import ErrorMessages -import Options -import HsToken -import HsTokenScanner -import TokenDef -import CommonTypes -} - -WRAPPER HsTokensRoot - - -ATTR Grammar Nonterminals Nonterminal Productions Production Children Child Rule Rules Expression [ options:{Options} | | ] - -ATTR Grammar Nonterminals Nonterminal Productions Production Rule Rules Pattern Patterns Expression HsTokensRoot HsToken HsTokens [ | | errors USE {Seq.><} {Seq.empty} : {Seq Error} ] - -ATTR Grammar Nonterminals Nonterminal Productions Production Child Children Rule Rules Pattern Patterns TypeSig TypeSigs Expression [ | | output : SELF ] - - -------------------------------------------------------------------------------- --- Deal with RHS -------------------------------------------------------------------------------- - -SEM Expression - | Expression - (loc.tks', lhs.errors) = let inh = Inh_HsTokensRoot { childInhs_Inh_HsTokensRoot = @lhs.childInhs - , childSyns_Inh_HsTokensRoot = @lhs.childSyns - , nt_Inh_HsTokensRoot = @lhs.nt - , con_Inh_HsTokensRoot = @lhs.con - , ruleDescr_Inh_HsTokensRoot = @lhs.ruleDescr - , useFieldIdent_Inh_HsTokensRoot = genUseTraces @lhs.options - } - sem = sem_HsTokensRoot (HsTokensRoot @tks) - syn = wrap_HsTokensRoot sem inh - in (tks_Syn_HsTokensRoot syn, errors_Syn_HsTokensRoot syn) - lhs.output = Expression @pos @tks' - - -ATTR HsTokensRoot HsTokens HsToken [ useFieldIdent : Bool | | ] - -ATTR HsToken HsTokens [ | addLines : Int | ] -SEM HsTokensRoot - | HsTokensRoot - tokens.addLines = 0 - -ATTR HsTokensRoot [ | | tks : {[HsToken]} ] -ATTR HsToken HsTokens [ | | tks : SELF ] - -SEM HsToken - | AGLocal - lhs.addLines = if @lhs.useFieldIdent - then @lhs.addLines + 1 - else @lhs.addLines - loc.tks = AGLocal @var (addl @lhs.addLines @pos) (if @lhs.useFieldIdent then Just @lhs.ruleDescr else Nothing) - | AGField - loc.mField = findField @field @attr @lhs.childSyns - - loc.field' = maybe @field id @loc.mField - lhs.errors = maybe (Seq.singleton (UndefAttr @lhs.nt @lhs.con @field (Ident "" (getPos @field)) False)) (const Seq.empty) @loc.mField - - lhs.addLines = if @lhs.useFieldIdent || length (getName @field) < length (getName @loc.field') - then @lhs.addLines + 1 - else @lhs.addLines - - loc.tks = AGField @loc.field' @attr (addl @lhs.addLines @pos) (if @lhs.useFieldIdent then Just @lhs.ruleDescr else Nothing) - | HsToken - loc.tks = HsToken @value (addl @lhs.addLines @pos) - | CharToken - loc.tks = CharToken @value (addl @lhs.addLines @pos) - | StrToken - loc.tks = StrToken @value (addl @lhs.addLines @pos) - | Err - loc.tks = Err @mesg (addl @lhs.addLines @pos) - -{ -addl :: Int -> Pos -> Pos -addl n (Pos l c f) = Pos (l+n) c f -} - - -------------------------------------------------------------------------------- --- Deal with LHS -------------------------------------------------------------------------------- - -SEM Pattern - | Alias - (loc.field', loc.err1) = maybeError @field (UndefAttr @lhs.nt @lhs.con (Ident "" (getPos @field)) @attr True) $ - findField @field @attr @lhs.childInhs - loc.err2 = if @loc.field' == @field - then Seq.empty - else if (@loc.field', @attr) `Set.member` @lhs.defs - then Seq.singleton $ DupRule @lhs.nt @lhs.con @field @attr @loc.field' - else Seq.empty - lhs.errors = @loc.err1 Seq.>< @loc.err2 Seq.>< @pat.errors - loc.output = Alias @loc.field' @attr @pat.output - - -------------------------------------------------------------------------------- --- Distribute attributes of children -------------------------------------------------------------------------------- - -ATTR Children Child [ | | childInhs, childSyns USE {++} {[]} : {[(Identifier, Identifier)]} ] -ATTR Rules Rule Pattern Patterns Expression HsTokensRoot HsToken HsTokens [ childInhs, childSyns : {[(Identifier, Identifier)]} | | ] - -SEM Child - | Child - lhs.childInhs = [(i, @name) | i <- Map.keys @loc.inh ] - lhs.childSyns = [(s, @name) | s <- Map.keys @loc.syn ] - -{ -maybeError :: a -> Error -> Maybe a -> (a, Seq Error) -maybeError def err mb - = maybe (def, Seq.singleton err) (\r -> (r, Seq.empty)) mb - -findField :: Identifier -> Identifier -> [(Identifier,Identifier)] -> Maybe Identifier -findField fld attr list - | fld == _FIRST = f list - | fld == _LAST = f (reverse list) - | otherwise = Just fld - where - f = lookup attr -} - - -------------------------------------------------------------------------------- --- Distribute nt and con -------------------------------------------------------------------------------- - -ATTR Productions Production Rule Rules Pattern Patterns Expression HsTokensRoot HsToken HsTokens [ nt : NontermIdent | | ] -ATTR Rule Rules Pattern Patterns Expression HsTokensRoot HsToken HsTokens [ con : ConstructorIdent | | ] - -SEM Nonterminal - | Nonterminal - prods.nt = @nt - -SEM Production - | Production - rules.con = @con - - -------------------------------------------------------------------------------- --- Distribute a pattern description -------------------------------------------------------------------------------- - -ATTR Expression HsTokensRoot HsToken HsTokens [ ruleDescr : String | | ] - -SEM Rule - | Rule - loc.ruleDescr = show @lhs.nt ++ " :: " ++ show @lhs.con ++ " :: " ++ (concat $ intersperse "," $ map (\(f,a) -> show f ++ "." ++ show a) $ Set.toList @pattern.defsCollect) - - -------------------------------------------------------------------------------- --- Distribute all defined attributes -------------------------------------------------------------------------------- - -ATTR Rule Rules Pattern Patterns [ | | defsCollect USE {`Set.union`} {Set.empty} : {Set (Identifier, Identifier)} ] -SEM Pattern - | Alias - loc.def = Set.singleton (@field, @attr) - lhs.defsCollect = @loc.def `Set.union` @pat.defsCollect - -ATTR Rule Rules Pattern Patterns [ defs : {Set (Identifier, Identifier)} | | ] -SEM Production - | Production - rules.defs = @rules.defsCollect - - -------------------------------------------------------------------------------- --- Collect a list of all attributes (that are not irrefutable) -------------------------------------------------------------------------------- - -ATTR Grammar Nonterminals Nonterminal Productions Production Rule Rules Pattern Patterns - [ | | allAttributes USE {`mergeAttributes`} {Map.empty} : {AttrMap} ] - -SEM Pattern - | Alias - lhs.allAttributes = (Map.singleton @lhs.nt $ Map.singleton @lhs.con $ Set.singleton (@field, @attr)) `mergeAttributes` @pat.allAttributes - | Irrefutable - lhs.allAttributes = Map.empty - -{ -mergeAttributes :: AttrMap -> AttrMap -> AttrMap -mergeAttributes = Map.unionWith $ Map.unionWith $ Set.union -} - - -------------------------------------------------------------------------------- --- Distribute a list of attributes forced to irrefutables -------------------------------------------------------------------------------- - -ATTR Grammar Nonterminals Nonterminal Productions Production Rule Rules Pattern Patterns - [ forcedIrrefutables : {AttrMap} | | ] - -SEM Pattern - | Alias - lhs.output = if Set.member (@field, @attr) $ Map.findWithDefault Set.empty @lhs.con $ Map.findWithDefault Map.empty @lhs.nt $ @lhs.forcedIrrefutables - then Irrefutable @loc.output - else @loc.output - - -------------------------------------------------------------------------------- --- Decompose augment map and rebuild it -------------------------------------------------------------------------------- - -ATTR Nonterminals Nonterminal [ augmentsIn : {Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))} - | | augmentsOut USE {`Map.union`} {Map.empty} : {Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))} ] -ATTR Productions Production [ augmentsIn : {Map ConstructorIdent (Map Identifier [Expression])} - | | augmentsOut USE {`Map.union`} {Map.empty} : {Map ConstructorIdent (Map Identifier [Expression])} ] - -SEM Grammar - | Grammar - nonts.augmentsIn = @augmentsMap - -SEM Nonterminal - | Nonterminal - loc.augmentsIn = Map.findWithDefault Map.empty @nt @lhs.augmentsIn - loc.augmentsOut = Map.singleton @nt @prods.augmentsOut - -SEM Production - | Production - loc.augmentsIn = Map.findWithDefault Map.empty @con @lhs.augmentsIn - loc.augmentsOut = Map.singleton @con @loc.augmentsOut1 - - (loc.augmentErrs, loc.augmentsOut1) = Map.mapAccum (desugarExprs @lhs.options @lhs.nt @con @children.childInhs @children.childSyns) Seq.empty @loc.augmentsIn - -WRAPPER Expression - -{ -desugarExprs :: Options -> NontermIdent -> ConstructorIdent -> - [(Identifier, Identifier)] -> [(Identifier, Identifier)] -> - Seq Error -> [Expression] -> (Seq Error, [Expression]) -desugarExprs options nt con childInhs childSyns - = mapAccum (desugarExpr options nt con childInhs childSyns) - where mapAccum f e = foldr (\x (e0,xs) -> let (e1,x') = f e0 x in (e1, x:xs)) (e, []) - -desugarExpr :: Options -> NontermIdent -> ConstructorIdent -> - [(Identifier, Identifier)] -> [(Identifier, Identifier)] -> - Seq Error -> Expression -> (Seq Error, Expression) -desugarExpr options nt con childInhs childSyns errs expr - = (errs Seq.>< errors_Syn_Expression syn, output_Syn_Expression syn) - where - inh = Inh_Expression { childInhs_Inh_Expression = childInhs - , childSyns_Inh_Expression = childSyns - , con_Inh_Expression = con - , nt_Inh_Expression = nt - , options_Inh_Expression = options - , ruleDescr_Inh_Expression = "augment-rule" - } - sem = sem_Expression expr - syn = wrap_Expression sem inh -} - - -------------------------------------------------------------------------------- --- Errors of a production -------------------------------------------------------------------------------- - -SEM Production - | Production - lhs.errors = @rules.errors Seq.>< @loc.augmentErrs - -------------------------------------------------------------------------------- --- Support for late binding of higher order children -------------------------------------------------------------------------------- - -ATTR Grammar Nonterminals Nonterminal Productions Production Children Child [ mainName : {String} | | ] - -SEM Nonterminal | Nonterminal - loc.extraInh = addLateAttr @lhs.options @lhs.mainName - -{ -addLateAttr :: Options -> String -> Attributes -addLateAttr options mainName - | kennedyWarren options && lateHigherOrderBinding options = - let tp = lateBindingType mainName - in Map.singleton idLateBindingAttr tp - | otherwise = Map.empty -} - -------------------------------------------------------------------------------- --- Reconstruct the grammar -------------------------------------------------------------------------------- - -SEM Nonterminal | Nonterminal - lhs.output = Nonterminal - @nt @params - (@loc.extraInh `Map.union` @inh) - @syn - @prods.output - -SEM Child | Child - lhs.output = Child @name @tp @kind - -SEM Grammar - | Grammar - lhs.output = Grammar @typeSyns - @useMap - @derivings - @wrappers - @nonts.output - @pragmas - @manualAttrOrderMap - @paramMap - @contextMap - @quantMap - @uniqueMap - @nonts.augmentsOut - @aroundsMap - @mergeMap diff --git a/src-ag/ErrorMessages.ag b/src-ag/ErrorMessages.ag deleted file mode 100644 --- a/src-ag/ErrorMessages.ag +++ /dev/null @@ -1,148 +0,0 @@ -imports -{ -import UU.Scanner.Position(Pos) -import Pretty -import CodeSyntax -import CommonTypes -} - -TYPE Errors = [Error] - -DATA Error | ParserError pos : {Pos} - problem : {String} - action : {String} - - | HsParseError pos : {Pos} - msg : {String} - - | DupAlt nt : {NontermIdent} - con,occ1 : {ConstructorIdent} - - | DupSynonym nt,occ1 : {NontermIdent} - - | DupSet name,occ1 : {NontermIdent} - - | DupInhAttr nt : {NontermIdent} - attr,occ1 :{Identifier} - - | DupSynAttr nt : {NontermIdent} - attr,occ1 : {Identifier} - - | DupChild nt : {NontermIdent} - con : {ConstructorIdent} - name,occ1 : {Identifier} - - | DupRule nt : {NontermIdent} - con : {ConstructorIdent} - field : {Identifier} - attr,occ1 : {Identifier} - - | DupRuleName nt : {NontermIdent} - con : {ConstructorIdent} - nm : {Identifier} - - | DupSig nt : {NontermIdent} - con : {ConstructorIdent} - attr : {Identifier} - - | UndefNont nt : {NontermIdent} - - | UndefAlt nt : {NontermIdent} - con : {ConstructorIdent} - - | UndefChild nt : {NontermIdent} - con : {ConstructorIdent} - name : {Identifier} - - | MissingRule --pos : {Pos} - nt : {NontermIdent} - con : {ConstructorIdent} - field : {Identifier} - attr : {Identifier} - - | MissingNamedRule nt : {NontermIdent} - con : {Identifier} - name : {Identifier} - - | SuperfluousRule nt : {NontermIdent} - con : {ConstructorIdent} - field : {Identifier} - attr : {Identifier} - --- | SuperfluousSig nt : {NontermIdent} --- con : {ConstructorIdent} --- attr : {Identifier} - - | UndefLocal nt : {NontermIdent} - con : {ConstructorIdent} - var : {Identifier} - - | ChildAsLocal nt : {NontermIdent} - con : {ConstructorIdent} - var : {Identifier} - - | UndefAttr nt : {NontermIdent} - con : {ConstructorIdent} - field : {Identifier} - attr : {Identifier} - isOut : {Bool} - - | Cyclic nt : {NontermIdent} - mbCon : {Maybe ConstructorIdent} - verts : {[String]} - - | CyclicSet name:{Identifier} - - | CustomError isWarning : {Bool} - pos : {Pos} - mesg : {PP_Doc} - - | LocalCirc nt : {NontermIdent} - con : {ConstructorIdent} - attr : {Identifier} - o_visit : {Bool} - path : {[String]} - - | InstCirc nt : {NontermIdent} - con : {ConstructorIdent} - attr : {Identifier} - o_visit : {Bool} - path : {[String]} - - | DirectCirc nt : {NontermIdent} - o_visit : {Bool} - cyclic : {[((Identifier,Identifier),[String],[String])]} - - | InducedCirc nt : {NontermIdent} - cinter : {CInterface} - cyclic : {[((Identifier,Identifier),[String],[String])]} - - | MissingTypeSig nt : {NontermIdent} - con : {ConstructorIdent} - attr : {Identifier} - - | MissingInstSig nt : {NontermIdent} - con : {ConstructorIdent} - attr : {Identifier} - - | DupUnique nt : {NontermIdent} - con : {ConstructorIdent} - attr : {Identifier} - - | MissingUnique nt : {NontermIdent} - attr : {Identifier} - - | MissingSyn nt : {NontermIdent} - attr : {Identifier} - - | IncompatibleVisitKind - child : {Identifier} - vis : {VisitIdentifier} - from : {VisitKind} - to : {VisitKind} - | IncompatibleRuleKind - rule : {Identifier} - kind : {VisitKind} - | IncompatibleAttachKind - child : {Identifier} - kind : {VisitKind} diff --git a/src-ag/ExecutionPlan.ag b/src-ag/ExecutionPlan.ag deleted file mode 100644 --- a/src-ag/ExecutionPlan.ag +++ /dev/null @@ -1,83 +0,0 @@ -imports -{ --- VisitSyntax.ag imports -import Patterns (Pattern(..),Patterns) -import Expression (Expression(..)) -import CommonTypes -import ErrorMessages - -import qualified Data.Set as Set -import Data.Set(Set) -import qualified Data.Map as Map -import Data.Map(Map) -} - -DATA ExecutionPlan | ExecutionPlan nonts : ENonterminals - typeSyns : {TypeSyns} - wrappers : {Set NontermIdent} - derivings : {Derivings} - -TYPE ENonterminals = [ENonterminal] - -TYPE EProductions = [EProduction] - -TYPE ERules = [ERule] - -TYPE EChildren = [EChild] - -TYPE VisitSteps = [VisitStep] - -TYPE Visits = [Visit] - -DATA ENonterminal | ENonterminal nt : {NontermIdent} - params : {[Identifier]} - classCtxs : {ClassContext} -- class context at the datatype level - initial : {StateIdentifier} - initialv : {[VisitIdentifier]} - nextVisits : {Map StateIdentifier StateCtx} -- info about the next visits from a given state - prevVisits : {Map StateIdentifier StateCtx} -- info about the previous visits to a given state - prods : EProductions - recursive : {Bool} - hoInfo : {HigherOrderInfo} - -DATA EProduction | EProduction con : {ConstructorIdent} - params : {[Identifier]} - constraints : {[Type]} -- (class/equality) constraints on types (requires GADTs) - rules : ERules - children : EChildren - visits : Visits - -DATA EChild | EChild name : {Identifier} - tp : {Type} - kind : {ChildKind} - hasAround : {Bool} -- if there exists a rule _around that transforms the child's sem - merges : {Maybe [Identifier]} -- Nothing: not the result of a merge of other children (ignored for now) - isMerged : {Bool} -- False: not being used to merge other children (ignored for now) - | ETerm name : {Identifier} - tp : {Type} - -DATA ERule | ERule name : {Identifier} - pattern : Pattern - rhs : Expression - owrt : {Bool} - origin : String -- just for documentation (and maybe errors) - explicit : Bool -- True if this rule defined in the source code - pure : Bool -- True if this rule is pure (not monadic/no side effect) - mbError : {Maybe Error} -- the rule may contain an error that is yielded when the rule is scheduled - -DATA Visit | Visit ident : {VisitIdentifier} - from : {StateIdentifier} - to : {StateIdentifier} - inh : {Set Identifier} - syn : {Set Identifier} - steps : VisitSteps - kind : {VisitKind} - -DATA VisitStep | Sem name : {Identifier} - | ChildVisit child : {Identifier} - nonterm : {NontermIdent} - visit : {VisitIdentifier} - | PureGroup steps : VisitSteps -- A group of steps that should be executed purely - ordered : {Bool} - | Sim steps : VisitSteps - | ChildIntro child : {Identifier} diff --git a/src-ag/ExecutionPlan2Caml.ag b/src-ag/ExecutionPlan2Caml.ag deleted file mode 100644 --- a/src-ag/ExecutionPlan2Caml.ag +++ /dev/null @@ -1,1487 +0,0 @@ --- As expected, the code generation for ML resembles the code generation for Haskell quite a bit. --- However, there are several differences: --- * no inline pragmas --- * no strictness annotations (not needed) --- * separating data types from code --- --- Generator conventions: --- * we generate functions definitions with an 'and' binding and a match statement --- * for some type aliasses, we'll introduce module decls in addition to a type --- --- Future work: --- * abuse the module system more? --- * parse ocaml blocks? --- * lazy evaluation? --- --- Other comments: --- * Empty records are not allowed in Ocaml. Mapping them to units. --- * line pragmas. There are now line pragmas around the body of rules. --- There cannot be syntactical mistakes in the patterns. However, there can be --- type errors if a function returns a value with a type that differs from what --- is expected. It's then not clear which location is reported. --- Also, errors in type signatures are not caught. --- However, usually, the problematic cases are syntax errors, and these are --- prevented by parsing the definitions first. - -INCLUDE "ExecutionPlan.ag" -INCLUDE "Patterns.ag" -INCLUDE "Expression.ag" -INCLUDE "HsToken.ag" - -imports -{ -import ExecutionPlan -import Pretty -import PPUtil -import Options -import Data.Monoid(mappend,mempty) -import Data.Maybe -import Data.Graph -import Debug.Trace -import System.IO -import System.Directory -import System.FilePath -import UU.Scanner.Position - -import TokenDef -import HsToken -import ErrorMessages - -import Data.Set (Set) -import qualified Data.Set as Set -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Sequence(Seq) -import qualified Data.Sequence as Seq -import Data.Foldable(toList) -} - -ATTR ExecutionPlan ENonterminals ENonterminal EProductions EProduction ERules ERule EChildren EChild - [ mainFile, mainName : String | | ] - -------------------------------------------------------------------------------- --- Options -------------------------------------------------------------------------------- -ATTR ExecutionPlan - ENonterminals ENonterminal - EProductions EProduction - ERules ERule - EChildren EChild - Expression - HsToken HsTokens HsTokensRoot - Pattern Patterns - Visits Visit - VisitSteps VisitStep [ options : {Options} | | ] -ATTR EProductions EProduction [ rename : {Bool} | | ] - -SEM ENonterminal | ENonterminal - prods.rename = rename @lhs.options - -------------------------------------------------------------------------------- --- Context info (nonterminal ident, constructor ident, nonterm params, etc.) -------------------------------------------------------------------------------- - -ATTR Visit Visits EProduction EProductions EChildren EChild ERules ERule [ nt : NontermIdent | | ] -SEM ENonterminal | ENonterminal - prods.nt = @nt - -ATTR EChildren EChild ERules ERule Visits Visit [ con : ConstructorIdent | | ] - -SEM EProduction | EProduction children.con = @con - rules.con = @con - visits.con = @con - -ATTR EProductions EProduction Visits Visit [ params : {[Identifier]} | | ] -SEM ENonterminal | ENonterminal - prods.params = @params - -------------------------------------------------------------------------------- --- output attributes: we make a distinction between data declarations --- and code -------------------------------------------------------------------------------- -ATTR ExecutionPlan [ | | datas, code, modules : {PP_Doc} ] - -SEM ExecutionPlan | ExecutionPlan - lhs.code = @nonts.code >-< @loc.wrappersExtra - lhs.datas = @nonts.datas >-< @loc.commonExtra - -ATTR ENonterminal ENonterminals - [ wrappers : {Set NontermIdent} | | datas,code,modules USE {>-<} {empty} : {PP_Doc} ] - -SEM ExecutionPlan | ExecutionPlan - nonts.wrappers = @wrappers - -SEM ENonterminal | ENonterminal - lhs.datas = ( text "" - >-< "(* *** " ++ getName @nt ++ " *** [data] *)") - >-< (if dataTypes @lhs.options - then pp "(* data *)" - >-< @loc.datatypeNt - >-< @loc.datatypeProds - >-< "" - else empty) - >-< (if @loc.hasWrapper - then pp "(* wrapper *)" - >-< @loc.wr_inh - >-< @loc.wr_syn - >-< "" - else empty) - >-< (if semfuns @lhs.options - then pp "(* semantic domain *)" - >-< @loc.t_init - >-< @loc.t_states - >-< @loc.c_states - >-< @prods.t_visits - >-< "" - else empty) - - lhs.code = ( text "" - >-< "(* *** " ++ getName @nt ++ " *** [code] *)") - >-< (if dataTypes @lhs.options - then pp "(* constructor functions *)" - >-< @loc.datatypeCon - else empty) - >-< (if @loc.hasWrapper - then pp "(* wrapper *)" - >-< @loc.wrapper - >-< "" - else empty) - >-< (if folds @lhs.options - then "(* cata *)" - >-< @loc.sem_nt - >-< "" - else empty) - >-< (if semfuns @lhs.options - then "(* semantic domain *)" - >-< @prods.sem_prod - >-< "" - else empty) - - -- note: we assume that these module declarations are not recursive, and - -- that their parameters do not depends on types generated by AG in the - -- same file. - lhs.modules = @loc.moduleDecl - - loc.hasWrapper = @nt `Set.member` @lhs.wrappers - -------------------------------------------------------------------------------- --- Nonterminal datatype -------------------------------------------------------------------------------- -ATTR ENonterminal ENonterminals [ typeSyns : {TypeSyns} | | ] - -SEM ExecutionPlan | ExecutionPlan - nonts.typeSyns = @typeSyns - -{ -ppRecordTp :: PP a => [a] -> PP_Doc -ppRecordTp es - | null es = text "unit" - | otherwise = pp_block "{" "}" "; " (map pp es) - -ppRecordVal :: PP a => [a] -> PP_Doc -ppRecordVal es - | null es = text "()" - | otherwise = pp_block "{" "}" "; " (map pp es) - -ppFieldsVal :: Bool -> [(PP_Doc,PP_Doc,PP_Doc,PP_Doc)] -> PP_Doc -ppFieldsVal record fields - | null fields = text "()" - | record = ppRecordVal [ r >#< "=" >#< x | (r,x,_,_) <- fields ] - | otherwise = pp_block "(" ")" "," [ x | (_,x,_,_) <- fields ] - -ppFieldsType :: Bool -> Bool -> [(PP_Doc,PP_Doc,PP_Doc,PP_Doc)] -> PP_Doc -ppFieldsType record defor fields - | null fields = text "unit" - | record = ppRecordTp [ r >#< ":" >#< (if defor then d else f) | (r,_,d,f) <- fields ] - | otherwise = pp_block "(" ")" "*" [ if defor then d else f | (_,_,d,f) <- fields ] -} - - --- for each nonterminal, the following data types in ocmal: --- * data type for the nonterminal, with a constructor for --- each production. The constructor takes a single field --- with the type explained below. --- * for each production, a record type comprising the --- children of the production. --- --- * class contexts are ignored --- * at most one type variable --- --- aliasses: lists, tuples --- *** think about maps, sets, etc. Perhaps the name of --- the alias should become a local module name. --- - -SEM ENonterminal | ENonterminal - loc.t_params = ppTypeParams @params - loc.aliasPre = "and" >#< @loc.t_params >#< @nt >#< "=" - loc.aliasMod = @loc.aliasPre >#< modName @nt >|< ".t" - loc.datatypeNt - = case lookup @nt @lhs.typeSyns of - -- generate special code for certain type aliasses - Just (List t) -> @loc.aliasPre >#< ppTp t >#< "list" - Just (Maybe t) -> @loc.aliasPre >#< ppTp t >#< "option" - Just (Tuple ts) -> @loc.aliasPre >#< (pp_block "(" ")" " * " $ map (ppTp . snd) ts) - - Just (Map k v) -> @loc.aliasMod - Just (IntMap t) -> @loc.aliasMod - Just (OrdSet t) -> @loc.aliasMod - Just IntSet -> @loc.aliasMod - - -- use the constructor-based data-type generation for all other types - _ -> "and" >#< @loc.t_params >#< @nt >#< "=" - >-< ( if null @prods.datatype - then pp "unit" - else indent 2 $ vlist @prods.datatype_call - ) - - loc.datatypeCon - = case lookup @nt @lhs.typeSyns of - Just _ -> empty -- no constructor funs for type aliasses - Nothing -> vlist @prods.datatype_con - - loc.moduleDecl - = let ppModule :: PP a => a -> PP_Doc - ppModule expr = "module" >#< modName @nt >#< "=" - in case lookup @nt @lhs.typeSyns of - Just (Map k _) -> ppModule ("Map.Make" >#< pp_parens (ppTp k)) - Just (IntMap _) -> ppModule ("Map.Make ()") - Just (OrdSet t) -> ppModule ("Set.Make" >#< pp_parens (ppTp t)) - Just IntSet -> ppModule ("Set.Make (struct type t = int let compare = Pervasives.compare end)") - _ -> empty - - loc.datatypeProds = vlist @prods.datatype - -ATTR EProduction [ | | datatype, datatype_call, datatype_con : {PP_Doc} ] -ATTR EProductions [ | | datatype, datatype_call, datatype_con USE {:} {[]} : {[PP_Doc]} ] - -SEM EProduction | EProduction - loc.o_records = dataRecords @lhs.options - loc.t_params = ppTypeParams @lhs.params - loc.t_c_params = ppTypeParams (cont_tvar : map pp @params) - loc.conname = conname @lhs.rename @lhs.nt @con - loc.recname = pp "fields_" >|< @loc.conname - lhs.datatype = "and" >#< @loc.t_params >#< @loc.recname >#< "=" - >#< ppFieldsType @loc.o_records False @children.sigs - lhs.datatype_call = pp "|" >#< @loc.conname >#< "of" >#< pp_parens (@loc.t_params >#< @loc.recname) - lhs.datatype_con - = let funNm = @lhs.nt >|< "_" >|< @con - decl = "and" >#< ppFunDecl @loc.o_sigs funNm params (@loc.t_params >#< @lhs.nt) body - params = [ (x, t) | (_,x,_,t) <- @children.sigs ] - body = @loc.conname >#< ppFieldsVal @loc.o_records @children.sigs - in decl - -ATTR EChild EChildren [ | | sigs USE {++} {[]} : {[(PP_Doc,PP_Doc,PP_Doc,PP_Doc)]} ] - -SEM EChild - | EChild ETerm - loc.tpDocFor = ppTp $ removeDeforested @tp - loc.tpDocDefor = ppTp $ forceDeforested @tp - loc.fieldNm = text $ recordFieldname @lhs.nt @lhs.con @name - loc.childNm = text (fieldname @name) - loc.field = (@loc.fieldNm, @loc.childNm, @loc.tpDocDefor, @loc.tpDocFor) - | EChild lhs.sigs = case @kind of - ChildAttr -> [] -- higher order attributes are not part of the data type - _ -> [@loc.field] - | ETerm lhs.sigs = [@loc.field] - -{ -ppTp :: Type -> PP_Doc -ppTp tp = case tp of - Haskell t -> pp t -- ocaml type - NT nt tps deforested - | nt == _SELF -> pp "?SELF?" - | null tps -> ppNontTp nt deforested - | otherwise -> pp_parens (ppSpaced (map pp_parens tps) >#< ppNontTp nt deforested) - Self -> pp "?SELF?" - -ppNontTp :: NontermIdent -> Bool -> PP_Doc -ppNontTp nt True = pp "t_" >|< pp nt -ppNontTp nt False = pp nt - --- multiple type parameters go into a tuple -ppTypeParams :: PP a => [a] -> PP_Doc -ppTypeParams [] = empty -ppTypeParams [x] = pp x -ppTypeParams xs = pp_block "(" ")" "," (map pp xs) -} - -------------------------------------------------------------------------------- --- Nonterminal semantic function -------------------------------------------------------------------------------- -SEM ENonterminal | ENonterminal - loc.fsemname = \x -> prefix @lhs.options ++ show x - loc.semname = @loc.fsemname @nt - loc.frecarg = \t x -> case t of - NT nt _ _ -> pp_parens (@fsemname nt >#< x) - _ -> x - - loc.sem_param_tp = @loc.t_params >#< @nt - loc.sem_res_tp = @loc.t_params >#< @loc.t_type - loc.sem_tp = @loc.sem_param_tp >#< "->" >#< @loc.sem_res_tp - - loc.o_sigs = typeSigs @lhs.options - loc.sem_nt_body = "match arg with" >-< (indent 2 $ @prods.sem_nt) - loc.sem_nt = let genSem :: PP a => a -> PP_Doc -> PP_Doc - genSem nm body = "and" >#< ppFunDecl @loc.o_sigs (pp @loc.semname) [(pp nm, @loc.sem_param_tp)] @loc.sem_res_tp body - genAlias alts = genSem (pp "arg") (pp "match arg with" >-< (indent 2 $ vlist $ map (pp "|" >#<) alts)) - genMap v = let body = modName @nt >|< ".fold" >#< @loc.semname >|< "_Entry" >#< @loc.semname >|< "_Nil" >#< els - els = case v of - NT nt _ _ -> pp_parens (modName @nt >|< ".map" >#< @loc.fsemname nt >#< "m") - _ -> pp "m" - in genSem "m" body - genSet mbNt = let body = "List.fold_right" >#< @loc.semname >|< "_Entry" >#< - els (pp_parens (modName @nt >|< ".elements" >#< "s")) >#< @loc.semname >|< "_Nil" - els r = maybe r (\nt -> pp_parens ("List.map" >#< @loc.fsemname nt >#< r)) mbNt - in genSem "s" body - in case lookup @nt @lhs.typeSyns of - -- generate special code for some aliasses - Just (List t) -> let body = "List.fold_right" >#< @loc.semname >|< "_Cons" >#< els >#< @loc.semname >|< "_Nil" - els = case t of - NT nt _ _ -> pp_parens ("List.map" >#< @loc.fsemname nt >#< "list") - _ -> pp "list" - in genSem "list" body - Just (Tuple ts) -> let pat = pp_parens (ppCommas $ map fst ts) - body = @loc.semname >|< "_Tuple" >#< ppSpaced (map (\t -> @loc.frecarg (snd t) (pp $ fst t)) ts) - in genSem pat body - Just (Map _ v) -> genMap v - Just (IntMap v) -> genMap v - Just (Maybe t) -> genAlias - [ "None" >#< "->" >#< "=" >#< @loc.semname >|< "_Nothing" - , "Some" >#< "just" >#< "->" >#< @loc.semname >|< "_Just" >#< @frecarg t (pp "just") - ] - Just (OrdSet t) -> genSet $ case t of - NT nt _ _ -> Just nt - _ -> Nothing - Just (IntSet) -> genSet Nothing - - -- structural fold for the remaining cases - _ -> genSem "arg" @loc.sem_nt_body - -{ --- convention for nonterminals to module names -modName :: NontermIdent -> PP_Doc -modName nt = pp "M_" >|< pp nt - -ppFunDecl :: Bool -> PP_Doc -> [(PP_Doc,PP_Doc)] -> PP_Doc -> PP_Doc -> PP_Doc -ppFunDecl gensigs nm args resSig expr = body where - body = nm >#< ppSpaced (map arg args) >#< ppRes >#< "=" - >-< indent 2 expr - arg (arg,tp) = ppArg gensigs arg tp - ppRes - | gensigs = ":" >#< resSig - | otherwise = empty - -ppArg :: Bool -> PP_Doc -> PP_Doc -> PP_Doc -ppArg gensigs arg tp - | gensigs = pp_parens (arg >#< ":" >#< tp) - | otherwise = arg - -} - --- The number of productions -ATTR EProductions EProduction [ | | count USE {+} {0} : {Int} ] -SEM EProduction | EProduction lhs.count = {1} - --- The per-production match-expr cases for the sem_NT function -ATTR EProduction EProductions [ | | sem_nt USE {>-<} {empty} : {PP_Doc} ] -SEM EProduction | EProduction - lhs.sem_nt = "|" >#< conname @lhs.rename @lhs.nt @con >#< ppFieldsVal @loc.o_records @children.sigs >#< "->" >#< - prefix @lhs.options >|< @lhs.nt >|< "_" >|< @con >#< ppSpaced @children.argnamesw - -ATTR EChild [ | | argnamesw : { PP_Doc } ] -ATTR EChildren [ | | argnamesw USE {:} {[]} : {[PP_Doc]} ] - -SEM EChild - | EChild lhs.argnamesw = case @kind of - ChildSyntax -> "(" >#< prefix @lhs.options >|< @loc.nt >#< @name >|< "_" >#< ")" - ChildAttr -> empty -- no sem-case for a higher-order child - ChildReplace tp -> "(" >#< prefix @lhs.options >|< extractNonterminal tp >#< @name >|< "_" >#< ")" - | ETerm lhs.argnamesw = text $ fieldname @name - -------------------------------------------------------------------------------- --- Types of attributes -------------------------------------------------------------------------------- -ATTR ExecutionPlan - ENonterminals - ENonterminal [ inhmap : {Map NontermIdent Attributes} - synmap : {Map NontermIdent Attributes} | | ] - -ATTR EProductions EProduction - ERules ERule - Patterns Pattern - Visits - Visit [ inhmap : {Attributes} - synmap : {Attributes} - allInhmap : {Map NontermIdent Attributes} - allSynmap : {Map NontermIdent Attributes} | | ] - -SEM ENonterminal - | ENonterminal (Just prods.inhmap) = Map.lookup @nt @lhs.inhmap - (Just prods.synmap) = Map.lookup @nt @lhs.synmap - prods.allInhmap = @lhs.inhmap - prods.allSynmap = @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.allstates = orderStates @initial @prods.allvisits - loc.stvisits = \st -> filter (\(v,f,t) -> f == st) @prods.allvisits - loc.t_type = type_nt_sem_top @nt - loc.t_c_params = ppTypeParams (cont_tvar : map pp @params) - - -- the initial "s" type: contains the "attach" function that delivers the initial st - loc.t_init = "and" >#< @loc.t_params >#< @loc.t_type >#< "=" >#< pp_braces ( nm_attach @nt >#< ":" >#< "unit" >#< "->" >#< @loc.t_params >#< type_nt_sem @nt @initial) - - -- the "s" type in a given state: contains the invoke function to go to a next state - loc.t_states = vlist $ map (\st -> - let s_st = type_nt_state @nt st - t_st = type_nt_sem @nt st - c_st = type_caller @nt st - nextVisits = Map.findWithDefault ManyVis st @nextVisits - decl = "and" >#< @loc.t_params >#< t_st >#< "=" - in case nextVisits of - NoneVis -> decl >#< "unit" -- final state: no more subsequent visits - _ -> decl >#< ppRecordVal [ nm_invoke @nt st >#< ":" >#< cont_tvar >#< "." >#< @loc.t_c_params >#< c_st >#< "->" >#< cont_tvar ] - ) @loc.allstates - -{ --- --- conventions --- - --- type of the state of a node: a closure containing the children states and attributes, --- with code of type 'type_nt_sem' that represents the subsequent visits to successor states. -type_nt_state nt st = "s_" >|< nt >|< "_" >|< st - --- type of a visit to a node (the initial, and when in a given state) --- an instance of this type is called the "semantics" -type_nt_sem_top nt = "t_" >|< nt -type_nt_sem nt st = type_nt_sem_top nt >|< "_s" >|< st - --- type of a caller (contains visit selection + inputs + continuation) -type_caller nt st = "c_" >|< nt >|< "_s" >|< st - --- names of records -nm_attach nt = "attach_">|< nt -nm_invoke nt st = "inv_" >|< nt >|< "_s" >|< st - --- name of the type variable representing the result type of the continuation -cont_tvar = text "'cont__" - - --- order states in reverse topological order so that successor states are --- earlier in the resulting list. -orderStates :: StateIdentifier -> [VisitStateState] -> [StateIdentifier] -orderStates initial edges = res where - source = Map.singleton initial Set.empty -- ensures that the initial state is in graph even when there are no edges - targets = [ Map.singleton t Set.empty | (_,_,t) <- edges ] - deps = [ Map.singleton f (Set.singleton t) | (_,f,t) <- edges ] - - mp = Map.unionsWith Set.union (source : (targets ++ deps)) - es = [ (f,f,Set.toList ts) | (f,ts) <- Map.toList mp ] - cps = stronglyConnComp es - res = flattenSCCs cps -} - --- type of a caller that selects a visit v from state s of the child, and --- provides a continuation of the caller after the visit to the child -SEM ENonterminal | ENonterminal - loc.c_states = vlist $ map (\st -> - let nt_st = type_nt_state @nt st - c_st = type_caller @nt st - outg = filter (\(_,f,_) -> f == st) @prods.allvisits - nextVisits = Map.findWithDefault ManyVis st @nextVisits - declHead = "and" >#< @loc.t_c_params >#< c_st >#< "=" - visitcons = vlist $ map (\(v,_,_) -> - "|" >#< con_visit @nt v >#< "of" >#< @loc.t_c_params >#< type_caller_visit @nt v - ) outg - in case nextVisits of -- slight optimization for when there is only one visit - NoneVis -> empty -- st is final state, no subsequent visits, thus no more caller info - OneVis v -> declHead >#< @loc.t_c_params >#< type_caller_visit @nt v - ManyVis -> declHead >-< indent 3 visitcons - ) @loc.allstates - -{ -type_caller_visit nt v = "c_" >|< nt >|< "_v" >|< v -con_visit nt v = "C_" >|< nt >|< "_v" >|< v - --- field names -nm_inh nt v = "inh_" >|< nt >|< "_v" >|< v -nm_cont nt v = "cont_" >|< nt >|< "_v" >|< v -} - --- type t_visit of a call to a visit v (inputs to the visit + continuation of the parents that gets the output + new state of the child) -ATTR Visit Visits EProduction EProductions [ | | t_visits USE {>-<} {empty} : {PP_Doc} ] - -SEM EProductions | Cons - lhs.t_visits = @hd.t_visits - -- just pick the first production (these results are the same for all of them) - -- todo: that means we should actually represent visit declarations in the AST... - -SEM Visit | Visit - loc.nameTIn_visit = conNmTVisitIn @lhs.nt @ident - loc.nameTOut_visit = conNmTVisitOut @lhs.nt @ident - loc.nameNextState = type_nt_sem @lhs.nt @to - loc.nameCaller_visit = type_caller_visit @lhs.nt @ident - - loc.nextVisitInfo = Map.findWithDefault ManyVis @to @lhs.nextVisits -- which visits can we do after we reach the @to state? - - loc.t_params = ppTypeParams @lhs.params - loc.t_c_params = ppTypeParams (cont_tvar : map pp @lhs.params) - - -- data type decls for the t_visit type - -- we generate a type for the caller of a visit, the arguments of the visit and the result of the visit - lhs.t_visits = "and" >#< @loc.t_c_params >#< @loc.nameCaller_visit >#< "=" >#< ppRecordTp - [ nm_inh @lhs.nt @ident >#< ":" >#< @loc.t_params >#< conNmTVisitIn @lhs.nt @ident - , nm_cont @lhs.nt @ident >#< ":" >#< @loc.t_params >#< conNmTVisitOut @lhs.nt @ident >#< "->" >#< cont_tvar - ] - >-< "and" >#< @loc.t_params >#< @loc.nameTIn_visit >#< "=" >#< ppRecordTp @loc.inhpart - >-< "and" >#< @loc.t_params >#< @loc.nameTOut_visit >#< "=" >#< ppRecordTp (@loc.synpart ++ @loc.contpart) - - loc.contpart = case @loc.nextVisitInfo of - NoneVis -> [] -- don't provide a continuation at all - _ -> [ nm_outarg_cont @lhs.nt @ident >#< ":" >#< @loc.t_params >#< @loc.nameNextState ] -- normal route: select the next semantics - - loc.inhpart = @loc.ppTypeList nm_inarg @inh @lhs.inhmap - loc.synpart = @loc.ppTypeList nm_outarg @syn @lhs.synmap - loc.ppTypeList = \f s m -> map (\i -> case Map.lookup i m of - Just tp -> f i @lhs.nt @ident >#< ":" >#< ppTp tp ) $ Set.toList s - -{ --- more naming conventions -nm_inarg nm nt v = "i_" >|< nm >|< "_" >|< nt >|< "_v" >|< v -nm_outarg nm nt v = "o_" >|< nm >|< "_" >|< nt >|< "_v" >|< v -nm_outarg_cont = nm_outarg "_cont" - -conNmTVisit nt vId = "t_" >|< nt >|< "_v" >|< vId -conNmTVisitIn nt vId = "t_" >|< nt >|< "_vIn" >|< vId -conNmTVisitOut nt vId = "t_" >|< nt >|< "_vOut" >|< vId - --- todo: remove ppMonadType -ppMonadType :: Options -> PP_Doc -ppMonadType opts - | parallelInvoke opts = text "IO" - | otherwise = text "Identity" -} - -------------------------------------------------------------------------------- --- Inh and Syn wrappers -------------------------------------------------------------------------------- -SEM ENonterminal | ENonterminal - loc.wr_inh = @loc.genwrap "inh" @loc.wr_inhs1 -- todo: is perhaps a mistake in 2hs - loc.wr_syn = @loc.genwrap "syn" @loc.wr_syns - loc.genwrap = \nm attrs -> - "and" >#< @loc.t_params >#< nm >|< "_" >|< @nt >#< "=" >#< ppRecordTp - [ i >|< "_" >|< nm >|< "_" >|< @nt >#< ":" >#< ppTp t | (i,t) <- attrs ] - - loc.inhAttrs = fromJust $ Map.lookup @nt @lhs.inhmap - loc.wr_inhs = Map.toList $ @loc.wr_filter $ @loc.inhAttrs - loc.wr_inhs1 = Map.toList @loc.inhAttrs - loc.wr_filter = if kennedyWarren @lhs.options && lateHigherOrderBinding @lhs.options - then Map.delete idLateBindingAttr - else id - loc.wr_syns = Map.toList $ fromJust $ Map.lookup @nt @lhs.synmap - - loc.wrapname = text ("wrap_" ++ show @nt) - loc.inhname = text ("inh_" ++ show @nt) - loc.synname = text ("syn_" ++ show @nt) - loc.firstVisitInfo = Map.findWithDefault ManyVis @initial @nextVisits - - loc.wrapArgSemTp = @loc.t_params >#< @loc.t_type - loc.wrapArgInhTp = @loc.t_params >#< @loc.inhname - loc.wrapArgPats = ppRecordVal [ i >|< "_inh_" >|< @nt >#< "=" >#< lhsname @lhs.options True i | (i,_) <- @loc.wr_inhs1 ] - loc.wrapResTp = @loc.t_params >#< @loc.synname - loc.wrapper = "and" >#< ppFunDecl @loc.o_sigs @loc.wrapname [(pp "act", @loc.wrapArgSemTp), (@loc.wrapArgPats, @loc.wrapArgInhTp)] @loc.wrapResTp @loc.wrapperPreamble - loc.wrapperPreamble - = ( if lateHigherOrderBinding @lhs.options - then "let" >#< lhsname @lhs.options True idLateBindingAttr >#< "=" >#< lateBindingFieldNm @lhs.mainName >#< "in" - else empty - ) -- initial attribute for late binding - >-< @loc.wrapperBody - loc.wrapperBody - = case @initialv of - [] -> text "{ }" -- case where there are no inherited or synthesized attributes - (initv:_) -> -- TODO: take care of multiple visits - let attach = "let" >#< "sem" >#< "=" >#< "act." >|< nm_attach @nt >#< "()" >#< "in" -- run attach code - - -- result transformer to wrapper output record - pat = ppRecordVal [ nm_outarg i @nt initv >#< "=" >#< lhsname @lhs.options False i | (i,_) <- @loc.wr_syns ] - bld = ppRecordVal [ i >|< "_syn_" >|< @nt >#< "=" >#< lhsname @lhs.options False i | (i,_) <- @loc.wr_syns ] - res = "let res = function" >#< pat >#< "->" >#< bld >#< "in" - - -- input to the visit (inh attrs + continuation) - inps = "let" >#< "inps" >#< "=" >#< ppRecordVal [ nm_inarg i @nt initv >#< "=" >#< lhsname @lhs.options True i | (i,_) <- @loc.wr_inhs ] >#< "in" - arg = "let" >#< "arg" >#< "=" >#< argcon >#< argrec >#< "in" - argcon = case @loc.firstVisitInfo of - ManyVis -> con_visit @nt initv - _ -> empty - argrec = ppRecordVal - [ nm_inh @nt initv >#< "=" >#< "inps" - , nm_cont @nt initv >#< "=" >#< "res" - ] - invoke = "sem." >|< nm_invoke @nt @initial >#< "arg" -- invoke the visit - in attach >-< res >-< inps >-< arg >-< invoke - -------------------------------------------------------------------------------- --- Collection of NT / Production sem funs references -------------------------------------------------------------------------------- - -ATTR ENonterminals ENonterminal EProductions EProduction [ | | semFunBndDefs, semFunBndTps USE {Seq.><} {Seq.empty} : {Seq PP_Doc} ] -SEM ENonterminal | ENonterminal - lhs.semFunBndDefs = @loc.semFunBndDef Seq.<| @prods.semFunBndDefs - lhs.semFunBndTps = @loc.semFunBndTp Seq.<| @prods.semFunBndTps - loc.semFunBndDef = @loc.semFunBndNm >#< "=" >#< @loc.semname - loc.semFunBndTp = @loc.semFunBndNm >#< ":" >#< @loc.sem_tp - loc.semFunBndNm = lateSemNtLabel @nt - -SEM EProduction | EProduction - lhs.semFunBndDefs = Seq.singleton @loc.semFunBndDef - lhs.semFunBndTps = Seq.singleton @loc.semFunBndTp - loc.semFunBndDef = @loc.semFunBndNm >#< "=" >#< @loc.semname - loc.semFunBndTp = @loc.semFunBndNm >#< ":" >#< @loc.sem_tp - loc.semFunBndNm = lateSemConLabel @lhs.nt @con - --- Generate a dictionary that contains the semantics of all semantic functions -SEM ExecutionPlan | ExecutionPlan - loc.wrappersExtra = if lateHigherOrderBinding @lhs.options - then @loc.lateSemBndDef - else empty - loc.commonExtra = if lateHigherOrderBinding @lhs.options - then @loc.lateSemBndTp - else empty - loc.lateSemBndTp = "and" >#< lateBindingTypeNm @lhs.mainName >#< "=" >#< ppRecordTp (toList @nonts.semFunBndTps) - loc.lateSemBndDef = "and" >#< lateBindingFieldNm @lhs.mainName >#< ":" >#< lateBindingTypeNm @lhs.mainName >#< "=" - >-< (indent 2 $ ppRecordVal $ toList @nonts.semFunBndDefs) - -------------------------------------------------------------------------------- --- Production semantic functions -------------------------------------------------------------------------------- -ATTR EProduction [ | | sem_prod : {PP_Doc} ] -ATTR EProductions [ | | sem_prod USE {>-<} {empty} : {PP_Doc} ] - -ATTR EProduction EProductions [ initial : {StateIdentifier} - allstates : {[StateIdentifier]} | | ] -SEM ENonterminal | ENonterminal - prods.initial = @initial - prods.allstates = @loc.allstates - -SEM EProduction | EProduction - loc.o_sigs = typeSigs @lhs.options - loc.t_type = type_nt_sem_top @lhs.nt - loc.semname = prefix @lhs.options >|< @lhs.nt >|< "_" >|< @con - loc.sem_res_tp = @loc.t_params >#< @loc.t_type - loc.sem_tp = pp_block "" "" "->" [ d | (_,_,d,_) <- @children.sigs ] >#< "->" >#< @loc.sem_res_tp - - loc.initializer - = -- some actions, performed upon attaching a child, can - -- be specified here in the form of a let-expression. - -- The resulting bindings of these actions are - -- in scope of the rules of the production - empty -- nothing for now - - loc.sem_prod = "and" >#< ppFunDecl @loc.o_sigs @loc.semname [ (x,d) | (_,x,d,_) <- @children.sigs ] @loc.sem_res_tp @loc.prod_body - loc.prod_body - = @loc.initializer - >-< "{" >#< nm_attach @lhs.nt >#< "=" >#< "function () ->" - >-< indent 2 - ( "(* rules of production" >#< @con >#< "*)" - >-< @rules.sem_rules - >-< "(* states of production" >#< @con >#< "*)" - >-< vlist @loc.statefuns - >-< nm_st @lhs.initial - ) - >#< "}" - - -- the semantic function of a production: defines a series of states and - -- their transitions. Two sorts of functions are important: - -- k-functions: inspect the caller_type to find out which visit the - -- caller wants and then dispatches that visit and continuation. - -- v-functions: the actual code of the visit. - loc.statefuns = map @loc.genstfn @lhs.allstates - loc.genstfn - = \st -> let nextVisitInfo = Map.findWithDefault ManyVis st @lhs.nextVisits - stNm = nm_st st - - -- note about the initial state: the initial state should be the only - -- state-binding that is not a function. It is non-recursive, its definition does - -- not involve side effect, and its not needed - -- anywhere except to be delivered as initial result. - stDef body = "let" >#< stNm >#< (if st == @lhs.initial then empty else @loc.stargs st) >#< "=" - >-< indent 2 body >#< "in" - - in case nextVisitInfo of - NoneVis -> -- the (empty) closure of a (non-initial) end state is not referenced - -- thus generating it is not needed (and omitting it may catch some small mistakes). - if st == @lhs.initial - then stDef (pp "unit") -- empty state - else empty -- no state generated - _ -> stDef $ mklets (@loc.stvs st ++ @loc.stks st) $ ppRecordVal - [ nm_invoke @lhs.nt st >#< "=" >#< nm_k st ] - - loc.stargs - = \st -> let attrs = maybe Map.empty id $ Map.lookup st @visits.intramap in ppSpaced - [ case mbAttr of - Just (AttrSyn child nm) | child == _LOC && not (noPerStateTypeSigs @lhs.options) -> - case Map.lookup nm @loc.localAttrTypes of - Just tp -> pp_parens (strNm >#< ":" >#< ppTp tp) - Nothing -> pp strNm - Just attr | not (noPerStateTypeSigs @lhs.options) -> - case lookupAttrType attr @lhs.allInhmap @lhs.allSynmap @loc.childTypes of - Just tpDoc -> pp_parens (strNm >#< ":" >#< tpDoc) - Nothing -> pp strNm - _ -> pp strNm - | (strNm, mbAttr) <- Map.assocs attrs - ] >#< dummyPat @lhs.options (Map.null attrs) - - -- produces the "k" function that inspect the caller argument to dispatch a visit - loc.stvisits = \st -> filter (\(_,f,_) -> f == st) @visits.allvisits - loc.stks - = \st -> let stvisits = @loc.stvisits st - def = ppFunDecl False {- @loc.o_sigs -} (pp $ nm_k st) - [(pp "arg", @loc.t_c_params >#< type_caller @lhs.nt st)] (pp cont_tvar) body - - nextVisitInfo = Map.findWithDefault ManyVis st @lhs.nextVisits - body = case nextVisitInfo of - NoneVis -> text "?no next visit?" - OneVis v -> dispatch "arg" v - ManyVis -> let alt (v,_,_) = "|" >#< con_visit @lhs.nt v >#< "chosen" >#< "->" >-< indent 2 (dispatch "chosen" v) - in "match arg with" >-< (indent 2 $ vlist $ map alt stvisits) - - dispatch nm v = "let" >#< ppRecordVal - [ nm_inh @lhs.nt v >#< "=" >#< "inp" - , nm_cont @lhs.nt v >#< "=" >#< "cont" ] - >#< "=" >#< pp nm - >-< "in" >#< "cont" >#< pp_parens (nm_visit v >#< "inp") -- call cont with res of visit - - in if null stvisits - then [] - else [ "(* k-function for production" >#< @con >#< " *)" >-< def ] - - loc.stvs = \st -> [ppf | (f,ppf) <- @visits.sem_visit, f == st] - visits.mrules = @rules.mrules - -{ -nm_visit v = "__v" >|< v -nm_k st = "__k" >|< st -nm_st st = "__st" >|< st - -mklets :: (PP b, PP c) => [b] -> c -> PP_Doc -mklets defs body = res where - ppLet def = "let" >#< def >#< "in" - res = vlist (map ppLet defs) >-< body -} - -------------------------------------------------------------------------------- --- Visit semantic functions -------------------------------------------------------------------------------- -ATTR Visit [ | | sem_visit : { (StateIdentifier,PP_Doc) } ] -ATTR Visits [ | | sem_visit USE {:} {[]} : { [(StateIdentifier,PP_Doc)] } ] - -SEM Visit | Visit - loc.o_sigs = typeSigs @lhs.options - lhs.sem_visit = ( @from - , let resTp = @loc.t_params >#< @loc.nameTOut_visit - argTp = @loc.t_params >#< @loc.nameTIn_visit - argMatch = ppRecordVal [ nm_inarg i @lhs.nt @ident >#< "=" >#< lhsname @lhs.options True i | i <- Set.toList @inh ] - in ppFunDecl @loc.o_sigs (nm_visit @ident) [(argMatch, argTp)] resTp @steps.sem_steps - ) - - steps.follow = @loc.nextStBuild >-< @loc.resultval - - loc.nextArgsMp = maybe Map.empty id $ Map.lookup @to @lhs.allintramap - loc.nextArgs = ppSpaced $ Map.keys $ @loc.nextArgsMp - loc.nextStExp = nm_st @to >#< @loc.nextArgs >#< dummyArg @lhs.options (Map.null @loc.nextArgsMp) - - loc.resultval = ppRecordVal - ( [ nm_outarg i @lhs.nt @ident >#< "=" >#< lhsname @lhs.options False i | i <- Set.toList @syn ] - ++ [ @loc.nextStRefExp ]) - - (loc.nextStBuild, loc.nextStRefExp) - = case @loc.nextVisitInfo of - NoneVis -> (empty, empty) - _ -> ( "let" >#< nextStName >#< "=" >#< @loc.nextStExp >#< "in" - , nm_outarg_cont @lhs.nt @ident >#< "=" >#< nextStName) - -{ -resultValName :: String -resultValName = "__result_" - -nextStName :: String -nextStName = "__st_" -} - --- Propagate the visit kind to the steps -ATTR VisitStep VisitSteps [ kind : VisitKind | | ] -SEM Visit | Visit steps.kind = @kind - --- the steps in this group should be executed in a pure fashion -SEM VisitStep | PureGroup - steps.kind = VisitPure @ordered - --- follow: the code of steps that follows after the VisitStep -ATTR Visits Visit VisitStep VisitSteps [ mrules : {Map Identifier (VisitKind -> Either Error PP_Doc)} | | ] -ATTR VisitStep VisitSteps [ follow : PP_Doc | | sem_steps USE {>-<} {empty} : PP_Doc ] - --- continuation flow (passing the right steps as left follow steps) -SEM VisitSteps - | Cons hd.follow = @tl.sem_steps - lhs.sem_steps = @hd.sem_steps - | Nil lhs.sem_steps = @lhs.follow - -SEM VisitStep - | Sem loc.ruleItf = Map.findWithDefault (error $ "Rule " ++ show @name ++ " not found") @name @lhs.mrules - (lhs.errors, loc.sem_steps) = case @loc.ruleItf @lhs.kind of - Left e -> (Seq.singleton e, empty) - Right stmt -> (Seq.empty, stmt) - lhs.sem_steps = @loc.sem_steps >-< @lhs.follow - | ChildIntro loc.attachItf = Map.findWithDefault (error $ "Child " ++ show @child ++ " not found") @child @lhs.childintros - (lhs.errors,loc.sem_steps,lhs.defs,lhs.uses) - = case @loc.attachItf @lhs.kind of - Left e -> (Seq.singleton e, empty, Set.empty, Map.empty) - Right (code, defs, uses) -> (Seq.empty, code, defs, uses) - lhs.sem_steps = @loc.sem_steps >-< @lhs.follow - | ChildVisit loc.visitItf = Map.findWithDefault (error $ "Visit " ++ show @visit ++ " not found") @visit @lhs.allchildvisit - loc.childType = Map.findWithDefault (error ("type of child " ++ show @child ++ " is not in the childTypes map! " ++ show @lhs.childTypes)) @child @lhs.childTypes - (lhs.errors, lhs.sem_steps) = case @loc.visitItf @child @loc.childType @lhs.kind @lhs.follow of - Left e -> (Seq.singleton e, empty) - Right steps -> (Seq.empty, steps) - | Sim -- simply propagates - | PureGroup -- simply propagates - --- --- Some properties of VisitStep(s) --- - --- Number of steps in a 'Sim' block -ATTR VisitSteps [ | | size : Int ] -SEM VisitSteps - | Nil lhs.size = 0 - | Cons lhs.size = 1 + @tl.size - --- Number the steps in a 'Sim' block -ATTR VisitSteps VisitStep [ | index : Int | ] -SEM VisitSteps | Cons - hd.index = @lhs.index -- copy rule - tl.index = 1 + @lhs.index - lhs.index = @tl.index -- copy rule -SEM Visit | Visit steps.index = 0 -SEM VisitStep | Sim steps.index = 0 - lhs.index = @lhs.index -- needed for if we ever allow nested Sims - --- Biggest number of steps in previous blocks that used parallel invocation --- This number - 1 (minimum 0) is the number of references for parallel invocation created -ATTR VisitSteps VisitStep [ | prevMaxSimRefs : Int | ] -SEM Visit | Visit steps.prevMaxSimRefs = 0 -SEM VisitStep | Sim - lhs.prevMaxSimRefs = if @loc.useParallel - then @lhs.prevMaxSimRefs `max` (@steps.index - 1) -- possibly new references made - else @lhs.prevMaxSimRefs -- no references created - --- Is this the last step? -ATTR VisitSteps VisitStep [ | | isLast : Bool ] -ATTR VisitStep [ isLast : Bool | | ] -SEM VisitSteps - | Nil lhs.isLast = True - | Cons lhs.isLast = False - hd.isLast = @tl.isLast - --- Use parallel invocation: only when option enabled and there is more than one visit to a child --- Todo: implement a parallel evaluator -SEM VisitSteps VisitStep [ useParallel : Bool | | ] -SEM Visit | Visit steps.useParallel = False -SEM VisitStep | Sim loc.useParallel = parallelInvoke @lhs.options && @steps.size > 1 - --- Child introduction -ATTR EChild EChildren - [ | | childintros USE {`Map.union`} {Map.empty} : {Map Identifier (VisitKind -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))} ] - -ATTR Visits Visit VisitSteps VisitStep - [ childintros : {Map Identifier (VisitKind -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))} | | ] - -SEM EProduction | EProduction - visits.childintros = @children.childintros - -SEM EChild - | ETerm lhs.childintros = Map.singleton @name (\_ -> Right (empty, Set.empty, Map.empty)) - | EChild lhs.childintros = Map.singleton @name @loc.introcode - loc.isDefor = case @tp of - NT _ _ defor -> defor - _ -> False - loc.valcode = case @kind of - ChildSyntax -> @name >|< "_" - ChildAttr -> -- decide if we need to invoke the sem-function under the hood - let head | not @loc.isDefor = if lateHigherOrderBinding @lhs.options - then lateSemNtLabel @loc.nt >#< lhsname @lhs.options True idLateBindingAttr - else prefix @lhs.options >|< @loc.nt - | otherwise = empty -- no need to intro a terminal - in pp_parens (head >#< instname @name) - ChildReplace _ -> -- the higher-order attribute is actually a function that transforms - -- the semantics of the child (always deforested) - pp_parens (instname @name >#< @name >|< "_") - loc.aroundcode = if @hasAround - then locname @lhs.options @name >|< "_around" - else empty - loc.introcode = \kind -> let pat = text $ stname @name @loc.initSt - attach = pp_parens (@loc.aroundcode >#< @loc.valcode) >|< "." >|< nm_attach @loc.nt >#< "()" - decl = pat >#< "=" >#< attach - in if compatibleAttach kind @loc.nt @lhs.options - then Right ( "let" >#< decl >#< "in" - , Set.singleton (stname @name @loc.initSt) -- variables defined by the child intro - , case @kind of -- variables used by the child introduction - ChildAttr -> Map.insert (instname @name) Nothing $ -- the sem attr - ( if @loc.isDefor || not (lateHigherOrderBinding @lhs.options) - then id -- the sem dictionary attr is not used - else Map.insert (lhsname @lhs.options True idLateBindingAttr) (Just $ AttrInh _LHS idLateBindingAttr) - ) $ - ( if @hasAround - then Map.insert (locname @lhs.options (@name) ++ "_around") Nothing - else id - ) $ Map.empty - ChildReplace _ -> Map.singleton (instname @name) Nothing -- uses the transformation function - ChildSyntax -> Map.empty - ) - else Left $ IncompatibleAttachKind @name kind - loc.nt = extractNonterminal @tp - -{ -stname :: Identifier -> Int -> String -stname child st = "_" ++ getName child ++ "X" ++ show st - --- should actually return some conversion info -compatibleAttach :: VisitKind -> NontermIdent -> Options -> Bool -compatibleAttach _ _ _ = True -} - --- rules -ATTR ERules ERule [ | | sem_rules USE {>-<} {empty} : {PP_Doc} - mrules USE {`Map.union`} {Map.empty} : {Map Identifier (VisitKind -> Either Error PP_Doc)} ] - -SEM ERule | ERule - lhs.sem_rules = if @loc.used == 0 - then empty - else @loc.rulecode - loc.rulecode = ( if @loc.genpragma - then @loc.pragma -- this additional pragma *may* help to give some AG source location in the presence of - -- type errors in the rule. It will definitely not be precise, and may take some additional - -- source space, but let's see if it's worth it in practice. - else empty - ) - >-< @loc.declHead - >-< indent ((column @rhs.pos - 2) `max` 2) - ( if @loc.genpragma - then @loc.pragma >-< @rhs.semfunc >-< @loc.endpragma - else @rhs.semfunc - ) - >#< "in" - loc.pragma = ppLinePragma @lhs.options (line @rhs.pos) (file @rhs.pos) - loc.endpragma = ppWithLineNr (\ln -> ppLinePragma @lhs.options (ln+1) @lhs.mainFile) - loc.genpragma = genLinePragmas @lhs.options && @explicit && @loc.haspos - loc.haspos = line @rhs.pos > 0 && column @rhs.pos >= 0 && not (null (file @rhs.pos)) - - -- Note: we also ensure that all rules are functions, so that they are not made part of any closures - -- but are lambda-lifted instead. - loc.declHead = "let" >#< @name >#< @loc.argPats >#< dummyPat @lhs.options (Map.null @rhs.attrs) >#< "=" - loc.argPats - = ppSpaced - [ case mbAttr of - Just (AttrSyn child nm) | child == _LOC && not (noPerStateTypeSigs @lhs.options) -> - case Map.lookup nm @lhs.localAttrTypes of - Just tp -> pp_parens (strNm >#< ":" >#< ppTp tp) - Nothing -> pp strNm - Just attr | not (noPerStateTypeSigs @lhs.options) -> - case lookupAttrType attr @lhs.allInhmap @lhs.allSynmap @lhs.childTypes of - Just tpDoc -> pp_parens (strNm >#< ":" >#< tpDoc) - Nothing -> pp strNm - _ -> pp strNm - | (strNm, mbAttr) <- Map.assocs @rhs.attrs - ] - - loc.argExprs = ppSpaced $ Map.keys @rhs.attrs - loc.stepcode = \kind -> - let mkBind (pat,expr) = "let" >#< pat >#< "=" >#< expr >#< "in" - in if kind `compatibleRule` @pure - then Right $ mkBind (@pattern.sem_lhs, @name >#< @loc.argExprs >#< dummyArg @lhs.options (Map.null @rhs.attrs)) - >-< vlist (map mkBind @pattern.extraDefs) - else Left $ IncompatibleRuleKind @name kind - - lhs.mrules = Map.singleton @name @loc.stepcode - -ATTR Expression [ | | tks : {[HsToken]} ] -SEM Expression - | Expression lhs.tks = @tks - -{ -dummyPat :: Options -> Bool -> PP_Doc -dummyPat opts noArgs - | not noArgs = empty - | strictDummyToken opts = text "()" - | otherwise = text "(_ : unit)" - -dummyArg :: Options -> Bool -> PP_Doc -dummyArg opts noArgs - | not noArgs = empty - | otherwise = text "()" - -dummyType :: Options -> Bool -> PP_Doc -dummyType opts noArgs - | not noArgs = empty - | otherwise = text "unit" -} - -ATTR Expression [ | | pos : {Pos} ] -SEM Expression | Expression lhs.pos = @pos - --- pattern and expression semantics -ATTR Pattern [ | | sem_lhs : { PP_Doc } ] -ATTR Patterns [ | | sem_lhs USE {:} {[]} : {[PP_Doc]} ] -ATTR Pattern Patterns [ | | extraDefs USE {++} {[]} : {[(PP_Doc,PP_Doc)]} ] - -SEM Pattern - | Alias loc.var = text $ attrname @lhs.options False @field @attr - loc.hasTp = isJust @loc.mbTp - loc.o_sigs = typeSigs @lhs.options - - lhs.sem_lhs = ppArg (@loc.hasTp && @loc.o_sigs) @loc.var (maybe (text "?no type?") ppTp @loc.mbTp) - lhs.extraDefs = if @pat.isUnderscore - then [] - else [ (@pat.sem_lhs, @loc.var) ] - | Product lhs.sem_lhs = pp_block "(" ")" "," @pats.sem_lhs - | Constr lhs.sem_lhs = pp_parens $ @name >#< pp_block "(" ")" "," @pats.sem_lhs - | Underscore lhs.sem_lhs = text "_" - | Irrefutable lhs.sem_lhs = pp_parens (text "lazy" >#< @pat.sem_lhs) - -- note that the above has the inverse meaning compared to Haskell: - -- the above forces the evaluation of a lazy value. It seems appropriate though. - --- Check if a pattern is just an underscore -ATTR Pattern [ | | isUnderscore:{Bool}] -SEM Pattern - | Constr lhs.isUnderscore = False - | Product lhs.isUnderscore = False - | Alias lhs.isUnderscore = False - | Underscore lhs.isUnderscore = True - --- Collect the attributes defined by a pattern -ATTR Pattern Patterns [ | | attrs USE {`Set.union`} {Set.empty} : {Set String} ] -SEM Pattern | Alias - lhs.attrs = Set.insert (attrname @lhs.options False @field @attr) @pat.attrs - --- All attribute types of this pattern --- Todo: if possible, make attribute types part of the pattern -ATTR Pattern Patterns [ | | attrTypes USE {>-<} {empty} : {PP_Doc} ] -SEM Pattern | Alias - loc.mbTp = if @field == _LHS - then Map.lookup @attr @lhs.synmap - else if @field == _LOC - then Map.lookup @attr @lhs.localAttrTypes - else Nothing - lhs.attrTypes = maybe empty (\tp -> (attrname @lhs.options False @field @attr) >#< "::" >#< ppTp tp) @loc.mbTp - >-< @pat.attrTypes - --- Collect the attributes used by the right-hand side -ATTR HsToken Expression [ | | attrs USE {`Map.union`} {Map.empty} : {Map String (Maybe NonLocalAttr)} ] -SEM HsToken - | AGLocal lhs.attrs = Map.singleton (fieldname @var) Nothing - | AGField loc.mbAttr = if @field == _INST || @field == _FIELD || @field == _INST' - then Nothing -- should not be used in the first place - else Just $ mkNonLocalAttr (@field == _LHS) @field @attr - lhs.attrs = Map.singleton (attrname @lhs.options True @field @attr) @loc.mbAttr - -{ -data NonLocalAttr - = AttrInh Identifier Identifier - | AttrSyn Identifier Identifier deriving Show - -mkNonLocalAttr :: Bool -> Identifier -> Identifier -> NonLocalAttr -mkNonLocalAttr True = AttrInh -- True: inherited attr -mkNonLocalAttr False = AttrSyn - -lookupAttrType :: NonLocalAttr -> Map Identifier Attributes -> Map Identifier Attributes -> Map Identifier Type -> Maybe PP_Doc -lookupAttrType (AttrInh child name) inhs _ = lookupType child name inhs -lookupAttrType (AttrSyn child name) _ syns = lookupType child name syns - --- Note: if the child takes type parameters, the type of an attribute of this child may refer to these parameters. This means that --- the actual type of the attribute needs to have its type parameters substituted with the actual type argument of the child. --- However, for now we simply decide to return Nothing in this case, which skips the type annotation. -lookupType :: Identifier -> Identifier -> Map Identifier Attributes -> Map Identifier Type -> Maybe PP_Doc -lookupType child name attrMp childMp - | noParameters childTp = Just ppDoc - | otherwise = Nothing - where - attrTp = Map.findWithDefault (error "lookupType: the attribute is not in the attrs of the child") name childAttrs - childAttrs = Map.findWithDefault (error "lookupType: the attributes of the nonterm are not in the map") nonterm attrMp - nonterm = extractNonterminal childTp - childTp = Map.findWithDefault (error ("lookupType: the child " ++ show child ++ "is not in the appropriate map")) child childMp - ppDoc = ppTp attrTp - -noParameters :: Type -> Bool -noParameters (Haskell _) = True -noParameters (NT _ args _) = null args -} - -ATTR Expression [ | | semfunc : {PP_Doc} ] - -SEM Expression - | Expression lhs.attrs = Map.unions $ map (\tok -> attrs_Syn_HsToken (wrap_HsToken (sem_HsToken tok) @loc.inhhstoken)) @tks - lhs.semfunc = vlist $ showTokens $ map (\tok -> tok_Syn_HsToken (wrap_HsToken (sem_HsToken tok) @loc.inhhstoken)) @tks - loc.inhhstoken = Inh_HsToken @lhs.options - --- child visit map -ATTR Visit - Visits - EProduction - EProductions - ENonterminal - ENonterminals [ allchildvisit : {Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc)} - | | childvisit USE {`Map.union`} {Map.empty} : {Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc)} ] - -ATTR VisitSteps VisitStep [ allchildvisit : {Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc)} | | ] - -SEM ExecutionPlan - | ExecutionPlan nonts.allchildvisit = @nonts.childvisit - --- code for the invocation of the visit: --- * "follow" is the pretty print of the code that follows this step, and is thus the code that comprises the continuation. --- * the child state contain a field which is the operation to invoke --- * we create a parameter with the inputs to the visit and the continuation --- * the continuation obtains the resulting outputs plus the updated state -SEM Visit | Visit - loc.prevVisitInfo = Map.findWithDefault ManyVis @from @lhs.nextVisits - lhs.childvisit = Map.singleton @ident @loc.invokecode - loc.invokecode - = \chld childTp kind follow -> -- "chld" is the name of the child at the place of invocation, and "kind" the kind of the calling visit - let code = cont >-< inps >-< call - - childNmTo = text $ stname chld @to - childNmFrom = text $ stname chld @from - childTpArgs = case childTp of - NT _ args _ -> args - _ -> error "generate visit call: type of the child is not a nonterminal!" - - -- cont is parameterized with the outputs of the child and brings them in scope - cont = "let" >#< contNm >#< ppArg @loc.o_sigs (ppRecordVal cont_in) cont_in_tp >#< "=" - >-< indent 2 follow -- the continuation-code - >#< "in" - cont_in = [ nm_outarg i @lhs.nt @ident >#< "=" >#< attrname @lhs.options True chld i | i <- Set.toList @syn ] - ++ case @loc.nextVisitInfo of - NoneVis -> [] - _ -> [ nm_outarg_cont @lhs.nt @ident >#< "=" >#< childNmTo ] - cont_in_tp = ppTypeParams childTpArgs >#< @loc.nameTOut_visit - - -- defines the input records to the visit function - inps = "let" >#< inpsNm >#< "=" >#< ppRecordVal - [ nm_inh @lhs.nt @ident >#< "=" >#< ppRecordVal inps_in - , nm_cont @lhs.nt @ident >#< "=" >#< contNm - ] >#< "in" - inps_in = [ nm_inarg i @lhs.nt @ident >#< "=" >#< attrname @lhs.options False chld i | i <- Set.toList @inh ] - - -- the call to the visit function, with possible the need to specify which visit function to dispatch to - call = childNmFrom >|< "." >|< nm_invoke @lhs.nt @from >#< arg - arg = case @loc.prevVisitInfo of - NoneVis -> error "error: invocation of a visit from a state that has no next visits" - OneVis _ -> pp inpsNm - ManyVis -> pp_parens (con_visit @lhs.nt @ident >#< inpsNm) - in if kind `compatibleKind` @kind - then Right code - else Left $ IncompatibleVisitKind chld @ident kind @kind - -{ -contNm = text "__cont_" -inpsNm = text "__inps_" - --- a `compatibleKind` b means: can kind b be invoked from a -compatibleKind :: VisitKind -> VisitKind -> Bool -compatibleKind _ _ = True - -compatibleRule :: VisitKind -> Bool -> Bool -compatibleRule (VisitPure _) False = False -compatibleRule _ _ = True -} - -------------------------------------------------------------------------------- --- Properties of rules -------------------------------------------------------------------------------- - --- Construct an environment that counts how often certain rules are used -ATTR Visits Visit VisitSteps VisitStep [ | | ruleUsage USE {`unionWithSum`} {Map.empty} : {Map Identifier Int} ] -ATTR ERules ERule [ usageInfo : {Map Identifier Int} | | ] - -SEM EProduction | EProduction rules.usageInfo = @visits.ruleUsage -SEM VisitStep | Sem lhs.ruleUsage = Map.singleton @name 1 -SEM ERule | ERule loc.used = Map.findWithDefault 0 @name @lhs.usageInfo - -{ -unionWithSum = Map.unionWith (+) -} - --- Collect in what visit-kinds a rule is used -ATTR Visits Visit VisitSteps VisitStep [ | | ruleKinds USE {`unionWithMappend`} {Map.empty} : {Map Identifier (Set VisitKind)} ] -SEM VisitStep | Sem - lhs.ruleKinds = Map.singleton @name (Set.singleton @lhs.kind) - -ATTR ERules ERule [ ruleKinds : {Map Identifier (Set VisitKind)} | | ] -SEM EProduction | EProduction - rules.ruleKinds = @visits.ruleKinds - -SEM ERule | ERule - loc.kinds = Map.findWithDefault Set.empty @name @lhs.ruleKinds - loc.anyLazyKind = Set.fold (\k r -> isLazyKind k || r) False @loc.kinds - -ATTR Pattern Patterns [ anyLazyKind : Bool | | ] - - -------------------------------------------------------------------------------- --- Intra attributes -------------------------------------------------------------------------------- -{ -uwSetUnion :: (Ord a, Ord b) => Map a (Set b) -> Map a (Set b) -> Map a (Set b) -uwSetUnion = Map.unionWith Set.union - -uwMapUnion :: (Ord a, Ord b) => Map a (Map b c) -> Map a (Map b c) -> Map a (Map b c) -uwMapUnion = Map.unionWith Map.union -} -ATTR Visit Visits [ allintramap : {Map StateIdentifier (Map String (Maybe NonLocalAttr))} - | | intramap USE {`uwMapUnion`} {Map.empty} : {Map StateIdentifier (Map String (Maybe NonLocalAttr))} ] - -ATTR Visit Visits [ terminaldefs : {Set String} | | ] -ATTR EChild EChildren [ | | terminaldefs USE {`Set.union`} {Set.empty} : {Set String} ] - -SEM EChild | ETerm - lhs.terminaldefs = Set.singleton $ fieldname @name - -SEM EProduction | EProduction - visits.allintramap = @visits.intramap - visits.terminaldefs = @children.terminaldefs - -SEM Visit - | Visit loc.thisintra = (@loc.uses `Map.union` @loc.nextintra) `Map.difference` @loc.defsAsMap - lhs.intramap = Map.singleton @from @loc.thisintra - loc.nextintra = maybe Map.empty id $ Map.lookup @to @lhs.allintramap - loc.uses = let mp1 = @steps.uses - mp2 = Map.fromList [ (lhsname @lhs.options False i, Just (AttrSyn _LHS i)) | i <- Set.elems @syn ] - in mp1 `Map.union` mp2 - loc.inhVarNms = Set.map (lhsname @lhs.options True) @inh - loc.defs = @steps.defs `Set.union` @loc.inhVarNms `Set.union` @lhs.terminaldefs - loc.defsAsMap = Map.fromList [ (a, Nothing) | a <- Set.elems @loc.defs ] - -ATTR ERule ERules [ | | ruledefs USE {`uwSetUnion`} {Map.empty} : {Map Identifier (Set String)} - ruleuses USE {`uwMapUnion`} {Map.empty} : {Map Identifier (Map String (Maybe NonLocalAttr))} ] -ATTR Visit Visits - VisitSteps VisitStep [ ruledefs : {Map Identifier (Set String)} - ruleuses : {Map Identifier (Map String (Maybe NonLocalAttr))} | | ] - -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 VisitIdentifier (Set Identifier)} - visituses USE {`uwSetUnion`} {Map.empty} : {Map VisitIdentifier (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 VisitIdentifier (Set Identifier)} - avisituses : {Map VisitIdentifier (Set Identifier)} | | ] - -SEM ExecutionPlan - | ExecutionPlan nonts.avisitdefs = @nonts.visitdefs - nonts.avisituses = @nonts.visituses - -ATTR VisitSteps VisitStep [ | | defs USE {`Set.union`} {Set.empty} : {Set String} - uses USE {`Map.union`} {Map.empty} : {Map String (Maybe NonLocalAttr)} ] -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 - | ChildVisit lhs.defs = Set.insert (stname @child @to) $ maybe (error "Visit not found") (Set.map $ attrname @lhs.options True @child) $ Map.lookup @visit @lhs.avisitdefs - lhs.uses = let convert attrs = Map.fromList [ (attrname @lhs.options False @child attr, Just $ mkNonLocalAttr True @child attr) | attr <- Set.elems attrs ] - in Map.insert (stname @child @from) Nothing $ convert $ - maybe (error "Visit not found") id $ Map.lookup @visit @lhs.avisituses - -------------------------------------------------------------------------------- --- Identification of lazy intra defs within a production --- --- These identifiers will not be marked as strict in rules and state closures -------------------------------------------------------------------------------- - -ATTR Visits Visit VisitSteps VisitStep [ | | lazyIntras USE {`Set.union`} {Set.empty} : {Set String} ] -ATTR ERules ERule [ lazyIntras : {Set String} | | ] - -SEM Visit | Visit - loc.lazyIntrasInh = case @kind of - VisitPure False -> @loc.inhVarNms `Set.union` @steps.defs - _ -> Set.empty - lhs.lazyIntras = @loc.lazyIntrasInh `Set.union` @steps.lazyIntras - -SEM VisitStep | PureGroup - lhs.lazyIntras = if @ordered - then @steps.lazyIntras - else @steps.defs - -SEM EProduction | EProduction - loc.lazyIntras = @visits.lazyIntras - -------------------------------------------------------------------------------- --- Pretty printing of haskell code -------------------------------------------------------------------------------- - --- note: this function produces strings, which are passed to showTokens which --- preserves layout. --- note: this may not be that important for ocaml code in comparison to Haskell -SEM HsTokens [ || tks : {[(Pos,String)]} ] - | Cons lhs.tks = @hd.tok : @tl.tks - | Nil lhs.tks = [] - -SEM HsToken - | AGLocal loc.tok = (@pos,fieldname @var) - -SEM HsToken [ || tok:{(Pos,String)}] - | AGField - loc.addTrace = case @rdesc of - Just d -> \x -> "(prerr_endline " ++ show (d ++ " -> " ++ show @field ++ "." ++ show @attr) ++ "; " ++ x ++ ")" - Nothing -> id - lhs.tok = (@pos, @loc.addTrace $ attrname @lhs.options 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, "") - --- --- Distribute single-visit-next map downward --- - -ATTR EProductions EProduction Visits Visit - [ prevVisits, nextVisits : {Map StateIdentifier StateCtx} | | ] - -SEM ENonterminal | ENonterminal - prods.nextVisits = @nextVisits - prods.prevVisits = @prevVisits - --- --- Collect and distribute the from/to states of a visit --- - -ATTR ENonterminals ENonterminal EProductions EProduction Visits Visit - [ | | fromToStates USE {`mappend`} {mempty} : {Map VisitIdentifier (Int,Int)} ] - -ATTR ENonterminals ENonterminal EProductions EProduction Visits Visit VisitSteps VisitStep - [ allFromToStates : {Map VisitIdentifier (Int,Int)} | | ] - -SEM Visit | Visit - lhs.fromToStates = Map.singleton @ident (@from, @to) - -SEM ExecutionPlan | ExecutionPlan - nonts.allFromToStates = @nonts.fromToStates - -SEM VisitStep | ChildVisit - (loc.from, loc.to) = Map.findWithDefault (error "visit not in allFromToStates") @visit @lhs.allFromToStates - - --- --- Collect and distribute the actual types of children of productions --- - -ATTR EChildren EChild [ | | childTypes USE {`mappend`} {mempty} : {Map Identifier Type} ] -ATTR ERules ERule Visits Visit VisitSteps VisitStep [ childTypes : {Map Identifier Type} | | ] - -SEM EProduction | EProduction - loc.childTypes = Map.singleton _LHS @lhs.ntType `Map.union` @children.childTypes - -SEM EChild | EChild ETerm - lhs.childTypes = Map.singleton @name @tp - --- --- Distribute types of local attributes --- - -ATTR ExecutionPlan ENonterminals ENonterminal [ localAttrTypes : {Map NontermIdent (Map ConstructorIdent (Map Identifier Type))} | | ] -ATTR EProductions EProduction [ localAttrTypes : {Map ConstructorIdent (Map Identifier Type)} | | ] -ATTR ERules ERule Pattern Patterns [ localAttrTypes : {Map Identifier Type} | | ] - -SEM ENonterminal | ENonterminal - prods.localAttrTypes = Map.findWithDefault Map.empty @nt @lhs.localAttrTypes - -SEM EProduction | EProduction - loc.localAttrTypes = Map.findWithDefault Map.empty @con @lhs.localAttrTypes - --- --- Collect and distribute visit kinds --- - -ATTR ENonterminals ENonterminal EProductions EProduction Visits Visit VisitSteps VisitStep - [ allVisitKinds : {Map VisitIdentifier VisitKind} | | visitKinds USE {`mappend`} {mempty} : {Map VisitIdentifier VisitKind} ] - -SEM Visit | Visit - lhs.visitKinds = Map.singleton @ident @kind - -SEM ExecutionPlan | ExecutionPlan - nonts.allVisitKinds = @nonts.visitKinds - --- --- Collect and distribute the initial state of nonterminals --- - -ATTR ENonterminals ENonterminal [ | | initStates USE {`mappend`} {mempty} : {Map NontermIdent Int} ] -ATTR ENonterminals ENonterminal EProductions EProduction EChildren EChild Visits Visit VisitSteps VisitStep - [ allInitStates : {Map NontermIdent Int} | | ] - -SEM ENonterminal | ENonterminal - lhs.initStates = Map.singleton @nt @initial - -SEM ExecutionPlan | ExecutionPlan - nonts.allInitStates = @nonts.initStates - -SEM EChild | EChild - loc.initSt = Map.findWithDefault (error "nonterminal not in allInitStates map") @loc.nt @lhs.allInitStates - --- --- Push the nonterminal type downward --- - -ATTR EProductions EProduction [ ntType : Type | | ] -SEM ENonterminal | ENonterminal - loc.ntType = NT @nt (map show @params) False - --- --- Collect errors contained in rules that should be yielded when the --- rules are scheduled. --- - -ATTR ExecutionPlan ENonterminals ENonterminal EProductions EProduction ERules ERule Visits Visit VisitSteps VisitStep [ | | errors USE {Seq.><} {Seq.empty} : {Seq Error} ] -SEM ERule | ERule - lhs.errors = case @mbError of - Just e | @loc.used > 0 -> Seq.singleton e - _ -> Seq.empty diff --git a/src-ag/ExecutionPlan2Clean.ag b/src-ag/ExecutionPlan2Clean.ag deleted file mode 100644 --- a/src-ag/ExecutionPlan2Clean.ag +++ /dev/null @@ -1,1684 +0,0 @@ -INCLUDE "ExecutionPlan.ag" -INCLUDE "Patterns.ag" -INCLUDE "Expression.ag" -INCLUDE "HsToken.ag" - -imports -{ -import ExecutionPlan -import Pretty -import PPUtil -import Options -import Data.Monoid(mappend,mempty) -import Data.Maybe -import Debug.Trace -import System.IO -import System.Directory -import System.FilePath -import UU.Scanner.Position - -import TokenDef -import HsToken -import ErrorMessages - -import Data.Set (Set) -import qualified Data.Set as Set -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Sequence(Seq) -import qualified Data.Sequence as Seq -import Data.Foldable(toList) -} - -ATTR ExecutionPlan ENonterminals ENonterminal EProductions EProduction ERules ERule EChildren EChild - [ importBlocks : PP_Doc - textBlocks : PP_Doc - iclModuleHeader : {String -> String -> String -> Bool -> String} - dclModuleHeader : {String -> String -> String -> Bool -> String} - mainFile : String - mainName : String - constructorTypeMap : {Map NontermIdent ConstructorType} | | ] - -------------------------------------------------------------------------------- --- Options -------------------------------------------------------------------------------- -ATTR ExecutionPlan - ENonterminals ENonterminal - EProductions EProduction - ERules ERule - EChildren EChild - Expression - HsToken HsTokens HsTokensRoot - Pattern Patterns - Visits Visit - VisitSteps VisitStep [ options : {Options} | | ] -ATTR EProductions EProduction [ rename : {Bool} | | ] - -SEM ENonterminal - | ENonterminal prods.rename = rename @lhs.options - -------------------------------------------------------------------------------- --- Context info (nonterminal ident, constructor ident, nonterm params, etc.) -------------------------------------------------------------------------------- - -ATTR Visit Visits EProduction EProductions EChildren EChild ERules ERule [ nt : NontermIdent | | ] -SEM ENonterminal - | ENonterminal prods.nt = @nt - -ATTR EChildren EChild ERules ERule Visits Visit - [ con : ConstructorIdent | | ] - -SEM EProduction - | EProduction children.con = @con - rules.con = @con - visits.con = @con - -ATTR EProductions EProduction Visits Visit [ params : {[Identifier]} | | ] -SEM ENonterminal | ENonterminal - prods.params = @params - -ATTR EProductions EProduction [ classCtxs : ClassContext | | ] -SEM ENonterminal | ENonterminal - prods.classCtxs = @classCtxs - -------------------------------------------------------------------------------- --- Default output -------------------------------------------------------------------------------- -ATTR ExecutionPlan [ | | output : {PP_Doc} - output_dcl : {PP_Doc} ] - -SEM ExecutionPlan - | ExecutionPlan lhs.output = @nonts.output >-< @loc.commonExtra >-< @loc.wrappersExtra - lhs.output_dcl = @nonts.output_dcl - -ATTR ENonterminal ENonterminals [ wrappers : {Set NontermIdent} - | | output USE {>-<} {empty} : {PP_Doc} - output_dcl USE {>-<} {empty} : {PP_Doc}] - -SEM ExecutionPlan - | ExecutionPlan nonts.wrappers = @wrappers - -SEM ENonterminal - | ENonterminal lhs.output = ("// " ++ getName @nt ++ " " ++ replicate (60 - length (getName @nt)) '-') - >-< (if @loc.hasWrapper - then "// wrapper" - >-< @loc.wr_inh_icl - >-< @loc.wr_syn_icl - >-< @loc.wrapper_icl - >-< "" - else empty) - >-< (if folds @lhs.options - then "// cata" - >-< @loc.sem_nt - >-< "" - else empty) - >-< (if semfuns @lhs.options - then "// semantic domain" - >-< @loc.t_init_icl - >-< @loc.t_states_icl - >-< @loc.k_states - >-< @prods.sem_prod - >-< "" - else empty) - loc.hasWrapper = @nt `Set.member` @lhs.wrappers - - lhs.output_dcl = ("// " ++ getName @nt ++ " " ++ replicate (60 - length (getName @nt)) '-') - >-< (if dataTypes @lhs.options - then "// data" - >-< @loc.datatype - >-< "" - else empty) - >-< (if @loc.hasWrapper - then "// wrapper" - >-< @loc.wr_inh_dcl - >-< @loc.wr_syn_dcl - >-< @loc.wrapper_dcl - >-< "" - else empty) - >-< (if folds @lhs.options - then "// cata" - >-< @loc.semname >#< "::" >#< @loc.sem_tp - >-< "" - else empty) - >-< (if semfuns @lhs.options - then "// semantic domain" - >-< @loc.t_init_dcl - >-< @loc.t_states_dcl - >-< @prods.t_visits - >-< @prods.sem_prod_tys - >-< "" - else empty) - -------------------------------------------------------------------------------- --- Nonterminal datatype -------------------------------------------------------------------------------- -ATTR ENonterminal ENonterminals [ typeSyns : {TypeSyns} - derivings : {Derivings} | | ] - -SEM ExecutionPlan - | ExecutionPlan nonts.typeSyns = @typeSyns - nonts.derivings = @derivings - -SEM ENonterminal - | ENonterminal loc.classPP = ppClasses $ classCtxsToDocs @classCtxs - loc.aliasPre = "::" >#< @loc.classPP >#< @nt >#< @loc.t_params >#< ":==" - loc.datatype = case lookup @nt @lhs.typeSyns of - Nothing -> "::" >#< @loc.classPP >#< @nt >#< @loc.t_params - >-< ( if null @prods.datatype - then empty - else if isRecordConstructor @nt @lhs.constructorTypeMap - then indent 2 $ "=" >#< @prods.recordtype - else indent 2 $ vlist $ ( ("=" >#< head @prods.datatype) - : (map ("|" >#<) $ tail @prods.datatype)) - ) - >-< indent 2 @loc.derivings - Just (List t) -> @loc.aliasPre >#< "[" >#< show t >#< "]" - Just (Maybe t) -> @loc.aliasPre >#< "Data.Maybe" >#< pp_parens (show t) - Just (Tuple ts) -> @loc.aliasPre >#< pp_parens (ppCommas $ map (show . snd) ts) - Just (Either l r) -> @loc.aliasPre >#< "Data.Either" >#< pp_parens (show l) >#< pp_parens (show r) - Just (Map k v) -> @loc.aliasPre >#< "Data.Map" >#< pp_parens (show k) >#< pp_parens (show v) - Just (IntMap t) -> @loc.aliasPre >#< "Data.IntMap.IntMap" >#< pp_parens (show t) - Just (OrdSet t) -> @loc.aliasPre >#< "Data.Set.Set" >#< pp_parens (show t) - Just IntSet -> @loc.aliasPre >#< "Data.IntSet.IntSet" --- 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) - -{ -classCtxsToDocs :: ClassContext -> [PP_Doc] -classCtxsToDocs = map toDoc where - toDoc (ident,args) = (ident >#< ppSpaced (map pp_parens args)) - -classConstrsToDocs :: [Type] -> [PP_Doc] -classConstrsToDocs = map ppTp - -ppClasses :: [PP_Doc] -> PP_Doc -ppClasses [] = empty -ppClasses xs = "|" >#< pp_block "" "" "&" xs - -ppQuants :: [Identifier] -> PP_Doc -ppQuants [] = empty -ppQuants ps = "E." >#< ppSpaced ps >#< ":" -} - -ATTR EProduction [ | | datatype : {PP_Doc} - recordtype : {PP_Doc} ] -ATTR EProductions [ | | datatype USE {:} {[]} : {[PP_Doc]} - recordtype : {PP_Doc} ] - --- we generate the data type in the type-class style instead of the GADT style --- the GADT extension may be required if equality constraints are used -SEM EProduction - | EProduction lhs.datatype = @loc.quantPP1 >#< @loc.classPP1 - >#< conname @lhs.rename @lhs.nt @con - >#< ppConFields (dataRecords @lhs.options) @children.datatype - lhs.recordtype = @loc.quantPP1 >#< @loc.classPP1 - >#< ppConFields True @children.recordtype - loc.classPP1 = ppClasses (classConstrsToDocs @constraints) - loc.quantPP1 = ppQuants @params - -SEM EProductions - | Cons lhs.recordtype = @hd.recordtype - | Nil lhs.recordtype = empty - -{ --- first parameter indicates: generate a record or not -ppConFields :: Bool -> [PP_Doc] -> PP_Doc -ppConFields True flds = ppListSep "{" "}" ", " flds -ppConFields False flds = ppSpaced flds -} - - -ATTR EChild [ | | datatype : {PP_Doc} - recordtype : {PP_Doc} ] -ATTR EChildren [ | | datatype USE {:} {[]} : {[PP_Doc]} - recordtype USE {:} {[]} : {[PP_Doc]} ] - --- Note: the child may be a higher-order attribute, and its semantics may be deforested -SEM EChild - | EChild ETerm - loc.tpDoc = @loc.addStrict $ pp_parens $ ppTp $ removeDeforested @tp - loc.strNm = recordFieldname @lhs.nt @lhs.con @name - loc.field = if dataRecords @lhs.options - then @loc.strNm >#< "::" >#< @loc.tpDoc - else @loc.tpDoc - loc.recordfield = @loc.strNm >#< "::" >#< @loc.tpDoc - loc.addStrict = \x -> if strictData @lhs.options then "!" >|< x else x - | EChild lhs.datatype = case @kind of - ChildAttr -> empty -- higher order attributes are not part of the data type - _ -> @loc.field - - lhs.recordtype = case @kind of - ChildAttr -> empty -- higher order attributes are not part of the data type - _ -> @loc.recordfield - | ETerm lhs.datatype = @loc.field - lhs.recordtype = @loc.recordfield - -{ -ppTp :: Type -> PP_Doc -ppTp = text . typeToHaskellString Nothing [] -} - -------------------------------------------------------------------------------- --- 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 - - -- The sem_NT function is lazy in the AST: it depends on the application of "child" - -- rules to which extend the AST needs to be constructed. - loc.sem_tp = @loc.quantPP >#< @loc.classPP >#< @nt >#< @loc.t_params >#< "->" >#< @loc.t_type >#< @loc.t_params - loc.quantPP = ppQuants @params - - loc.sem_nt = @loc.semname >#< "::" >#< @loc.sem_tp - >-< case lookup @nt @lhs.typeSyns of - Nothing -> @prods.sem_nt - Just (List t) -> @loc.semname >#< "list" >#< "=" >#< "foldr" >#< @loc.semname >|< "_Cons" - >#< @loc.semname >|< "_Nil" - >#< case t of - NT nt _ _ -> pp_parens ("map" >#< @fsemname nt >#< "list") - _ -> pp "list" - Just (Maybe t) -> @loc.semname >#< "'Data.Maybe'.Nothing" >#< "=" >#< @loc.semname >|< "_Nothing" - >-< @loc.semname >#< pp_parens ("'Data.Maybe'.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 >#< "('Data.Either'.Left left)" >#< "=" >#< @loc.semname >|< "_Left" >#< @frecarg l "left" - >-< @loc.semname >#< "('Data.Either'.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 (OrdSet t) -> @loc.semname >#< "s" >#< "=" >#< "foldr" >#< @loc.semname >|< "_Entry" - >#< @loc.semname >|< "_Nil" - >#< pp_parens ( - ( case t of - NT nt _ _ -> pp_parens ("map" >#< @fsemname nt) - _ -> empty - ) >#< pp_parens ("'Data.IntSet'.elems" >#< "s") - ) - Just IntSet -> @loc.semname >#< "s" >#< "=" >#< "foldr" >#< @loc.semname >|< "_Entry" - >#< @loc.semname >|< "_Nil" - >#< pp_parens ("'Data.IntSet'.elems" >#< "s") --- Just x -> error $ "Type " ++ show x ++ " is not supported yet" -- TODO: other typeSyns - --- The number of productions -ATTR EProductions EProduction [ | | count USE {+} {0} : {Int} ] -SEM EProduction | EProduction lhs.count = {1} - --- The per-production cases for the sem_NT function -ATTR EProduction EProductions [ | | sem_nt USE {>-<} {empty} : {PP_Doc} ] -SEM EProduction - | EProduction lhs.sem_nt = let lhs = "sem_" >|< @lhs.nt - rhs = "=" >#< "sem_" >|< @lhs.nt >|< "_" >|< @con >#< ppSpaced @children.argnamesw - cnnm = conname @lhs.rename @lhs.nt @con - in if isRecordConstructor @lhs.nt @lhs.constructorTypeMap - then lhs >#< "{" >#< cnnm >#< "|" >#< - pp_block "" "" "," (zipWith (\l r -> l >#< "=" >#< r) @children.recfields @children.argpats) >#< "}" >#< rhs - else lhs >#< "(" >#< cnnm >#< ppSpaced @children.argpats >#< ")" >#< rhs - -{ -isRecordConstructor :: NontermIdent -> Map NontermIdent ConstructorType -> Bool -isRecordConstructor nt ctm = Map.lookup nt ctm == Just RecordConstructor -} - -ATTR EChild [ | | argnamesw : { PP_Doc } ] -ATTR EChildren [ | | argnamesw USE {:} {[]} : {[PP_Doc]} ] - -SEM EChild - | EChild lhs.argnamesw = case @kind of - ChildSyntax -> "(" >#< "sem_" >|< @loc.nt >#< @name >|< "_" >#< ")" - ChildAttr -> empty -- no sem-case for a higher-order child - ChildReplace tp -> "(" >#< "sem_" >|< extractNonterminal tp >#< @name >|< "_" >#< ")" - | ETerm lhs.argnamesw = text $ fieldname @name - -------------------------------------------------------------------------------- --- Types of attributes -------------------------------------------------------------------------------- -ATTR ExecutionPlan - ENonterminals - ENonterminal [ inhmap : {Map NontermIdent Attributes} - synmap : {Map NontermIdent Attributes} | | ] - -ATTR EProductions EProduction - ERules ERule - Patterns Pattern - Visits - Visit [ inhmap : {Attributes} - synmap : {Attributes} - allInhmap : {Map NontermIdent Attributes} - allSynmap : {Map NontermIdent Attributes} | | ] - -SEM ENonterminal - | ENonterminal (Just prods.inhmap) = Map.lookup @nt @lhs.inhmap - (Just prods.synmap) = Map.lookup @nt @lhs.synmap - prods.allInhmap = @lhs.inhmap - prods.allSynmap = @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.stvisits = \st -> filter (\(v,f,t) -> f == st) @prods.allvisits - loc.t_type = "T_" >|< @nt - loc.lt_type = "t_" >|< @nt - loc.t_params = ppSpaced @params - loc.t_init_icl = @loc.t_init_dcl >-< - "attach_" >|< @loc.t_type >#< pp_parens (@loc.t_type >#< @loc.lt_type) >#< "=" >#< @loc.lt_type - loc.t_init_dcl = "::" >#< @loc.t_type >#< @loc.t_params >#< "=" >#< @loc.t_type - >#< - pp_parens ( - ppMonadType @lhs.options >#< pp_parens (@loc.t_type >|< "_s" >|< @initial >#< @loc.t_params)) - loc.t_states_icl = vlist $ map (\st -> - let nt_st = @nt >|< "_s" >|< st - c_st = "C_" >|< nt_st - inv_st = "inv_" >|< nt_st - nextVisit = Map.findWithDefault ManyVis st @nextVisits - in case nextVisit of - NoneVis -> empty -- empty semantics - OneVis vId -> inv_st >#< pp_parens (c_st >#< "x") >#< "=" >#< "x" - ManyVis -> empty - ) $ Set.toList @loc.allstates - loc.t_states_dcl = 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 - nextVisit = Map.findWithDefault ManyVis st @nextVisits - in case nextVisit of - NoneVis -> "::" >#< t_st >#< @loc.t_params >#< "=" >#< c_st -- empty semantics - OneVis vId -> "::" >#< t_st >#< @loc.t_params >#< "=" >#< c_st >#< (pp_parens (conNmTVisit @nt vId >#< @loc.t_params)) - ManyVis -> "::" >#< t_st >#< @loc.t_params >#< "where" >#< c_st >#< "::" -- TODO : Cleanify - >#< (pp_braces $ inv_st >#< "::" >#< "!" >|< pp_parens ("E.t:" >#< k_st >#< @loc.t_params >#< "t" >#< "->" >#< "t")) - >#< "->" >#< t_st >#< @loc.t_params -- this is a conventional data type, but declared with GADT syntax - ) $ 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_params >#< pp_parens (@loc.t_type >|< "_v" >|< v >#< @loc.t_params) - ) outg - nextVisit = Map.findWithDefault ManyVis st @nextVisits - decl = "::" >#< k_st >#< "k" >#< @loc.t_params >#< "where" >-< indent 3 visitlist - in case nextVisit of - NoneVis -> empty - OneVis _ -> empty - ManyVis -> decl - ) $ Set.toList @loc.allstates - --- type of a visit v, with continuation as new state s -ATTR Visit Visits EProduction EProductions [ | | t_visits USE {>-<} {empty} : {PP_Doc} ] - -SEM EProductions - | Cons lhs.t_visits = @hd.t_visits -- just pick the first production - -SEM Visit - | Visit loc.nameT_visit = conNmTVisit @lhs.nt @ident - loc.nameTIn_visit = conNmTVisitIn @lhs.nt @ident - loc.nameTOut_visit = conNmTVisitOut @lhs.nt @ident - loc.nameTNext_visit = conNmTNextVisit @lhs.nt @to - - loc.nextVisitInfo = Map.findWithDefault ManyVis @to @lhs.nextVisits -- which visits can we do after we reach the @to state? - loc.typecon = case @kind of - VisitPure _ -> empty - VisitMonadic -> ppMonadType @lhs.options - - loc.t_params = ppSpaced @lhs.params - lhs.t_visits = "::" >#< @loc.nameT_visit >#< @loc.t_params >#< ":==" >#< - pp_parens (@loc.nameTIn_visit >#< @loc.t_params) - >#< ( if dummyTokenVisit @lhs.options - then "->" >#< dummyType @lhs.options True -- Additional (unused though) argument - else empty - ) - >#< "->" >#< @loc.typecon >#< pp_parens (@loc.nameTOut_visit >#< @loc.t_params) - >-< "::" >#< @loc.nameTIn_visit >#< @loc.t_params >#< "=" >#< @loc.nameTIn_visit >#< - @loc.inhpart - >-< "::" >#< @loc.nameTOut_visit >#< @loc.t_params >#< "=" >#< @loc.nameTOut_visit >#< - @loc.synpart >#< case @loc.nextVisitInfo of - NoneVis -> empty -- don't return a continuation at all - _ -> @loc.addbang1 $ pp_parens (@loc.nameTNext_visit >#< @loc.t_params) -- normal route: select the next semantics - - loc.inhpart = @loc.ppTypeList @inh @lhs.inhmap - loc.synpart = @loc.ppTypeList @syn @lhs.synmap - loc.ppTypeList = \s m -> ppSpaced $ map (\i -> @loc.addbang1 $ pp_parens $ case Map.lookup i m of - Just tp -> ppTp tp ) $ Set.toList s - -{ -conNmTVisit nt vId = "T_" >|< nt >|< "_v" >|< vId -conNmTVisitIn nt vId = "T_" >|< nt >|< "_vIn" >|< vId -conNmTVisitOut nt vId = "T_" >|< nt >|< "_vOut" >|< vId -conNmTNextVisit nt stId = "T_" >|< nt >|< "_s" >|< stId - -ppMonadType :: Options -> PP_Doc -ppMonadType opts - | parallelInvoke opts = text "IO" - | otherwise = text "Identity" -} - -------------------------------------------------------------------------------- --- Inh and Syn wrappers -------------------------------------------------------------------------------- -SEM ENonterminal - | ENonterminal loc.wr_inh_icl = @loc.genwrap_icl "Inh" @loc.wr_inhs - loc.wr_syn_icl = @loc.genwrap_icl "Syn" @loc.wr_syns - loc.genwrap_icl = \nm attr -> - let tyConName = nm >|< "_" >|< @nt - in (let (d, _, _) = foldr (\(i, t) (d, c, n) -> (d >-< - i >|< "_" >|< tyConName >#< "::" >#< tyConName >#< "->" >#< (@loc.addbang $ pp_parens $ typeToHaskellString (Just @nt) [] t) - >-< i >|< "_" >|< tyConName >#< pp_parens (tyConName >#< unwords (replicate (n - c - 1) "_" ++ ["x"] ++ replicate c "_")) >#< "= x" - , c + 1, n) - ) (empty, 0, length attr) attr - in d) - loc.wr_inh_dcl = @loc.genwrap_dcl "Inh" @loc.wr_inhs - loc.wr_syn_dcl = @loc.genwrap_dcl "Syn" @loc.wr_syns - loc.genwrap_dcl = \nm attr -> - let tyConName = nm >|< "_" >|< @nt - in "::" >#< tyConName >#< @loc.t_params >#< "=" >#< tyConName -- >#< "{" - >#< (ppSpaced $ map (\(_,t) -> @loc.addbang $ pp_parens $ typeToHaskellString (Just @nt) [] t) attr) -- >#< "}" - >-< - (let (d, _, _) = foldr (\(i, t) (d, c, n) -> (d >-< - i >|< "_" >|< tyConName >#< "::" >#< tyConName >#< "->" >#< (@loc.addbang $ pp_parens $ typeToHaskellString (Just @nt) [] t) - , c + 1, n) - ) (empty, 0, length attr) attr - in d) - loc.synAttrs = fromJust $ Map.lookup @nt @lhs.inhmap - loc.wr_inhs = Map.toList $ @loc.wr_filter $ @loc.synAttrs - loc.wr_inhs1 = Map.toList @loc.synAttrs - loc.wr_filter = if lateHigherOrderBinding @lhs.options - then Map.delete idLateBindingAttr - else id - loc.wr_syns = Map.toList $ fromJust $ Map.lookup @nt @lhs.synmap - loc.inhlist = map (lhsname @lhs.options True . fst) @loc.wr_inhs - loc.inhlist1 = map (lhsname @lhs.options True . fst) @loc.wr_inhs1 - loc.synlist = map (lhsname @lhs.options False . fst) @loc.wr_syns - loc.wrapname = "wrap_" ++ show @nt - loc.inhname = "Inh_" ++ show @nt - loc.synname = "Syn_" ++ show @nt - loc.firstVisitInfo = Map.findWithDefault ManyVis @initial @nextVisits - loc.wrapper_icl = (@loc.wrapname >#< "::" >#< @loc.quantPP >#< @loc.classPP >#< @loc.t_type >#< @loc.t_params -- TODO : Remove ? >#< "->" - >#< @loc.inhname >#< @loc.t_params >#< "->" >#< ( if monadicWrappers @lhs.options then ppMonadType @lhs.options else empty) >#< pp_parens (@loc.synname >#< @loc.t_params)) - >-< (@loc.wrapname >#< (@loc.addbang $ pp_parens (@loc.t_type >#< pp "act")) - >#< (@loc.addbang $ pp_parens (@loc.inhname - >#< (ppSpaced $ map (@loc.addbangWrap . pp) @loc.inhlist)) >#< "=")) - >-< - indent 3 (case @initialv of - -- case where there are no inherited or synthesized attributes - [] -> text @loc.synname -- TODO : Remove? >#< " { }" - (initv:_) -> -- TODO: take care of multiple visits - let inCon = conNmTVisitIn @nt initv - outCon = conNmTVisitOut @nt initv - pat = @loc.addbang $ pp_parens $ pat0 - pat0 = outCon >#< ppSpaced @loc.synlist -- should be an "end" state, thus no continuation expected here - arg = inCon >#< ppSpaced @loc.inhlist1 - ind = case @loc.firstVisitInfo of - NoneVis -> error "wrapper: initial state should have a next visit but it has none" - OneVis _ -> empty - ManyVis -> @loc.k_type >|< "_v" >|< initv - extra = if dummyTokenVisit @lhs.options - then pp $ dummyArg @lhs.options True - else empty - convert = case Map.lookup initv @lhs.allVisitKinds of - Just kind -> case kind of - VisitPure _ -> text "lift" - VisitMonadic -> empty - _ -> empty - unMonad | monadicWrappers @lhs.options = empty - | otherwise = unMon @lhs.options - in unMonad >#< "(" - >-< indent 2 - ("act >>= \\" >#< @loc.addbang (pp "sem") >#< "->" -- run the per-node monadic code to get the initial state (of the root) - >-< "lift" >#< pp_parens arg >#< ">>= \\" >#< @loc.addbangWrap (pp "arg") >#< "->" - >-< convert >#< pp_parens ("inv_" >|< @nt >|< "_s" >|< @initial >#< "sem" >#< ind >#< "arg" >#< extra) >#< ">>= \\" >#< pat >#< "->" -- invoke initial state (of the root) - >-< "lift" >#< pp_parens (@loc.synname >#< ppSpaced @loc.synlist) - ) - >-< ")" ) - >-< if lateHigherOrderBinding @lhs.options - then indent 2 ("where" >#< lhsname @lhs.options True idLateBindingAttr >#< "=" >#< lateBindingFieldNm @lhs.mainName) - else empty - loc.wrapper_dcl = (@loc.wrapname >#< "::" >#< @loc.quantPP >#< @loc.classPP >#< @loc.t_type >#< @loc.t_params -- TODO : Remove ? >#< "->" - >#< @loc.inhname >#< @loc.t_params >#< "->" >#< ( if monadicWrappers @lhs.options then ppMonadType @lhs.options else empty) >#< pp_parens (@loc.synname >#< @loc.t_params)) - -------------------------------------------------------------------------------- --- Collection of NT / Production sem funs references -------------------------------------------------------------------------------- - -ATTR ENonterminals ENonterminal EProductions EProduction [ | | semFunBndDefs, semFunBndTps USE {Seq.><} {Seq.empty} : {Seq PP_Doc} ] -SEM ENonterminal | ENonterminal - lhs.semFunBndDefs = @loc.semFunBndDef Seq.<| @prods.semFunBndDefs - lhs.semFunBndTps = @loc.semFunBndTp Seq.<| @prods.semFunBndTps - loc.semFunBndDef = @loc.semFunBndNm >#< "=" >#< @loc.semname - loc.semFunBndTp = @loc.semFunBndNm >#< "::" >#< @loc.sem_tp - loc.semFunBndNm = lateSemNtLabel @nt - -SEM EProduction | EProduction - lhs.semFunBndDefs = Seq.singleton @loc.semFunBndDef - lhs.semFunBndTps = Seq.singleton @loc.semFunBndTp - loc.semFunBndDef = @loc.semFunBndNm >#< "=" >#< @loc.semname - loc.semFunBndTp = @loc.semFunBndNm >#< "::" >#< @loc.sem_tp - loc.semFunBndNm = lateSemConLabel @lhs.nt @con - --- Generate a dictionary that contains the semantics of all semantic functions -SEM ExecutionPlan | ExecutionPlan - loc.wrappersExtra = if lateHigherOrderBinding @lhs.options - then @loc.lateSemBndDef - else empty - loc.commonExtra = if lateHigherOrderBinding @lhs.options - then @loc.lateSemBndTp - else empty - loc.lateSemBndTp = "::" >#< lateBindingTypeNm @lhs.mainName >#< "=" >#< lateBindingTypeNm @lhs.mainName - >-< (indent 2 $ pp_block "{" "}" "," $ toList @nonts.semFunBndTps) - loc.lateSemBndDef = lateBindingFieldNm @lhs.mainName >#< "::" >#< lateBindingTypeNm @lhs.mainName - >-< lateBindingFieldNm @lhs.mainName >#< "=" >#< lateBindingTypeNm @lhs.mainName - >-< (indent 2 $ pp_block "{" "}" "," $ toList @nonts.semFunBndDefs ) - -------------------------------------------------------------------------------- --- Production semantic functions -------------------------------------------------------------------------------- -ATTR EProduction [ | | sem_prod : {PP_Doc} - sem_prod_tys : {PP_Doc} ] -ATTR EProductions [ | | sem_prod USE {>-<} {empty} : {PP_Doc} - sem_prod_tys USE {>-<} {empty} : {PP_Doc} ] - -ATTR EProduction EProductions [ initial : {StateIdentifier} - allstates : {Set StateIdentifier} | | ] -SEM ENonterminal - | ENonterminal prods.initial = @initial - prods.allstates = @loc.allstates - -ATTR EChild [ | | argtps : { PP_Doc } - argpats : { PP_Doc } - recfields USE {++} {[]} : { [Identifier] }] -ATTR EChildren [ | | argtps USE {:} {[]} : { [PP_Doc] } - argpats USE {:} {[]} : { [PP_Doc] } - recfields USE {++} {[]} : { [Identifier] }] - -SEM EChild - | EChild lhs.argtps = case @kind of - ChildSyntax -> pp_parens $ ppDefor @tp -- TODO Remove? >#< "->" - ChildReplace tp -> pp_parens $ ppDefor tp -- TODO Remove? >#< "->" - _ -> empty -- higher order attribute - loc.argpats = case @kind of - ChildSyntax -> @name >|< "_" -- no strictification of children semantics to allow infinite trees - ChildReplace _ -> @name >|< "_" - _ -> empty - - lhs.recfields = case @kind of - ChildSyntax -> [@name] -- no strictification of children semantics to allow infinite trees - ChildReplace _ -> [@name] - _ -> [] - - -- | ETerm lhs.argtps = (pp_parens $ show @tp) >#< "572->" -- TODO Remove? - | ETerm lhs.argtps = pp_parens $ show @tp - loc.argpats = @loc.addbang $ text $ fieldname @name -- terminals may be strict (perhaps this should become an option) - lhs.recfields = [@name] - -{ -ppDefor :: Type -> PP_Doc -ppDefor (NT nt args _) = "T_" >|< nt >#< ppSpaced (map pp_parens args) -ppDefor (Haskell s) = text s -} - -SEM EProduction - | EProduction loc.t_type = "T_" >|< @lhs.nt - loc.t_params = ppSpaced @lhs.params - loc.usedArgs = @children.usedArgs `Set.union` @visits.usedArgs `Set.union` @rules.usedArgs - -- A bit ugly, but this code renames arguments and puts an underscore when the argument - -- is never used. This avoids compiler warnings of unused variables. - loc.args = map (\x -> let (name,arg) = case show x of - "" -> ("", empty) - '!':name -> ("arg_" ++ name, "!arg_" >|< name) - name -> ("arg_" ++ name, "arg_" >|< name) - in if null name || name `Set.member` @loc.usedArgs - then arg - else text "_") @children.argpats - loc.semname = "sem_" ++ show @lhs.nt ++ "_" ++ show @con - loc.sem_tp = @loc.quantPP2 >#< @loc.classPP2 >#< ppSpaced @children.argtps - >#< (if length @children.argtps > 0 then "->" else "") - >#< @loc.t_type >#< @loc.t_params -- TODO Keep -> here? - loc.classPP2 = ppClasses (classCtxsToDocs @lhs.classCtxs ++ classConstrsToDocs @constraints) - loc.quantPP2 = ppQuants (@lhs.params ++ @params) - - lhs.sem_prod_tys = @loc.semname >#< " ::" >#< @loc.sem_tp - - loc.sem_prod = @loc.semname >#< " ::" >#< @loc.sem_tp - >-< @loc.mkSemBody (@loc.semname >#< ppSpaced @loc.args >#< "=" >#< @loc.t_type) - @loc.mbInitializer @loc.outerlet ("lift" >#< "st" >|< @lhs.initial) - loc.mkSemBody = \prefix mbInit outerlet ret -> - case mbInit of - Nothing -> prefix >#< pp_parens ret >#< "where" - >-< indent 3 outerlet -- code for states and visits - Just m -> prefix >#< "(" >#< "do" -- TODO: desugar - >-< indent 1 ( - m - >-< "let" - >-< indent 2 outerlet -- code for the states and visits - >-< ret ) - >-< indent 1 ")" - - loc.mbInitializer = --some monadic actions, performed upon attaching a child, can - -- be specified here. The resulting bindings of these actions are - -- in scope of the rules of the production - if parallelInvoke @lhs.options - then (Nothing :: Maybe PP_Doc) -- perhaps do some per-node registation, etc. For now: nothing - else Nothing -- nothing special here - loc.outerlet = vlist @loc.statefns >-< @rules.sem_rules - loc.statefns = map @loc.genstfn $ Set.toList @lhs.allstates - loc.genstfn = \st -> let nextVisitInfo = Map.findWithDefault ManyVis st @lhs.nextVisits - prevVisitInfo = Map.findWithDefault ManyVis st @lhs.prevVisits - stNm = "st" >|< st - lhs = bang stNm >#< "=" >#< - ( -- generating a lambda for the same reasons as generating - -- a lambda for rules: to ensure that overloading is - -- resolved for all visit functions and rules together. - if st == @lhs.initial - then empty - else "\\" >#< @loc.stargs st >#< "->" - ) - - cCon = "C_" >|< @lhs.nt >|< "_s" >|< st - bang | st == @lhs.initial = @loc.addbang -- initial state is not parameterized - | otherwise = id - - -- note about the initial state: the initial state should be the only - -- state-binding that is not a function. It is non-recursive and not needed - -- anywhere except delivered as initial result. This binding therefore does - -- not end up needlessly in any closure. - in case nextVisitInfo of - NoneVis -> -- the (empty) closure of a (non-initial) end state is not referenced - -- thus generating it is not needed (and omitting it may catch some small mistakes). - if st == @lhs.initial - then lhs >#< cCon -- empty state - else empty -- no state generated - OneVis vId -> mklet lhs (@loc.stvs st False) (cCon >#< "v" >|< vId) - ManyVis -> mklet lhs (@loc.stks st >-< @loc.stvs st True) (cCon >#< "k" >|< st) - loc.stargs = \st -> let attrs = maybe Map.empty id $ Map.lookup st @visits.intramap - in ppSpaced [ let match | str `Set.member` @loc.lazyIntras = pp str - | otherwise = @loc.addbang (pp str) - in case mbAttr of - Just (AttrSyn child nm) | child == _LOC && not (noPerStateTypeSigs @lhs.options) -> - case Map.lookup nm @loc.localAttrTypes of - Just tp -> pp_parens (pp_parens match >#< "::" >#< ppTp tp) - Nothing -> match - Just attr | not (noPerStateTypeSigs @lhs.options) -> - case lookupAttrType attr @lhs.allInhmap @lhs.allSynmap @loc.childTypes of - Just tpDoc -> pp_parens (pp_parens match >#< "::" >#< tpDoc) - Nothing -> match - _ -> match - | (str,mbAttr) <- Map.assocs attrs - ] >#< dummyPat @lhs.options (Map.null attrs) - - loc.stks = \st -> if null (@loc.stvisits st) - then empty - else "k" >|< st >#< "::" >#< "K_" >|< @lhs.nt >|< "_s" >|< st >#< @loc.t_params >#< "t" >#< "->" >#< "t" - >-< vlist (map (\(v,f,t) -> "k" >|< st >#< "K_" >|< @lhs.nt >|< "_v" >|< v >#< "=" - >#< "v" >|< v) $ @loc.stvisits st) - loc.stvisits = \st -> filter (\(v,f,t) -> f == st) @visits.allvisits - loc.stvs = \st inlinePragma -> vlist [ppf inlinePragma | (f,ppf) <- @visits.sem_visit, f == st] - visits.mrules = @rules.mrules - -{ -mklet :: (PP a, PP b, PP c) => a -> b -> c -> PP_Doc -mklet prefix defs body = - prefix - >-< indent (length (show prefix)) - ("let" - >-< indent 4 defs - >-< "in" >#< body) -} - -------------------------------------------------------------------------------- --- Visit semantic functions -------------------------------------------------------------------------------- -ATTR Visit [ | | sem_visit : { (StateIdentifier,Bool -> PP_Doc) } ] -ATTR Visits [ | | sem_visit USE {:} {[]} : { [(StateIdentifier,Bool -> PP_Doc)] } ] - -SEM Visit - | Visit lhs.sem_visit = ( @from - , \_ -> - -- TODO: Generate type signature "v" >|< @ident >#< "::" >#< @loc.nameTIn_visit >#< "->" >#< @loc.nameT_visit >#< @loc.t_params >-< - - -- Haskell: generate a lambda here as well instead of a function definition - -- >-< "v" >|< @ident >#< "=" >#< "\\" >#< (@loc.addbang $ pp_parens (@loc.nameTIn_visit >#< @loc.inhpats)) - -- Clean: generate a function - "v" >|< @ident >#< (@loc.addbang $ pp_parens (@loc.nameTIn_visit >#< @loc.inhpats)) >#< "=" - >#< ( if dummyTokenVisit @lhs.options - then pp $ dummyPat @lhs.options True -- extra (but unused) argument - else empty - ) - -- >#< "->" - -- >#< "(" - >-< indent 10 (@loc.stepsInitial - >-< indent 4 @steps.sem_steps) >-< indent 10 @loc.stepsClosing - -- >#< ")" - ) - loc.stepsInitial = case @kind of - VisitPure False -> text "let" - VisitPure True -> empty - VisitMonadic -> text "do" - loc.stepsClosing = let decls = @loc.nextStBuild - >-< @loc.addbang (pp resultValName) >#< "=" >#< @loc.resultval - in case @kind of - VisitPure False -> indent 4 decls - >-< "in" >#< resultValName - VisitPure True -> "let" >#< decls - >-< indent 1 ("in" >#< resultValName) - VisitMonadic -> "let" >#< decls - >-< "lift" >#< resultValName - loc.vname = "v" >|< @ident - loc.inhpats = ppSpaced $ map (\arg -> pp $ attrname @lhs.options True _LHS arg) $ Set.toList @inh - loc.inhargs = \chn -> ppSpaced $ map (attrname @lhs.options False chn) $ Set.toList @inh - loc.synargs = ppSpaced $ map (\arg -> attrname @lhs.options False _LHS arg) $ Set.toList @syn - loc.nextargsMp = maybe Map.empty id $ Map.lookup @to @lhs.allintramap - loc.nextargs = ppSpaced $ Map.keys $ @loc.nextargsMp - loc.nextst = "st" >|< @to >#< @loc.nextargs >#< dummyArg @lhs.options (Map.null @loc.nextargsMp) - loc.resultval = @loc.nameTOut_visit >#< @loc.synargs >#< @loc.nextStRef - (loc.nextStBuild, loc.nextStRef) - = case @loc.nextVisitInfo of - NoneVis -> (empty, empty) - _ -> (@loc.addbang (pp nextStName) >#< "=" >#< @loc.nextst, pp nextStName) - -{ -resultValName :: String -resultValName = "ag__result_" - -nextStName :: String -nextStName = "ag__st_" -} - --- Propagate the visit kind to the steps -ATTR VisitStep VisitSteps [ kind : VisitKind | | ] -SEM Visit | Visit steps.kind = @kind - --- the steps in this group should be executed in a pure fashion -SEM VisitStep | PureGroup - steps.kind = VisitPure @ordered - -ATTR Visits Visit VisitStep VisitSteps [ mrules : {Map Identifier (VisitKind -> FormatMode -> Either Error PP_Doc)} | | ] -ATTR VisitStep VisitSteps [ | | sem_steps USE {>-<} {empty} : {PP_Doc} ] -SEM VisitStep - | Sem loc.ruleItf = Map.findWithDefault (error $ "Rule " ++ show @name ++ " not found") @name @lhs.mrules - (lhs.errors, loc.sem_steps) = case @loc.ruleItf @lhs.kind @lhs.fmtMode of - Left e -> (Seq.singleton e, empty) - Right stmt -> (Seq.empty, stmt) - | ChildIntro loc.attachItf = Map.findWithDefault (error $ "Child " ++ show @child ++ " not found") @child @lhs.childintros - (lhs.errors,lhs.sem_steps,lhs.defs,lhs.uses) - = case @loc.attachItf @lhs.kind @lhs.fmtMode of - Left e -> (Seq.singleton e, empty, Set.empty, Map.empty) - Right (code, defs, uses) -> (Seq.empty, code, defs, uses) - | ChildVisit loc.visitItf = Map.findWithDefault (error $ "Visit " ++ show @visit ++ " not found") @visit @lhs.allchildvisit - (lhs.errors, loc.patPP, loc.exprPP) = case @loc.visitItf @child @lhs.kind of - Left e -> (Seq.singleton e, empty, empty) - Right (pat,expr) -> (Seq.empty, pat, expr) - - lhs.sem_steps = let decl = case @lhs.kind of - VisitPure _ -> @loc.patPP >#< "=" >#< @loc.exprPP - VisitMonadic -> @loc.exprPP >#< ">>= \\" >#< @loc.patPP >#< "->" - in fmtDecl False @lhs.fmtMode decl - loc.convToMonad = case @loc.callKind of - VisitPure _ -> text "lift" - VisitMonadic -> empty - loc.callKind = Map.findWithDefault (error "visit kind should be in the map") @visit @lhs.allVisitKinds - | Sim lhs.sem_steps = @steps.sem_steps - | PureGroup lhs.sem_steps = case @lhs.fmtMode of - FormatDo -> "let" >#< @steps.sem_steps -- formatted as a let-block (not a line-let) - _ -> @steps.sem_steps - --- The fmtMode indicates in what kind of expression (do/let/line-lets) we are printing --- declarations, because that determines how we need to wrap declarations --- Invariant: @lhs.kind == VisitMonadic ---> @lhs.fmtMode == FormatDo -ATTR VisitSteps VisitStep [ fmtMode : FormatMode | | ] -SEM Visit | Visit - steps.fmtMode = case @kind of - VisitPure False -> FormatLetDecl - VisitPure True -> FormatLetLine - VisitMonadic -> FormatDo - -SEM VisitStep | PureGroup - steps.fmtMode = case @lhs.fmtMode of - FormatDo -> FormatLetDecl - mode -> mode - -{ -parResultName :: String -parResultName = "__outcome_" - -fmtDecl :: PP a => Bool -> FormatMode -> a -> PP_Doc -fmtDecl declPure fmt decl = case fmt of - FormatLetDecl -> pp decl - FormatLetLine -> "let" >#< decl >#< "in" - FormatDo | declPure -> "let" >#< decl >#< "in" - | otherwise -> pp decl -} - --- --- Some properties of VisitStep(s) --- - --- Used arguments -ATTR VisitSteps VisitStep Visit Visits EChild EChildren ERule ERules [ | | usedArgs USE {`Set.union`} {Set.empty} : {Set String} ] -SEM ERule - | ERule +usedArgs = Set.union $ Map.keysSet $ Map.mapKeys (\a -> "arg_" ++ a) $ Map.filter isNothing @rhs.attrs - -SEM EChild - | EChild +usedArgs = \s -> case @kind of - ChildSyntax -> Set.insert ("arg_" ++ show @name ++ "_") s - _ -> s - - --- Number of steps in a 'Sim' block -ATTR VisitSteps [ | | size : Int ] -SEM VisitSteps - | Nil lhs.size = 0 - | Cons lhs.size = 1 + @tl.size - --- Number the steps in a 'Sim' block -ATTR VisitSteps VisitStep [ | index : Int | ] -SEM VisitSteps | Cons - hd.index = @lhs.index -- copy rule - tl.index = 1 + @lhs.index - lhs.index = @tl.index -- copy rule -SEM Visit | Visit steps.index = 0 -SEM VisitStep | Sim steps.index = 0 - lhs.index = @lhs.index -- needed for if we ever allow nested Sims - --- Is this the last step? -ATTR VisitSteps VisitStep [ | | isLast : Bool ] -ATTR VisitStep [ isLast : Bool | | ] -SEM VisitSteps - | Nil lhs.isLast = True - | Cons lhs.isLast = False - hd.isLast = @tl.isLast - -SEM VisitStep | Sim - loc.isMonadic = case @lhs.kind of - VisitMonadic -> True - _ -> False - - --- Child introduction -ATTR EChild EChildren [ | | childintros USE {`Map.union`} {Map.empty} : {Map Identifier (VisitKind -> FormatMode -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))} ] - -ATTR Visits Visit - VisitSteps VisitStep [ childintros : {Map Identifier (VisitKind -> FormatMode -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))} | | ] - -SEM EProduction - | EProduction visits.childintros = @children.childintros - -SEM EChild - | ETerm lhs.childintros = Map.singleton @name (\_ _ -> Right (empty, Set.empty, Map.empty)) - | EChild lhs.childintros = Map.singleton @name @loc.introcode - loc.isDefor = case @tp of - NT _ _ defor -> defor - _ -> False - loc.valcode = case @kind of - ChildSyntax -> "arg_" >|< @name >|< "_" - ChildAttr -> -- decide if we need to invoke the sem-function under the hood - let prefix | not @loc.isDefor = if lateHigherOrderBinding @lhs.options -- && sepsemmods @lhs.options -- when sepsemmods is not enabled, the indirection can be optimized away - then lateSemNtLabel @loc.nt >#< lhsname @lhs.options True idLateBindingAttr - else "sem_" >|< @loc.nt - | otherwise = empty -- no need to intro a terminal - in pp_parens (prefix >#< instname @name) - ChildReplace _ -> -- the higher-order attribute is actually a function that transforms - -- the semantics of the child (always deforested) - pp_parens (instname @name >#< @name >|< "_") - loc.aroundcode = if @hasAround - then locname @lhs.options @name >|< "_around" - else empty - loc.introcode = \kind fmtMode -> - let pat = text $ stname @name @loc.initSt - patStrict = @loc.addbang pat - attach = "attach_T_" >|< @loc.nt >#< pp_parens (@loc.aroundcode >#< @loc.valcode) - runAttach = unMon @lhs.options >#< pp_parens attach - decl = case kind of - VisitPure False -> pat >#< "=" >#< runAttach - VisitPure True -> patStrict >#< "=" >#< runAttach - VisitMonadic -> attach >#< ">>= \\" >#< patStrict >#< "->" - in if compatibleAttach kind @loc.nt @lhs.options - then Right ( fmtDecl False fmtMode decl - , Set.singleton (stname @name @loc.initSt) -- variables defined by the child intro - , case @kind of -- variables used by the child introduction - ChildAttr -> Map.insert (instname @name) Nothing $ -- the sem attr - ( if @loc.isDefor || not (lateHigherOrderBinding @lhs.options) - then id -- the sem dictionary attr is not used - else Map.insert (lhsname @lhs.options True idLateBindingAttr) (Just $ AttrInh _LHS idLateBindingAttr) - ) $ - ( if @hasAround - then Map.insert (locname @lhs.options (@name) ++ "_around") Nothing - else id - ) $ Map.empty - ChildReplace _ -> Map.singleton (instname @name) Nothing -- uses the transformation function - ChildSyntax -> Map.empty - ) - else Left $ IncompatibleAttachKind @name kind - loc.nt = extractNonterminal @tp - -{ -stname :: Identifier -> Int -> String -stname child st = "st_" ++ getName child ++ "X" ++ show st - --- should actually return some conversion info -compatibleAttach :: VisitKind -> NontermIdent -> Options -> Bool -compatibleAttach _ _ _ = True - -unMon :: Options -> PP_Doc -unMon options - | parallelInvoke options = text "'System.IO.Unsafe'.unsafePerformIO" -- IO monad - | otherwise = text "'Control.Monad.Identity'.runIdentity" -- identity monad -} - --- rules -ATTR ERules ERule [ | | sem_rules USE {>-<} {empty} : {PP_Doc} - mrules USE {`Map.union`} {Map.empty} : {Map Identifier (VisitKind -> FormatMode -> Either Error PP_Doc)} ] - -SEM ERule | ERule - lhs.sem_rules = if @loc.used == 0 - then empty - else @loc.rulecode - loc.rulecode = ( if @loc.genpragma - then @loc.pragma -- this additional pragma *may* help to give some AG source location in the presence of - -- type errors in the rule. It will definitely not be precise, and may take some additional - -- source space, but let's see if it's worth it in practice. - else empty - ) - >-< @loc.lambda - >-< indent ((column @rhs.pos - 2) `max` 2) - ( if @loc.genpragma - then @loc.pragma >-< @rhs.semfunc >-< @loc.endpragma - else @rhs.semfunc - ) - loc.pragma = "/*# LINE" >#< show (line @rhs.pos) >#< show (file @rhs.pos) >#< "#*/" - loc.endpragma = ppWithLineNr (\ln -> "/*# LINE " ++ show (ln+1) ++ " " ++ show @lhs.mainFile ++ "#*/") - loc.genpragma = genLinePragmas @lhs.options && @explicit && @loc.haspos - loc.haspos = line @rhs.pos > 0 && column @rhs.pos >= 0 && not (null (file @rhs.pos)) - - -- This comment describes the Haskell rationale for lambdas - -- we generate a simple pattern binding because of overloading-resolving during the type inference process. - -- The types of the rules are not generalized (nor do we want that - rules are used in a single typing-context). - -- If overloading is resolved separately, it may not be clear which dictionaries to use. For that all rules have - -- to be considered together, which is done when we use simple pattern bindings with a lambda expression instead - -- of a function definition. - -- Note: we also ensure that all rules are lambda expressions, so that they are not made part of any closures - -- but are lambda-lifted instead. - -- loc.lambda = @name >#< "=" >#< "\\" >#< @loc.argPats >#< dummyPat @lhs.options (Map.null @rhs.attrs) >#< "->" - - -- For Clean, we do not want to generate lambdas, but functions instead - loc.lambda = @name >#< @loc.argPats >#< dummyPat @lhs.options (Map.null @rhs.attrs) >#< "=" - - loc.argPats = ppSpaced [ let match | str `Set.member` @lhs.lazyIntras = pp str - | otherwise = @loc.addbang1 (pp str) - in case mbAttr of - Just (AttrSyn child nm) | child == _LOC && not (noPerStateTypeSigs @lhs.options) -> - case Map.lookup nm @lhs.localAttrTypes of - Just tp -> pp_parens (pp_parens match) -- TODO Remove? >#< "::" >#< ppTp tp) - Nothing -> match - Just attr | not (noPerRuleTypeSigs @lhs.options) -> - case lookupAttrType attr @lhs.allInhmap @lhs.allSynmap @lhs.childTypes of - Just tpDoc -> pp_parens (pp_parens match) -- TODO Remove? >#< "::" >#< tpDoc) - Nothing -> match - _ -> match - | (str,mbAttr) <- Map.assocs @rhs.attrs - ] - loc.argExprs = ppSpaced [ case mbAttr of - Nothing -> "arg_" >|< str - _ -> text str - | (str,mbAttr) <- Map.assocs @rhs.attrs - ] - loc.stepcode = \kind fmtMode -> if kind `compatibleRule` @pure - then Right $ let oper | @pure = "=" - | otherwise = "<-" -- TODO Desugar - decl = @pattern.sem_lhs >#< oper >#< @name >#< @loc.argExprs >#< dummyArg @lhs.options (Map.null @rhs.attrs) - tp = if @pure && not (noPerRuleTypeSigs @lhs.options) - then @pattern.attrTypes - else empty - in fmtDecl @pure fmtMode (tp >-< decl) - else Left $ IncompatibleRuleKind @name kind - - lhs.mrules = Map.singleton @name @loc.stepcode - -ATTR Expression [ | | tks : {[HsToken]} ] -SEM Expression - | Expression lhs.tks = @tks - -{ -dummyPat :: Options -> Bool -> PP_Doc -dummyPat opts noArgs - | not noArgs && tupleAsDummyToken opts = empty -- no unnecessary tuples - | tupleAsDummyToken opts = if strictDummyToken opts - then text "Void" - else text "(_)" - | otherwise = let match | strictDummyToken opts = "!_" - | otherwise = "_" - in pp_parens (match >#< "::" >#< dummyType opts noArgs) - where match | strictDummyToken opts = "(!_)" - | otherwise = "_" - -dummyArg :: Options -> Bool -> PP_Doc -dummyArg opts noArgs - | not noArgs && tupleAsDummyToken opts = empty -- no unnecessary tuples - | tupleAsDummyToken opts = text "Void" - | otherwise = text "GHC.Prim.realWorld#" - -dummyType :: Options -> Bool -> PP_Doc -dummyType opts noArgs - | not noArgs && tupleAsDummyToken opts = empty -- no unnecessary tuples - | tupleAsDummyToken opts = text "Void" - | otherwise = text "(GHC.Prim.State# GHC.Prim.RealWorld)" -} - -{ --- rules are "deinlined" to prevent needless code duplication. --- if there is only a bit of duplication, we allow ghc to decide if it is worth it. --- if the duplication crosses this threshold, however, we tell ghc definitely not to inline it. -ruleInlineThresholdSoft :: Int -ruleInlineThresholdSoft = 3 - -ruleInlineThresholdHard :: Int -ruleInlineThresholdHard = 5 - -reallyOftenUsedThreshold :: Int -reallyOftenUsedThreshold = 12 -} - -ATTR Expression [ | | pos : {Pos} ] -SEM Expression | Expression lhs.pos = @pos - --- pattern and expression semantics -ATTR Pattern [ | | sem_lhs : { PP_Doc } ] -ATTR Patterns [ | | sem_lhs USE {:} {[]} : {[PP_Doc]} ] -ATTR Pattern Patterns [ | | ] - -SEM Pattern - | Alias loc.varPat = text $ attrname @lhs.options False @field @attr - loc.patExpr = if @pat.isUnderscore - then @loc.varPat - else @loc.varPat >|< "@" >|< @pat.sem_lhs - lhs.sem_lhs = @loc.addbang1 @loc.patExpr - | Product lhs.sem_lhs = @loc.addbang1 $ pp_block "(" ")" "," @pats.sem_lhs - | Constr lhs.sem_lhs = @loc.addbang1 $ pp_parens $ @name >#< hv_sp @pats.sem_lhs - | Underscore lhs.sem_lhs = text "_" - | Irrefutable lhs.sem_lhs = text "~" >|< pp_parens @pat.sem_lhs - --- Check if a pattern is just an underscore -ATTR Pattern [ | | isUnderscore:{Bool}] -SEM Pattern - | Constr lhs.isUnderscore = False - | Product lhs.isUnderscore = False - | Alias lhs.isUnderscore = False - | Underscore lhs.isUnderscore = True - --- Collect the attributes defined by a pattern -ATTR Pattern Patterns [ | | attrs USE {`Set.union`} {Set.empty} : {Set String} ] -SEM Pattern | Alias - lhs.attrs = Set.insert (attrname @lhs.options False @field @attr) @pat.attrs - --- All attribute types of this pattern -ATTR Pattern Patterns [ | | attrTypes USE {>-<} {empty} : {PP_Doc} ] -SEM Pattern | Alias - loc.mbTp = if @field == _LHS - then Map.lookup @attr @lhs.synmap - else if @field == _LOC - then Map.lookup @attr @lhs.localAttrTypes - else Nothing - lhs.attrTypes = empty -- Don't generate these type signatures; increases performance in Clean - -- maybe empty (\tp -> (attrname @lhs.options False @field @attr) >#< "::" >#< ppTp tp) @loc.mbTp - -- >-< @pat.attrTypes - --- Collect the attributes used by the right-hand side -ATTR HsToken Expression [ | | attrs USE {`Map.union`} {Map.empty} : {Map String (Maybe NonLocalAttr)} ] -SEM HsToken - | AGLocal lhs.attrs = Map.singleton (fieldname @var) Nothing - | AGField loc.mbAttr = if @field == _INST || @field == _FIELD || @field == _INST' - then Nothing -- should not be used in the first place - else Just $ mkNonLocalAttr (@field == _LHS) @field @attr - lhs.attrs = Map.singleton (attrname @lhs.options True @field @attr) @loc.mbAttr - -{ -data NonLocalAttr - = AttrInh Identifier Identifier - | AttrSyn Identifier Identifier deriving Show - -mkNonLocalAttr :: Bool -> Identifier -> Identifier -> NonLocalAttr -mkNonLocalAttr True = AttrInh -- True: inherited attr -mkNonLocalAttr False = AttrSyn - -lookupAttrType :: NonLocalAttr -> Map Identifier Attributes -> Map Identifier Attributes -> Map Identifier Type -> Maybe PP_Doc -lookupAttrType (AttrInh child name) inhs _ = lookupType child name inhs -lookupAttrType (AttrSyn child name) _ syns = lookupType child name syns - --- Note: if the child takes type parameters, the type of an attribute of this child may refer to these parameters. This means that --- the actual type of the attribute needs to have its type parameters substituted with the actual type argument of the child. --- However, for now we simply decide to return Nothing in this case, which skips the type annotation. -lookupType :: Identifier -> Identifier -> Map Identifier Attributes -> Map Identifier Type -> Maybe PP_Doc -lookupType child name attrMp childMp - | noParameters childTp = Just ppDoc - | otherwise = Nothing - where - attrTp = Map.findWithDefault (error "lookupType: the attribute is not in the attrs of the child") name childAttrs - childAttrs = Map.findWithDefault (error "lookupType: the attributes of the nonterm are not in the map") nonterm attrMp - nonterm = extractNonterminal childTp - childTp = Map.findWithDefault (error ("lookupType: the child " ++ show child ++ "is not in the appropriate map")) child childMp - ppDoc = ppTp attrTp - -noParameters :: Type -> Bool -noParameters (Haskell _) = True -noParameters (NT _ args _) = null args -} - -ATTR Expression [ | | semfunc : {PP_Doc} ] - -SEM Expression - | Expression lhs.attrs = Map.unions $ map (\tok -> attrs_Syn_HsToken (wrap_HsToken (sem_HsToken tok) @loc.inhhstoken)) @tks - lhs.semfunc = vlist $ showTokens $ map (\tok -> tok_Syn_HsToken (wrap_HsToken (sem_HsToken tok) @loc.inhhstoken)) @tks - loc.inhhstoken = Inh_HsToken @lhs.options - --- child visit map -ATTR Visit - Visits - EProduction - EProductions - ENonterminal - ENonterminals [ allchildvisit : {Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))} - | | childvisit USE {`Map.union`} {Map.empty} : {Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))} ] - -ATTR VisitSteps VisitStep [ allchildvisit : {Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))} | | ] - -SEM ExecutionPlan - | ExecutionPlan nonts.allchildvisit = @nonts.childvisit - -SEM Visit - | Visit - loc.prevVisitInfo = Map.findWithDefault ManyVis @from @lhs.nextVisits - lhs.childvisit = Map.singleton @ident @loc.invokecode - loc.invokecode = \chn kind -> -- "chn" is the name of the child at the place of invocation, and "kind" the kind of the calling visit - if kind `compatibleKind` @kind - then Right $ - let pat | isLazyKind @kind = pat0 - | otherwise = @loc.addbang pat0 - pat0 = pp_parens pat1 - pat1 = @loc.nameTOut_visit >#< (ppSpaced $ map (attrname @lhs.options True chn) $ Set.toList @syn) - >#< cont - cont = case @loc.nextVisitInfo of - NoneVis -> empty - _ -> ch1 - ch0 = text $ stname chn @from - ch1 = text $ stname chn @to - expr = case (kind, @kind) of - (VisitPure _, VisitPure _) -> expr0 - (VisitPure _, VisitMonadic) -> unMon @lhs.options >#< expr0 - (VisitMonadic, VisitPure _) -> "lift" >#< expr0 - (VisitMonadic, VisitMonadic) -> expr0 - expr0 = case @loc.prevVisitInfo of - NoneVis -> error "error: invocation of a visit from a state that has no next visits" - OneVis _ -> "inv_" >|< @lhs.nt >|< "_s" >|< @from >#< ch0 >#< args - ManyVis -> "inv_" >|< @lhs.nt >|< "_s" >|< @from >#< ch0 - >#< "K_" >|< @lhs.nt >|< "_v" >|< @ident >#< args - args = pp_parens args0 >#< args1 - args0 = @loc.nameTIn_visit >#< @loc.inhargs chn - args1 | dummyTokenVisit @lhs.options = pp $ dummyArg @lhs.options True - | otherwise = empty - in (pat, expr) -- pretty print of the pattern and the expression part - else Left $ IncompatibleVisitKind chn @ident kind @kind - -{ --- a `compatibleKind` b means: can kind b be invoked from a -compatibleKind :: VisitKind -> VisitKind -> Bool -compatibleKind _ _ = True - -compatibleRule :: VisitKind -> Bool -> Bool -compatibleRule (VisitPure _) False = False -compatibleRule _ _ = True -} - -------------------------------------------------------------------------------- --- Properties of rules -------------------------------------------------------------------------------- - --- Construct an environment that counts how often certain rules are used -ATTR Visits Visit VisitSteps VisitStep [ | | ruleUsage USE {`unionWithSum`} {Map.empty} : {Map Identifier Int} ] -ATTR ERules ERule [ usageInfo : {Map Identifier Int} | | ] - -SEM EProduction | EProduction rules.usageInfo = @visits.ruleUsage -SEM VisitStep | Sem lhs.ruleUsage = Map.singleton @name 1 -SEM ERule | ERule loc.used = Map.findWithDefault 0 @name @lhs.usageInfo - -{ -unionWithSum = Map.unionWith (+) -} - --- Collect in what visit-kinds a rule is used -ATTR Visits Visit VisitSteps VisitStep [ | | ruleKinds USE {`unionWithMappend`} {Map.empty} : {Map Identifier (Set VisitKind)} ] -SEM VisitStep | Sem - lhs.ruleKinds = Map.singleton @name (Set.singleton @lhs.kind) - -ATTR ERules ERule [ ruleKinds : {Map Identifier (Set VisitKind)} | | ] -SEM EProduction | EProduction - rules.ruleKinds = @visits.ruleKinds - -SEM ERule | ERule - loc.kinds = Map.findWithDefault Set.empty @name @lhs.ruleKinds - loc.anyLazyKind = Set.fold (\k r -> isLazyKind k || r) False @loc.kinds - -ATTR Pattern Patterns [ anyLazyKind : Bool | | ] - - -------------------------------------------------------------------------------- --- Intra attributes -------------------------------------------------------------------------------- -{ -uwSetUnion :: (Ord a, Ord b) => Map a (Set b) -> Map a (Set b) -> Map a (Set b) -uwSetUnion = Map.unionWith Set.union - -uwMapUnion :: (Ord a, Ord b) => Map a (Map b c) -> Map a (Map b c) -> Map a (Map b c) -uwMapUnion = Map.unionWith Map.union -} -ATTR Visit Visits [ allintramap : {Map StateIdentifier (Map String (Maybe NonLocalAttr))} - | | intramap USE {`uwMapUnion`} {Map.empty} : {Map StateIdentifier (Map String (Maybe NonLocalAttr))} ] - -ATTR Visit Visits [ terminaldefs : {Set String} | | ] -ATTR EChild EChildren [ | | terminaldefs USE {`Set.union`} {Set.empty} : {Set String} ] - -SEM EChild | ETerm - lhs.terminaldefs = Set.singleton $ fieldname @name - -SEM EProduction | EProduction - visits.allintramap = @visits.intramap - visits.terminaldefs = @children.terminaldefs - -SEM Visit - | Visit loc.thisintra = (@loc.uses `Map.union` @loc.nextintra) `Map.difference` @loc.defsAsMap - lhs.intramap = Map.singleton @from @loc.thisintra - loc.nextintra = maybe Map.empty id $ Map.lookup @to @lhs.allintramap - loc.uses = let mp1 = @steps.uses - mp2 = Map.fromList [ (lhsname @lhs.options False i, Just (AttrSyn _LHS i)) | i <- Set.elems @syn ] - in mp1 `Map.union` mp2 - loc.inhVarNms = Set.map (lhsname @lhs.options True) @inh - loc.defs = @steps.defs `Set.union` @loc.inhVarNms `Set.union` @lhs.terminaldefs - loc.defsAsMap = Map.fromList [ (a, Nothing) | a <- Set.elems @loc.defs ] - -ATTR ERule ERules [ | | ruledefs USE {`uwSetUnion`} {Map.empty} : {Map Identifier (Set String)} - ruleuses USE {`uwMapUnion`} {Map.empty} : {Map Identifier (Map String (Maybe NonLocalAttr))} ] -ATTR Visit Visits - VisitSteps VisitStep [ ruledefs : {Map Identifier (Set String)} - ruleuses : {Map Identifier (Map String (Maybe NonLocalAttr))} | | ] - -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 VisitIdentifier (Set Identifier)} - visituses USE {`uwSetUnion`} {Map.empty} : {Map VisitIdentifier (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 VisitIdentifier (Set Identifier)} - avisituses : {Map VisitIdentifier (Set Identifier)} | | ] - -SEM ExecutionPlan - | ExecutionPlan nonts.avisitdefs = @nonts.visitdefs - nonts.avisituses = @nonts.visituses - -ATTR VisitSteps VisitStep [ | | defs USE {`Set.union`} {Set.empty} : {Set String} - uses USE {`Map.union`} {Map.empty} : {Map String (Maybe NonLocalAttr)} ] -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 - | ChildVisit lhs.defs = Set.insert (stname @child @to) $ maybe (error "Visit not found") (Set.map $ attrname @lhs.options True @child) $ Map.lookup @visit @lhs.avisitdefs - lhs.uses = let convert attrs = Map.fromList [ (attrname @lhs.options False @child attr, Just $ mkNonLocalAttr True @child attr) | attr <- Set.elems attrs ] - in Map.insert (stname @child @from) Nothing $ convert $ - maybe (error "Visit not found") id $ Map.lookup @visit @lhs.avisituses - -------------------------------------------------------------------------------- --- Identification of lazy intra defs within a production --- --- These identifiers will not be marked as strict in rules and state closures -------------------------------------------------------------------------------- - -ATTR Visits Visit VisitSteps VisitStep [ | | lazyIntras USE {`Set.union`} {Set.empty} : {Set String} ] -ATTR ERules ERule [ lazyIntras : {Set String} | | ] - -SEM Visit | Visit - loc.lazyIntrasInh = case @kind of - VisitPure False -> @loc.inhVarNms `Set.union` @steps.defs - _ -> Set.empty - lhs.lazyIntras = @loc.lazyIntrasInh `Set.union` @steps.lazyIntras - -SEM VisitStep | PureGroup - lhs.lazyIntras = if @ordered - then @steps.lazyIntras - else @steps.defs - -SEM EProduction | EProduction - loc.lazyIntras = @visits.lazyIntras - -------------------------------------------------------------------------------- --- 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,fieldname @var) - -SEM HsToken [ || tok:{(Pos,String)}] - | AGField - loc.addTrace = case @rdesc of - Just d -> \x -> "(trace_n " ++ show (d ++ " -> " ++ show @field ++ "." ++ show @attr) ++ " (" ++ x ++ "))" - Nothing -> id - lhs.tok = (@pos, @loc.addTrace $ attrname @lhs.options 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 [ mainBlocksDoc : PP_Doc textBlockMap : {Map BlockInfo PP_Doc} - | | genIO : {IO ()} ] - -SEM ExecutionPlan - | ExecutionPlan lhs.genIO = do @loc.genMainModule - @loc.genCommonModule - @nonts.genProdIO - loc.mainModuleFile = @lhs.mainFile - loc.ppMonadImports = pp "import qualified Control.Monad.Identity" - loc.genMainModule = writeModule @loc.mainModuleFile - ( [ pp $ @lhs.iclModuleHeader @lhs.mainName "" "" False - , @loc.ppMonadImports - , pp $ "import " ++ @lhs.mainName ++ "_common" - ] - ++ @nonts.imports - ++ [@lhs.mainBlocksDoc] - ++ [@loc.wrappersExtra] - ++ @nonts.appendMain - ) - loc.commonFile = replaceBaseName @lhs.mainFile (takeBaseName @lhs.mainFile ++ "_common") - loc.genCommonModule = writeModule @loc.commonFile - ( [ pp $ @lhs.iclModuleHeader @lhs.mainName "_common" "" True - , @loc.ppMonadImports - , @lhs.importBlocks - , @lhs.textBlocks - , @loc.commonExtra - ] - ++ @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_icl - >-< @loc.wr_syn_icl - >-< @loc.wrapper_icl - else empty) - >-< @loc.sem_nt - lhs.appendCommon = (if dataTypes @lhs.options then @loc.datatype else empty) - >-< @loc.t_init_icl - >-< @loc.t_states_icl - >-< @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 = replaceBaseName @lhs.mainFile (takeBaseName @lhs.mainFile ++ @loc.suffix) - loc.ppMonadImports = pp "import qualified Control.Monad.Identity" - lhs.genProdIO = writeModule @loc.outputfile - [ pp $ @lhs.iclModuleHeader @lhs.mainName @loc.suffix @loc.semname True - , @lhs.importBlocks - , @loc.ppMonadImports - , 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 - -cleanIclModuleHeader :: Options -> String -> String -cleanIclModuleHeader flags input - = case moduleName flags - of Name nm -> genMod nm - Default -> genMod (defaultModuleName input) - NoName -> "" - where genMod x = "implementation module " ++ x - -cleanDclModuleHeader :: Options -> String -> Maybe String -> String -cleanDclModuleHeader flags input export - = case moduleName flags - of Name nm -> genMod nm - Default -> genMod (defaultModuleName input) - NoName -> "" - where genMod x = "definition module " ++ x ++ genExp export x - genExp Nothing _ = "" - genExp (Just e) x = "(module " ++ x ++ ", module " ++ e ++ ")" - -defaultModuleName :: String -> String -defaultModuleName = dropExtension - -mkIclModuleHeader :: Maybe (String,String,String) -> String -> String -> String -> Bool -> String -mkIclModuleHeader Nothing defaultName suffix _ _ - = "implementation module " ++ defaultName ++ suffix -mkIclModuleHeader (Just (name, exports, imports)) _ suffix addExports replaceExports - = "implementation module " ++ name ++ suffix ++ "\n" ++ imports ++ "\n" - -mkDclModuleHeader :: Maybe (String,String,String) -> String -> String -> String -> Bool -> String -mkDclModuleHeader Nothing defaultName suffix _ _ - = "definition module " ++ defaultName ++ suffix -mkDclModuleHeader (Just (name, exports, _)) _ suffix addExports replaceExports - = "definition module " ++ name ++ suffix ++ ex ++ "\n" - where - ex = if null exports || (replaceExports && null addExports) - then "" - else if null addExports - then exports - else if replaceExports - then addExports - else exports ++ "," ++ addExports -} - - --- --- Bang pattern usage --- - -SEM ERule | ERule loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x -SEM Visit | Visit loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x -SEM ENonterminal | ENonterminal loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x -SEM EProduction | EProduction loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x -SEM EChild | EChild loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x -SEM EChild | ETerm loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x -SEM VisitStep | ChildVisit loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x -SEM Pattern | Alias Constr Product loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x - -SEM Visit | Visit loc.addbang1 = if isLazyKind @kind then id else @loc.addbang -SEM ENonterminal | ENonterminal loc.addbangWrap = id --if strictWrap @lhs.options then @loc.addbang else id -SEM ERule | ERule loc.addbang1 = if @loc.anyLazyKind then id else @loc.addbang -SEM Pattern | Alias Constr Product loc.addbang1 = if @lhs.anyLazyKind then id else @loc.addbang - --- --- Distribute single-visit-next map downward --- - -ATTR EProductions EProduction Visits Visit - [ prevVisits, nextVisits : {Map StateIdentifier StateCtx} | | ] - -SEM ENonterminal | ENonterminal - prods.nextVisits = @nextVisits - prods.prevVisits = @prevVisits - --- --- Collect and distribute the from/to states of a visit --- - -ATTR ENonterminals ENonterminal EProductions EProduction Visits Visit - [ | | fromToStates USE {`mappend`} {mempty} : {Map VisitIdentifier (Int,Int)} ] - -ATTR ENonterminals ENonterminal EProductions EProduction Visits Visit VisitSteps VisitStep - [ allFromToStates : {Map VisitIdentifier (Int,Int)} | | ] - -SEM Visit | Visit - lhs.fromToStates = Map.singleton @ident (@from, @to) - -SEM ExecutionPlan | ExecutionPlan - nonts.allFromToStates = @nonts.fromToStates - -SEM VisitStep | ChildVisit - (loc.from, loc.to) = Map.findWithDefault (error "visit not in allFromToStates") @visit @lhs.allFromToStates - - --- --- Collect and distribute the actual types of children of productions --- - -ATTR EChildren EChild [ | | childTypes USE {`mappend`} {mempty} : {Map Identifier Type} ] -ATTR ERules ERule Visits Visit VisitSteps VisitStep [ childTypes : {Map Identifier Type} | | ] - -SEM EProduction | EProduction - loc.childTypes = Map.singleton _LHS @lhs.ntType `Map.union` @children.childTypes - -SEM EChild | EChild ETerm - lhs.childTypes = Map.singleton @name @tp - --- --- Distribute types of local attributes --- - -ATTR ExecutionPlan ENonterminals ENonterminal [ localAttrTypes : {Map NontermIdent (Map ConstructorIdent (Map Identifier Type))} | | ] -ATTR EProductions EProduction [ localAttrTypes : {Map ConstructorIdent (Map Identifier Type)} | | ] -ATTR ERules ERule Pattern Patterns [ localAttrTypes : {Map Identifier Type} | | ] - -SEM ENonterminal | ENonterminal - prods.localAttrTypes = Map.findWithDefault Map.empty @nt @lhs.localAttrTypes - -SEM EProduction | EProduction - loc.localAttrTypes = Map.findWithDefault Map.empty @con @lhs.localAttrTypes - --- --- Collect and distribute visit kinds --- - -ATTR ENonterminals ENonterminal EProductions EProduction Visits Visit VisitSteps VisitStep - [ allVisitKinds : {Map VisitIdentifier VisitKind} | | visitKinds USE {`mappend`} {mempty} : {Map VisitIdentifier VisitKind} ] - -SEM Visit | Visit - lhs.visitKinds = Map.singleton @ident @kind - -SEM ExecutionPlan | ExecutionPlan - nonts.allVisitKinds = @nonts.visitKinds - --- --- Collect and distribute the initial state of nonterminals --- - -ATTR ENonterminals ENonterminal [ | | initStates USE {`mappend`} {mempty} : {Map NontermIdent Int} ] -ATTR ENonterminals ENonterminal EProductions EProduction EChildren EChild Visits Visit VisitSteps VisitStep - [ allInitStates : {Map NontermIdent Int} | | ] - -SEM ENonterminal | ENonterminal - lhs.initStates = Map.singleton @nt @initial - -SEM ExecutionPlan | ExecutionPlan - nonts.allInitStates = @nonts.initStates - -SEM EChild | EChild - loc.initSt = Map.findWithDefault (error "nonterminal not in allInitStates map") @loc.nt @lhs.allInitStates - --- --- Push the nonterminal type downward --- - -ATTR EProductions EProduction [ ntType : Type | | ] -SEM ENonterminal | ENonterminal - loc.ntType = NT @nt (map show @params) False - --- --- Collect errors contained in rules that should be yielded when the --- rules are scheduled. --- - -ATTR ExecutionPlan ENonterminals ENonterminal EProductions EProduction ERules ERule Visits Visit VisitSteps VisitStep [ | | errors USE {Seq.><} {Seq.empty} : {Seq Error} ] -SEM ERule | ERule - lhs.errors = case @mbError of - Just e | @loc.used > 0 -> Seq.singleton e - _ -> Seq.empty - diff --git a/src-ag/ExecutionPlan2Hs.ag b/src-ag/ExecutionPlan2Hs.ag deleted file mode 100644 --- a/src-ag/ExecutionPlan2Hs.ag +++ /dev/null @@ -1,1711 +0,0 @@ -INCLUDE "ExecutionPlan.ag" -INCLUDE "Patterns.ag" -INCLUDE "Expression.ag" -INCLUDE "HsToken.ag" - -imports -{ -import ExecutionPlan -import Pretty -import PPUtil -import Options -import Data.Monoid(mappend,mempty) -import Data.Maybe -import Debug.Trace -import System.IO -import System.Directory -import System.FilePath -import UU.Scanner.Position - -import TokenDef -import HsToken -import ErrorMessages - -import Data.Set (Set) -import qualified Data.Set as Set -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Sequence(Seq) -import qualified Data.Sequence as Seq -import Data.Foldable(toList) -} - -ATTR ExecutionPlan ENonterminals ENonterminal EProductions EProduction ERules ERule EChildren EChild - [ importBlocks : PP_Doc - pragmaBlocks : String - textBlocks : PP_Doc - moduleHeader : {String -> String -> String -> Bool -> String} - mainFile : String - mainName : String | | ] - -------------------------------------------------------------------------------- --- Options -------------------------------------------------------------------------------- -ATTR ExecutionPlan - ENonterminals ENonterminal - EProductions EProduction - ERules ERule - EChildren EChild - Expression - HsToken HsTokens HsTokensRoot - Pattern Patterns - Visits Visit - VisitSteps VisitStep [ options : {Options} | | ] -ATTR EProductions EProduction [ rename : {Bool} | | ] - -SEM ENonterminal - | ENonterminal prods.rename = rename @lhs.options - -------------------------------------------------------------------------------- --- Context info (nonterminal ident, constructor ident, nonterm params, etc.) -------------------------------------------------------------------------------- - -ATTR Visit Visits EProduction EProductions EChildren EChild ERules ERule [ nt : NontermIdent | | ] -SEM ENonterminal - | ENonterminal prods.nt = @nt - -ATTR EChildren EChild ERules ERule Visits Visit - [ con : ConstructorIdent | | ] - -SEM EProduction - | EProduction children.con = @con - rules.con = @con - visits.con = @con - -ATTR EProductions EProduction Visits Visit [ params : {[Identifier]} | | ] -SEM ENonterminal | ENonterminal - prods.params = @params - -ATTR EProductions EProduction [ classCtxs : ClassContext | | ] -SEM ENonterminal | ENonterminal - prods.classCtxs = @classCtxs - -------------------------------------------------------------------------------- --- Default output -------------------------------------------------------------------------------- -ATTR ExecutionPlan [ | | output : {PP_Doc} ] - -SEM ExecutionPlan - | ExecutionPlan lhs.output = @nonts.output >-< @loc.commonExtra >-< @loc.wrappersExtra - -ATTR ENonterminal ENonterminals [ wrappers : {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 @loc.hasWrapper - 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) - loc.hasWrapper = @nt `Set.member` @lhs.wrappers - -------------------------------------------------------------------------------- --- Nonterminal datatype -------------------------------------------------------------------------------- -ATTR ENonterminal ENonterminals [ typeSyns : {TypeSyns} - derivings : {Derivings} | | ] - -SEM ExecutionPlan - | ExecutionPlan nonts.typeSyns = @typeSyns - nonts.derivings = @derivings - -SEM ENonterminal - | ENonterminal loc.classPP = ppClasses $ classCtxsToDocs @classCtxs - loc.aliasPre = "type" >#< @loc.classPP >#< @nt >#< @loc.t_params >#< "=" - loc.datatype = case lookup @nt @lhs.typeSyns of - Nothing -> "data" >#< @loc.classPP >#< @nt >#< @loc.t_params - >-< ( if null @prods.datatype - then empty - else indent 2 $ vlist $ ( ("=" >#< head @prods.datatype) - : (map ("|" >#<) $ tail @prods.datatype)) - ) - >-< indent 2 @loc.derivings - Just (List t) -> @loc.aliasPre >#< "[" >#< show t >#< "]" - Just (Maybe t) -> @loc.aliasPre >#< "Maybe" >#< pp_parens (show t) - Just (Tuple ts) -> @loc.aliasPre >#< pp_parens (ppCommas $ map (show . snd) ts) - Just (Either l r) -> @loc.aliasPre >#< "Either" >#< pp_parens (show l) >#< pp_parens (show r) - Just (Map k v) -> @loc.aliasPre >#< "Data.Map" >#< pp_parens (show k) >#< pp_parens (show v) - Just (IntMap t) -> @loc.aliasPre >#< "Data.IntMap.IntMap" >#< pp_parens (show t) - Just (OrdSet t) -> @loc.aliasPre >#< "Data.Set.Set" >#< pp_parens (show t) - Just IntSet -> @loc.aliasPre >#< "Data.IntSet.IntSet" --- 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) - -{ -classCtxsToDocs :: ClassContext -> [PP_Doc] -classCtxsToDocs = map toDoc where - toDoc (ident,args) = (ident >#< ppSpaced (map pp_parens args)) - -classConstrsToDocs :: [Type] -> [PP_Doc] -classConstrsToDocs = map ppTp - -ppClasses :: [PP_Doc] -> PP_Doc -ppClasses [] = empty -ppClasses xs = pp_block "(" ")" "," xs >#< "=>" - -ppQuants :: [Identifier] -> PP_Doc -ppQuants [] = empty -ppQuants ps = "forall" >#< ppSpaced ps >#< "." -} - -ATTR EProduction [ | | datatype : {PP_Doc} ] -ATTR EProductions [ | | datatype USE {:} {[]} : {[PP_Doc]} ] - --- we generate the data type in the type-class style instead of the GADT style --- the GADT extension may be required if equality constraints are used -SEM EProduction - | EProduction lhs.datatype = @loc.quantPP1 >#< @loc.classPP1 - >#< conname @lhs.rename @lhs.nt @con - >#< ppConFields (dataRecords @lhs.options) @children.datatype - loc.classPP1 = ppClasses (classConstrsToDocs @constraints) - loc.quantPP1 = ppQuants @params - -{ --- first parameter indicates: generate a record or not -ppConFields :: Bool -> [PP_Doc] -> PP_Doc -ppConFields True flds = ppListSep "{" "}" ", " $ filter (not . isEmpty) flds -ppConFields False flds = ppSpaced flds -} - - -ATTR EChild [ | | datatype : {PP_Doc} ] -ATTR EChildren [ | | datatype USE {:} {[]} : {[PP_Doc]} ] - --- Note: the child may be a higher-order attribute, and its semantics may be deforested -SEM EChild - | EChild ETerm - loc.tpDoc = @loc.addStrict $ pp_parens $ ppTp $ removeDeforested @tp - loc.strNm = recordFieldname @lhs.nt @lhs.con @name - loc.field = if dataRecords @lhs.options - then @loc.strNm >#< "::" >#< @loc.tpDoc - else @loc.tpDoc - loc.addStrict = \x -> if strictData @lhs.options then "!" >|< x else x - | EChild lhs.datatype = case @kind of - ChildAttr -> empty -- higher order attributes are not part of the data type - _ -> @loc.field - - | ETerm lhs.datatype = @loc.field - -{ -ppTp :: Type -> PP_Doc -ppTp = text . typeToHaskellString Nothing [] -} - -------------------------------------------------------------------------------- --- 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 - - -- The sem_NT function is lazy in the AST: it depends on the application of "child" - -- rules to which extend the AST needs to be constructed. - loc.sem_tp = @loc.quantPP >#< @loc.classPP >#< @nt >#< @loc.t_params >#< "->" >#< @loc.t_type >#< @loc.t_params - loc.quantPP = ppQuants @params - loc.sem_nt = @loc.semPragma - >-< @loc.semname >#< "::" >#< @loc.sem_tp - >-< 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 (OrdSet t) -> @loc.semname >#< "s" >#< "=" >#< "Prelude.foldr" >#< @loc.semname >|< "_Entry" - >#< @loc.semname >|< "_Nil" - >#< pp_parens ( - ( case t of - NT nt _ _ -> pp_parens ("Prelude.map" >#< @fsemname nt) - _ -> empty - ) >#< pp_parens ("Data.IntSet.elems" >#< "s") - ) - Just IntSet -> @loc.semname >#< "s" >#< "=" >#< "Prelude.foldr" >#< @loc.semname >|< "_Entry" - >#< @loc.semname >|< "_Nil" - >#< pp_parens ("Data.IntSet.elems" >#< "s") --- Just x -> error $ "Type " ++ show x ++ " is not supported yet" -- TODO: other typeSyns - - -- precise inlining strategies for inlining - loc.inlineNt = not (lateHigherOrderBinding @lhs.options) && not @recursive && (@prods.count == 1 || (aggressiveInlinePragmas @lhs.options && not @loc.hasWrapper)) -- lucrative for inlining - loc.semPragma = if noInlinePragmas @lhs.options - then empty - else if @loc.inlineNt - then ppInline @loc.semname - else if helpInlining @lhs.options && not (lateHigherOrderBinding @lhs.options) - then ppInlinable @loc.semname - else ppNoInline @loc.semname - --- The number of productions -ATTR EProductions EProduction [ | | count USE {+} {0} : {Int} ] -SEM EProduction | EProduction lhs.count = {1} - --- The per-production cases for the sem_NT function -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.argpats >#< ")" - >#< "=" >#< "sem_" >|< @lhs.nt >|< "_" >|< @con >#< ppSpaced @children.argnamesw - -ATTR EChild [ | | argnamesw : { PP_Doc } ] -ATTR EChildren [ | | argnamesw USE {:} {[]} : {[PP_Doc]} ] - -SEM EChild - | EChild lhs.argnamesw = case @kind of - ChildSyntax -> "(" >#< "sem_" >|< @loc.nt >#< @name >|< "_" >#< ")" - ChildAttr -> empty -- no sem-case for a higher-order child - ChildReplace tp -> "(" >#< "sem_" >|< extractNonterminal tp >#< @name >|< "_" >#< ")" - | ETerm lhs.argnamesw = text $ fieldname @name - -------------------------------------------------------------------------------- --- Types of attributes -------------------------------------------------------------------------------- -ATTR ExecutionPlan - ENonterminals - ENonterminal [ inhmap : {Map NontermIdent Attributes} - synmap : {Map NontermIdent Attributes} | | ] - -ATTR EProductions EProduction - ERules ERule - Patterns Pattern - Visits - Visit [ inhmap : {Attributes} - synmap : {Attributes} - allInhmap : {Map NontermIdent Attributes} - allSynmap : {Map NontermIdent Attributes} | | ] - -SEM ENonterminal - | ENonterminal (Just prods.inhmap) = Map.lookup @nt @lhs.inhmap - (Just prods.synmap) = Map.lookup @nt @lhs.synmap - prods.allInhmap = @lhs.inhmap - prods.allSynmap = @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.stvisits = \st -> filter (\(v,f,t) -> f == st) @prods.allvisits - loc.t_type = "T_" >|< @nt - loc.t_params = ppSpaced @params - loc.t_init = "newtype" >#< @loc.t_type >#< @loc.t_params >#< "=" >#< @loc.t_type >#< - pp_braces ( - "attach_">|< @loc.t_type >#< "::" - >#< ppMonadType @lhs.options >#< pp_parens (@loc.t_type >|< "_s" >|< @initial >#< @loc.t_params)) - 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 - nextVisit = Map.findWithDefault ManyVis st @nextVisits - in case nextVisit of - NoneVis -> "data" >#< t_st >#< @loc.t_params >#< "=" >#< c_st -- empty semantics - OneVis vId -> "newtype" >#< t_st >#< @loc.t_params >#< "=" >#< c_st - >#< (pp_braces $ inv_st >#< "::" >#< pp_parens (conNmTVisit @nt vId >#< @loc.t_params)) - ManyVis -> "data" >#< t_st >#< @loc.t_params >#< "where" >#< c_st >#< "::" - >#< (pp_braces $ inv_st >#< "::" >#< "!" >|< pp_parens ("forall t." >#< k_st >#< @loc.t_params >#< "t" >#< "->" >#< "t")) - >#< "->" >#< t_st >#< @loc.t_params -- this is a conventional data type, but declared with GADT syntax - ) $ 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_params >#< pp_parens (@loc.t_type >|< "_v" >|< v >#< @loc.t_params) - ) outg - nextVisit = Map.findWithDefault ManyVis st @nextVisits - decl = "data" >#< k_st >#< "k" >#< @loc.t_params >#< "where" >-< indent 3 visitlist - in case nextVisit of - NoneVis -> empty - OneVis _ -> empty - ManyVis -> decl - ) $ Set.toList @loc.allstates - --- type of a visit v, with continuation as new state s -ATTR Visit Visits EProduction EProductions [ | | t_visits USE {>-<} {empty} : {PP_Doc} ] - -SEM EProductions - | Cons lhs.t_visits = @hd.t_visits -- just pick the first production - -SEM Visit - | Visit loc.nameT_visit = conNmTVisit @lhs.nt @ident - loc.nameTIn_visit = conNmTVisitIn @lhs.nt @ident - loc.nameTOut_visit = conNmTVisitOut @lhs.nt @ident - loc.nameTNext_visit = conNmTNextVisit @lhs.nt @to - - loc.nextVisitInfo = Map.findWithDefault ManyVis @to @lhs.nextVisits -- which visits can we do after we reach the @to state? - loc.typecon = case @kind of - VisitPure _ -> empty - VisitMonadic -> ppMonadType @lhs.options - - loc.t_params = ppSpaced @lhs.params - lhs.t_visits = "type" >#< @loc.nameT_visit >#< @loc.t_params >#< "=" >#< - pp_parens (@loc.nameTIn_visit >#< @loc.t_params) - >#< ( if dummyTokenVisit @lhs.options - then "->" >#< dummyType @lhs.options True -- Additional (unused though) argument - else empty - ) - >#< "->" >#< @loc.typecon >#< pp_parens (@loc.nameTOut_visit >#< @loc.t_params) - >-< "data" >#< @loc.nameTIn_visit >#< @loc.t_params >#< "=" >#< @loc.nameTIn_visit >#< - @loc.inhpart - >-< "data" >#< @loc.nameTOut_visit >#< @loc.t_params >#< "=" >#< @loc.nameTOut_visit >#< - @loc.synpart >#< case @loc.nextVisitInfo of - NoneVis -> empty -- don't return a continuation at all - _ -> @loc.addbang1 $ pp_parens (@loc.nameTNext_visit >#< @loc.t_params) -- normal route: select the next semantics - loc.inhpart = @loc.ppTypeList @inh @lhs.inhmap - loc.synpart = @loc.ppTypeList @syn @lhs.synmap - loc.ppTypeList = \s m -> ppSpaced $ map (\i -> @loc.addbang1 $ pp_parens $ case Map.lookup i m of - Just tp -> ppTp tp ) $ Set.toList s - -{ -conNmTVisit nt vId = "T_" >|< nt >|< "_v" >|< vId -conNmTVisitIn nt vId = "T_" >|< nt >|< "_vIn" >|< vId -conNmTVisitOut nt vId = "T_" >|< nt >|< "_vOut" >|< vId -conNmTNextVisit nt stId = "T_" >|< nt >|< "_s" >|< stId - -ppMonadType :: Options -> PP_Doc -ppMonadType opts - | parallelInvoke opts = text "IO" - | otherwise = text "Identity" -} - -------------------------------------------------------------------------------- --- 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 >#< @loc.t_params >#< "=" >#< nm >|< "_" >|< @nt >#< "{" - >#< (ppCommas $ map (\(i,t) -> i >|< "_" >|< nm >|< "_" >|< @nt >#< "::" - >#< (@loc.addbang $ pp_parens $ typeToHaskellString (Just @nt) [] t)) attr) >#< "}" - loc.synAttrs = fromJust $ Map.lookup @nt @lhs.inhmap - loc.wr_inhs = Map.toList $ @loc.wr_filter $ @loc.synAttrs - loc.wr_inhs1 = Map.toList @loc.synAttrs - loc.wr_filter = if lateHigherOrderBinding @lhs.options - then Map.delete idLateBindingAttr - else id - loc.wr_syns = Map.toList $ fromJust $ Map.lookup @nt @lhs.synmap - loc.inhlist = map (lhsname @lhs.options True . fst) @loc.wr_inhs - loc.inhlist1 = map (lhsname @lhs.options True . fst) @loc.wr_inhs1 - loc.synlist = map (lhsname @lhs.options False . fst) @loc.wr_syns - loc.wrapname = "wrap_" ++ show @nt - loc.inhname = "Inh_" ++ show @nt - loc.synname = "Syn_" ++ show @nt - loc.firstVisitInfo = Map.findWithDefault ManyVis @initial @nextVisits - loc.wrapper = @loc.wrapPragma - >-< (@loc.wrapname >#< "::" >#< @loc.quantPP >#< @loc.classPP >#< @loc.t_type >#< @loc.t_params >#< "->" - >#< @loc.inhname >#< @loc.t_params >#< "->" >#< ( if monadicWrappers @lhs.options then ppMonadType @lhs.options else empty) >#< pp_parens (@loc.synname >#< @loc.t_params)) - >-< (@loc.wrapname >#< (@loc.addbang $ pp_parens (@loc.t_type >#< pp "act")) - >#< (@loc.addbang $ pp_parens (@loc.inhname - >#< (ppSpaced $ map (@loc.addbangWrap . pp) @loc.inhlist)) >#< "=")) - >-< - indent 3 (case @initialv of - -- case where there are no inherited or synthesized attributes - [] -> @loc.synname >#< " { }" - initvs@(initv:_) -> - let extra = if dummyTokenVisit @lhs.options - then pp $ dummyArg @lhs.options True - else empty - unMonad | monadicWrappers @lhs.options = empty - | otherwise = unMon @lhs.options - genSteps _ [] = [] - genSteps curst (curv:nextvs) = setarg : dovis : genSteps nextst nextvs where - inCon = conNmTVisitIn @nt curv - outCon = conNmTVisitOut @nt curv - pat = @loc.addbang $ pp_parens $ pat0 - pat0 = outCon >#< ppSpaced (map (lhsname @lhs.options False) syns) >#< cont - cont | null nextvs = empty - | otherwise = pp "sem" - inhs = Set.toList $ Map.findWithDefault Set.empty curv @prods.visituses - syns = Set.toList $ Map.findWithDefault Set.empty curv @prods.visitdefs - arg = inCon >#< ppSpaced (map (lhsname @lhs.options True) inhs) - setarg = "let" >#< @loc.addbangWrap (pp "arg" >|< curv) >#< "=" >#< arg - ind = case Map.findWithDefault ManyVis curst @nextVisits of - NoneVis -> error "wrapper: initial state should have a next visit but it has none" - OneVis _ -> empty - ManyVis -> @loc.k_type >|< "_v" >|< initv - nextst = curst + 1 -- This is not correct, but works both for KW and AOAG - -- Should be lookup up based on visit - convert = case Map.lookup curv @lhs.allVisitKinds of - Just kind -> case kind of - VisitPure _ -> text "return" - VisitMonadic -> empty - dovis = pat >#< "<-" >#< convert >#< pp_parens - ("inv_" >|< @nt >|< "_s" >|< curst >#< "sem" >#< ind - >#< "arg" >|< curv >#< extra) - in unMonad >#< "(" - >-< indent 2 ( - "do" >#< ( @loc.addbang (pp "sem") >#< "<-" >#< "act" -- run the per-node monadic code to get the initial state (of the root) - >-< vlist (genSteps @initial initvs) - >-< "return" >#< pp_parens (@loc.synname >#< ppSpaced @loc.synlist) - ) - ) - >-< ")" ) - >-< if lateHigherOrderBinding @lhs.options - then indent 2 ("where" >#< lhsname @lhs.options True idLateBindingAttr >#< "=" >#< lateBindingFieldNm @lhs.mainName) - else empty - loc.wrapPragma = if parallelInvoke @lhs.options && not (monadicWrappers @lhs.options) - then ppNoInline @loc.wrapname -- required for the use of unsafePerformIO in case of the IO monad - else if noInlinePragmas @lhs.options - then empty - else ppInlinable @loc.wrapname -- ensure that the wrapper is exposed as inlinable - -------------------------------------------------------------------------------- --- Collection of NT / Production sem funs references -------------------------------------------------------------------------------- - -ATTR ENonterminals ENonterminal EProductions EProduction [ | | semFunBndDefs, semFunBndTps USE {Seq.><} {Seq.empty} : {Seq PP_Doc} ] -SEM ENonterminal | ENonterminal - lhs.semFunBndDefs = @loc.semFunBndDef Seq.<| @prods.semFunBndDefs - lhs.semFunBndTps = @loc.semFunBndTp Seq.<| @prods.semFunBndTps - loc.semFunBndDef = @loc.semFunBndNm >#< "=" >#< @loc.semname - loc.semFunBndTp = @loc.semFunBndNm >#< "::" >#< @loc.sem_tp - loc.semFunBndNm = lateSemNtLabel @nt - -SEM EProduction | EProduction - lhs.semFunBndDefs = Seq.singleton @loc.semFunBndDef - lhs.semFunBndTps = Seq.singleton @loc.semFunBndTp - loc.semFunBndDef = @loc.semFunBndNm >#< "=" >#< @loc.semname - loc.semFunBndTp = @loc.semFunBndNm >#< "::" >#< @loc.sem_tp - loc.semFunBndNm = lateSemConLabel @lhs.nt @con - --- Generate a dictionary that contains the semantics of all semantic functions -SEM ExecutionPlan | ExecutionPlan - loc.wrappersExtra = if lateHigherOrderBinding @lhs.options - then @loc.lateSemBndDef - else empty - loc.commonExtra = if lateHigherOrderBinding @lhs.options - then @loc.lateSemBndTp - else empty - loc.lateSemBndTp = "data" >#< lateBindingTypeNm @lhs.mainName >#< "=" >#< lateBindingTypeNm @lhs.mainName - >-< (indent 2 $ pp_block "{" "}" "," $ toList @nonts.semFunBndTps) - loc.lateSemBndDef = ( if noInlinePragmas @lhs.options - then empty - else if helpInlining @lhs.options && Set.size @wrappers == 1 - then ppInline $ lateBindingFieldNm @lhs.mainName -- inline in the single wrapper - else ppNoInline $ lateBindingFieldNm @lhs.mainName - ) - >-< lateBindingFieldNm @lhs.mainName >#< "::" >#< lateBindingTypeNm @lhs.mainName - >-< lateBindingFieldNm @lhs.mainName >#< "=" >#< lateBindingTypeNm @lhs.mainName - >-< (indent 2 $ pp_block "{" "}" "," $ toList @nonts.semFunBndDefs ) - -------------------------------------------------------------------------------- --- Production semantic functions -------------------------------------------------------------------------------- -ATTR EProduction [ | | sem_prod : {PP_Doc} ] -ATTR EProductions [ | | sem_prod USE {>-<} {empty} : {PP_Doc} ] - -ATTR EProduction EProductions [ initial : {StateIdentifier} - allstates : {Set StateIdentifier} | | ] -SEM ENonterminal - | ENonterminal prods.initial = @initial - prods.allstates = @loc.allstates - -ATTR EChild [ | | argtps : { PP_Doc } - argpats : { PP_Doc } ] -ATTR EChildren [ | | argtps USE {:} {[]} : { [PP_Doc] } - argpats USE {:} {[]} : { [PP_Doc] } ] - -SEM EChild - | EChild lhs.argtps = case @kind of - ChildSyntax -> ppDefor @tp >#< "->" - ChildReplace tp -> ppDefor tp >#< "->" - _ -> empty -- higher order attribute - loc.argpats = case @kind of - ChildSyntax -> @name >|< "_" -- no strictification of children semantics to allow infinite trees - ChildReplace _ -> @name >|< "_" - _ -> empty - | ETerm lhs.argtps = (pp_parens $ show @tp) >#< "->" - loc.argpats = @loc.addbang $ text $ fieldname @name -- terminals may be strict (perhaps this should become an option) - -{ -ppDefor :: Type -> PP_Doc -ppDefor (NT nt args _) = "T_" >|< nt >#< ppSpaced (map pp_parens args) -ppDefor (Haskell s) = text s -} - -SEM EProduction - | EProduction loc.t_type = "T_" >|< @lhs.nt - loc.t_params = ppSpaced @lhs.params - loc.usedArgs = @children.usedArgs `Set.union` @visits.usedArgs `Set.union` @rules.usedArgs - -- A bit ugly, but this code renames arguments and puts an underscore when the argument - -- is never used. This avoids compiler warnings of unused variables. - loc.args = map (\x -> let (name,arg) = case show x of - "" -> ("", empty) - '!':name -> ("arg_" ++ name, "!arg_" >|< name) - name -> ("arg_" ++ name, "arg_" >|< name) - in if null name || name `Set.member` @loc.usedArgs - then arg - else text "_") @children.argpats - loc.semname = "sem_" ++ show @lhs.nt ++ "_" ++ show @con - loc.sem_tp = @loc.quantPP2 >#< @loc.classPP2 >#< ppSpaced @children.argtps >#< @loc.t_type >#< @loc.t_params - loc.classPP2 = ppClasses (classCtxsToDocs @lhs.classCtxs ++ classConstrsToDocs @constraints) - loc.quantPP2 = ppQuants (@lhs.params ++ @params) - loc.sem_prod = @loc.semInlinePragma - >-< @loc.semname >#< "::" >#< @loc.sem_tp - >-< @loc.mkSemBody (@loc.semname >#< ppSpaced @loc.args >#< "=" >#< @loc.scc >#< @loc.t_type) - @loc.mbInitializer @loc.outerlet ("return" >#< "st" >|< @lhs.initial) - loc.mkSemBody = \prefix mbInit outerlet ret -> - case mbInit of - Nothing -> prefix >#< pp_parens ret >#< "where" - >-< indent 3 outerlet -- code for states and visits - Just m -> prefix >#< "(" >#< "do" - >-< indent 1 ( - m - >-< "let" - >-< indent 2 outerlet -- code for the states and visits - >-< ret ) - >-< indent 1 ")" - - loc.mbInitializer = --some monadic actions, performed upon attaching a child, can - -- be specified here. The resulting bindings of these actions are - -- in scope of the rules of the production - if parallelInvoke @lhs.options - then (Nothing :: Maybe PP_Doc) -- perhaps do some per-node registation, etc. For now: nothing - else Nothing -- nothing special here - loc.scc = if genCostCentres @lhs.options - then ppCostCentre @loc.semname - else empty - loc.semInlinePragma = if noInlinePragmas @lhs.options - then empty - else ppNoInline @loc.semname -- prevent the semantic functions of constructors to be inlined (e.g. in the nt sem-funs) - loc.outerlet = vlist @loc.statefns >-< @rules.sem_rules - loc.statefns = map @loc.genstfn $ Set.toList @lhs.allstates - loc.genstfn = \st -> let nextVisitInfo = Map.findWithDefault ManyVis st @lhs.nextVisits - prevVisitInfo = Map.findWithDefault ManyVis st @lhs.prevVisits - stNm = "st" >|< st - lhs = pragma >-< bang stNm >#< "=" >#< - ( -- generating a lambda for the same reasons as generating - -- a lambda for rules: to ensure that overloading is - -- resolved for all visit functions and rules together. - if st == @lhs.initial - then empty - else "\\" >#< @loc.stargs st >#< "->" - ) - - pragma = if noInlinePragmas @lhs.options - then empty - else if helpInlining @lhs.options - then case prevVisitInfo of - ManyVis -> ppNoInline stNm - OneVis _ -> if aggressiveInlinePragmas @lhs.options - then ppInline stNm - else ppInlinable stNm - NoneVis -> if st /= @lhs.initial - then error ("State " ++ show st ++ " is not reachable from the initial state.") - else if aggressiveInlinePragmas @lhs.options - then ppInline stNm -- first state can be inlined - else ppInlinable stNm - else ppNoInline stNm - cCon = "C_" >|< @lhs.nt >|< "_s" >|< st - bang | st == @lhs.initial = @loc.addbang -- initial state is not parameterized - | otherwise = id - - -- note about the initial state: the initial state should be the only - -- state-binding that is not a function. It is non-recursive and not needed - -- anywhere except delivered as initial result. This binding therefore does - -- not end up needlessly in any closure. - in case nextVisitInfo of - NoneVis -> -- the (empty) closure of a (non-initial) end state is not referenced - -- thus generating it is not needed (and omitting it may catch some small mistakes). - if st == @lhs.initial - then lhs >#< cCon -- empty state - else empty -- no state generated - OneVis vId -> mklet lhs (@loc.stvs st False) (cCon >#< "v" >|< vId) - ManyVis -> mklet lhs (@loc.stks st >-< @loc.stvs st True) (cCon >#< "k" >|< st) - loc.stargs = \st -> let attrs = maybe Map.empty id $ Map.lookup st @visits.intramap - in ppSpaced [ let match | str `Set.member` @loc.lazyIntras = pp str - | otherwise = @loc.addbang (pp str) - in case mbAttr of - Just (AttrSyn child nm) | child == _LOC && not (noPerStateTypeSigs @lhs.options) -> - case Map.lookup nm @loc.localAttrTypes of - Just tp -> pp_parens (pp_parens match >#< "::" >#< ppTp tp) - Nothing -> match - Just attr | not (noPerStateTypeSigs @lhs.options) -> - case lookupAttrType attr @lhs.allInhmap @lhs.allSynmap @loc.childTypes of - Just tpDoc -> pp_parens (pp_parens match >#< "::" >#< tpDoc) - Nothing -> match - _ -> match - | (str,mbAttr) <- Map.assocs attrs - ] >#< dummyPat @lhs.options (Map.null attrs) - - loc.stks = \st -> if null (@loc.stvisits st) - then empty - else ( if not (noInlinePragmas @lhs.options) && helpInlining @lhs.options - then ppNoInline ("k" >|< st) - else empty - ) - >-< "k" >|< st >#< "::" >#< "K_" >|< @lhs.nt >|< "_s" >|< st >#< @loc.t_params >#< "t" >#< "->" >#< "t" - >-< vlist (map (\(v,f,t) -> "k" >|< st >#< "K_" >|< @lhs.nt >|< "_v" >|< v >#< "=" - >#< "v" >|< v) $ @loc.stvisits st) - loc.stvisits = \st -> filter (\(v,f,t) -> f == st) @visits.allvisits - loc.stvs = \st inlinePragma -> vlist [ppf inlinePragma | (f,ppf) <- @visits.sem_visit, f == st] - visits.mrules = @rules.mrules - -{ -mklet :: (PP a, PP b, PP c) => a -> b -> c -> PP_Doc -mklet prefix defs body = - prefix >#< "let" - >-< indent 3 defs - >-< indent 2 "in" >#< body -} - -------------------------------------------------------------------------------- --- Visit semantic functions -------------------------------------------------------------------------------- -ATTR Visit [ | | sem_visit : { (StateIdentifier,Bool -> PP_Doc) } ] -ATTR Visits [ | | sem_visit USE {:} {[]} : { [(StateIdentifier,Bool -> PP_Doc)] } ] - -SEM Visit - | Visit lhs.sem_visit = ( @from - , \addInlinePragma -> - ( if noInlinePragmas @lhs.options - then empty - else if addInlinePragma && aggressiveInlinePragmas @lhs.options - then ppInline @loc.vname - else if helpInlining @lhs.options - then ppNoInline @loc.vname - else empty - ) - >-< "v" >|< @ident >#< "::" >#< @loc.nameT_visit >#< @loc.t_params - - -- generate a lambda here as well instead of a function definition - >-< "v" >|< @ident >#< "=" >#< "\\" >#< (@loc.addbang $ pp_parens (@loc.nameTIn_visit >#< @loc.inhpats)) - >#< ( if dummyTokenVisit @lhs.options - then pp $ dummyPat @lhs.options True -- extra (but unused) argument - else empty - ) - >#< "->" - >#< ( if genCostCentres @lhs.options - then ppCostCentre (@loc.vname >|< "_" >|< @lhs.nt >|< "_" >|< @lhs.con) - else empty - ) >#< "(" >#< @loc.stepsInitial - >-< indent 3 (@steps.sem_steps >-< @loc.stepsClosing >#< ")") - ) - loc.stepsInitial = case @kind of - VisitPure False -> text "let" - VisitPure True -> empty - VisitMonadic -> text "do" - loc.stepsClosing = let decls = @loc.nextStBuild - >-< @loc.addbang (pp resultValName) >#< "=" >#< @loc.resultval - in case @kind of - VisitPure False -> decls - >-< "in" >#< resultValName - VisitPure True -> "let" >#< decls - >-< indent 1 ("in" >#< resultValName) - VisitMonadic -> "let" >#< decls - >-< "return" >#< resultValName - loc.vname = "v" >|< @ident - loc.inhpats = ppSpaced $ map (\arg -> {-@loc.addbang $-} pp $ attrname @lhs.options True _LHS arg) $ Set.toList @inh - loc.inhargs = \chn -> ppSpaced $ map (attrname @lhs.options False chn) $ Set.toList @inh - loc.synargs = ppSpaced $ map (\arg -> attrname @lhs.options False _LHS arg) $ Set.toList @syn - loc.nextargsMp = maybe Map.empty id $ Map.lookup @to @lhs.allintramap - loc.nextargs = ppSpaced $ Map.keys $ @loc.nextargsMp - loc.nextst = "st" >|< @to >#< @loc.nextargs >#< dummyArg @lhs.options (Map.null @loc.nextargsMp) - loc.resultval = @loc.nameTOut_visit >#< @loc.synargs >#< @loc.nextStRef - (loc.nextStBuild, loc.nextStRef) - = case @loc.nextVisitInfo of - NoneVis -> (empty, empty) - _ -> (@loc.addbang (pp nextStName) >#< "=" >#< @loc.nextst, pp nextStName) - -{ -resultValName :: String -resultValName = "__result_" - -nextStName :: String -nextStName = "__st_" -} - --- Propagate the visit kind to the steps -ATTR VisitStep VisitSteps [ kind : VisitKind | | ] -SEM Visit | Visit steps.kind = @kind - --- the steps in this group should be executed in a pure fashion -SEM VisitStep | PureGroup - steps.kind = VisitPure @ordered - -ATTR Visits Visit VisitStep VisitSteps [ mrules : {Map Identifier (VisitKind -> FormatMode -> Either Error PP_Doc)} | | ] -ATTR VisitStep VisitSteps [ | | sem_steps USE {>-<} {empty} : {PP_Doc} ] -SEM VisitStep - | Sem loc.ruleItf = Map.findWithDefault (error $ "Rule " ++ show @name ++ " not found") @name @lhs.mrules - (lhs.errors, loc.sem_steps) = case @loc.ruleItf @lhs.kind @lhs.fmtMode of - Left e -> (Seq.singleton e, empty) - Right stmt -> (Seq.empty, stmt) - | ChildIntro loc.attachItf = Map.findWithDefault (error $ "Child " ++ show @child ++ " not found") @child @lhs.childintros - (lhs.errors,lhs.sem_steps,lhs.defs,lhs.uses) - = case @loc.attachItf @lhs.kind @lhs.fmtMode of - Left e -> (Seq.singleton e, empty, Set.empty, Map.empty) - Right (code, defs, uses) -> (Seq.empty, code, defs, uses) - | ChildVisit loc.visitItf = Map.findWithDefault (error $ "Visit " ++ show @visit ++ " not found") @visit @lhs.allchildvisit - (lhs.errors, loc.patPP, loc.exprPP) = case @loc.visitItf @child @lhs.kind of - Left e -> (Seq.singleton e, empty, empty) - Right (pat,expr) -> (Seq.empty, pat, expr) - - loc.useParallel = @lhs.useParallel && not @lhs.isLast - lhs.sem_steps = if @loc.useParallel -- assumes to be in a monadic do-expression - then @loc.addbang ("sync_" >|< @lhs.index) >#< "<- newEmptyMVar" - >-< "forkIO" >#< pp_parens (@loc.convToMonad >#< pp_parens @loc.exprPP >#< ">>= \\" >#< @loc.addbang (pp parResultName) >#< " -> putMVar sync_" >|< @lhs.index >#< parResultName) -- parResultName is guaranteed to be evaluated - else let decl = case @lhs.kind of - VisitPure _ -> @loc.patPP >#< "=" >#< @loc.exprPP - VisitMonadic -> @loc.patPP >#< "<-" >#< @loc.exprPP - in fmtDecl False @lhs.fmtMode decl - loc.convToMonad = case @loc.callKind of - VisitPure _ -> text "return" - VisitMonadic -> empty - loc.callKind = Map.findWithDefault (error "visit kind should be in the map") @visit @lhs.allVisitKinds - | Sim lhs.sem_steps = @steps.sem_steps >-< @steps.sync_steps - | PureGroup lhs.sem_steps = case @lhs.fmtMode of - FormatDo -> "let" >#< @steps.sem_steps -- formatted as a let-block (not a line-let) - _ -> @steps.sem_steps - -ATTR VisitSteps VisitStep [ | | sync_steps USE {>-<} {empty} : {PP_Doc} ] -SEM VisitStep | ChildVisit - lhs.sync_steps = if @loc.useParallel - then @loc.patPP >#< "<-" >#< "takeMVar sync_" >|< @lhs.index - else empty - --- The fmtMode indicates in what kind of expression (do/let/line-lets) we are printing --- declarations, because that determines how we need to wrap declarations --- Invariant: @lhs.kind == VisitMonadic ---> @lhs.fmtMode == FormatDo -ATTR VisitSteps VisitStep [ fmtMode : FormatMode | | ] -SEM Visit | Visit - steps.fmtMode = case @kind of - VisitPure False -> FormatLetDecl - VisitPure True -> FormatLetLine - VisitMonadic -> FormatDo - -SEM VisitStep | PureGroup - steps.fmtMode = case @lhs.fmtMode of - FormatDo -> FormatLetDecl - mode -> mode - -{ -parResultName :: String -parResultName = "__outcome_" - -fmtDecl :: PP a => Bool -> FormatMode -> a -> PP_Doc -fmtDecl declPure fmt decl = case fmt of - FormatLetDecl -> pp decl - FormatLetLine -> "let" >#< decl >#< "in" - FormatDo | declPure -> "let" >#< decl - | otherwise -> pp decl -} - --- --- Some properties of VisitStep(s) --- - --- Used arguments -ATTR VisitSteps VisitStep Visit Visits EChild EChildren ERule ERules [ | | usedArgs USE {`Set.union`} {Set.empty} : {Set String} ] -SEM ERule - | ERule +usedArgs = Set.union $ Map.keysSet $ Map.mapKeys (\a -> "arg_" ++ a) $ Map.filter isNothing @rhs.attrs - -SEM EChild - | EChild +usedArgs = \s -> case @kind of - ChildSyntax -> Set.insert ("arg_" ++ show @name ++ "_") s - _ -> s - - --- Number of steps in a 'Sim' block -ATTR VisitSteps [ | | size : Int ] -SEM VisitSteps - | Nil lhs.size = 0 - | Cons lhs.size = 1 + @tl.size - --- Number the steps in a 'Sim' block -ATTR VisitSteps VisitStep [ | index : Int | ] -SEM VisitSteps | Cons - hd.index = @lhs.index -- copy rule - tl.index = 1 + @lhs.index - lhs.index = @tl.index -- copy rule -SEM Visit | Visit steps.index = 0 -SEM VisitStep | Sim steps.index = 0 - lhs.index = @lhs.index -- needed for if we ever allow nested Sims - --- Biggest number of steps in previous blocks that used parallel invocation --- This number - 1 (minimum 0) is the number of references for parallel invocation created -ATTR VisitSteps VisitStep [ | prevMaxSimRefs : Int | ] -SEM Visit | Visit steps.prevMaxSimRefs = 0 -SEM VisitStep | Sim - lhs.prevMaxSimRefs = if @loc.useParallel - then @lhs.prevMaxSimRefs `max` (@steps.index - 1) -- possibly new references made - else @lhs.prevMaxSimRefs -- no references created - --- Is this the last step? -ATTR VisitSteps VisitStep [ | | isLast : Bool ] -ATTR VisitStep [ isLast : Bool | | ] -SEM VisitSteps - | Nil lhs.isLast = True - | Cons lhs.isLast = False - hd.isLast = @tl.isLast - --- Use parallel invocation: only when option enabled and there is more than one visit to a child -SEM VisitSteps VisitStep [ useParallel : Bool | | ] -SEM Visit | Visit steps.useParallel = False -SEM VisitStep | Sim loc.useParallel = parallelInvoke @lhs.options && @steps.size > 1 && @loc.isMonadic - loc.isMonadic = case @lhs.kind of - VisitMonadic -> True - _ -> False - - --- Child introduction -ATTR EChild EChildren [ | | childintros USE {`Map.union`} {Map.empty} : {Map Identifier (VisitKind -> FormatMode -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))} ] - -ATTR Visits Visit - VisitSteps VisitStep [ childintros : {Map Identifier (VisitKind -> FormatMode -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))} | | ] - -SEM EProduction - | EProduction visits.childintros = @children.childintros - -SEM EChild - | ETerm lhs.childintros = Map.singleton @name (\_ _ -> Right (empty, Set.empty, Map.empty)) - | EChild lhs.childintros = Map.singleton @name @loc.introcode - loc.isDefor = case @tp of - NT _ _ defor -> defor - _ -> False - loc.valcode = case @kind of - ChildSyntax -> "arg_" >|< @name >|< "_" - ChildAttr -> -- decide if we need to invoke the sem-function under the hood - let prefix | not @loc.isDefor = if lateHigherOrderBinding @lhs.options -- && sepsemmods @lhs.options -- when sepsemmods is not enabled, the indirection can be optimized away - then lateSemNtLabel @loc.nt >#< lhsname @lhs.options True idLateBindingAttr - else "sem_" >|< @loc.nt - | otherwise = empty -- no need to intro a terminal - in pp_parens (prefix >#< instname @name) - ChildReplace _ -> -- the higher-order attribute is actually a function that transforms - -- the semantics of the child (always deforested) - pp_parens (instname @name >#< @name >|< "_") - loc.aroundcode = if @hasAround - then locname @lhs.options @name >|< "_around" - else empty - loc.introcode = \kind fmtMode -> - let pat = text $ stname @name @loc.initSt - patStrict = @loc.addbang pat - attach = "attach_T_" >|< @loc.nt >#< pp_parens (@loc.aroundcode >#< @loc.valcode) - runAttach = unMon @lhs.options >#< pp_parens attach - decl = case kind of - VisitPure False -> pat >#< "=" >#< runAttach - VisitPure True -> patStrict >#< "=" >#< runAttach - VisitMonadic -> patStrict >#< "<-" >#< attach - in if compatibleAttach kind @loc.nt @lhs.options - then Right ( fmtDecl False fmtMode decl - , Set.singleton (stname @name @loc.initSt) -- variables defined by the child intro - , case @kind of -- variables used by the child introduction - ChildAttr -> Map.insert (instname @name) Nothing $ -- the sem attr - ( if @loc.isDefor || not (lateHigherOrderBinding @lhs.options) - then id -- the sem dictionary attr is not used - else Map.insert (lhsname @lhs.options True idLateBindingAttr) (Just $ AttrInh _LHS idLateBindingAttr) - ) $ - ( if @hasAround - then Map.insert (locname @lhs.options (@name) ++ "_around") Nothing - else id - ) $ Map.empty - ChildReplace _ -> Map.singleton (instname @name) Nothing -- uses the transformation function - ChildSyntax -> Map.empty - ) - else Left $ IncompatibleAttachKind @name kind - loc.nt = extractNonterminal @tp - -{ -stname :: Identifier -> Int -> String -stname child st = "_" ++ getName child ++ "X" ++ show st - --- should actually return some conversion info -compatibleAttach :: VisitKind -> NontermIdent -> Options -> Bool -compatibleAttach _ _ _ = True - -unMon :: Options -> PP_Doc -unMon options - | parallelInvoke options = text "System.IO.Unsafe.unsafePerformIO" -- IO monad - | otherwise = text "Control.Monad.Identity.runIdentity" -- identity monad -} - --- rules -ATTR ERules ERule [ | | sem_rules USE {>-<} {empty} : {PP_Doc} - mrules USE {`Map.union`} {Map.empty} : {Map Identifier (VisitKind -> FormatMode -> Either Error PP_Doc)} ] - -SEM ERule | ERule - lhs.sem_rules = if @loc.used == 0 - then empty - else @loc.rulePragma >-< @loc.rulecode - loc.rulecode = ( if @loc.genpragma - then @loc.pragma -- this additional pragma *may* help to give some AG source location in the presence of - -- type errors in the rule. It will definitely not be precise, and may take some additional - -- source space, but let's see if it's worth it in practice. - else empty - ) - >-< @loc.lambda >#< @loc.scc - >-< indent ((column @rhs.pos - 2) `max` 2) - ( if @loc.genpragma - then @loc.pragma >-< @rhs.semfunc >-< @loc.endpragma - else @rhs.semfunc - ) - loc.rulePragma = ( let reallyInlineStr = "INLINE" - reallyNoInlineStr = "NOINLINE" - in if noInlinePragmas @lhs.options - then empty - else if @loc.used == 1 - then ppPragmaBinding reallyInlineStr @name -- always inline if used exactly once - else if helpInlining @lhs.options - then if not @explicit && @loc.used <= reallyOftenUsedThreshold - then ppPragmaBinding "INLINE[1]" @name -- inline if copy rule - else if @loc.used > ruleInlineThresholdSoft && @explicit -- noinline if it passes the threshold and is not a copy rule - then if @loc.used > ruleInlineThresholdHard - then ppPragmaBinding reallyNoInlineStr @name -- used too often: force ghc not to inline it - else if aggressiveInlinePragmas @lhs.options - then ppPragmaBinding "NOINLINE[2]" @name -- allow inlining but only late in the process - else ppNoInline @name - else if aggressiveInlinePragmas @lhs.options - then ppPragmaBinding "NOINLINE[1]" @name -- otherwise, let GHC decide (but do other inlining first) - else ppNoInline @name - else if not @explicit || @loc.used <= ruleInlineThresholdSoft - then ppPragmaBinding "NOINLINE[1]" @name -- otherwise, let GHC decide (but do other inlining first) - else ppNoInline @name - ) - loc.scc = if genCostCentres @lhs.options && @explicit && @pure && not (noPerRuleCostCentres @lhs.options) - then ppCostCentre (@name >|< "_" >|< line @rhs.pos >|< "_" >|< @lhs.nt >|< "_" >|< @lhs.con) - else empty - loc.pragma = "{-# LINE" >#< show (line @rhs.pos) >#< show (file @rhs.pos) >#< "#-}" - loc.endpragma = ppWithLineNr (\ln -> "{-# LINE " ++ show (ln+1) ++ " " ++ show @lhs.mainFile ++ "#-}") - loc.genpragma = genLinePragmas @lhs.options && @explicit && @loc.haspos - loc.haspos = line @rhs.pos > 0 && column @rhs.pos >= 0 && not (null (file @rhs.pos)) - - -- we generate a simple pattern binding because of overloading-resolving during the type inference process. - -- The types of the rules are not generalized (nor do we want that - rules are used in a single typing-context). - -- If overloading is resolved separately, it may not be clear which dictionaries to use. For that all rules have - -- to be considered together, which is done when we use simple pattern bindings with a lambda expression instead - -- of a function definition. - -- Note: we also ensure that all rules are lambda expressions, so that they are not made part of any closures - -- but are lambda-lifted instead. - loc.lambda = @name >#< "=" >#< "\\" >#< @loc.argPats >#< dummyPat @lhs.options (Map.null @rhs.attrs) >#< "->" - - loc.argPats = ppSpaced [ let match | str `Set.member` @lhs.lazyIntras = pp str - | otherwise = @loc.addbang1 (pp str) - in case mbAttr of - Just (AttrSyn child nm) | child == _LOC && not (noPerStateTypeSigs @lhs.options) -> - case Map.lookup nm @lhs.localAttrTypes of - Just tp -> pp_parens (pp_parens match >#< "::" >#< ppTp tp) - Nothing -> match - Just attr | not (noPerRuleTypeSigs @lhs.options) -> - case lookupAttrType attr @lhs.allInhmap @lhs.allSynmap @lhs.childTypes of - Just tpDoc -> pp_parens (pp_parens match >#< "::" >#< tpDoc) - Nothing -> match - _ -> match - | (str,mbAttr) <- Map.assocs @rhs.attrs - ] - loc.argExprs = ppSpaced [ case mbAttr of - Nothing -> "arg_" >|< str - _ -> text str - | (str,mbAttr) <- Map.assocs @rhs.attrs - ] - loc.stepcode = \kind fmtMode -> if kind `compatibleRule` @pure - then Right $ let oper | @pure = "=" - | otherwise = "<-" - decl = @pattern.sem_lhs >#< oper >#< @name >#< @loc.argExprs >#< dummyArg @lhs.options (Map.null @rhs.attrs) - tp = if @pure && not (noPerRuleTypeSigs @lhs.options) - then @pattern.attrTypes - else empty - in fmtDecl @pure fmtMode (tp >-< decl) - else Left $ IncompatibleRuleKind @name kind - - lhs.mrules = Map.singleton @name @loc.stepcode - -ATTR Expression [ | | tks : {[HsToken]} ] -SEM Expression - | Expression lhs.tks = @tks - -{ -dummyPat :: Options -> Bool -> PP_Doc -dummyPat opts noArgs - | not noArgs && tupleAsDummyToken opts = empty -- no unnecessary tuples - | tupleAsDummyToken opts = if strictDummyToken opts - then text "()" - else text "(_ :: ())" - | otherwise = let match | strictDummyToken opts = "!_" - | otherwise = "_" - in pp_parens (match >#< "::" >#< dummyType opts noArgs) - where match | strictDummyToken opts = "(!_)" - | otherwise = "_" - -dummyArg :: Options -> Bool -> PP_Doc -dummyArg opts noArgs - | not noArgs && tupleAsDummyToken opts = empty -- no unnecessary tuples - | tupleAsDummyToken opts = text "()" - | otherwise = text "GHC.Prim.realWorld#" - -dummyType :: Options -> Bool -> PP_Doc -dummyType opts noArgs - | not noArgs && tupleAsDummyToken opts = empty -- no unnecessary tuples - | tupleAsDummyToken opts = text "()" - | otherwise = text "(GHC.Prim.State# GHC.Prim.RealWorld)" -} - -{ --- rules are "deinlined" to prevent needless code duplication. --- if there is only a bit of duplication, we allow ghc to decide if it is worth it. --- if the duplication crosses this threshold, however, we tell ghc definitely not to inline it. -ruleInlineThresholdSoft :: Int -ruleInlineThresholdSoft = 3 - -ruleInlineThresholdHard :: Int -ruleInlineThresholdHard = 5 - -reallyOftenUsedThreshold :: Int -reallyOftenUsedThreshold = 12 -} - -ATTR Expression [ | | pos : {Pos} ] -SEM Expression | Expression lhs.pos = @pos - --- pattern and expression semantics -ATTR Pattern [ | | sem_lhs : { PP_Doc } ] -ATTR Patterns [ | | sem_lhs USE {:} {[]} : {[PP_Doc]} ] -ATTR Pattern Patterns [ | | ] - -SEM Pattern - | Alias loc.varPat = text $ attrname @lhs.options False @field @attr - loc.patExpr = if @pat.isUnderscore - then @loc.varPat - else @loc.varPat >|< "@" >|< @pat.sem_lhs - lhs.sem_lhs = @loc.addbang1 @loc.patExpr - | Product lhs.sem_lhs = @loc.addbang1 $ pp_block "(" ")" "," @pats.sem_lhs - | Constr lhs.sem_lhs = @loc.addbang1 $ pp_parens $ @name >#< hv_sp @pats.sem_lhs - | Underscore lhs.sem_lhs = text "_" - | Irrefutable lhs.sem_lhs = text "~" >|< pp_parens @pat.sem_lhs - --- Check if a pattern is just an underscore -ATTR Pattern [ | | isUnderscore:{Bool}] -SEM Pattern - | Constr lhs.isUnderscore = False - | Product lhs.isUnderscore = False - | Alias lhs.isUnderscore = False - | Underscore lhs.isUnderscore = True - --- Collect the attributes defined by a pattern -ATTR Pattern Patterns [ | | attrs USE {`Set.union`} {Set.empty} : {Set String} ] -SEM Pattern | Alias - lhs.attrs = Set.insert (attrname @lhs.options False @field @attr) @pat.attrs - --- All attribute types of this pattern -ATTR Pattern Patterns [ | | attrTypes USE {>-<} {empty} : {PP_Doc} ] -SEM Pattern | Alias - loc.mbTp = if @field == _LHS - then Map.lookup @attr @lhs.synmap - else if @field == _LOC - then Map.lookup @attr @lhs.localAttrTypes - else Nothing - lhs.attrTypes = maybe empty (\tp -> (attrname @lhs.options False @field @attr) >#< "::" >#< ppTp tp) @loc.mbTp - >-< @pat.attrTypes - --- Collect the attributes used by the right-hand side -ATTR HsToken Expression [ | | attrs USE {`Map.union`} {Map.empty} : {Map String (Maybe NonLocalAttr)} ] -SEM HsToken - | AGLocal lhs.attrs = Map.singleton (fieldname @var) Nothing - | AGField loc.mbAttr = if @field == _INST || @field == _FIELD || @field == _INST' - then Nothing -- should not be used in the first place - else Just $ mkNonLocalAttr (@field == _LHS) @field @attr - lhs.attrs = Map.singleton (attrname @lhs.options True @field @attr) @loc.mbAttr - -{ -data NonLocalAttr - = AttrInh Identifier Identifier - | AttrSyn Identifier Identifier deriving Show - -mkNonLocalAttr :: Bool -> Identifier -> Identifier -> NonLocalAttr -mkNonLocalAttr True = AttrInh -- True: inherited attr -mkNonLocalAttr False = AttrSyn - -lookupAttrType :: NonLocalAttr -> Map Identifier Attributes -> Map Identifier Attributes -> Map Identifier Type -> Maybe PP_Doc -lookupAttrType (AttrInh child name) inhs _ = lookupType child name inhs -lookupAttrType (AttrSyn child name) _ syns = lookupType child name syns - --- Note: if the child takes type parameters, the type of an attribute of this child may refer to these parameters. This means that --- the actual type of the attribute needs to have its type parameters substituted with the actual type argument of the child. --- However, for now we simply decide to return Nothing in this case, which skips the type annotation. -lookupType :: Identifier -> Identifier -> Map Identifier Attributes -> Map Identifier Type -> Maybe PP_Doc -lookupType child name attrMp childMp - | noParameters childTp = Just ppDoc - | otherwise = Nothing - where - attrTp = Map.findWithDefault (error "lookupType: the attribute is not in the attrs of the child") name childAttrs - childAttrs = Map.findWithDefault (error "lookupType: the attributes of the nonterm are not in the map") nonterm attrMp - nonterm = extractNonterminal childTp - childTp = Map.findWithDefault (error ("lookupType: the child " ++ show child ++ "is not in the appropriate map")) child childMp - ppDoc = ppTp attrTp - -noParameters :: Type -> Bool -noParameters (Haskell _) = True -noParameters (NT _ args _) = null args -} - -ATTR Expression [ | | semfunc : {PP_Doc} ] - -SEM Expression - | Expression lhs.attrs = Map.unions $ map (\tok -> attrs_Syn_HsToken (wrap_HsToken (sem_HsToken tok) @loc.inhhstoken)) @tks - lhs.semfunc = vlist $ showTokens $ map (\tok -> tok_Syn_HsToken (wrap_HsToken (sem_HsToken tok) @loc.inhhstoken)) @tks - loc.inhhstoken = Inh_HsToken @lhs.options - --- child visit map -ATTR Visit - Visits - EProduction - EProductions - ENonterminal - ENonterminals [ allchildvisit : {Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))} - | | childvisit USE {`Map.union`} {Map.empty} : {Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))} ] - -ATTR VisitSteps VisitStep [ allchildvisit : {Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))} | | ] - -SEM ExecutionPlan - | ExecutionPlan nonts.allchildvisit = @nonts.childvisit - -SEM Visit - | Visit - loc.prevVisitInfo = Map.findWithDefault ManyVis @from @lhs.nextVisits - lhs.childvisit = Map.singleton @ident @loc.invokecode - loc.invokecode = \chn kind -> -- "chn" is the name of the child at the place of invocation, and "kind" the kind of the calling visit - if kind `compatibleKind` @kind - then Right $ - let pat | isLazyKind @kind = pat0 - | otherwise = @loc.addbang pat0 - pat0 = pp_parens pat1 - pat1 = @loc.nameTOut_visit >#< (ppSpaced $ map (attrname @lhs.options True chn) $ Set.toList @syn) - >#< cont - cont = case @loc.nextVisitInfo of - NoneVis -> empty - _ -> ch1 - ch0 = text $ stname chn @from - ch1 = text $ stname chn @to - expr = case (kind, @kind) of - (VisitPure _, VisitPure _) -> expr0 - (VisitPure _, VisitMonadic) -> unMon @lhs.options >#< expr0 - (VisitMonadic, VisitPure _) -> "return" >#< expr0 - (VisitMonadic, VisitMonadic) -> expr0 - expr0 = case @loc.prevVisitInfo of - NoneVis -> error "error: invocation of a visit from a state that has no next visits" - OneVis _ -> "inv_" >|< @lhs.nt >|< "_s" >|< @from >#< ch0 >#< args - ManyVis -> "inv_" >|< @lhs.nt >|< "_s" >|< @from >#< ch0 - >#< "K_" >|< @lhs.nt >|< "_v" >|< @ident >#< args - args = pp_parens args0 >#< args1 - args0 = @loc.nameTIn_visit >#< @loc.inhargs chn - args1 | dummyTokenVisit @lhs.options = pp $ dummyArg @lhs.options True - | otherwise = empty - in (pat, expr) -- pretty print of the pattern and the expression part - else Left $ IncompatibleVisitKind chn @ident kind @kind - -{ --- a `compatibleKind` b means: can kind b be invoked from a -compatibleKind :: VisitKind -> VisitKind -> Bool -compatibleKind _ _ = True - -compatibleRule :: VisitKind -> Bool -> Bool -compatibleRule (VisitPure _) False = False -compatibleRule _ _ = True -} - -------------------------------------------------------------------------------- --- Properties of rules -------------------------------------------------------------------------------- - --- Construct an environment that counts how often certain rules are used -ATTR Visits Visit VisitSteps VisitStep [ | | ruleUsage USE {`unionWithSum`} {Map.empty} : {Map Identifier Int} ] -ATTR ERules ERule [ usageInfo : {Map Identifier Int} | | ] - -SEM EProduction | EProduction rules.usageInfo = @visits.ruleUsage -SEM VisitStep | Sem lhs.ruleUsage = Map.singleton @name 1 -SEM ERule | ERule loc.used = Map.findWithDefault 0 @name @lhs.usageInfo - -{ -unionWithSum = Map.unionWith (+) -} - --- Collect in what visit-kinds a rule is used -ATTR Visits Visit VisitSteps VisitStep [ | | ruleKinds USE {`unionWithMappend`} {Map.empty} : {Map Identifier (Set VisitKind)} ] -SEM VisitStep | Sem - lhs.ruleKinds = Map.singleton @name (Set.singleton @lhs.kind) - -ATTR ERules ERule [ ruleKinds : {Map Identifier (Set VisitKind)} | | ] -SEM EProduction | EProduction - rules.ruleKinds = @visits.ruleKinds - -SEM ERule | ERule - loc.kinds = Map.findWithDefault Set.empty @name @lhs.ruleKinds - loc.anyLazyKind = Set.fold (\k r -> isLazyKind k || r) False @loc.kinds - -ATTR Pattern Patterns [ anyLazyKind : Bool | | ] - - -------------------------------------------------------------------------------- --- Intra attributes -------------------------------------------------------------------------------- -{ -uwSetUnion :: (Ord a, Ord b) => Map a (Set b) -> Map a (Set b) -> Map a (Set b) -uwSetUnion = Map.unionWith Set.union - -uwMapUnion :: (Ord a, Ord b) => Map a (Map b c) -> Map a (Map b c) -> Map a (Map b c) -uwMapUnion = Map.unionWith Map.union -} -ATTR Visit Visits [ allintramap : {Map StateIdentifier (Map String (Maybe NonLocalAttr))} - | | intramap USE {`uwMapUnion`} {Map.empty} : {Map StateIdentifier (Map String (Maybe NonLocalAttr))} ] - -ATTR Visit Visits [ terminaldefs : {Set String} | | ] -ATTR EChild EChildren [ | | terminaldefs USE {`Set.union`} {Set.empty} : {Set String} ] - -SEM EChild | ETerm - lhs.terminaldefs = Set.singleton $ fieldname @name - -SEM EProduction | EProduction - visits.allintramap = @visits.intramap - visits.terminaldefs = @children.terminaldefs - -SEM Visit - | Visit loc.thisintra = (@loc.uses `Map.union` @loc.nextintra) `Map.difference` @loc.defsAsMap - lhs.intramap = Map.singleton @from @loc.thisintra - loc.nextintra = maybe Map.empty id $ Map.lookup @to @lhs.allintramap - loc.uses = let mp1 = @steps.uses - mp2 = Map.fromList [ (lhsname @lhs.options False i, Just (AttrSyn _LHS i)) | i <- Set.elems @syn ] - in mp1 `Map.union` mp2 - loc.inhVarNms = Set.map (lhsname @lhs.options True) @inh - loc.defs = @steps.defs `Set.union` @loc.inhVarNms `Set.union` @lhs.terminaldefs - loc.defsAsMap = Map.fromList [ (a, Nothing) | a <- Set.elems @loc.defs ] - -ATTR ERule ERules [ | | ruledefs USE {`uwSetUnion`} {Map.empty} : {Map Identifier (Set String)} - ruleuses USE {`uwMapUnion`} {Map.empty} : {Map Identifier (Map String (Maybe NonLocalAttr))} ] -ATTR Visit Visits - VisitSteps VisitStep [ ruledefs : {Map Identifier (Set String)} - ruleuses : {Map Identifier (Map String (Maybe NonLocalAttr))} | | ] - -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 VisitIdentifier (Set Identifier)} - visituses USE {`uwSetUnion`} {Map.empty} : {Map VisitIdentifier (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 VisitIdentifier (Set Identifier)} - avisituses : {Map VisitIdentifier (Set Identifier)} | | ] - -SEM ExecutionPlan - | ExecutionPlan nonts.avisitdefs = @nonts.visitdefs - nonts.avisituses = @nonts.visituses - -ATTR VisitSteps VisitStep [ | | defs USE {`Set.union`} {Set.empty} : {Set String} - uses USE {`Map.union`} {Map.empty} : {Map String (Maybe NonLocalAttr)} ] -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 - | ChildVisit lhs.defs = Set.insert (stname @child @to) $ maybe (error "Visit not found") (Set.map $ attrname @lhs.options True @child) $ Map.lookup @visit @lhs.avisitdefs - lhs.uses = let convert attrs = Map.fromList [ (attrname @lhs.options False @child attr, Just $ mkNonLocalAttr True @child attr) | attr <- Set.elems attrs ] - in Map.insert (stname @child @from) Nothing $ convert $ - maybe (error "Visit not found") id $ Map.lookup @visit @lhs.avisituses - -------------------------------------------------------------------------------- --- Identification of lazy intra defs within a production --- --- These identifiers will not be marked as strict in rules and state closures -------------------------------------------------------------------------------- - -ATTR Visits Visit VisitSteps VisitStep [ | | lazyIntras USE {`Set.union`} {Set.empty} : {Set String} ] -ATTR ERules ERule [ lazyIntras : {Set String} | | ] - -SEM Visit | Visit - loc.lazyIntrasInh = case @kind of - VisitPure False -> @loc.inhVarNms `Set.union` @steps.defs - _ -> Set.empty - lhs.lazyIntras = @loc.lazyIntrasInh `Set.union` @steps.lazyIntras - -SEM VisitStep | PureGroup - lhs.lazyIntras = if @ordered - then @steps.lazyIntras - else @steps.defs - -SEM EProduction | EProduction - loc.lazyIntras = @visits.lazyIntras - -------------------------------------------------------------------------------- --- 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,fieldname @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 @lhs.options 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 [ mainBlocksDoc : PP_Doc textBlockMap : {Map BlockInfo PP_Doc} - | | genIO : {IO ()} ] - -SEM ExecutionPlan - | ExecutionPlan lhs.genIO = do @loc.genMainModule - @loc.genCommonModule - @nonts.genProdIO - loc.mainModuleFile = @lhs.mainFile - loc.ppMonadImports = ( if tupleAsDummyToken @lhs.options - then empty - else pp "import GHC.Prim" - ) - >-< if parallelInvoke @lhs.options - then pp "import qualified System.IO.Unsafe(unsafePerformIO)" - >-< pp "import System.IO(IO)" - >-< pp "import Control.Concurrent(newEmptyMVar,forkIO,putMVar,takeMVar)" - else pp "import Control.Monad.Identity" - loc.genMainModule = writeModule @loc.mainModuleFile - ( [ warrenFlagsPP @lhs.options - , pp $ @lhs.pragmaBlocks - , pp $ @lhs.moduleHeader @lhs.mainName "" "" False - , @loc.ppMonadImports - , pp $ "import " ++ @lhs.mainName ++ "_common" - ] - ++ @nonts.imports - ++ [@lhs.mainBlocksDoc] - ++ [@loc.wrappersExtra] - ++ @nonts.appendMain - ) - loc.commonFile = replaceBaseName @lhs.mainFile (takeBaseName @lhs.mainFile ++ "_common") - loc.genCommonModule = writeModule @loc.commonFile - ( [ pp $ "{-# LANGUAGE Rank2Types, GADTs #-}" -- the common module only needs GADTs and Rank2Types - , pp $ @lhs.pragmaBlocks - , pp $ @lhs.moduleHeader @lhs.mainName "_common" "" True - , @loc.ppMonadImports - , @lhs.importBlocks - , @lhs.textBlocks - , @loc.commonExtra - ] - ++ @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 = replaceBaseName @lhs.mainFile (takeBaseName @lhs.mainFile ++ @loc.suffix) - loc.ppMonadImports = if parallelInvoke @lhs.options - then pp "import qualified System.IO.Unsafe(unsafePerformIO)" - >-< pp "import System.IO(IO)" - >-< pp "import Control.Concurrent(newEmptyMVar,forkIO,putMVar,takeMVar)" - else pp "import Control.Monad.Identity" - lhs.genProdIO = writeModule @loc.outputfile - [ warrenFlagsPP @lhs.options - , pp $ @lhs.pragmaBlocks - , pp $ @lhs.moduleHeader @lhs.mainName @loc.suffix @loc.semname True - , @lhs.importBlocks - , @loc.ppMonadImports - , ( if tupleAsDummyToken @lhs.options - then empty - else pp "import GHC.Prim" -- need it to pass State# - ) - , 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 -} - - --- --- Bang pattern usage --- - -SEM ERule | ERule loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x -SEM Visit | Visit loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x -SEM ENonterminal | ENonterminal loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x -SEM EProduction | EProduction loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x -SEM EChild | EChild loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x -SEM EChild | ETerm loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x -SEM VisitStep | ChildVisit loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x -SEM Pattern | Alias Constr Product loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x - -SEM Visit | Visit loc.addbang1 = if isLazyKind @kind then id else @loc.addbang -SEM ENonterminal | ENonterminal loc.addbangWrap = id --if strictWrap @lhs.options then @loc.addbang else id -SEM ERule | ERule loc.addbang1 = if @loc.anyLazyKind then id else @loc.addbang -SEM Pattern | Alias Constr Product loc.addbang1 = if @lhs.anyLazyKind then id else @loc.addbang - --- --- Distribute single-visit-next map downward --- - -ATTR EProductions EProduction Visits Visit - [ prevVisits, nextVisits : {Map StateIdentifier StateCtx} | | ] - -SEM ENonterminal | ENonterminal - prods.nextVisits = @nextVisits - prods.prevVisits = @prevVisits - --- --- Collect and distribute the from/to states of a visit --- - -ATTR ENonterminals ENonterminal EProductions EProduction Visits Visit - [ | | fromToStates USE {`mappend`} {mempty} : {Map VisitIdentifier (Int,Int)} ] - -ATTR ENonterminals ENonterminal EProductions EProduction Visits Visit VisitSteps VisitStep - [ allFromToStates : {Map VisitIdentifier (Int,Int)} | | ] - -SEM Visit | Visit - lhs.fromToStates = Map.singleton @ident (@from, @to) - -SEM ExecutionPlan | ExecutionPlan - nonts.allFromToStates = @nonts.fromToStates - -SEM VisitStep | ChildVisit - (loc.from, loc.to) = Map.findWithDefault (error "visit not in allFromToStates") @visit @lhs.allFromToStates - - --- --- Collect and distribute the actual types of children of productions --- - -ATTR EChildren EChild [ | | childTypes USE {`mappend`} {mempty} : {Map Identifier Type} ] -ATTR ERules ERule Visits Visit VisitSteps VisitStep [ childTypes : {Map Identifier Type} | | ] - -SEM EProduction | EProduction - loc.childTypes = Map.singleton _LHS @lhs.ntType `Map.union` @children.childTypes - -SEM EChild | EChild ETerm - lhs.childTypes = Map.singleton @name @tp - --- --- Distribute types of local attributes --- - -ATTR ExecutionPlan ENonterminals ENonterminal [ localAttrTypes : {Map NontermIdent (Map ConstructorIdent (Map Identifier Type))} | | ] -ATTR EProductions EProduction [ localAttrTypes : {Map ConstructorIdent (Map Identifier Type)} | | ] -ATTR ERules ERule Pattern Patterns [ localAttrTypes : {Map Identifier Type} | | ] - -SEM ENonterminal | ENonterminal - prods.localAttrTypes = Map.findWithDefault Map.empty @nt @lhs.localAttrTypes - -SEM EProduction | EProduction - loc.localAttrTypes = Map.findWithDefault Map.empty @con @lhs.localAttrTypes - --- --- Collect and distribute visit kinds --- - -ATTR ENonterminals ENonterminal EProductions EProduction Visits Visit VisitSteps VisitStep - [ allVisitKinds : {Map VisitIdentifier VisitKind} | | visitKinds USE {`mappend`} {mempty} : {Map VisitIdentifier VisitKind} ] - -SEM Visit | Visit - lhs.visitKinds = Map.singleton @ident @kind - -SEM ExecutionPlan | ExecutionPlan - nonts.allVisitKinds = @nonts.visitKinds - --- --- Collect and distribute the initial state of nonterminals --- - -ATTR ENonterminals ENonterminal [ | | initStates USE {`mappend`} {mempty} : {Map NontermIdent Int} ] -ATTR ENonterminals ENonterminal EProductions EProduction EChildren EChild Visits Visit VisitSteps VisitStep - [ allInitStates : {Map NontermIdent Int} | | ] - -SEM ENonterminal | ENonterminal - lhs.initStates = Map.singleton @nt @initial - -SEM ExecutionPlan | ExecutionPlan - nonts.allInitStates = @nonts.initStates - -SEM EChild | EChild - loc.initSt = Map.findWithDefault (error "nonterminal not in allInitStates map") @loc.nt @lhs.allInitStates - --- --- Push the nonterminal type downward --- - -ATTR EProductions EProduction [ ntType : Type | | ] -SEM ENonterminal | ENonterminal - loc.ntType = NT @nt (map show @params) False - --- --- Collect errors contained in rules that should be yielded when the --- rules are scheduled. --- - -ATTR ExecutionPlan ENonterminals ENonterminal EProductions EProduction ERules ERule Visits Visit VisitSteps VisitStep [ | | errors USE {Seq.><} {Seq.empty} : {Seq Error} ] -SEM ERule | ERule - lhs.errors = case @mbError of - Just e | @loc.used > 0 -> Seq.singleton e - _ -> Seq.empty - - --- Some pretty printing utility functions -{ -ppNoInline :: PP a => a -> PP_Doc -ppNoInline = ppPragmaBinding "NOINLINE" - -ppInline :: PP a => a -> PP_Doc -ppInline = ppPragmaBinding "INLINE" - -ppInlinable :: PP a => a -> PP_Doc -ppInlinable = ppPragmaBinding "INLINABLE" - -ppPragmaBinding :: (PP a, PP b) => a -> b -> PP_Doc -ppPragmaBinding pragma nm = "{-#" >#< pragma >#< nm >#< "#-}" - -ppCostCentre :: PP a => a -> PP_Doc -ppCostCentre nm = "{-#" >#< "SCC" >#< "\"" >|< nm >|< "\"" >#< "#-}" - -warrenFlagsPP :: Options -> PP_Doc -warrenFlagsPP options = vlist - [ pp "{-# LANGUAGE Rank2Types, GADTs #-}" - , if bangpats options - then pp "{-# LANGUAGE BangPatterns #-}" - else empty - , if noPerRuleTypeSigs options && noPerStateTypeSigs options - then empty - else pp "{-# LANGUAGE ScopedTypeVariables #-}" - , if tupleAsDummyToken options - then empty - else pp "{-# LANGUAGE ScopedTypeVariables, MagicHash #-}" - , -- not that the meaning of "unbox" is here that strict fields in data types may be - -- unboxed if possible. This may affect user-defined data types declared in the module. - -- Unfortunately, we cannot turn it on for only the AG generated data types without - -- causing a zillion of warnings. - if unbox options && bangpats options - then pp $ "{-# OPTIONS_GHC -funbox-strict-fields -fstrictness #-}" - else empty - , if parallelInvoke options && not (noEagerBlackholing options) - then pp $ "{-# OPTIONS_GHC -feager-blackholing #-}" - else empty - ] -} diff --git a/src-ag/Expression.ag b/src-ag/Expression.ag deleted file mode 100644 --- a/src-ag/Expression.ag +++ /dev/null @@ -1,12 +0,0 @@ -imports -{ -import UU.Scanner.Position(Pos) -import HsToken -} - -DATA Expression - | Expression pos:{Pos} - tks:{[HsToken]} - -SET AllExpression - = Expression diff --git a/src-ag/GenerateCode.ag b/src-ag/GenerateCode.ag deleted file mode 100644 --- a/src-ag/GenerateCode.ag +++ /dev/null @@ -1,1187 +0,0 @@ -PRAGMA strictwrap -PRAGMA strictdata - -INCLUDE "CodeSyntax.ag" -INCLUDE "Patterns.ag" -INCLUDE "DeclBlocks.ag" - -imports -{ -import CommonTypes -import SequentialTypes -import Code hiding (Type) -import qualified Code -import Options -import CodeSyntax -import ErrorMessages -import GrammarInfo -import DeclBlocks - -import qualified Data.Map as Map -import Data.Map(Map) -import qualified Data.Set as Set -import Data.Set(Set) -import qualified Data.Sequence as Seq -import Data.Sequence(Seq) -import UU.Scanner.Position -import TokenDef -import HsToken -import HsTokenScanner - -import Data.List(partition,intersperse) -import Data.Maybe(fromJust,isJust) - -} - - -------------------------------------------------------------------------------- --- Options -------------------------------------------------------------------------------- - -ATTR CNonterminals CNonterminal - CProductions CProduction - CVisits CVisit - Sequence CRule - CInterface CSegments CSegment - [ o_unbox,o_sig,o_sem,o_newtypes,o_case,o_pretty,o_rename,o_cata,o_strictwrap,o_splitsems,o_traces,o_costcentre,o_linePragmas,o_monadic,o_clean : Bool - o_data : {Maybe Bool} - prefix : String - options : Options - | | ] -SEM CGrammar [ options : Options | | ] - | CGrammar nonts.o_sig = typeSigs @lhs.options - .o_cata = folds @lhs.options - .o_sem = semfuns @lhs.options - .o_newtypes = newtypes @lhs.options - .o_unbox = unbox @lhs.options - .o_case = cases @lhs.options - .o_pretty = attrInfo @lhs.options - .o_rename = rename @lhs.options - .o_strictwrap = strictWrap @lhs.options - .o_splitsems = splitSems @lhs.options - .o_data = if dataTypes @lhs.options then Just (strictData @lhs.options) else Nothing - .prefix = prefix @lhs.options - .o_traces = genTraces @lhs.options - .o_costcentre = genCostCentres @lhs.options - .o_linePragmas = genLinePragmas @lhs.options - .o_monadic = monadic @lhs.options - .o_clean = clean @lhs.options - -SEM CGrammar | CGrammar - loc.options = @lhs.options { breadthFirst = breadthFirst @lhs.options && visit @lhs.options && cases @lhs.options && @multivisit } - -ATTR CNonterminals CNonterminal CProductions CProduction CVisits CVisit [ allPragmas : PragmaMap | | ] - -SEM CGrammar - | CGrammar nonts.allPragmas = @pragmas - -------------------------------------------------------------------------------- --- Passing information about nonterminal and constructor down -------------------------------------------------------------------------------- - -ATTR CProductions CProduction CVisits - CVisit Sequence CRule CInterface - CSegments CSegment [ nt:NontermIdent inh,syn:Attributes | | ] -SEM CNonterminal - | CNonterminal inter.(inh,syn,nt) = (@inh,@syn,@nt) - prods.(inh,syn,nt) = (@inh,@syn,@nt) - -ATTR CVisits CVisit Sequence CRule [ con:ConstructorIdent - terminals : {[Identifier]} | | ] -SEM CProduction - | CProduction visits.con = @con - visits.terminals = @terminals - -ATTR CNonterminals CNonterminal CSegments CSegment CInterface CProductions CProduction CVisits CVisit Sequence CRule [ paramMap : ParamMap | | ] - -SEM CGrammar - | CGrammar nonts.paramMap = @paramMap - - -ATTR CVisits CVisit Sequence CRule [ paramInstMap : {Map Identifier (NontermIdent, [String])} | | ] - -SEM CProduction - | CProduction - loc.paramInstMap = Map.fromList [(nm, (extractNonterminal tp, tps)) | (nm,tp,_) <- @children, let tps = map (cleanupArg @lhs.options) $ nontermArgs tp, not (null tps) ] - -{ --- remove possible @v references in the types of a data type. -cleanupArg :: Options -> String -> String -cleanupArg opts s - = case idEvalType opts (SimpleType s) of - SimpleType s' -> s' - _ -> error "Only SimpleType supported" -} - -ATTR CNonterminals CNonterminal CProductions CProduction CVisits CVisit [ contextMap : {ContextMap} quantMap : QuantMap | | ] - -SEM CGrammar - | CGrammar - nonts.contextMap = @contextMap - nonts.quantMap = @quantMap - -{ -appContext :: ContextMap -> NontermIdent -> Code.Type -> Code.Type -appContext mp nt tp - = maybe tp (\ctx -> CtxApp (map (\(n,ns) -> (getName n, ns)) ctx) tp) $ Map.lookup nt mp - -appQuant :: QuantMap -> NontermIdent -> Code.Type -> Code.Type -appQuant mp nt tp - = foldr QuantApp tp $ Map.findWithDefault [] nt mp -} - -ATTR CNonterminals CNonterminal CProductions CProduction CVisits CVisit Sequence CRule [ allNts : {Set NontermIdent} | | ] - -SEM CGrammar - | CGrammar - nonts.allNts = @nonts.gathNts - -ATTR CNonterminals CNonterminal [ | | gathNts USE {`Set.union`} {Set.empty} : {Set NontermIdent} ] - -SEM CNonterminal - | CNonterminal - lhs.gathNts = Set.singleton @nt - --- keep track of which children have had their first visit -ATTR CVisits CVisit Sequence CRule [ | visitedSet : {Set Identifier} | ] -SEM CProduction | CProduction visits.visitedSet = Set.empty -SEM CRule | CChildVisit loc.visitedSet = Set.insert @name @lhs.visitedSet - -------------------------------------------------------------------------------- --- Generating declarations from the sequence. We generate the origin --- comment if pretty printing is requested. A childvisit takes inherited --- attributes and returns synthesized attributes and the next visit. -------------------------------------------------------------------------------- - -ATTR Sequence CRule [ | | decls USE {++} {[]} : {Decls} ] -SEM CRule - | CRule loc.instTypes = [ (n, (t, mb, for)) | (n, NT t _ for, mb) <- @lhs.children ] - loc.originComment = if @lhs.o_pretty - then (Comment @origin:) - else id - loc.instDecls = [ mkDecl @lhs.o_monadic (Pattern3 (Alias _INST' inst (Underscore (getPos inst)))) - ( let (nm,mb,defor) = fromJust $ inst `lookup` @loc.instTypes - in unwrapSem @lhs.o_newtypes nm - $ case mb of - ChildReplace _ -> App instLocFieldName [SimpleExpr $ fieldname inst] - _ -> - if defor - then SimpleExpr instLocFieldName - else App (cataname @lhs.prefix nm) - [SimpleExpr instLocFieldName] - ) - (Set.singleton instSemFieldName) - (Set.singleton instLocFieldName) - | inst <- @loc.definedInsts - , let instLocFieldName = attrname @lhs.options True _INST inst - instSemFieldName = attrname @lhs.options False _INST' inst - ] - loc.patDescr = if @isIn - then "_" - else concat $ intersperse "," (map (\(f,a) -> show f ++ "." ++ show a) @pattern.patternAttributes) - loc.traceDescr = (maybe "" (\nm -> show nm ++ ":") @mbNamed) ++ show @nt ++ " :: " ++ show @con ++ " :: " ++ @loc.patDescr - - loc.addTrace = \v -> if @lhs.o_traces - then Trace @loc.traceDescr v - else v - loc.costCentreDescr = show @nt ++ ":" ++ show @con ++ ":" ++ @loc.patDescr - loc.addCostCentre = \v -> if @lhs.o_costcentre - then PragmaExpr True False ("SCC \"" ++ @loc.costCentreDescr ++ "\"") v - else v - loc.addLinePragma = \v -> let p = getPos @name - hasPos = line p > 0 && column p >= 0 && not (null (file p)) - in if @lhs.o_linePragmas && hasPos - then PragmaExpr True True ("LINE " ++ show (line p) ++ " " ++ show (file p)) - $ LineExpr - $ v - else v - loc.decls = if @hasCode - then @originComment ( mkDecl (@lhs.o_monadic && @explicit) (Pattern3 @pattern.copy) (@loc.addTrace $ @loc.addCostCentre $ @loc.addLinePragma $ (TextExpr @rhs)) - (Set.fromList [attrname @lhs.options False fld nm | (fld,nm,_) <- Map.elems @defines]) - (Set.fromList [attrname @lhs.options True fld nm | (fld,nm) <- Set.toList @uses]) - : @loc.instDecls) - else @loc.instDecls - | CChildVisit loc.costCentreDescr = show @lhs.nt ++ ":" ++ show @lhs.con ++ ":" ++ show @name ++ ":" ++ show @nt ++ ":" ++ show @nr - loc.addCostCentre = \v -> if @lhs.o_costcentre - then PragmaExpr True False ("SCC \"" ++ @loc.costCentreDescr ++ "\"") v - else v - loc.decls = let lhsVars = map (attrname @lhs.options True @name) (Map.keys @syn) - ++ if @isLast then [] else [unwrap ++ funname @name (@nr+1)] - rhsVars = map (attrname @lhs.options False @name) (Map.keys @inh) - unwrap = if @lhs.o_newtypes then typeName @nt (@nr + 1) ++ " " else "" - tuple | isMerging = TupleLhs [locname @lhs.options @name ++ "_comp"] - | otherwise = mkTupleLhs @lhs.o_unbox (null $ Map.keys @inh) lhsVars - rhs = @loc.addCostCentre $ Code.InvokeExpr (typeName @nt @nr) (SimpleExpr fun) (map SimpleExpr rhsVars) - isVirtual _ [] = False - isVirtual nm ((n,_,kind) : r) - | nm == n = case kind of - ChildAttr -> True - _ -> False - | otherwise = isVirtual nm r - isMerged = @name `Map.member` @lhs.mergeMap - isMerging = @name `elem` concatMap (\(_,cs) -> cs) (Map.elems @lhs.mergeMap) - merges = [ (c,cs) | (c,(_,cs)) <- Map.assocs @lhs.mergeMap, all (`Set.member` @loc.visitedSet) cs, @name `elem` (c:cs) ] - - baseNm = if @nr == 0 && isVirtual @name @lhs.children - then Ident (getName @name ++ "_inst") (getPos @name) - else @name - fun | @nr == 0 && Set.member @name @lhs.aroundMap - = locname @lhs.options @name ++ "_around " ++ funname baseNm 0 - | otherwise = funname baseNm @nr - outDecls | isMerged = [] -- merged variant is only produced after the last visit of the merged children - | otherwise = -- [mkDecl @lhs.o_monadic tuple rhs (Set.fromList lhsVars) (Set.fromList (funname baseNm @nr : rhsVars))] - if isMerging - then [mkDecl @lhs.o_monadic tuple rhs Set.empty Set.empty] - else [Resume @lhs.o_monadic (typeName @nt @nr) tuple rhs] - outMerged | null merges || @nr /= 0 = [] -- no merged child to produce - | otherwise = let (c,cs) = head merges - tuple' = mkTupleLhs @lhs.o_unbox (null $ Map.keys @inh) lhsVars' - lhsVars' = map (attrname @lhs.options True c) (Map.keys @syn) - ++ if @isLast then [] else [unwrap ++ funname c (@nr+1)] - rhsVars' = [ locname @lhs.options c' ++ "_comp" | c' <- cs ] - fun' = locname @lhs.options c ++ "_merge" - rhs' = App fun' (map SimpleExpr rhsVars') - in [Resume @lhs.o_monadic (typeName @nt @nr) tuple' rhs'] - in -- trace (show @name ++ " # " ++ show @loc.visitedSet ++ " # " ++ show (Map.assocs @lhs.mergeMap) ++ " # " ++ show merges ++ " # " ++ show @nr ++ " # " ++ show (length outMerged)) $ - (outDecls ++ outMerged) - -{ -mkDecl :: Bool -> Lhs -> Expr -> Set String -> Set String -> Decl -mkDecl True lhs rhs _ _ = Bind lhs rhs -mkDecl False lhs rhs s1 s2 = Decl lhs rhs s1 s2 - -unwrapSem :: Bool -> NontermIdent -> Expr -> Expr -unwrapSem False _ e = e -unwrapSem True nm e = Case e alts - where alts = [CaseAlt left right] - left = Fun (typeName nm 0) [SimpleExpr "x"] - right = SimpleExpr "x" -} - -ATTR Sequence CRule [ children : {[(Identifier,Type,ChildKind)]} ||] - -ATTR Sequence CRule Pattern Patterns [|| definedInsts USE {++} {[]} : {[Identifier]} ] -SEM Pattern - | Alias lhs.definedInsts = (if @field == _INST then [@attr] else []) ++ @pat.definedInsts - -SEM CRule - | CRule loc.definedInsts = if @isIn then [] else @pattern.definedInsts - -ATTR Pattern Patterns [ | | patternAttributes USE {++} {[]} : {[(Identifier, Identifier)]} ] -SEM Pattern - | Alias - lhs.patternAttributes = (@field,@attr) : @pat.patternAttributes - -------------------------------------------------------------------------------- --- Numbering the visits -------------------------------------------------------------------------------- - -ATTR CVisits CVisit Sequence CRule - CSegments CSegment [ nr : Int | | ] -SEM CProduction - | CProduction visits.nr = 0 -SEM CVisits - | Cons tl.nr = @lhs.nr + 1 -SEM CInterface - | CInterface seg.nr = 0 -SEM CSegments - | Cons tl.nr = @lhs.nr + 1 - -------------------------------------------------------------------------------- --- Checking last visit -------------------------------------------------------------------------------- - -ATTR CVisit CSegment [ isLast : Bool | | ] -ATTR CVisits CSegments [ | | isNil : Bool ] -SEM CVisits - | Cons lhs.isNil = False - hd.isLast = @tl.isNil - | Nil lhs.isNil = True -SEM CSegments - | Cons lhs.isNil = False - hd.isLast = @tl.isNil - | Nil lhs.isNil = True - -------------------------------------------------------------------------------- --- Getting the next intra-visit dependencies -------------------------------------------------------------------------------- - -ATTR CVisit [ nextIntra : {Exprs} nextIntraVars : {Set String} | | ] -ATTR CVisits CVisit [ | | intra : {Exprs} intraVars : {Set String} ] -SEM CVisit - | CVisit lhs.intra = @intra.exprs - lhs.intraVars = @intra.usedVars -SEM CVisits - | Cons hd.nextIntra = @tl.intra - hd.nextIntraVars = @tl.intraVars - lhs.intra = @hd.intra - lhs.intraVars = @hd.intraVars - | Nil lhs.intra = [] - lhs.intraVars = Set.empty - -------------------------------------------------------------------------------- --- Superfluous intra-visit dependencies due to higher-order children --- (higher-order children can only be passed from their moment of creation) -------------------------------------------------------------------------------- - -SEM CRule - | CChildVisit - loc.isSuperfluousHigherOrderIntra - = @lhs.nr <= Map.findWithDefault (-1) @name @lhs.instVisitNrs - -------------------------------------------------------------------------------- --- Intra-visit dependencies are expressions that need to be passed -------------------------------------------------------------------------------- - -ATTR Sequence CRule [ | | exprs USE {++} {[]} : {Exprs} ] -SEM CRule - | CRule loc.rulename = if @field == _LOC && @name `elem` @lhs.terminals - then funname @name 0 - else attrname @lhs.options @isIn @field @name - lhs.exprs = [SimpleExpr @loc.rulename] - | CChildVisit - loc.names = -- do not pass inst-childs as parameter if they are not defined yet - if @loc.isSuperfluousHigherOrderIntra - then [] - else [funname @name (@nr+1)] - lhs.exprs = let wrap = if @lhs.o_newtypes then \x -> App (typeName @nt (@nr + 1)) [x] else id - - addType expr | null @loc.instParams = expr - | otherwise = TypedExpr expr (@lhs.unfoldSemDom @nt (@nr+1) @loc.instParams) - - in map (wrap . addType . SimpleExpr) @loc.names - -ATTR Sequence CRule [ | | usedVars USE {`Set.union`} {Set.empty} : {Set String} ] -SEM CRule - | CRule - lhs.usedVars = Set.singleton @loc.rulename - | CChildVisit - lhs.usedVars = Set.fromList @loc.names - -------------------------------------------------------------------------------- --- Type signatures are added to the declarations. -------------------------------------------------------------------------------- - -ATTR Sequence CRule [ | | tSigs USE {++} {[]} : {[Decl]} ] -SEM CRule - | CRule loc.mkTp = typeToCodeType (Just @lhs.nt) @loc.orgParams - lhs.tSigs = [ TSig (attrname @lhs.options False field attr) tp' - | (field,attr,tp) <- Map.elems @defines, isJust tp - , let tp1 = @loc.evalTp field $ @mkTp (fromJust tp) - tp' = case findOrigType attr @lhs.children of - Just tp'' -> let tp2 = @loc.evalTp field $ @mkTp tp'' - in Arr tp2 tp1 - Nothing -> tp1 - findOrigType _ [] = Nothing - findOrigType nm ((n,_,kind) : r) - | nm == n = case kind of - ChildReplace orig -> Just orig - _ -> Nothing - | otherwise = findOrigType nm r - ] - - loc.orgParams = map getName $ Map.findWithDefault [] @lhs.nt @lhs.paramMap - loc.evalTp = - \field tp -> let orgFldParams = map getName $ Map.findWithDefault [] childNt @lhs.paramMap - (childNt,instParams) = Map.findWithDefault (@lhs.nt,[]) field @lhs.paramInstMap - replMap = Map.fromList (zip orgFldParams instParams) - replace k = Map.findWithDefault ('@':k) k replMap - in if null instParams - then if null @orgParams - then tp - else idEvalType @lhs.options tp - else evalType @lhs.options replace tp - - | CChildVisit loc.mkTp = @loc.evalTp . typeToCodeType (Just @nt) @loc.orgParams - loc.definedTps = [ TSig (attrname @lhs.options True @name a) (@mkTp tp) | (a,tp) <- Map.toList @syn ] - loc.nextTp = typeName @nt (@nr+1) - lhs.tSigs = (if @isLast then id else (TSig (funname @name (@nr+1)) (TypeApp (SimpleType @nextTp) (map SimpleType @loc.instParams)) :)) @definedTps - - loc.orgParams = map getName $ Map.findWithDefault [] @nt @lhs.paramMap - loc.instParams = snd $ Map.findWithDefault (@nt,[]) @name @lhs.paramInstMap - loc.replParamMap = Map.fromList (zip @loc.orgParams @loc.instParams) - loc.replace = \k -> Map.findWithDefault k k @loc.replParamMap - loc.evalTp = if null @loc.orgParams then id else evalType @lhs.options @loc.replace - - -------------------------------------------------------------------------------- --- Types of intra-visit dependencies are needed in the type of the --- semantic function. -------------------------------------------------------------------------------- - -ATTR CVisits CVisit [ children : {[(Identifier,Type, ChildKind)]} | | ] -SEM CProduction - | CProduction visits.children = @children - - -ATTR Sequence CRule [ | | tps USE {++} {[]} : {[Type]} - allTpsFound USE {&&} {True} : Bool ] -SEM CRule - | CRule lhs.(tps,allTpsFound) = maybe ([],False) (\tp -> ([tp],True)) @tp - | CChildVisit lhs.tps = if @loc.isSuperfluousHigherOrderIntra - then [] - else [NT (ntOfVisit @nt (@nr+1)) @loc.instParams False] - -------------------------------------------------------------------------------- --- Each visit has its semantic function -------------------------------------------------------------------------------- - -ATTR CVisits [ | | decls : {Decls} ] -ATTR CVisit [ | decls : {Decls} | ] -SEM CVisits - | Nil lhs.decls = [] - | Cons lhs.decls = @hd.decls - hd.decls = @tl.decls - --- Note: lhs.decls are the decls related to the next visit function. We pass it --- chained from right to left in order to build the next visit function inside --- the previous one. --- Note: intra decls are ignored. The intra-visit variables are not passed on --- explicitly, but handled automatically due to nesting level. - -SEM CVisit - | CVisit (loc.higherOrderChildren,loc.firstOrderChildren) = partition (\(_,_,virt) -> isHigherOrder virt) @lhs.children - loc.firstOrderOrig = map pickOrigType @loc.firstOrderChildren - loc.funcname = seqSemname @lhs.prefix @lhs.nt @lhs.con @lhs.nr - loc.nextVisitName = if @lhs.isLast then [] else [visitname @lhs.prefix @lhs.nt (@lhs.nr+1)] - loc.nextVisitDecl = let lhs = TupleLhs @nextVisitName - -- rhs = App fun @lhs.nextIntra - rhs = Let @lhs.decls (SimpleExpr fun) - fun = seqSemname @lhs.prefix @lhs.nt @lhs.con (@lhs.nr+1) - in if @lhs.isLast - then [] - else [Decl lhs rhs (Set.fromList @nextVisitName) @lhs.nextIntraVars] - loc.isOneVisit = @lhs.isLast && @lhs.nr == 0 - loc.hasWrappers = @lhs.nt `Set.member` @lhs.wrappers - loc.refDecls = if @loc.isOneVisit && @loc.hasWrappers && reference @lhs.options - then let synAttrs = Map.toList @syn - synNT = "Syn" ++ "_" ++ getName @lhs.nt - synVars = [ SimpleExpr (attrname @lhs.options False _LHS a) | (a,_) <- synAttrs ] - rhs = App synNT synVars - lhs = Fun "___node" [] - in [Decl lhs rhs Set.empty Set.empty] - else [] - loc.decls = if @lhs.o_clean - then @vss.decls ++ @nextVisitDecl ++ @loc.refDecls -- Don't generate type signatures for Clean, they will cause the compiler to generate functions, even for constants - else @typeSigs ++ @vss.decls ++ @nextVisitDecl ++ @loc.refDecls - vss.lastExpr = mkTupleExpr @lhs.o_unbox (null $ Map.keys @inh) $ map (SimpleExpr . lhsname @lhs.options False) (Map.keys @syn) ++ map SimpleExpr @nextVisitName - intra.lastExpr = error "lastExpr: not used here" - loc.lastExprVars = map (lhsname @lhs.options False) (Map.keys @syn) ++ @loc.nextVisitName - (loc.blockFunDecls, loc.blockFirstFunCall) = mkPartitionedFunction @loc.funcname @loc.o_case @loc.nextVisitDecl @loc.lastExprVars @vss.blockDecls - - loc.costCentreDescr = "b" ++ ":" ++ show @lhs.nt ++ ":" ++ show @lhs.con ++ ":" ++ show @lhs.nr - loc.addCostCentre = \v -> if @lhs.o_costcentre - then PragmaExpr True False ("SCC \"" ++ @loc.costCentreDescr ++ "\"") v - else v - - loc.params = map getName $ Map.findWithDefault [] @lhs.nt @lhs.paramMap - loc.semFun = let lhs = Fun @funcname lhs_args - lhs_args = if @lhs.nr == 0 then map field @loc.firstOrderOrig else [] -- @intra.exprs - - field (name,NT tp tps _,_) = let unwrap | @lhs.o_newtypes = \x -> App (sdtype tp) [x] - | otherwise = id - - addType expr | null tps = expr - | otherwise = TypedExpr expr (@lhs.unfoldSemDom tp 0 tps) - - in unwrap $ addType $ SimpleExpr $ funname name 0 - field (name,tp,_) = let expr = SimpleExpr (funname name 0) - in if null @loc.params - then expr - else TypedExpr expr (idEvalType @lhs.options $ typeToCodeType (Just @lhs.nt) @loc.params $ removeDeforested tp) - - mbEvalTp | null @loc.params = const Nothing - | otherwise = Just . (idEvalType @lhs.options) - - rhs = wrap - . mkSemFun @lhs.nt @lhs.nr [mkLambdaArg (lhsname @lhs.options True nm) (mbEvalTp $ typeToCodeType (Just @lhs.nt) @loc.params $ removeDeforested tp) | (nm,tp) <- Map.assocs @inh] - $ @loc.addCostCentre - $ if @ordered && @loc.o_splitsems - then @loc.blockFirstFunCall - else mkDecls @loc.declsType @decls - . ResultExpr (typeName @lhs.nt @lhs.nr) - . mkTupleExpr @lhs.o_unbox (null $ Map.keys @inh) - $ map (SimpleExpr . lhsname @lhs.options False) (Map.keys @syn) ++ map SimpleExpr @nextVisitName - wrap = if @lhs.o_newtypes - then \x -> App (typeName @lhs.nt @lhs.nr) [x] - else id - in Decl lhs rhs Set.empty Set.empty - loc.tsig = TSig @funcname @semType - loc.semType = let argType (NT tp tps _) r | tp /= _SELF = typeAppStrs (sdtype tp) tps `Arr` r - | tp == _SELF = error "GenerateCode: found an intra-type with type SELF, which should have been prevented by CRule.tps" - argType (Haskell tp) r = SimpleType tp `Arr` r - argType _ _ = error "Self type not allowed here" - evalTp | null @loc.params = id - | otherwise = idEvalType @lhs.options - - in appQuant @lhs.quantMap @lhs.nt $ appContext @lhs.contextMap @lhs.nt $ evalTp $ - if @lhs.nr == 0 - then foldr argType (typeAppStrs (sdtype @lhs.nt ) @loc.params) (map (\(_,t,_) -> t) @loc.firstOrderOrig) - else foldr argType (typeAppStrs (typeName @lhs.nt @lhs.nr) @loc.params) [] -- @intra.tps - lhs.decls = ( if @lhs.with_sig - then [@tsig, @semFun] - else [@semFun] - ) ++ - ( if @ordered && @loc.o_splitsems - then @loc.blockFunDecls - else [] - ) - loc.typeSigs = if @lhs.o_sig && not @o_case - then @vss.tSigs - else [] - loc.o_do = @ordered && @lhs.o_monadic - loc.o_case = not @loc.o_do && @lhs.o_case && @ordered && not (hasPragma @lhs.allPragmas @lhs.nt @lhs.con _NOCASE) - loc.declsType = if @loc.o_do - then DeclsDo - else if @loc.o_case - then DeclsCase - else DeclsLet - loc.o_splitsems = @ordered && @lhs.o_splitsems - -{ -mkLambdaArg :: String -> Maybe Code.Type -> Expr -mkLambdaArg nm Nothing = SimpleExpr nm -mkLambdaArg nm (Just tp) = TypedExpr (SimpleExpr nm) tp - -mkLambda :: Exprs -> Expr -> Expr -mkLambda [] e = e -mkLambda xs e = Lambda xs e - -mkSemFun :: Identifier -> Int -> Exprs -> Expr -> Expr -mkSemFun nt nr xs e = SemFun (typeName nt nr) xs e - -typeAppStrs :: String -> [String] -> Code.Type -typeAppStrs nm params = TypeApp (SimpleType nm) (map SimpleType params) - -isHigherOrder :: ChildKind -> Bool -isHigherOrder ChildAttr = True -isHigherOrder _ = False - -pickOrigType :: (Identifier, Type, ChildKind) -> (Identifier, Type, ChildKind) -pickOrigType (nm, _, virt@(ChildReplace x)) = (nm, x, virt) -pickOrigType x = x -} - -ATTR CVisits CVisit Sequence CRule [ instVisitNrs : {Map Identifier Int} || ] -ATTR CVisits CVisit [|| gatherInstVisitNrs USE {`Map.union`} {Map.empty} : {Map Identifier Int} ] -SEM CProduction - | CProduction - visits.instVisitNrs = @visits.gatherInstVisitNrs - -SEM CVisit - | CVisit - lhs.gatherInstVisitNrs = Map.fromList [(i,@lhs.nr) | i <- @vss.definedInsts] - -------------------------------------------------------------------------------- --- Push aroundsMap downward -------------------------------------------------------------------------------- - -ATTR CNonterminals CNonterminal - [ aroundMap : {Map NontermIdent (Map ConstructorIdent (Set Identifier))} || ] - -ATTR CProductions CProduction - [ aroundMap : {Map ConstructorIdent (Set Identifier)} || ] - -ATTR CVisits CVisit Sequence CRule [ aroundMap : {Set Identifier} | | ] - -SEM CGrammar | CGrammar loc.aroundMap = @aroundsMap -SEM CNonterminal | CNonterminal loc.aroundMap = Map.findWithDefault Map.empty @nt @lhs.aroundMap -SEM CProduction | CProduction loc.aroundMap = Map.findWithDefault Set.empty @con @lhs.aroundMap - -------------------------------------------------------------------------------- --- Push mergeMap downward -------------------------------------------------------------------------------- - -ATTR CNonterminals CNonterminal - [ mergeMap : {Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier, [Identifier])))} || ] - -ATTR CProductions CProduction - [ mergeMap : {Map ConstructorIdent (Map Identifier (Identifier, [Identifier]))} || ] - -ATTR CVisits CVisit Sequence CRule [ mergeMap : {Map Identifier (Identifier, [Identifier])} | | ] - -SEM CGrammar | CGrammar loc.mergeMap = @mergeMap -SEM CNonterminal | CNonterminal loc.mergeMap = Map.findWithDefault Map.empty @nt @lhs.mergeMap -SEM CProduction | CProduction loc.mergeMap = Map.findWithDefault Map.empty @con @lhs.mergeMap - -------------------------------------------------------------------------------- --- Generate a partitioned version of the sequence of rules -------------------------------------------------------------------------------- - -ATTR Sequence [ lastExpr : Expr | | blockDecls : DeclBlocks ] - -ATTR Sequence CRule [ | declsAbove : {[Decl]} | ] -SEM CVisit - | CVisit - vss.declsAbove = [] - intra.declsAbove = error "declsAbove: not used here" - -SEM CRule - | CRule - lhs.declsAbove = @lhs.declsAbove ++ @loc.decls - | CChildVisit - lhs.declsAbove = [] - -SEM Sequence - | Cons - lhs.blockDecls = @hd.bldBlocksFun @tl.blockDecls - | Nil - lhs.blockDecls = DeclTerminator @lhs.declsAbove @lhs.lastExpr - -ATTR CRule [ | | bldBlocksFun : {DeclBlocks -> DeclBlocks} ] -SEM CRule - | CRule - lhs.bldBlocksFun = id - | CChildVisit - lhs.bldBlocksFun = DeclBlock @lhs.declsAbove (head @loc.decls) - -{ -mkPartitionedFunction :: String -> Bool -> [Decl] -> [String] -> DeclBlocks -> ([Decl], Expr) -mkPartitionedFunction prefix' optCase nextVisitDecls lastExprVars cpsTree - = let inh = Inh_DeclBlocksRoot { prefix_Inh_DeclBlocksRoot = prefix' - , optCase_Inh_DeclBlocksRoot = optCase - , nextVisitDecls_Inh_DeclBlocksRoot = nextVisitDecls - , lastExprVars_Inh_DeclBlocksRoot = lastExprVars - } - sem = sem_DeclBlocksRoot (DeclBlocksRoot cpsTree) - syn = wrap_DeclBlocksRoot sem inh - in (lambdas_Syn_DeclBlocksRoot syn, firstCall_Syn_DeclBlocksRoot syn) -} - -WRAPPER DeclBlocksRoot - -ATTR DeclBlocksRoot DeclBlocks [ prefix : String optCase : Bool nextVisitDecls : {[Decl]} lastExprVars : {[String]} | | ] -ATTR DeclBlocksRoot [ | | lambdas : {[Decl]} firstCall : Expr ] - -SEM DeclBlocksRoot - | DeclBlocksRoot - lhs.lambdas = @blocks.decls - lhs.firstCall = @blocks.callExpr - -ATTR DeclBlocks [ blockNr : Int | | ] -SEM DeclBlocksRoot - | DeclBlocksRoot - blocks.blockNr = 1 -SEM DeclBlocks - | DeclBlock - next.blockNr = @lhs.blockNr + 1 - -ATTR DeclBlocks [ | | callExpr : Expr freeVars : {[String]} ] -SEM DeclBlocks - | DeclBlock DeclTerminator - loc.lambdaName = @lhs.prefix ++ "_block" ++ show @lhs.blockNr - loc.pragmaDecl = PragmaDecl ("NOINLINE " ++ @loc.lambdaName) - lhs.callExpr = App @loc.lambdaName (map SimpleExpr @loc.freeVars) - | DeclTerminator - loc.freeVars = freevars @lhs.lastExprVars (@defs ++ @lhs.nextVisitDecls) - | DeclBlock - loc.freeVars = freevars @next.freeVars (@visit : @defs) - -ATTR DeclBlocks [ | | decls : {[Decl]} ] -SEM DeclBlocks - | DeclTerminator - lhs.decls = [ mkBlockLambda @lhs.optCase @loc.lambdaName @loc.freeVars (@defs ++ @lhs.nextVisitDecls) @result ] - | DeclBlock - loc.decl = mkBlockLambda @lhs.optCase @loc.lambdaName @loc.freeVars (@defs ++ [@visit]) @next.callExpr - lhs.decls = (if @lhs.blockNr > 1 then [@loc.pragmaDecl] else []) ++ [@loc.decl] ++ @next.decls - -{ -freevars :: [String] -> [Decl] -> [String] -freevars additional decls - = Set.toList (allused `Set.difference` alldefined) - where - allused = Set.unions (Set.fromList additional : map usedvars decls) - alldefined = Set.unions (map definedvars decls) - - usedvars (Decl _ _ _ uses) = uses - usedvars _ = Set.empty - - definedvars (Decl _ _ defs _) = defs - definedvars _ = Set.empty - -mkBlockLambda :: Bool -> String -> [String] -> [Decl] -> Expr -> Decl -mkBlockLambda optCase name args decls expr - = Decl lhs rhs Set.empty Set.empty - where - lhs = Fun name (map SimpleExpr args) - rhs = mkLet optCase decls expr -} - - -------------------------------------------------------------------------------- --- The semantic domain is generated from the interface. -------------------------------------------------------------------------------- - -ATTR CInterface CSegments CSegment [ | | semDom USE {++} {[]} : {[Decl]} ] -SEM CInterface - | CInterface lhs.semDom = Comment "semantic domain" : @seg.semDom - -SEM CSegment - | CSegment loc.altSemForm = breadthFirst @lhs.options - loc.tp = if @loc.altSemForm - then TypeApp (SimpleType "Child") [SimpleType "EvalInfo", @loc.indexExpr ] - else foldr Arr @loc.synTps @loc.inhTps - loc.inhTps = [typeToCodeType (Just @lhs.nt) @loc.params tp | tp <- Map.elems @inh] - loc.inhTup = mkTupleType @lhs.o_unbox (null @loc.inhTps) @loc.inhTps - loc.synTps = mkTupleType @lhs.o_unbox (null @loc.inhTps) ([typeToCodeType (Just @lhs.nt) @loc.params tp | tp <- Map.elems @syn] ++ @loc.continuation) - loc.curTypeName = typeName @lhs.nt @lhs.nr - loc.nextTypeName = typeName @lhs.nt (@lhs.nr + 1) - loc.indexName = "I_" ++ @loc.curTypeName - loc.dataIndex = Code.Data @loc.indexName @loc.params [DataAlt @loc.indexName []] False [] - loc.indexExpr = TypeApp (SimpleType @loc.indexName) (map (SimpleType . ('@':)) @loc.params) - loc.indexStr = "(" ++ @loc.indexName ++ concatMap (\p -> " " ++ p) @loc.params ++ ")" - loc.inhInstance = Code.Data "instance Inh" [@loc.indexStr] [DataAlt (typeName @lhs.nt @lhs.nr ++ "_Inh") [@loc.inhTup] ] False [] - loc.synInstance = Code.Data "instance Syn" [@loc.indexStr] [DataAlt (typeName @lhs.nt @lhs.nr ++ "_Syn") [@loc.synTps] ] False [] - loc.continuation = if @lhs.isLast - then [] - else [TypeApp (SimpleType @loc.nextTypeName) (map (SimpleType . ('@':)) @loc.params)] - loc.params = map getName $ Map.findWithDefault [] @lhs.nt @lhs.paramMap - lhs.semDom = let name = typeName @lhs.nt @lhs.nr - evalTp | null @loc.params = id - | otherwise = idEvalType @lhs.options - in ( if @lhs.o_newtypes - then [ Code.NewType name @loc.params name (evalTp @loc.tp) ] - else [ Code.Type name @loc.params (evalTp @loc.tp) ] ) - ++ ( if @loc.altSemForm - then [@loc.dataIndex, @loc.inhInstance, @loc.synInstance] - else [] ) - -ATTR CNonterminals CNonterminal CInterface CSegments CSegment [ | | semDomUnfoldGath USE {`Map.union`} {Map.empty} : {Map (NontermIdent, Int) ([String], Code.Type)} ] - -SEM CSegment - | CSegment - lhs.semDomUnfoldGath = Map.singleton (@lhs.nt, @lhs.nr) (@loc.params, @loc.tp) - -ATTR CNonterminals CNonterminal CProductions CProduction CVisits CVisit Sequence CRule [ unfoldSemDom : {NontermIdent -> Int -> [String] -> Code.Type} | | ] - -SEM CGrammar - | CGrammar - loc.unfoldSemDom = - \nt nr repl -> - let (params, tp) = Map.findWithDefault (error ("No such semantic domain: " ++ show nt)) (nt, nr) @nonts.semDomUnfoldGath - replMap = Map.fromList (zip params repl) - replace k = Map.findWithDefault ('@':k) k replMap - in evalType @lhs.options replace tp - -{ -typeToCodeType :: Maybe NontermIdent -> [String] -> Type -> Code.Type -typeToCodeType _ _ tp - = case tp of - NT nt tps defor -> NontermType (getName nt) tps defor - Haskell t -> SimpleType t - Self -> error "Self type not allowed here." - -evalType :: Options -> (String -> String) -> Code.Type -> Code.Type -evalType opts replf t' - = chase t' - where - chase t - = case t of - Arr l r -> Arr (chase l) (chase r) - TypeApp f as -> TypeApp (chase f) (map chase as) - TupleType tps -> TupleType (map chase tps) - UnboxedTupleType tps -> UnboxedTupleType (map chase tps) - Code.List tp -> Code.List (chase tp) - SimpleType txt -> let tks = lexTokens opts (initPos txt) txt - tks' = map replaceTok tks - txt' = unlines . showTokens . tokensToStrings $ tks' - in SimpleType txt' - TMaybe m -> TMaybe (chase m) - TEither l r -> TEither (chase l) (chase r) - TMap k v -> TMap (chase k) (chase v) - TIntMap v -> TIntMap (chase v) - TSet m -> TSet (chase m) - _ -> t - - replaceTok t - = case t of - AGLocal v p _ -> HsToken (replf $ getName v) p - _ -> t - -idEvalType :: Options -> Code.Type -> Code.Type -idEvalType options = evalType options id -} - -------------------------------------------------------------------------------- --- Wrapper functions -------------------------------------------------------------------------------- - -SEM CNonterminal - | CNonterminal loc.semWrapper = let params' = map getName @params - inhAttrs = Map.toList @inh - synAttrs = Map.toList @syn - inhVars = [ SimpleExpr (attrname @lhs.options True _LHS a) | (a,_) <- inhAttrs ] - synVars = [ SimpleExpr (attrname @lhs.options False _LHS a) | (a,_) <- synAttrs ] - var = "sem" - wrapNT = "wrap" ++ "_" ++ getName @nt - inhNT = "Inh" ++ "_" ++ getName @nt - synNT = "Syn" ++ "_" ++ getName @nt - varPat = if @lhs.o_newtypes - then App (sdtype @nt) [SimpleExpr var] - else SimpleExpr var - - evalTp | null params' = id - | otherwise = idEvalType @lhs.options - appParams nm = TypeApp (SimpleType nm) (map SimpleType params') - typeSig = TSig wrapNT (evalTp $ appParams (sdtype @nt) `Arr` (appParams inhNT `Arr` appParams synNT)) - mkstrict = Named @lhs.o_strictwrap - mkdata n attrs = Data n params' [Record n [mkstrict (getName f++"_"++n) $ evalTp $ typeToCodeType (Just @nt) params' t | (f,t) <- attrs]] False [] - datas = [mkdata inhNT inhAttrs, mkdata synNT synAttrs] - in datas ++ [ typeSig - , Decl (Fun wrapNT [varPat, App inhNT inhVars]) - (Let @inter.wrapDecls (App synNT synVars)) - Set.empty Set.empty - ] - -ATTR CInterface CSegments CSegment [ | | wrapDecls USE {++} {[]}: {Decls} ] -SEM CSegment - | CSegment lhs.wrapDecls = let lhsVars = map (lhsname @lhs.options False) (Map.keys @syn) - ++ if @lhs.isLast then [] else [unwrap ++ sem (@lhs.nr+1)] - rhsVars = map (lhsname @lhs.options True) (Map.keys @inh) - rhs = map SimpleExpr rhsVars - unwrap = if @lhs.o_newtypes then typeName @lhs.nt (@lhs.nr + 1) ++ " " else "" - var = "sem" - sem 0 = var - sem n = var ++ "_" ++ show n - ntt = typeName @lhs.nt @lhs.nr - in [ EvalDecl ntt (mkTupleLhs @lhs.o_unbox (null $ Map.keys @inh) lhsVars) (InvokeExpr ntt (SimpleExpr $ sem @lhs.nr) rhs) ] - -- [ Decl (mkTupleLhs @lhs.o_unbox (null $ Map.keys @inh) lhsVars) (App (sem @lhs.nr) rhs) (Set.fromList lhsVars) (Set.fromList rhsVars) ] - -------------------------------------------------------------------------------- --- Errors for missing type signatures. It's an error when one of the --- attributes in the intra-visit dependencies does not have a type. --- UPDATE: it is not an error anymore... -------------------------------------------------------------------------------- - -ATTR CNonterminals CNonterminal - CProductions CProduction - CVisits CVisit [ with_sig : Bool | | ] - -SEM CGrammar - | CGrammar nonts.with_sig = typeSigs @lhs.options - -SEM CGrammar [ | | errors : {Seq Error} ] - | CGrammar lhs.errors = Seq.empty - -------------------------------------------------------------------------------- --- Provide a description of the interfaces as comments -------------------------------------------------------------------------------- - -SEM CNonterminal - | CNonterminal loc.comment = Comment . unlines . map ind $ ( @inter.comments ++ ("alternatives:" : map ind @prods.comments) ) - -ATTR CInterface CSegments CSegment - CProductions CProduction - CVisits CVisit Sequence CRule [ | | comments USE {++} {[]}: {[String]} ] - -ATTR Sequence CRule [ what:String | | ] - -SEM CSegment - | CSegment lhs.comments = let body = map ind (showsSegment (CSegment @inh @syn)) - in if null body - then [] - else ("visit " ++ show @lhs.nr ++ ":") : body - -SEM CProduction - | CProduction loc.firstOrderChildren = [ (nm,fromJust mb,virt) | (nm,tp,virt) <- @children, let mb = isFirstOrder virt tp, isJust mb ] - lhs.comments = ("alternative " ++ getName @con ++ ":") - : map ind ( map (\(x,y,_) -> makeLocalComment 14 "child" x (Just y)) @loc.firstOrderChildren - ++ @visits.comments - ) - -{ --- for a virtual child that already existed as a child, returns -isFirstOrder :: ChildKind -> Type -> Maybe Type -isFirstOrder ChildSyntax tp = Just tp -isFirstOrder ChildAttr _ = Nothing -isFirstOrder (ChildReplace tp) _ = Just tp -} - -SEM CVisit - | CVisit lhs.comments = let body = map ind (@vss.comments ++ @intra.comments) - in if null body - then [] - else ("visit " ++ show @lhs.nr ++ ":") : body - vss.what = "local" - intra.what = "intra" - - -SEM CRule - | CRule lhs.comments = [ makeLocalComment 11 @lhs.what name tp | (field,name,tp) <- Map.elems @defines, field == _LOC ] - ++ [ makeLocalComment 11 "inst " name tp | (field,name,tp) <- Map.elems @defines, field == _INST ] - -{ -makeLocalComment :: Int -> String -> Identifier -> Maybe Type -> String -makeLocalComment width what name tp = let x = getName name - y = maybe "_" (\t -> case t of - (NT nt tps _) -> getName nt ++ " " ++ unwords tps - Haskell t' -> '{' : t' ++ "}" - Self -> error "Self type not allowed here.") tp - in ( what ++ " " ++ x ++ replicate ((width - length x) `max` 0) ' ' ++ " : " ++ y ) - -} - -------------------------------------------------------------------------------- --- And tie it all together -------------------------------------------------------------------------------- - -ATTR CNonterminals CNonterminal [ | | chunks USE {++} {[]} : {Chunks} ] -ATTR CProductions CProduction [ | | decls USE {++} {[]} : {Decls} ] -ATTR CGrammar [ | | output : Program ] - -SEM CGrammar - | CGrammar lhs.output = Program @nonts.chunks @multivisit - -SEM CNonterminal - | CNonterminal lhs.chunks = [ Chunk (getName @nt) - (Comment (getName @nt ++ " " ++ replicate (60 - length (getName @nt)) '-')) - (if @lhs.o_pretty then [@loc.comment] else []) - (if isJust @lhs.o_data then [@loc.dataDef] else []) - (if @lhs.o_cata && @loc.genCata then @loc.cataFun else []) - (if @lhs.o_sig then @inter.semDom else []) - (if @nt `Set.member` @lhs.wrappers then @loc.semWrapper else []) - (if @lhs.o_sem then @prods.decls else []) - (if @lhs.o_sem then @prods.semNames else []) - ] - -{ --- Lets or nested Cases? --- or even a do-expression? - -data DeclsType = DeclsLet | DeclsCase | DeclsDo - -mkDecls :: DeclsType -> Decls -> Expr -> Expr -mkDecls DeclsLet = mkLet False -mkDecls DeclsCase = mkLet True -mkDecls DeclsDo = \decls -> Do (map toBind decls) - where toBind (Decl lhs rhs _ _) = BindLet lhs rhs - toBind d = d - -mkLet :: Bool -> Decls -> Expr -> Expr -mkLet False decls body = Let decls body -mkLet True decls body = foldr oneCase body decls - -oneCase :: Decl -> Expr -> Expr -oneCase (Decl left rhs _ _) ex = Case rhs [CaseAlt left ex] -oneCase (Resume _ nt left rhs) ex = ResumeExpr nt rhs left ex -oneCase _ ex = ex - --- Gives the name of the visit function -funname :: Show a => a -> Int -> String -funname field 0 = show field ++ "_" -funname field nr = show field ++ "_" ++ show nr - --- Gives the name of a semantic function -seqSemname :: String -> NontermIdent -> ConstructorIdent -> Int -> String -seqSemname pre nt con 0 = semname pre nt con -seqSemname pre nt con nr = semname pre nt con ++ "_" ++ show nr - --- Gives the name of a type -typeName :: NontermIdent -> Int -> String -typeName nt 0 = "T_" ++ show nt -typeName nt n = "T_" ++ show nt ++ "_" ++ show n - -ntOfVisit :: NontermIdent -> Int -> NontermIdent -ntOfVisit nt 0 = nt -ntOfVisit nt n = Ident (show nt ++ "_" ++ show n) (getPos nt) - --- Gives the name of a visit function -visitname :: String -> NontermIdent -> Int -> String -visitname pre nt n = pre ++ getName nt ++ "_" ++ show n -} - -------------------------------------------------------------------------------- --- Datatypes were already present -------------------------------------------------------------------------------- - -ATTR CNonterminals CNonterminal [ derivings: {Derivings} typeSyns : {TypeSyns} | | ] -ATTR CNonterminals CNonterminal CProductions CProduction CVisits CVisit [ wrappers:{Set NontermIdent} | | ] - -SEM CGrammar - | CGrammar nonts . typeSyns = @typeSyns - . derivings = @derivings - . wrappers = @wrappers - -SEM CNonterminal - | CNonterminal loc.dataDef = let params' = map getName @params - typeSyn tp = let theType = - case tp of - CommonTypes.Maybe t -> TMaybe $ typeToCodeType (Just @nt) params' t - CommonTypes.Either t1 t2 -> TEither (typeToCodeType (Just @nt) params' t1) (typeToCodeType (Just @nt) params' t2) - CommonTypes.Map t1 t2 -> TMap (typeToCodeType (Just @nt) params' t1) (typeToCodeType (Just @nt) params' t2) - CommonTypes.IntMap t -> TIntMap $ typeToCodeType (Just @nt) params' t - CommonTypes.List t -> Code.List $ typeToCodeType (Just @nt) params' t - CommonTypes.Tuple ts -> Code.TupleType [typeToCodeType (Just @nt) params' t | (_,t) <- ts ] - CommonTypes.OrdSet t -> TSet $ typeToCodeType (Just @nt) params' t - CommonTypes.IntSet -> TIntSet - in Code.Type (getName @nt) params' (idEvalType @lhs.options theType) - derivings = maybe [] (map getName . Set.toList) (Map.lookup @nt @lhs.derivings) - dataDef = Data (getName @nt) (map getName @params) @prods.dataAlts (maybe False id @lhs.o_data) derivings - in maybe dataDef typeSyn $ lookup @nt @lhs.typeSyns - -ATTR CProductions [ | | dataAlts : {DataAlts} ] -ATTR CProduction [ | | dataAlt : {DataAlt} ] - -SEM CProductions - | Cons lhs.dataAlts = @hd.dataAlt : @tl.dataAlts - | Nil lhs.dataAlts = [] - -SEM CProduction - | CProduction loc.params = map getName $ Map.findWithDefault [] @lhs.nt @lhs.paramMap - lhs.dataAlt = let conNm = conname @lhs.o_rename @lhs.nt @con - mkFields :: (NontermIdent -> ConstructorIdent -> Identifier -> Code.Type -> a) -> [a] - mkFields f = map (\(nm,t,_) -> f @lhs.nt @con nm (typeToCodeType (Just @lhs.nt) @loc.params $ removeDeforested t)) @loc.firstOrderChildren - in if dataRecords @lhs.options - then Record conNm $ mkFields $ toNamedType (strictData @lhs.options) - else DataAlt conNm $ mkFields $ \_ _ _ t -> t - -{ -toNamedType :: Bool -> NontermIdent -> ConstructorIdent -> Identifier -> Code.Type -> Code.NamedType -toNamedType genStrict nt con nm tp - = Code.Named genStrict strNm tp - where strNm = recordFieldname nt con nm -} - -------------------------------------------------------------------------------- --- Catamorphism were already present -------------------------------------------------------------------------------- - -SEM CNonterminal - | CNonterminal loc.genCata = not (@nt `Set.member` nocatas @lhs.options) - loc.cataFun = let appParams nm = TypeApp (SimpleType nm) (map SimpleType (map getName @params)) - evalTp | null @params = id - | otherwise = idEvalType @lhs.options - tSig = TSig (cataname @lhs.prefix @nt) - (appQuant @lhs.quantMap @nt $ appContext @lhs.contextMap @nt $ evalTp $ appParams (getName @nt) `Arr` appParams (sdtype @nt)) - special typ = case typ of - CommonTypes.List tp -> - let cons = SimpleExpr (semname @lhs.prefix @nt (identifier "Cons")) - nil = SimpleExpr (semname @lhs.prefix @nt (identifier "Nil" )) - arg = SimpleExpr "list" - rarg = case tp of - NT t _ _ -> let t' = maybe t id (deforestedNt t) - in SimpleExpr ("(Prelude.map " ++ (cataname @lhs.prefix t') ++ " list)") - _ -> arg - lhs = Fun (cataname @lhs.prefix @nt) [arg] - rhs = (App "Prelude.foldr" [cons,nil,rarg]) - in [Decl lhs rhs Set.empty Set.empty] - CommonTypes.Maybe tp -> - let just = semname @lhs.prefix @nt (identifier "Just") - nothing = semname @lhs.prefix @nt (identifier "Nothing" ) - arg = SimpleExpr "x" - rarg = case tp of - NT t _ _ -> let t' = maybe t id (deforestedNt t) - in App (cataname @lhs.prefix t') [arg] - _ -> arg - lhs a = Fun (cataname @lhs.prefix @nt) [a] - in [Decl (lhs (App "Prelude.Just" [arg])) (App just [rarg]) Set.empty Set.empty - ,Decl (lhs (SimpleExpr "Prelude.Nothing")) (SimpleExpr nothing) Set.empty Set.empty - ] - CommonTypes.Either tp1 tp2 -> - let left = semname @lhs.prefix @nt (identifier "Left") - right = semname @lhs.prefix @nt (identifier "Right" ) - arg = SimpleExpr "x" - rarg0 = case tp1 of - NT t _ _ -> let t' = maybe t id (deforestedNt t) - in App (cataname @lhs.prefix t') [arg] - _ -> arg - rarg1 = case tp2 of - NT t _ _ -> let t' = maybe t id (deforestedNt t) - in App (cataname @lhs.prefix t') [arg] - _ -> arg - lhs a = Fun (cataname @lhs.prefix @nt) [a] - in [Decl (lhs (App "Prelude.Left" [arg])) (App left [rarg0]) Set.empty Set.empty - ,Decl (lhs (App "Prelude.Right" [arg])) (App right [rarg1]) Set.empty Set.empty - ] - CommonTypes.Map _ tp -> - let entry = SimpleExpr (semname @lhs.prefix @nt (identifier "Entry")) - nil = SimpleExpr (semname @lhs.prefix @nt (identifier "Nil")) - arg = SimpleExpr "m" - rarg = case tp of - NT t _ _ -> let t' = maybe t id (deforestedNt t) - in App "Data.Map.map" [SimpleExpr $ cataname @lhs.prefix t', arg] - _ -> arg - lhs = Fun (cataname @lhs.prefix @nt) [arg] - rhs = App "Data.Map.foldrWithKey" [entry,nil,rarg] - in [Decl lhs rhs Set.empty Set.empty] - CommonTypes.IntMap tp -> - let entry = SimpleExpr (semname @lhs.prefix @nt (identifier "Entry")) - nil = SimpleExpr (semname @lhs.prefix @nt (identifier "Nil")) - arg = SimpleExpr "m" - rarg = case tp of - NT t _ _ -> let t' = maybe t id (deforestedNt t) - in App "Data.IntMap.map" [SimpleExpr $ cataname @lhs.prefix t', arg] - _ -> arg - lhs = Fun (cataname @lhs.prefix @nt) [arg] - rhs = App "Data.IntMap.foldWithKey" [entry,nil,rarg] - in [Decl lhs rhs Set.empty Set.empty] - CommonTypes.Tuple tps -> - let con = semname @lhs.prefix @nt (identifier "Tuple") - tps' = [ (SimpleExpr (getName x),y) | (x,y) <- tps] - rargs = map rarg tps' - rarg (n, tp) = case tp of - NT t _ _ -> let t' = maybe t id (deforestedNt t) - in App (cataname @lhs.prefix t') [n] - _ -> n - - lhs = Fun (cataname @lhs.prefix @nt) [TupleExpr (map fst tps')] - rhs = App con rargs - in [Decl lhs rhs Set.empty Set.empty] - CommonTypes.OrdSet tp -> - let entry = SimpleExpr (semname @lhs.prefix @nt (identifier "Entry")) - nil = SimpleExpr (semname @lhs.prefix @nt (identifier "Nil" )) - arg = SimpleExpr "set" - rentry = case tp of - NT t _ _ -> let t' = maybe t id (deforestedNt t) - in App "(.)" [entry, SimpleExpr $ cataname @lhs.prefix t'] - _ -> entry - lhs = Fun (cataname @lhs.prefix @nt) [arg] - rhs = (App "Data.Set.foldr" [rentry,nil,arg]) - in [Decl lhs rhs Set.empty Set.empty] - CommonTypes.IntSet -> - let entry = SimpleExpr (semname @lhs.prefix @nt (identifier "Entry")) - nil = SimpleExpr (semname @lhs.prefix @nt (identifier "Nil" )) - arg = SimpleExpr "set" - lhs = Fun (cataname @lhs.prefix @nt) [arg] - rhs = (App "Data.IntSet.foldr" [entry,nil,arg]) - in [Decl lhs rhs Set.empty Set.empty] - in Comment "cata" : - (if @lhs.o_sig then [tSig] else []) ++ - maybe @prods.cataAlts special (lookup @nt @lhs.typeSyns) - -ATTR CProductions [ | | cataAlts : {Decls} ] -ATTR CProduction [ | | cataAlt : {Decl} ] - - -SEM CProductions - | Cons lhs.cataAlts = @hd.cataAlt : @tl.cataAlts - | Nil lhs.cataAlts = [] - -SEM CProduction - | CProduction lhs.cataAlt = let lhs = Fun (cataname @lhs.prefix @lhs.nt) [lhs_pat] - lhs_pat = App (conname @lhs.o_rename @lhs.nt @con) - (map (\(n,_,_) -> SimpleExpr $ locname @lhs.options $ n) @loc.firstOrderChildren) - rhs = App (semname @lhs.prefix @lhs.nt @con) - (map argument @loc.firstOrderChildren) - argument (nm,NT tp _ _,_) = App (cataname @lhs.prefix tp) - [SimpleExpr (locname @lhs.options nm)] - argument (nm, _,_) = SimpleExpr (locname @lhs.options nm) - in Decl lhs rhs Set.empty Set.empty - - -------------------------------------------------------------------------------- --- Collect names of generated stuff -------------------------------------------------------------------------------- - -ATTR CProductions CProduction CVisits CVisit [ | | semNames USE {++} {[]} : {[String]} ] - -{- -SEM CProduction - | CProduction - lhs.semNames = [cataname @lhs.prefix @lhs.nt] ++ @visits.semNames --} - -SEM CVisit - | CVisit - lhs.semNames = [@loc.funcname] - diff --git a/src-ag/HsToken.ag b/src-ag/HsToken.ag deleted file mode 100644 --- a/src-ag/HsToken.ag +++ /dev/null @@ -1,33 +0,0 @@ -imports -{ -import CommonTypes -import UU.Scanner.Position(Pos) -} - -DATA HsTokensRoot - | HsTokensRoot tokens : HsTokens - -TYPE HsTokens = [HsToken] - -DATA HsToken - | AGLocal var : {Identifier} -- either a local or a terminal - pos : {Pos} - rdesc : {Maybe String} -- description of the rule the local reference appears in - - | AGField field : {Identifier} -- Misnomer: this is actually a reference to an attribute, not a terminal! - attr : {Identifier} - pos : {Pos} - rdesc : {Maybe String} -- description of the rule the attribute reference appears in - - | HsToken value : {String} - pos : {Pos} - | CharToken value : {String} - pos : {Pos} - | StrToken value : {String} - pos : {Pos} - | Err mesg : {String} - pos : {Pos} - - - -DERIVING HsToken : Show diff --git a/src-ag/Interfaces.ag b/src-ag/Interfaces.ag deleted file mode 100644 --- a/src-ag/Interfaces.ag +++ /dev/null @@ -1,16 +0,0 @@ -imports -{ -import CommonTypes -import SequentialTypes -} - -DATA IRoot | IRoot inters:Interfaces -TYPE Interfaces = [Interface] -DATA Interface | Interface nt:NontermIdent - cons:{[ConstructorIdent]} - seg:Segments -TYPE Segments = [Segment] -DATA Segment | Segment inh:{[Vertex]} - syn:{[Vertex]} - - diff --git a/src-ag/InterfacesRules.lag b/src-ag/InterfacesRules.lag deleted file mode 100644 --- a/src-ag/InterfacesRules.lag +++ /dev/null @@ -1,451 +0,0 @@ -\begin{Code} -PRAGMA strictdata -PRAGMA optimize -PRAGMA bangpats -PRAGMA strictwrap - -INCLUDE "Interfaces.ag" - -imports -{ -import Interfaces -import CodeSyntax -import GrammarInfo - -import qualified Data.Sequence as Seq -import Data.Sequence(Seq) -import qualified Data.Map as Map -import Data.Map(Map) -import Data.Tree(Tree(Node), Forest) -import Data.Graph(Graph, dfs, edges, buildG, transposeG) -import Data.Maybe (fromJust) -import Data.List (partition,transpose,(\\),nub,findIndex) -import Data.Array ((!),inRange,bounds,assocs) -import Data.Foldable(toList) -} -\end{Code} - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{Visit sub-sequence-graph} - -Visit sub-sequences can be generated from the |Tdp| by a topological -sort. To that end we add vertices to |Tdp|. For each production, for -each child, for each visit to that child, we add a vertex $v$. - -We add the following edges: - -\begin{enumerate} - - \item From the inherited attributes passed to the visit to $v$, - because these attributes need to be computed before visiting $v$. - - \item From the synthesized attributes computed by the visit to - $v$, because a visit to $v$ computes these attributes. - - \item From the previous visit to $v$, because we can only visit - $c$ for the $i$-th time if we have visited it the $(i-1)$-th time. - -\end{enumerate} - -Now we can define a visit sub-sequence as a list of vertices: - -\begin{Code} -{ -type VisitSS = [Vertex] -} -\end{Code} - -We define a function that generates the visit-subsequences-graph and a -description of the newly added vertices. We do this using an attribute -grammar. The visit subsequences graph has transposed edges, so we can -use |topSort'|. - -\begin{Code} -ATTR IRoot [ tdp : Graph | | ] -SEM IRoot - | IRoot loc.newedges = toList @inters.newedges - loc.visitssGraph = let graph = buildG (0,@inters.v-1) es - es = @newedges ++ edges @lhs.tdp - in transposeG graph -\end{Code} - -As we will need to look up information, we pass |info| down. An -attribute v stores a fresh vertex. We start counting from the hightest -vertex in |tdp|. - -\begin{Code} -ATTR Interfaces Interface Segments Segment [ | v : Vertex | ] -ATTR IRoot Interfaces Interface Segments Segment [ info : Info | | ] -SEM IRoot - | IRoot inters.v = snd (bounds @lhs.tdp) + 1 -\end{Code} - -The actual generation of edges takes place in |Segment|. We group the -attribute occurrences. |isEqualField| checks are at the same position -(either lhs of the same child). - -\begin{Code} -{ -gather :: Info -> [Vertex] -> [[Vertex]] -gather info = eqClasses comp - where comp a b = isEqualField (ruleTable info ! a) (ruleTable info ! b) -} -\end{Code} - -When we do this for right-hand side occurrences of the inherited and -syntesized attributes of a |Segment|, we find the new vertices. - -\begin{Code} -SEM Segment - | Segment loc.look : {Vertex -> CRule} - loc.look = \a -> ruleTable @lhs.info ! a - - loc.occurAs : {(CRule -> Bool) -> [Vertex] -> [Vertex]} - loc.occurAs = \p us -> [ a | u <- us - , a <- tdsToTdp @lhs.info ! u - , p (@look a)] - loc.groups : {[([Vertex],[Vertex])]} - loc.groups = let group as = gather @lhs.info (@occurAs isRhs as) - in map (partition (isInh . @look)) (group (@inh ++ @syn)) - loc.v : {Int} - loc.v = @lhs.v + length @groups - loc.newvertices = [@lhs.v .. @loc.v-1] -\end{Code} - -A description of the new vertices van be found by looking up the field -of an attribute occurrence - -\begin{Code} -ATTR Interfaces Interface Segments Segment - [ visitDescr : {Map Vertex ChildVisit} | | ] -SEM IRoot - | IRoot inters.visitDescr = Map.fromList @descr -ATTR Interfaces Interface Segments Segment - [ | | newedges USE {Seq.><} {Seq.empty} : {Seq Edge } - descr USE {Seq.><} {Seq.empty} : {Seq (Vertex,ChildVisit)} ] -SEM Segment - | Segment lhs.descr = Seq.fromList $ zipWith (cv @look @lhs.n) @newvertices @groups {-$-} - -{ --- Only non-empty syn will ever be forced, because visits with empty syn are never performed --- Right hand side synthesized attributes always have a field -cv :: (Vertex -> CRule) -> Int -> Vertex -> ([Vertex],[Vertex]) -> (Vertex,ChildVisit) -cv look n v (inh,syn) = let fld = getField (look (head syn)) - rnt = fromJust (getRhsNt (look (head syn))) - d = ChildVisit fld rnt n inh syn - in (v,d) -} -\end{Code} - -\begin{Code} -SEM IRoot - | IRoot loc.descr = toList @inters.descr -\end{Code} - -The edges between attributes occurrences and their corresponding -visits can be found as follows: - -\begin{Code} -SEM Segment - | Segment loc.attredges = concat (zipWith ed @newvertices @groups) - -{ -ed :: Vertex -> ([Vertex], [Vertex]) -> [(Vertex, Vertex)] -ed v (inh,syn) = map (\i -> (i,v)) inh ++ map (\s -> (v,s)) syn -} -\end{Code} - -For edges between visits we simpy |zip| the current vertices with the -next ones. - -\begin{Code} -ATTR Segment [ nextNewvertices : {[Vertex]} | | newvertices : {[Vertex]} ] -ATTR Segments [ | | newvertices : {[Vertex]} ] -SEM Segments - | Cons hd.nextNewvertices = @tl.newvertices - lhs.newvertices = @hd.newvertices - | Nil lhs.newvertices = [] - -SEM Segment - | Segment loc.visitedges = zip @newvertices @lhs.nextNewvertices - lhs.newedges = Seq.fromList @attredges Seq.>< Seq.fromList @visitedges -\end{Code} - -The first visit to a child is passed to the first visit of the parent, -so we add edges for this, too. - -\begin{Code} -ATTR Segments Segment [ | | groups : {[([Vertex],[Vertex])]} ] -SEM Segments - | Cons lhs.groups = @hd.groups - | Nil lhs.groups = [] -SEM Interface - | Interface seg.v = @lhs.v - loc.v = @seg.v + length @seg.newvertices - lhs.v = @loc.v - loc.firstvisitvertices = [@seg.v .. @v-1] - loc.newedges = zip @firstvisitvertices @seg.newvertices - lhs.newedges = @seg.newedges Seq.>< Seq.fromList @newedges - - loc.look : {Vertex -> CRule} - loc.look = \a -> ruleTable @lhs.info ! a - loc.descr = zipWith (cv @look (-1)) @firstvisitvertices @seg.groups - lhs.descr = @seg.descr Seq.>< Seq.fromList @descr -\end{Code} - -The visit number can simply be counted - -\begin{Code} -ATTR Segments Segment [ n : Int | | ] -SEM Interface - | Interface seg.n = 0 -SEM Segments - | Cons tl.n = @lhs.n + 1 -\end{Code} - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\subsection{Visit sub-sequences} - -To compute the visit subsequences, we pass the visit-subsequence graph down - -\begin{Code} -ATTR Interfaces Interface Segments Segment [ vssGraph : Graph | | ] -SEM IRoot - | IRoot inters.vssGraph = @visitssGraph -\end{Code} - -Each segment computes subsequences for each production of the -nonterminal. We group the occurrences of the synthesized attributes, -and perform a topological sort on it. In the absence of synthesized -attributes, nothing needs to be computed, so the visit subsequence -is empty. - -\begin{Code} -SEM Segment - | Segment loc.synOccur = gather @lhs.info (@occurAs isLhs @syn) - loc.vss = let hasCode' v | inRange (bounds (ruleTable @lhs.info)) v = getHasCode (ruleTable @lhs.info ! v) - | otherwise = True - in if null @syn - then replicate (length @lhs.cons) [] - else map (filter hasCode' . topSort' @lhs.vssGraph) @synOccur -ATTR Segments Segment [ cons : {[ConstructorIdent]} | | ] -SEM Interface - | Interface seg.cons = @cons -\end{Code} - -We adapt the topological sort to take a list of vertices to start -sorting. - -\begin{Code} -{ -postorder :: Tree a -> [a] -postorder (Node a ts) = postorderF ts ++ [a] -postorderF :: Forest a -> [a] -postorderF = concatMap postorder -postOrd :: Graph -> [Vertex] -> [Vertex] -postOrd g = postorderF . dfs g -topSort' :: Graph -> [Vertex] -> [Vertex] -topSort' g = postOrd g -} -\end{Code} - -This gives us the subsequence required to compute the synthesized -attributes. However, a part of this subsequence has already been -computed in previous visits. We thread this part through. It starts -with all first visits to children. - -\begin{Code} -ATTR Interfaces Interface [ prev : {[Vertex]} | | firstvisitvertices USE {++} {[]} : {[Vertex]} ] -SEM IRoot - | IRoot inters.prev = let terminals = [ v | (v,cr) <- assocs (ruleTable @lhs.info), not (getHasCode cr), isLocal cr ] - in @inters.firstvisitvertices ++ terminals - -ATTR Segments Segment [ | prev : {[Vertex]} | ] -\end{Code} - -and we remove this part from the subsequence - -\begin{Code} -SEM Segment [ | | visitss : {[VisitSS]} ] - | Segment loc.visitss' = map (\\ @lhs.prev) @vss - loc.defined = let defines v = case Map.lookup v @lhs.visitDescr of - Nothing -> [v] - Just (ChildVisit _ _ _ inh _) -> v:inh - in concatMap (concatMap defines) @visitss - lhs.prev = @lhs.prev ++ @defined -\end{Code} - -When more that one attribute is defined in the same rule, this rule is -repeated in the visit subsequence. We do not want this. - -\begin{Code} -SEM Segment - | Segment loc.visitss : {[[Vertex]]} - loc.visitss = let rem' :: [(Identifier,Identifier,Maybe Type)] -> [Vertex] -> [Vertex] - rem' _ [] = [] - rem' prev (v:vs) - | inRange (bounds table) v - = let cr = table ! v - addV = case findIndex cmp prev of - Just _ -> id - _ -> (v:) - cmp (fld,attr,tp) = getField cr == fld && getAttr cr == attr && sameNT (getType cr) tp - sameNT (Just (NT ntA _ _)) (Just (NT ntB _ _)) = ntA == ntB - sameNT _ _ = False - def = Map.elems (getDefines cr) - in addV (rem' (def ++ prev) vs) - | otherwise = v:rem' prev vs - table = ruleTable @lhs.info - in map (rem' []) @visitss' -\end{Code} - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\subsection{Intra-visit dependencies} - -We ignore terminals, they need to be passed from the first visit up to -where they are needed. Intra-visit dependencies descibe what a visit -needs from its previous visits. The first visit does not have -intra-visit dependencies, because there are no previous visits. We add -an attribute that indicates whether it's the first visit. - -\begin{Code} -ATTR Segment Segments [ isFirst : {Bool} | | ] -SEM Interface - | Interface seg.isFirst = True -SEM Segments - | Cons tl.isFirst = False -\end{Code} - -We declare an attribute intravisit which gives the intra-visit -dependencies. We pass the intravisit of the next visit to this -one. -\begin{Code} -{ -type IntraVisit = [Vertex] -} - -ATTR Segment [ nextIntravisits : {[IntraVisit]} | | intravisits : {[IntraVisit]} ] -SEM Segments [ | | hdIntravisits : {[IntraVisit]} ] - | Cons hd.nextIntravisits = @tl.hdIntravisits - lhs.hdIntravisits = @hd.intravisits - | Nil lhs.hdIntravisits = repeat [] -\end{Code} - -The first visit does not have intra-visit dependencies. A later visit -need all attributes that it's subsequence depends on, and the -intra-visit dependecies of the next visit, except for those attributes -that are compted in this visit. - -\begin{Code} -ATTR IRoot [ dpr : {[Edge]} | | ] -ATTR Interfaces Interface Segments Segment [ ddp : Graph | | ] -SEM IRoot - | IRoot inters.ddp = buildG (0,@inters.v-1) (map swap (@lhs.dpr ++ @newedges)) - -{ -swap :: (a,b) -> (b,a) -swap (a,b) = (b,a) -} - -ATTR Segments Segment [ fromLhs : {[Vertex]} | | ] -SEM Interface - | Interface seg.fromLhs = @lhs.prev -SEM Segments - | Cons hd.fromLhs = @lhs.fromLhs - tl.fromLhs = [] -SEM Segment - | Segment loc.fromLhs = @occurAs isLhs @inh ++ @lhs.fromLhs - loc.computed = let computes v = case Map.lookup v @lhs.visitDescr of - Nothing -> Map.keys (getDefines (ruleTable @lhs.info ! v)) - Just (ChildVisit _ _ _ _ syn) -> v:syn - in concatMap (concatMap computes) @visitss - loc.intravisits = zipWith @iv @visitss @lhs.nextIntravisits - loc.iv = \vs next -> - let needed = concatMap (@lhs.ddp !) vs - in nub (needed ++ next) \\ (@fromLhs ++ @computed) -\end{Code} - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\subsection{Result} - -Our resulting datastructure is: - -Now we pass the visit sub-sequences up. In |Interface|, |@seg.visitss| -gives us for each segment, for each production a subsequence. What we -want is for each production, for each visit a subsequence, which is -accomplished by |transpose|. The same is done for intravisits. - -\begin{Code} -ATTR Interfaces Interface Segments Segment [ allInters : {CInterfaceMap} | | ] -SEM IRoot - | IRoot inters.allInters = @inters.inters - -ATTR IRoot Interfaces [ | | inters : {CInterfaceMap} - visits : {CVisitsMap} ] -SEM Interfaces - | Cons lhs.inters = Map.insert @hd.nt @hd.inter @tl.inters - lhs.visits = Map.insert @hd.nt @hd.visits @tl.visits - | Nil lhs.inters = Map.empty - lhs.visits = Map.empty - -SEM Interface [ | | nt : NontermIdent ] - | Interface lhs.nt = @nt - -SEM Interface [ | | inter : CInterface - visits : {Map ConstructorIdent CVisits} ] - | Interface lhs.inter = CInterface @seg.segs - lhs.visits = Map.fromList (zip @cons (transpose @seg.cvisits)) - -SEM Segments [ | | segs : CSegments - cvisits USE {:} {[]} : {[[CVisit]]} ] -- For each visit, for each constructor the CVisit - | Cons lhs.segs = @hd.seg : @tl.segs - | Nil lhs.segs = [] - -SEM Segment [ | | seg : CSegment - cvisits : {[CVisit]} ] -- For this visit, for each constructor the CVisit - | Segment lhs.seg = -- A fake dependency fixes a type-3 cycle - if False then undefined @lhs.vssGraph @lhs.visitDescr @lhs.prev else CSegment @inhmap @synmap - loc.inhmap : {Map Identifier Type} - loc.synmap : {Map Identifier Type} - loc.(inhmap,synmap) = let makemap = Map.fromList . map findType - findType v = getNtaNameType (attrTable @lhs.info ! v) - in (makemap @inh,makemap @syn) - lhs.cvisits = let mkVisit vss intra = CVisit @inhmap @synmap (mkSequence vss) (mkSequence intra) True - mkSequence = map mkRule - mkRule v = case Map.lookup v @lhs.visitDescr of - Nothing -> ruleTable @lhs.info ! v - Just (ChildVisit name nt n _ _) -> ccv name nt n @lhs.allInters - in zipWith mkVisit @visitss @intravisits - -{ -ccv :: Identifier -> NontermIdent -> Int -> CInterfaceMap -> CRule -ccv name nt n table - = CChildVisit name nt n inh syn lst - where CInterface segs = Map.findWithDefault (error ("InterfacesRules::ccv::interfaces not in table for nt: " ++ show nt)) nt table - (seg:remain) = drop n segs - CSegment inh syn = seg - lst = null remain -} -\end{Code} - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\subsection{EDP} - -To find a type-3 cycle we need to know the dependencies that the -interfaces generate. - -\begin{Code} -ATTR Interfaces Interface Segments Segment [ | | edp USE {Seq.><} {Seq.empty} : {Seq Edge} ] -SEM Segment - | Segment lhs.edp = Seq.fromList [(i,s) | i <- @inh, s <- @syn] - Seq.>< Seq.fromList [(s,i) | s <- @syn, i <- @lhs.nextInh ] -SEM IRoot [ | | edp : {[Edge]} ] - | IRoot lhs.edp = toList @inters.edp -SEM Segment [ nextInh : {[Vertex]} | | inh : {[Vertex]} ] - | Segment lhs.inh = @inh -SEM Segments [ | | firstInh : {[Vertex]} ] - | Cons hd.nextInh = @tl.firstInh - lhs.firstInh = @hd.inh - | Nil lhs.firstInh = [] -\end{Code} - diff --git a/src-ag/KWOrder.ag b/src-ag/KWOrder.ag deleted file mode 100644 --- a/src-ag/KWOrder.ag +++ /dev/null @@ -1,217 +0,0 @@ -INCLUDE "AbstractSyntax.ag" -INCLUDE "HsToken.ag" -INCLUDE "Expression.ag" -INCLUDE "Patterns.ag" -INCLUDE "DistChildAttr.ag" -INCLUDE "ExecutionPlanPre.ag" -INCLUDE "ExecutionPlanCommon.ag" - -imports -{ -import AbstractSyntax -import HsToken -import Expression -import Patterns -import Options -import PPUtil -import Pretty -import Knuth1 -import KennedyWarren -import ExecutionPlan -import Data.Maybe -import Debug.Trace -import Data.Set(Set) -import Data.Map(Map) -import Data.Sequence(Seq) -import qualified Data.Set as Set -import qualified Data.Map as Map -import qualified Data.Sequence as Seq -import Data.Monoid(mappend,mempty) -} - -------------------------------------------------------------------------------- --- Dependency graph per production -------------------------------------------------------------------------------- --- Gather vertices -ATTR HsToken Expression - Rule Rules - Pattern Patterns - Child Children [ | | vertices USE {`Set.union`} {Set.empty} : {Set.Set Vertex} ] - --- All vertices from the righthandside of a rule -SEM HsToken - | AGLocal lhs.vertices = Set.singleton $ VChild @var - | AGField lhs.vertices = Set.singleton $ VAttr (if @field == _LHS then Inh - else if @field == _LOC then Loc - else Syn) @field @attr - --- Gather vertices for an expression (make a higher order child) -SEM Expression - | Expression lhs.vertices = Set.unions $ map (\tok -> vertices_Syn_HsToken - (wrap_HsToken (sem_HsToken tok) Inh_HsToken)) @tks - --- Gather vertices at patterns -SEM Pattern - | Alias loc.vertex = if @field == _INST then VChild @attr - else VAttr (if @field == _LHS then Syn - else if @field == _LOC then Loc - else Inh) @field @attr - lhs.vertices = Set.insert @loc.vertex @pat.vertices - --- Gather vertices for children --- --- The behavior for merged children is a bit more complicated (and ignored for now) -SEM Child - | Child loc.vertex = VChild @name - loc.synvertices = map (VAttr Syn @name) . Map.keys $ @loc.syn - loc.inhvertices = map (VAttr Inh @name) . Map.keys $ @loc.inh - lhs.vertices = case @tp of -- only Nonterminal children need to be in dependency graph - NT _ _ _ -> Set.insert @loc.vertex $ Set.fromList (@loc.synvertices ++ @loc.inhvertices) - _ -> Set.empty - --- Add extra vertex for a rule -SEM Rule - | Rule loc.vertex = VRule @loc.rulename - lhs.vertices = Set.insert @loc.vertex $ @pattern.vertices `Set.union` @rhs.vertices - --- Combine all vertices for a production -SEM Production - | Production loc.vertices = @rules.vertices `Set.union` @children.vertices - --- Gather edges -ATTR Rule Rules - Child Children [ | | edges USE {`Set.union`} {Set.empty} : {Set.Set Edge} ] - --- Gather edges for a rule -SEM Rule - | Rule loc.edgesout = map ((,) @loc.vertex) (Set.toList @rhs.vertices) - loc.edgesin = map (flip (,) @loc.vertex) (Set.toList @pattern.vertices) - lhs.edges = Set.fromList $ @loc.edgesout ++ @loc.edgesin - --- When a child is defined by a higher order attribute and the late binding option --- is enabled, we refer to the additional inherited attribute under the hood, hence --- we need to tell the dependency analysis about this in order to actually have the --- attribute available when we attach the child. --- Note that the dependencies on the rule that creates the semantics of the child --- is handled elsewhere by mapping an "inst"-attribute to the right child vertex. -SEM Child | Child - loc.childIsDeforested = case @tp of - NT _ _ defor -> defor - _ -> False - loc.higherOrderEdges = case @kind of - ChildAttr | lateHigherOrderBinding @lhs.options && not @loc.childIsDeforested - -> [(@loc.vertex, VAttr Inh _LHS idLateBindingAttr)] - _ -> [] -- attribute is not referenced implicitly - loc.aroundEdges = if @loc.hasArounds - then [(@loc.vertex, VAttr Syn _LOC (Ident (getName @name ++ "_around") (getPos @name)))] - else [] - --- Gather edges for a child -SEM Child - | Child loc.edgesout = @loc.higherOrderEdges - loc.edgesin = map (flip (,) @loc.vertex) @loc.synvertices - lhs.edges = Set.fromList (@loc.edgesout ++ @loc.edgesin) - --- Add manual attribute dependencies -ATTR Nonterminals Nonterminal [ manualDeps : AttrOrderMap | | ] -ATTR Productions Production [ manualDeps : {Map ConstructorIdent (Set Dependency)} | | ] - -SEM Grammar | Grammar nonts.manualDeps = @manualAttrOrderMap -SEM Nonterminal | Nonterminal prods.manualDeps = Map.findWithDefault Map.empty @nt @lhs.manualDeps -SEM Production | Production - loc.manualDeps = Map.findWithDefault Set.empty @con @lhs.manualDeps - loc.manualEdges = Set.map depToEdge @loc.manualDeps - -{ --- a depends on b, thus a is a successor of b -depToEdge :: Dependency -> Edge -depToEdge (Dependency a b) = (occToVertex False b, occToVertex True a) - -occToVertex :: Bool -> Occurrence -> Vertex -occToVertex _ (OccRule nm) = VRule nm -occToVertex isDependency (OccAttr c a) - | c == _LOC = VAttr Syn c a -- local attributes are treated as synthesized attrs of 'loc' - | c == _INST = VChild a -- higher-order attributes are treated as children - | otherwise = VAttr kind c a where - kind | isDependency && c == _LHS = Inh -- these dependencies have the property that - | isDependency && c /= _LHS = Syn -- they can all be faked by writing a 'const' rule - | not isDependency && c == _LHS = Syn -- Perhaps we should also allow other forms of dependencies - | not isDependency && c /= _LHS = Inh -- as well, such as two inherited attributes, which would - -- force them in different visits -} - --- Combine all edges for a production -SEM Production - | Production loc.edges = @rules.edges `Set.union` @children.edges - --- Find all child nonterminal names for a production -ATTR Child Children [ | | nontnames USE {++} {[]} : {[(Identifier, Identifier)]}] - -SEM Child - | Child lhs.nontnames = case @tp of - NT nont _ _ -> [(@name, nont)] - _ -> [] - --- Return a dependency graph for each production -ATTR Production [ | | depgraph : {ProdDependencyGraph} ] -ATTR Productions [ | | depgraph USE {:} {[]} : {[ProdDependencyGraph]} ] - -SEM Production - | Production lhs.depgraph = ProdDependencyGraph { pdgVertices = Set.toList @loc.vertices - , pdgEdges = Set.toList @loc.edges - , pdgRules = @rules.erules - , pdgChilds = @children.echilds - , pdgProduction = @con - , pdgChildMap = @children.nontnames - , pdgConstraints = @constraints - , pdgParams = @params } - -------------------------------------------------------------------------------- --- Dependency graph per nonterminal -------------------------------------------------------------------------------- - --- Vertices are just all inherited and syntesized attributes -SEM Nonterminal - | Nonterminal loc.synvertices = map (VAttr Syn @nt) . Map.keys $ @syn - loc.inhvertices = map (VAttr Inh @nt) . Map.keys $ @inh - loc.vertices = @loc.synvertices ++ @loc.inhvertices - --- Construct nonterminal dependency graph for production -SEM Nonterminal - | Nonterminal loc.nontgraph = NontDependencyGraph { ndgVertices = @loc.vertices - , ndgEdges = [] } - --- Create dependency information for nonterminal and pass it upwards -ATTR Nonterminal [ | | depinfo : {NontDependencyInformation} ] -ATTR Nonterminals [ | | depinfo USE {:} {[]} : {[NontDependencyInformation]} ] - -SEM Nonterminal - | Nonterminal lhs.depinfo = NontDependencyInformation { ndiNonterminal = @nt - , ndiParams = @params - , ndiInh = Map.keys @inh - , ndiSyn = Map.keys @syn - , ndiDepGraph = @loc.nontgraph - , ndiProds = @prods.depgraph - , ndiRecursive = @loc.recursive - , ndiHoInfo = @loc.hoInfo - , ndiClassCtxs = @loc.classContexts - } - -------------------------------------------------------------------------------- --- Call the kennedy-warren algorithm -------------------------------------------------------------------------------- -ATTR Grammar [ | | output : {ExecutionPlan} - depgraphs : {PP_Doc} - visitgraph : {PP_Doc} - errors : {Seq Error} ] - -SEM Grammar - | Grammar (lhs.output, lhs.depgraphs, lhs.visitgraph, lhs.errors) - = let lazyPlan = kennedyWarrenLazy @lhs.options @wrappers @nonts.depinfo @typeSyns @derivings - in if visit @lhs.options && withCycle @lhs.options - then case kennedyWarrenOrder @lhs.options @wrappers @nonts.depinfo @typeSyns @derivings of - Left e -> (lazyPlan,empty,empty,Seq.singleton e) - Right (o,d,v) -> (o,d,v,Seq.empty) - else (lazyPlan,empty,empty,Seq.empty) - - diff --git a/src-ag/LOAG/Order.ag b/src-ag/LOAG/Order.ag deleted file mode 100644 --- a/src-ag/LOAG/Order.ag +++ /dev/null @@ -1,435 +0,0 @@ -INCLUDE "AbstractSyntax" -INCLUDE "Patterns" -INCLUDE "CodeSyntax" -INCLUDE "Expression" -INCLUDE "HsToken" -INCLUDE "LOAG/Rep" -INCLUDE "LOAG/Prepare" -INCLUDE "ExecutionPlanCommon" - -MODULE {LOAG.Order} -{} -{} -imports{ -import qualified Data.Array as A -import qualified Data.Map as Map -import qualified Data.IntMap as IMap -import qualified Data.Set as Set -import qualified Data.IntSet as IS -import qualified Data.Sequence as Seq -import qualified CommonTypes as CT -import Control.Monad (forM,when) -import Control.Monad.ST -import Data.Maybe(catMaybes) -import Data.Monoid(mappend,mempty) -import Data.STRef -import AbstractSyntax -import qualified LOAG.AOAG as AOAG -import LOAG.Common -import LOAG.Chordal -import LOAG.Rep -import LOAG.Graphs -import CodeSyntax -import Data.Maybe (isJust, fromJust) -import ExecutionPlan -import GrammarInfo -import HsToken (HsToken(..)) -import Pretty -import qualified System.IO as IO -import System.IO.Unsafe -} - -{ -fst' (a,_,_) = a -snd' (_,b,_) = b -trd' (_,_,c) = c -} - -ATTR Grammar [ | | - output : ExecutionPlan - ads : {Maybe PP_Doc} - errors : {Seq.Seq Error}] - -SEM Grammar | Grammar - lhs.errors = either Seq.singleton (const Seq.empty) @loc.schedRes - lhs.ads = case either (const []) trd' @loc.schedRes of - [] -> Nothing - ads -> Just $ ppAds @lhs.options @nonts.pmp ads - lhs.output = ExecutionPlan @nonts.enonts @typeSyns @wrappers @derivings - - nonts.sched = either (const Map.empty) snd' @loc.schedRes - nonts.tdp = either (error "no tdp") (fromJust.fst') @loc.schedRes - - loc.schedRes = if CT.loag @lhs.options - then if CT.aoag @lhs.options - then AOAG.schedule @smf.self @self @loc.ag @nonts.ads - else @loc.loagRes - else Right (Nothing,Map.empty,[]) - loc.loagRes = let putStrLn s = when (verbose @lhs.options) (IO.putStrLn s) - in Right $ unsafePerformIO $ scheduleLOAG @loc.ag putStrLn @lhs.options - loc.ag = repToAg @smf.self @self - - nonts.res_ads = either (const []) trd' @loc.schedRes - --- Gather the fake dependencies from the ads result of AOAG - -ATTR Nonterminals Nonterminal Productions Production - [ res_ads : {[Edge]} || ] -ATTR Nonterminals Nonterminal - [ || fdps USE {Map.union} {Map.empty} : AttrOrderMap ] - -SEM Nonterminal | Nonterminal - lhs.fdps = Map.singleton @nt @prods.fdps - -ATTR Productions Production [ || - fdps USE {Map.union} {Map.empty} : {Map.Map ConstructorIdent (Set Dependency)} ] - -SEM Production | Production - lhs.fdps = - let op d@(f,t) ds - | fst (argsOf $ findWithErr @lhs.pmpf "fdps" f) == (@lhs.dty,getName @con) - = Set.insert (edgeToDep @lhs.pmpf d) ds - | otherwise - = ds - in Map.singleton @con $ foldr op Set.empty @lhs.res_ads -{ -data AltAttr = AltAttr Identifier Identifier Bool - deriving (Eq, Ord, Show) - -edgeToDep :: PMP -> Edge -> Dependency -edgeToDep pmp (f,t) = - Dependency (OccAttr (identifier f1) (identifier i1)) - (OccAttr (identifier f2) (identifier i2)) - where (MyOccurrence (_,f1) (i1,_),MyOccurrence (_,f2) (i2,_)) - = (findWithErr pmp "edgeToDep" f, - findWithErr pmp "edgeToDep" t) - -ppAds :: Options -> PMP -> [Edge] -> PP_Doc -ppAds opts pmp = foldr ((>-<) . ppEdge opts pmp) empty - -ppEdge :: Options -> PMP -> Edge -> PP_Doc -ppEdge opts pmp (f,t) = - text sem >#< text (show ty) >|< " | " >|< text p >|< " " - >|< ppOcc pmp f >|< text " < " >|< ppOcc pmp t - where (MyOccurrence ((ty,p),_) _) = pmp Map.! f - sem | lcKeywords opts = "sem" - | otherwise = "SEM" - -ppOcc :: PMP -> Vertex -> PP_Doc -ppOcc pmp v = text f >|< text "." >|< fst a - where (MyOccurrence ((t,p),f) a) = findWithErr pmp "ppOcc" v - -} - --- Construct Execution Plan - -ATTR Nonterminals Nonterminal [ - visMapf : {IMap.IntMap Int} - tdp : TDPRes || - enonts USE {(++)} {[]} : ENonterminals - visMap USE {IMap.union} {IMap.empty} : {IMap.IntMap Int}] - -SEM Grammar - | Grammar nonts.visMapf = @nonts.visMap - nonts.visitnum = 0 - -SEM Nonterminal - | Nonterminal - loc.initial = @lhs.visitnum - loc.vnums = zipWith const [@loc.initial..] @segments - loc.initialVisit = @vnums - loc.nextVis = Map.fromList $ (@loc.initial + length @vnums, NoneVis) - : [(v, OneVis v) | v <- @vnums ] - loc.prevVis = Map.fromList $ (@loc.initial, NoneVis) - : [(v+1, OneVis v) | v <- @vnums ] - loc.visMap = let op vnr (MySegment visnr ins syns _ _) = - IMap.fromList $ zip syns (repeat vnr) - in IMap.unions $ zipWith op [@loc.initial..] @mysegments - lhs.enonts = [ENonterminal - @nt - @params - @loc.classContexts - @loc.initial - @loc.initialVisit - @loc.nextVis - @loc.prevVis - @prods.eprods - @loc.recursive - @loc.hoInfo ] - -ATTR Productions Production [ - visMapf : {IMap.IntMap Int} - tdp : TDPRes || - eprods USE {(++)} {[]} : EProductions ] - -SEM Production - | Production - segs.ruleMap = @rules.ruleMap - segs.done = (Set.empty, Set.empty, Set.empty, Set.empty) - loc.intros = let intro (Child nm _ kind) - | kind == ChildAttr = Nothing - | otherwise = Just $ ChildIntro nm - in catMaybes $ map intro @children.self - lhs.eprods = - let ((Visit ident from to inh syn steps kind):vss) = @segs.evisits - steps' = @loc.intros ++ steps - visits | null @segs.evisits = [] - | otherwise = - ((Visit ident from to inh syn steps' kind):vss) - in [EProduction - @con - @params - @constraints - @rules.erules - @children.echilds - visits ] - -ATTR Nonterminals Nonterminal Productions Production MySegments MySegment - [ | visitnum : Int | ] - --- Visit nums should be the same for each production, but different globally -SEM Productions - | Cons tl.visitnum = @lhs.visitnum - lhs.visitnum = @hd.visitnum - -SEM MySegment | MySegment +visitnum = (+1) -ATTR MySegments MySegment [ - -- maps which attribute occurrence is calculated in which visit - visMapf : {IMap.IntMap Int} | | ] - -ATTR MySegments MySegment [ - ps : PLabel - ruleMap : {Map.Map MyOccurrence Identifier} - nmprf : NMP_R - options : {Options} - tdp : TDPRes - done : { (Set.Set MyOccurrence, Set.Set FLabel - , Set.Set Identifier, Set.Set (FLabel,Int))} - ||] - -ATTR MySegments [|| evisits USE {:} {[]} : {Visits}] -ATTR MySegment [|| - evisits : {Visit} - -- synthesized attribute occurrences of this segment - synsO : {[Int]} - visnr : Int - done : { (Set.Set MyOccurrence, Set.Set FLabel - ,Set.Set Identifier, Set.Set (FLabel,Int))}] - -SEM MySegments - | Cons hd.done = @lhs.done - tl.done = @hd.done - -SEM MySegment - | MySegment - loc.inhs = Map.keysSet$ Map.unions $ map (vertexToAttr @lhs.nmp) @inhAttr - loc.syns = Map.keysSet$ Map.unions $ map (vertexToAttr @lhs.nmp) @synAttr - loc.inhsO= maybe (error "segment not instantiated") id @inhOccs - loc.synsO= maybe (error "segment not instantiated") id @synOccs - lhs.visnr= @visnr - loc.kind = if monadic @lhs.options then VisitMonadic else VisitPure True - lhs.evisits = Visit @lhs.visitnum @lhs.visitnum (@lhs.visitnum+1) - @loc.inhs @loc.syns @loc.steps @loc.kind - loc.steps = if monadic @lhs.options - then [Sim @loc.vss] else [PureGroup @loc.vss True] - (loc.vss,lhs.done) = (runST $ getVss @lhs.done @lhs.ps @lhs.tdp @synsO - @lhs.lfpf @lhs.nmprf @lhs.pmpf @lhs.pmprf @lhs.fty - @lhs.visMapf @lhs.ruleMap @lhs.hoMapf) - -{ -getVss (done,intros,rules,vnrs) ps tdp synsO lfp nmpr pmp pmpr fty visMap ruleMap hoMap = do - ref <- newSTRef done - introed <- newSTRef intros - ruleref <- newSTRef rules - vnrsref <- newSTRef vnrs - lists <- forM synsO (visit ref introed ruleref vnrsref . (pmp Map.!)) - done <- readSTRef ref - intros <- readSTRef introed - rules <- readSTRef ruleref - vnrs <- readSTRef vnrsref - return (concat lists, (done, intros, rules, vnrs)) - where - hochildren = maybe Set.empty id $ Map.lookup ps hoMap - visit ref introed ruleref vnrsref o@(MyOccurrence (_,f) (_,d)) = do - visited <- readSTRef ref - if (o `Set.member` visited) - then return [] -- already visited - else do -- prevent doubles - modifySTRef ref (Set.insert o) - if inOutput - then do -- has to be calculated in this sequence - rest' <- rest - locs' <- locs - sem' <- sem o - return $ (rest' ++ locs' ++ sem') - else if "lhs" == (snd $ argsOf o) - then return [] -- inherited of parent, nothing todo - else do -- other input occurrence, perform visit - locs' <- locs - rest' <- rest - visit'<- toVisit o - return (rest' ++ locs' ++ visit') - where preds = maybe [] (IS.toList . (tdp A.!)) $ Map.lookup o pmpr - rest = forM preds (visit ref introed ruleref vnrsref. (pmp Map.!)) - >>= (return . concat) - free = maybe [] (Set.toList) $ Map.lookup o lfp - locs = forM free (visit ref introed ruleref vnrsref) - >>= (return . concat) - sem o = do rules <- readSTRef ruleref - if r `Set.member` rules - then return [] - else do writeSTRef ruleref (r `Set.insert` rules) - return [Sem r] - where r = maybe (error "ruleMap") id $ Map.lookup o ruleMap - inOutput = f == "lhs" && d == Syn || f /= "lhs" && d == Inh - toVisit o = do - vnrs <- readSTRef vnrsref - if (child,visnr) `Set.member` vnrs - then return [] - else writeSTRef vnrsref ((child,visnr) `Set.insert` vnrs) >> - if child `Set.member` hochildren - then do intros <- readSTRef introed - case child `Set.member` intros of - True -> return [cvisit] - False -> do - writeSTRef introed (Set.insert child intros) - let occ = (ps,"inst") >.< (child, AnyDir) - preds = Set.toList $ setConcatMap rep $ - lfp Map.! occ - rep :: MyOccurrence -> Set.Set MyOccurrence - rep occ | isLoc occ = Set.insert occ $ - setConcatMap rep $ lfp Map.! occ - | otherwise = Set.singleton occ - rest <- forM preds - (visit ref introed ruleref vnrsref) - sem' <- sem occ - return $ (concat rest) ++ - sem' ++ - [ChildIntro (identifier child)] ++ - [cvisit] - else return [cvisit] - where cvisit= ChildVisit (identifier child) ntid visnr - child = snd $ argsOf o - ntid = ((\(NT name _ _ )-> name) . fromMyTy) nt - visnr = (\x-> visMap IMap.! x) (nmpr Map.! (nt <.> attr o)) - nt = fty Map.! (ps,child) -} - -ATTR Nonterminals Nonterminal [ - sched : {InterfaceRes} ||] -SEM Nonterminal - | Nonterminal - loc.assigned = findWithErr @lhs.sched "could not const. interfaces" - (getName @nt) - loc.mx = if Map.null @lhs.sched - then 0 - else let mx = fst $ IMap.findMax @loc.assigned in - if even mx then mx else mx + 1 - loc.mysegments = - map (\i -> MySegment ((@loc.mx - i) `div` 2) - (maybe [] id $ IMap.lookup i @loc.assigned) - (maybe [] id $ IMap.lookup (i-1) @loc.assigned) - Nothing Nothing) - [@loc.mx,@loc.mx-2 .. 2] - loc.segments = - map (\(MySegment visnr is ss _ _) -> - CSegment (Map.unions $ map (vertexToAttr @lhs.nmp) is) - (Map.unions $ map (vertexToAttr @lhs.nmp) ss)) - @loc.mysegments - -ATTR Productions Production [ mysegments : MySegments || ] -SEM Production - | Production - inst.segs : MySegments - --translate from attribute to occurrences - inst.segs = - map (\(MySegment visnr inhs syns _ _) -> - MySegment visnr inhs syns - (Just $ map (@lhs.pmprf Map.!) $ - handAllOut (@loc.ps,"lhs") $ - map (@lhs.nmp Map.!) inhs) - (Just $ map (@lhs.pmprf Map.!) $ - handAllOut (@loc.ps,"lhs") $ - map (@lhs.nmp Map.!) syns) - ) @lhs.mysegments - -{ -repToAg :: LOAGRep -> Grammar -> Ag -repToAg sem (Grammar _ _ _ _ dats _ _ _ _ _ _ _ _ _) = - Ag bounds_s bounds_p de (map toNt dats) - where - pmp = (pmp_LOAGRep_LOAGRep sem) - pmpr = (pmpr_LOAGRep_LOAGRep sem) - nmp = (nmp_LOAGRep_LOAGRep sem) - nmpr = (nmpr_LOAGRep_LOAGRep sem) - genA = gen_LOAGRep_LOAGRep sem - fieldM = fieldMap_LOAGRep_LOAGRep sem - genEdge (f,t) = (gen f, gen t) - fsInP = map2F (fsInP_LOAGRep_LOAGRep sem) - siblings (f, t) = ofld A.! f == ofld A.! t - ofld = (ofld_LOAGRep_LOAGRep sem) - sfp = map2F' (sfp_LOAGRep_LOAGRep sem) - afp = filter inOutput . ap - ap = map (findWithErr pmpr "building ap") . map2F (ap_LOAGRep_LOAGRep sem) - inss = inss_LOAGRep_LOAGRep sem - gen v = genA A.! v - ain = map (findWithErr nmpr "building an") . map2F (ain_LOAGRep_LOAGRep sem) - asn = map (findWithErr nmpr "building an") . map2F (asn_LOAGRep_LOAGRep sem) - inOutput = not . inContext - inContext f = (f1 == "lhs" && d1 == Inh || f1 /= "lhs" && d1 == Syn) - where (MyOccurrence (_,f1) (_,d1)) = pmp Map.! f - de = [ e | p <- ps, e <- dpe p ] - dpe p = [ (findWithErr pmpr "building dpe" a, b) - | b <- ap p, a <- Set.toList $ sfp (findWithErr pmp "fetching sfp" b) ] - ps = ps_LOAGRep_LOAGRep sem - bounds_p = if Map.null pmp then (0,-1) - else (fst $ Map.findMin pmp, fst $ Map.findMax pmp) - bounds_s = if Map.null nmp then (0,-1) - else (fst $ Map.findMin nmp, fst $ Map.findMax nmp) - - - - toNt :: Nonterminal -> Nt - toNt (Nonterminal ntid _ _ _ prods) = Nt nt dpf dpt - (addD Inh $ ain ty) (addD Syn $ asn ty) (map (toPr ty) prods) - where nt = getName ntid - ty = TyData nt - dpt = [ (as, ai) | ai <- ain ty - , as <- nub$ [ gen s | - i <- inss A.! ai - , s <- map (pmpr Map.!) $ - Set.toList (sfp $ pmp Map.! i) - , siblings (s,i)]] - dpf = [ (ai, as) | as <- asn ty - , ai <- nub$ [ gen i | - s <- inss A.! as - , i <- map (pmpr Map.!) $ - Set.toList (sfp $ pmp Map.! s) - , siblings (i,s)]] - addD d = map (\i -> (i,inss A.! i,d)) - toPr :: MyType -> Production -> Pr - toPr ty (Production con _ _ _ _ _ _) = - Pr p dpp fc_occs (map toFd $ fsInP p) - where p = (ty, getName con) - dpp = [ (f',t) - | t <- afp p, f <- (Set.toList $ sfp (pmp Map.! t)) - , let f' = pmpr Map.! f - , not (siblings (f',t))] - fc_occs = foldl' match [] fss - where fss = fsInP p - match s fs = [ ready (inp, out) lhs | inp <- Set.toList inhs - , out <- Set.toList syns] ++ s - where ((inhs, syns), lhs) - | (snd fs) /= "lhs" = - (swap (fieldM Map.! fs),False) - | otherwise = (fieldM Map.! fs, True) - ready e@(f,t) b = (e', genEdge e', b) - where e' = (pmpr Map.! f, pmpr Map.! t) - toFd :: (PLabel, FLabel) -> Fd - toFd fs@((TyData ty, pr), fd) = Fd fd ty inhs syns - where (is,ss) = fieldM Map.! fs - inhs = map (((genA A.!) &&& id).(pmpr Map.!))$ Set.toList is - syns = map (((genA A.!) &&& id).(pmpr Map.!))$ Set.toList ss - - -} diff --git a/src-ag/LOAG/Rep.ag b/src-ag/LOAG/Rep.ag deleted file mode 100644 --- a/src-ag/LOAG/Rep.ag +++ /dev/null @@ -1,49 +0,0 @@ -MODULE {LOAG.Rep} -{}{ -import CommonTypes -import AbstractSyntax -import LOAG.Common -import qualified Data.Array as A -import qualified Data.Map as Map -import qualified Data.Set as Set -} -imports{ -import Data.List (intercalate, foldl', nub) -import Data.Tuple (swap) -import Control.Arrow -} - -DATA LOAGRep | LOAGRep - ps : {[PLabel]} - ap : A_P - an : A_N - ain : AI_N - asn : AS_N - sfp : SF_P - pmp : PMP - pmpr : PMP_R - nmp : NMP - nmpr : NMP_R - gen : {A.Array Int Int} - inss : {A.Array Int [Int]} - ofld : {A.Array Int Int} - fty : FTY - fieldMap : FMap - fsInP: {Map.Map PLabel [(PLabel,FLabel)]} - -TYPE FieldAtts = [FieldAtt] --- t is the type of the attribute this occurrence belongs to -DATA FieldAtt | FieldAtt t : {MyType} p : {PLabel} - f : {FLabel} a : {ALabel} - -TYPE MySegments = [MySegment] -DATA MySegment | MySegment - visnr : Int - inhAttr : {[Int]} - synAttr : {[Int]} - inhOccs : {Maybe [Int]} - synOccs : {Maybe [Int]} - -DERIVING MySegments MySegment : Show - - diff --git a/src-ag/Macro.ag b/src-ag/Macro.ag deleted file mode 100644 --- a/src-ag/Macro.ag +++ /dev/null @@ -1,24 +0,0 @@ ---marcos: macros extension - -imports -{ -import CommonTypes -} - -TYPE MaybeMacro = MAYBE Macro - -DATA Macro | Macro con : {ConstructorIdent} - children : MacroChildren - | None - -TYPE MacroChildren = [MacroChild] - -DATA MacroChild | RuleChild name : {Identifier} - macro : Macro - | ChildChild name : {Identifier} - child : {Identifier} - - | ValueChild name : {Identifier} - value : {String} - -DERIVING MaybeMacro Macro MacroChildren MacroChild : Show diff --git a/src-ag/Order.ag b/src-ag/Order.ag deleted file mode 100644 --- a/src-ag/Order.ag +++ /dev/null @@ -1,809 +0,0 @@ -PRAGMA strictdata -PRAGMA strictwrap - -INCLUDE "Patterns.ag" -INCLUDE "Expression.ag" -INCLUDE "AbstractSyntax.ag" -INCLUDE "DistChildAttr.ag" - -imports -{ --- From uuagc -import CommonTypes -import Patterns -import ErrorMessages -import AbstractSyntax -import Code hiding (Type) -import qualified Code -import Expression -import Options -import SequentialComputation -import SequentialTypes -import CodeSyntax -import GrammarInfo -import HsToken(HsTokensRoot(HsTokensRoot)) -import SemHsTokens(sem_HsTokensRoot,wrap_HsTokensRoot, Syn_HsTokensRoot(..),Inh_HsTokensRoot(..)) --- From uulib -import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified Data.Sequence as Seq -import Data.Map(Map) -import Data.Set(Set) -import Data.Sequence(Seq, (><)) -import UU.Util.Utils -import UU.Scanner.Position(Pos(..),initPos) -import Data.Foldable(toList) - --- From haskell libraries -import Control.Monad(liftM) -import qualified Data.Array as Array -import Data.Array((!),bounds,inRange) -import Data.List(elemIndex,partition,sort,mapAccumL,find,nubBy,intersperse,groupBy,transpose) -import qualified Data.Tree as Tree -import Data.Maybe -} - -{ --- Terminates with an error if the key is not in the map -findWithErr1 :: (Ord k, Show k) => String -> k -> Map k a -> a -findWithErr1 s k - = Map.findWithDefault (error ("findWithErr1 " ++ s ++ ": key " ++ show k ++ " not in map.")) k - -findWithErr2 :: (Ord k, Show k, Show a) => k -> Map k a -> a -findWithErr2 k m - = Map.findWithDefault (error ("findWithErr2: key " ++ show k ++ " not in map: " ++ show m)) k m -} - --- --- Some statistics, count number of attributes --- - -ATTR Grammar Nonterminals Nonterminal Productions Production Rules Rule [ | | nAutoRules,nExplicitRules USE {+} {0} : {Int} ] - -SEM Rule - | Rule lhs.nExplicitRules = if @explicit - then 1 - else 0 - lhs.nAutoRules = if startsWith "use rule" @origin || startsWith "copy rule" @origin - then 1 - else 0 - -{ -startsWith :: String -> String -> Bool -startsWith k h = k == take (length k) h -} - - -------------------------------------------------------------------------------- --- Errors -------------------------------------------------------------------------------- --- Everyone that wants to report an error can do this by adding an error message to the --- stream of errors - -ATTR Nonterminals Nonterminal Productions Production - Child Children Rule Rules Pattern Patterns Grammar [ | | errors USE {Seq.><} {Seq.empty}:{Seq Error} ] - -------------------------------------------------------------------------------- --- Distributing name of nonterminal and names of attributes -------------------------------------------------------------------------------- -ATTR Productions Production Child Children Rules Rule Patterns Pattern [ nt : {Identifier} inh,syn : {Attributes} | | ] -ATTR Child Children Rules Rule Patterns Pattern [ con : {Identifier} | | ] - -SEM Production - | Production children . con = @con -SEM Production - | Production rules . con = @con -SEM Nonterminal - | Nonterminal prods . nt = @nt - -SEM Nonterminal - | Nonterminal prods.inh = @inh - prods.syn = @syn - - -------------------------------------------------------------------------------- --- Distributing options -------------------------------------------------------------------------------- - -ATTR Grammar [ options:{Options} | | ] -ATTR Nonterminals Nonterminal Productions Production Rules Rule - [ o_newtypes - , o_cata - , o_sig - , o_sem - , o_rename - , o_wantvisit -- True if the option for visit functions has been specified - , o_dovisit -- True if o_wantvisit and it is possible to generate visit functions (no cycles) - , o_case:{Bool} - prefix : {String} | | ] -ATTR Nonterminals Nonterminal Productions Production Children Child [ o_unbox:{Bool} | | ] -ATTR Nonterminals Nonterminal [ o_data:{Bool} | | ] - -SEM Grammar - | Grammar loc.o_dovisit = visit @lhs.options && null @cyclesErrors - nonts.o_cata = folds @lhs.options - .o_data = dataTypes @lhs.options - .o_sig = typeSigs @lhs.options - .o_sem = semfuns @lhs.options - .o_rename = rename @lhs.options - .o_newtypes= newtypes @lhs.options - .o_wantvisit = visit @lhs.options - .o_unbox = unbox @lhs.options - .o_case = cases @lhs.options - .prefix = prefix @lhs.options - ------------------------------------------------------------------- --- Building a mapping from Vertices to Ints ------------------------------------------------------------------- -{ -getNtName :: Type -> NontermIdent -getNtName (NT nt _ _) = nt -getNtName _ = nullIdent -} - ------------------------------------------------------------------- --- Collect attribute occurrences --- --- All attribute occurences in an alternative are gathered. --- This is done by joining various sublists: --- 1. inherited attributes for _LHS --- 2a. synthesized attributes for children --- 2b. children that are a trivial field --- 3a. inherited attributes for children --- 3b. synthesized attributes for _LHS --- 3c. local attributes --- --- Sublist 3 is exactly the targets for ATTR definitions, and --- thus can be obtained by traversing all rules. --- --- The (field,attr) combination is not enough to uniquely identify --- an attribute occurence, because threaded attributes occur twice. --- Therefore, in the AltAttr structures, a boolean is added, --- that is False in sublists 3a and 3b, i.e. the non-local output fields. --- --- Each AltAttr, that is eacht attribute occurence, is mapped to a number --- in the altAttrs Map, starting at vcount -{ -data AltAttr = AltAttr Identifier Identifier Bool - deriving (Eq, Ord, Show) -} -ATTR Rules Rule Production Productions Nonterminal Nonterminals - [ options : {Options} | | ] - -ATTR Children Child Rules Rule Patterns Pattern [ | | gathAltAttrs USE {++} {[]} : {[AltAttr]} ] -SEM Production - | Production loc.gathAltAttrs = [ AltAttr _LHS inh True | inh <- Map.keys @lhs.inh ] -- sublist 1 - ++ @children.gathAltAttrs -- sublist 2 - ++ @rules.gathAltAttrs -- sublist 3 - -SEM Child - | Child loc.maptolocal = case @tp of - NT nt _ _ -> Map.null @syn - _ -> True - lhs.gathAltAttrs = if @maptolocal - then [ AltAttr _LOC @name True ] -- sublist 2b - else [ AltAttr @name syn True | syn <- Map.keys @loc.syn ] -- sublist 2a -SEM Pattern - | Alias lhs.gathAltAttrs = [AltAttr @field @attr (@field == _LOC || @field == _INST)] -- sublist 3 - -ATTR Rules Rule Patterns Pattern [ altAttrs : {Map AltAttr Vertex} | | ] -SEM Production - | Production loc.altAttrs = Map.fromList (zip @gathAltAttrs [@lhs.vcount..]) - --- Information passed to Pattern -ATTR Children Child - [ | | nts USE {Seq.><} {Seq.empty} : {Seq (Identifier,NontermIdent)} - inhs USE {Seq.><} {Seq.empty} : {Seq (Identifier,Attributes)} ] -SEM Child - | Child lhs.nts = Seq.singleton (@name,getNtName @tp) - lhs.inhs = Seq.singleton (@name,@loc.inh) -ATTR Rules Rule - [ childNts : {Map Identifier NontermIdent} - childInhs : {Map Identifier Attributes} | | ] -SEM Production - | Production rules.childNts = Map.fromList (toList @children.nts) - rules.childInhs = Map.fromList (toList @children.inhs) - --- Collect CRules -ATTR Children Child Rules Rule - [ | | gathRules USE {Seq.><} {Seq.empty} : {Seq CRule} ] -SEM Production - | Production loc.inhRules = [ cRuleLhsInh inh @lhs.nt @con tp | (inh,tp) <- Map.assocs @lhs.inh ] - loc.gathRules = @inhRules ++ toList (@children.gathRules Seq.>< @rules.gathRules) - -SEM Child - | Child loc.gathRules = if @maptolocal - then Seq.singleton (cRuleTerminal @name @lhs.nt @lhs.con @tp) - else Seq.fromList [ cRuleRhsSyn syn @lhs.nt @lhs.con tp @name (getNtName @tp) | (syn,tp) <- Map.assocs @loc.syn] - -SEM Rule - | Rule loc.defines = let tp field attr | field == _LOC || field == _INST - = Map.lookup attr @lhs.allTypeSigs - | field == _LHS = Map.lookup attr @lhs.syn - | otherwise = Map.lookup attr (findWithErr1 "Rule.defines.tp" field @lhs.childInhs) - typ :: Pattern -> Maybe Type - typ (Alias field attr _) = tp field attr - typ (Underscore _) = Nothing - -- typ (Product _ pats) = tp _LOC undefined pats - typ _ = Nothing - - in Map.fromList [ (findWithErr1 "Rule.defines" aa @lhs.altAttrs, (field,attr,(tp field attr))) - | (field,attr,isLocalOrInst) <- @pattern.patternAttrs - , let aa = AltAttr field attr isLocalOrInst - ] - loc.gathRules = let childnt field = Map.lookup field @lhs.childNts - in Seq.fromList [ CRule attr False True @lhs.nt @lhs.con field (childnt field) tp @pattern.copy @rhs.textLines @defines @owrt @origin @rhs.allRhsVars @explicit @mbName - | (field,attr,tp) <- Map.elems @defines - ] - -{ -substSelf nt tp - = case tp of - NT n tps defor | n == _SELF -> NT nt tps defor - _ -> tp - -haskellTupel :: [Type] -> Maybe Type -haskellTupel ts = Just ( Haskell ( '(' : (concat (intersperse "," (map show ts))) ++ ")" )) -} - - -ATTR Patterns Pattern [ | | patternAttrs USE {++} {[]} : {[(Identifier,Identifier,Bool)]} ] - -SEM Pattern - | Alias lhs.patternAttrs = [(@field,@attr,(@field == _LOC || @field == _INST))] - - - --- Giving them a number -ATTR Nonterminals Nonterminal Productions Production - [ | vcount : Int - | rules USE {Seq.><} {Seq.empty} : {Seq (Vertex,CRule)}] -SEM Grammar - | Grammar nonts.vcount = 0 -SEM Production - | Production lhs.rules = Seq.fromList (zip [@lhs.vcount..] @gathRules) - lhs.vcount = @lhs.vcount + length @gathRules - --- Direct dependencies -ATTR Nonterminals Nonterminal - Productions Production - Rules Rule [ | | directDep USE {Seq.><} {Seq.empty} : {Seq Edge} ] -SEM Rule - | Rule lhs.directDep - = let defined = Map.keys @defines - used = [ Map.lookup (AltAttr field attr True) @lhs.altAttrs | (field,attr) <- @rhs.usedAttrs] - ++ [ Map.lookup (AltAttr _LOC attr True) @lhs.altAttrs | attr <- @rhs.usedLocals ++ @rhs.usedFields ] - in Seq.fromList [ (x,y) | Just x <- used, y <- defined ] - --- Manual depdendencies (provided by the programmer) --- --- a dependency f1.a1 < f2.a2 is translated to --- the edge (vertex(f1.a1), vertex(f2.a2)) -ATTR Nonterminals Nonterminal - Productions Production - [ manualAttrDepMap : {AttrOrderMap} | | additionalDep USE {Seq.><} {Seq.empty} : {Seq Edge} ] - -SEM Grammar - | Grammar - nonts.manualAttrDepMap = @manualAttrOrderMap - -SEM Production - | Production - loc.manualDeps - = Set.toList $ Map.findWithDefault Set.empty @con $ Map.findWithDefault Map.empty @lhs.nt @lhs.manualAttrDepMap - - lhs.additionalDep - = Seq.fromList [ (vertex True occA, vertex False occB) - | Dependency occA occB <- @loc.manualDeps - , let vertex inout (OccAttr child nm) - | child == _LOC = findWithErr2 (AltAttr _LOC nm True) @loc.altAttrs - | otherwise = findWithErr2 (AltAttr child nm inout) @loc.altAttrs - vertex _ (OccRule nm) - = findWithErr2 (AltAttr _LOC (Ident ("_rule_" ++ show nm) (getPos nm)) True) @loc.altAttrs - ] - --- Inst dependencies --- --- For each inst attribute x of nt N, add the dependency --- (inst.x,x.y) for each synthesized attribute of N --- - -ATTR Nonterminals Nonterminal - Productions Production - Rules Rule [ | | instDep USE {Seq.><} {Seq.empty} : {Seq Edge} ] -SEM Rule - | Rule - loc.instDep1 - = Seq.fromList $ - [ (instVert, synVert) - | (field,instNm,_) <- Map.elems @defines - , field == _INST - , synNm <- Map.keys (findWithErr2 instNm @lhs.synsOfChildren) - , let instAttr = AltAttr _INST instNm True - synAttr = AltAttr instNm synNm True - instVert = findWithErr2 instAttr @lhs.altAttrs - synVert = findWithErr2 synAttr @lhs.altAttrs - ] - loc.instDep2 - = Seq.fromList $ - [ (instVert, inhVert) - | (field,instNm,_) <- Map.elems @defines - , field == _INST - , inhNm <- Map.keys (findWithErr2 instNm @lhs.inhsOfChildren) - , let instAttr = AltAttr _INST instNm True - inhAttr = AltAttr instNm inhNm False - instVert = findWithErr2 instAttr @lhs.altAttrs - inhVert = findWithErr2 inhAttr @lhs.altAttrs - ] - lhs.instDep = @loc.instDep1 Seq.>< @loc.instDep2 - -ATTR Rules Rule [ synsOfChildren, inhsOfChildren : {Map Identifier Attributes} | | ] -SEM Production - | Production rules.synsOfChildren = @children.collectChildrenSyns - rules.inhsOfChildren = @children.collectChildrenInhs - -ATTR Children Child [ | | collectChildrenSyns, collectChildrenInhs USE {`Map.union`} {Map.empty} : {Map Identifier Attributes } ] -SEM Child - | Child lhs.collectChildrenSyns = Map.singleton @name @loc.syn - lhs.collectChildrenInhs = Map.singleton @name @loc.inh - --- --- Merge stuff --- - -ATTR Nonterminals Nonterminal - [ mergeMap : {Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier])))} | | ] - -ATTR Productions Production - [ mergeMap : {Map ConstructorIdent (Map Identifier (Identifier,[Identifier]))} | | ] - -SEM Nonterminal | Nonterminal loc.mergeMap = Map.findWithDefault Map.empty @nt @lhs.mergeMap -SEM Production | Production loc.mergeMap = Map.findWithDefault Map.empty @con @lhs.mergeMap - -ATTR Rules Rule Children Child Expression [ mergeMap : {Map Identifier (Identifier,[Identifier])} | | ] - --- for a child c : N, with merged children cs, add dependencies between synthesized attrs of --- c to synthesized attrs of cs, and to the merge-attribute -ATTR Nonterminals Nonterminal Productions Production - [ | | mergeDep USE {Seq.><} {Seq.empty} : {Seq Edge} ] - -SEM Production - | Production - lhs.mergeDep = @loc.mergeDep1 Seq.>< @loc.mergeDep2 - loc.mergeDep1 - = Seq.fromList $ - [ (childVert, synVert) - | childNm <- Map.keys @loc.mergeMap - , synNm <- Map.keys (findWithErr2 childNm @children.collectChildrenSyns) - , let childNm' = Ident (show childNm ++ "_merge") (getPos childNm) - childAttr = AltAttr _LOC childNm' True - synAttr = AltAttr childNm synNm True - childVert = findWithErr2 childAttr @loc.altAttrs - synVert = findWithErr2 synAttr @loc.altAttrs - ] - loc.mergeDep2 - = Seq.fromList $ - [ (mergedVert, sourceVert) - | (childNm, (_,cs)) <- Map.assocs @loc.mergeMap - , c <- cs - , synNm <- Map.keys (findWithErr2 childNm @children.collectChildrenSyns) - , let sourceAttr = AltAttr childNm synNm True - mergedAttr = AltAttr c synNm True - sourceVert = findWithErr2 sourceAttr @loc.altAttrs - mergedVert = findWithErr2 mergedAttr @loc.altAttrs - ] - - --- Around dependencies --- --- For each around x_around on x of nt N, add the dependency --- (x_around, x.y) for each synthesized attribute y of N --- - -ATTR Nonterminals Nonterminal - Productions Production - [ | | aroundDep USE {Seq.><} {Seq.empty} : {Seq Edge} ] - -ATTR Nonterminals Nonterminal - [ aroundMap : {Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))} || ] - -ATTR Productions Production - [ aroundMap : {Map ConstructorIdent (Map Identifier [Expression])} || ] - -SEM Nonterminal | Nonterminal loc.aroundMap = Map.findWithDefault Map.empty @nt @lhs.aroundMap -SEM Production | Production loc.aroundMap = Map.findWithDefault Map.empty @con @lhs.aroundMap - -SEM Grammar - | Grammar nonts.aroundMap = @aroundsMap - -SEM Production - | Production - loc.aroundDep1 - = Seq.fromList $ - [ (childVert, synVert) - | childNm <- Map.keys @loc.aroundMap - , synNm <- Map.keys (findWithErr2 childNm @children.collectChildrenSyns) - , let childNm' = Ident (show childNm ++ "_around") (getPos childNm) - childAttr = AltAttr _LOC childNm' True - synAttr = AltAttr childNm synNm True - childVert = findWithErr2 childAttr @loc.altAttrs - synVert = findWithErr2 synAttr @loc.altAttrs - ] - loc.aroundDep2 - = Seq.fromList $ - [ (childVert, inhVert) - | childNm <- Map.keys @loc.aroundMap - , inhNm <- Map.keys (findWithErr2 childNm @children.collectChildrenInhs) - , let childNm' = Ident (show childNm ++ "_around") (getPos childNm) - childAttr = AltAttr _LOC childNm' True - inhAttr = AltAttr childNm inhNm False - childVert = findWithErr2 childAttr @loc.altAttrs - inhVert = findWithErr2 inhAttr @loc.altAttrs - ] - lhs.aroundDep = @loc.aroundDep1 Seq.>< @loc.aroundDep2 - - --- Wrapping an Expression - -ATTR Expression [ nt,con :{Identifier} - allfields:{[(Identifier,Type,ChildKind)]} - allnts :{[Identifier]} - attrs :{[(Identifier,Identifier)]} - options :{Options} - || - errors :{Seq Error} - usedLocals:{[Identifier]} - usedAttrs :{[(Identifier,Identifier)]} - usedFields:{[Identifier]} - textLines :{[String]} - copy : SELF - allRhsVars : {Set (Identifier,Identifier)} - ] - --- appendum: filter out the syn attrs of merged children in the input attr list. --- add the merged children to the used attr list --- appendum: ignored the error reporting on expressions. These are already --- reported by the separate 'ResolveLocals' pass. -SEM Expression - | Expression loc.(textLines,usedAttrs,usedLocals,usedFields) - = let mergedChildren = [ x | (_,xs) <- Map.elems @lhs.mergeMap, x <- xs ] - attrsIn = filter (\(fld,_) -> not (fld `elem` mergedChildren)) @lhs.attrs - inherited = Inh_HsTokensRoot - { attrs_Inh_HsTokensRoot = attrsIn - , con_Inh_HsTokensRoot = @lhs.con - , allfields_Inh_HsTokensRoot = @lhs.allfields - , allnts_Inh_HsTokensRoot = @lhs.allnts - , nt_Inh_HsTokensRoot = @lhs.nt - , options_Inh_HsTokensRoot = @lhs.options - } - synthesized = wrap_HsTokensRoot (sem_HsTokensRoot (HsTokensRoot @tks)) inherited - in case synthesized of - Syn_HsTokensRoot - { textLines_Syn_HsTokensRoot = textLines - , usedAttrs_Syn_HsTokensRoot = usedAttrs - , usedLocals_Syn_HsTokensRoot = usedLocals - , usedFields_Syn_HsTokensRoot = usedFields - } -> let extraAttrs = [ (src,attr) - | (fld,attr) <- usedAttrs, let mbMerged = Map.lookup fld @lhs.mergeMap, isJust mbMerged - , let (Just (_, srcs)) = mbMerged, src <- srcs ] - usedAttrs' = usedAttrs ++ extraAttrs - in (textLines,usedAttrs',usedLocals,usedFields) - - lhs.errors = Seq.empty - lhs.allRhsVars = Set.fromList @loc.usedAttrs - `Set.union` - Set.fromList [ (_LOC, l) | l <- @loc.usedLocals] - `Set.union` - Set.fromList [ (_FIELD, fld) | fld <- @loc.usedFields] - - -------------------------------------- --- NT-Attributes -------------------------------------- -ATTR Nonterminals Nonterminal - [ | acount : Int | ntattrs USE {Seq.><} {Seq.empty} : {Seq (Vertex,NTAttr)} - aranges USE {Seq.><} {Seq.empty} : {Seq (Int,Int,Int)}] - -SEM Grammar - | Grammar nonts.acount = 0 - -SEM Nonterminal - | Nonterminal loc.ntattrs = [ NTAInh @nt inh tp | (inh,tp) <- Map.assocs @inh ] - ++ [NTASyn @nt syn tp | (syn,tp) <- Map.assocs @syn ] - lhs.ntattrs = Seq.fromList (zip [@lhs.acount ..] @ntattrs) - lhs.acount = @lhs.acount + Map.size @inh + Map.size @syn - lhs.aranges = Seq.singleton - (@lhs.acount - ,@lhs.acount + Map.size @inh - ,@lhs.acount + Map.size @syn + Map.size @inh - 1) ------------------------------------------------------------------- --- Pass structure up ------------------------------------------------------------------- -ATTR Nonterminals Nonterminal [ | | nonts USE {++} {[]} : {[(NontermIdent,[ConstructorIdent])]} ] -SEM Nonterminal - | Nonterminal lhs.nonts = [(@nt,@prods.cons)] -ATTR Productions Production [ | | cons USE {++} {[]} : {[ConstructorIdent]} ] -SEM Production - | Production lhs.cons = [@con] - ------------------------------------------------------------------- --- Collect type signatures ------------------------------------------------------------------- -ATTR TypeSigs TypeSig [ | typeSigs : {Map Identifier Type} | ] -SEM Production - | Production typeSigs.typeSigs = Map.empty -SEM TypeSig - | TypeSig lhs.typeSigs = Map.insert @name @tp @lhs.typeSigs - -ATTR Rules Rule Patterns Pattern [ allTypeSigs : {Map Identifier Type} | | ] -SEM Production - | Production rules.allTypeSigs = @typeSigs.typeSigs - ------------------------------------------------------------------- --- Invoking sequential computation ------------------------------------------------------------------- -SEM Grammar - | Grammar loc.ruleTable = Array.array (0,@nonts.vcount-1) (toList @nonts.rules) - loc.attrTable = Array.array (0,@nonts.acount-1) (toList @nonts.ntattrs) - loc.attrVertex = Map.fromList (map swap (toList @nonts.ntattrs)) - loc.tdpToTds = [ (s, maybe (-1) (\v -> findWithErr1 "Grammar.tdpToTds" v @attrVertex) (ntattr cr)) - | (s,cr) <- toList @nonts.rules] - loc.tdsToTdp = let eq (_,v) (_,v') = v == v' - conv ((s,v):svs) | v == -1 = Nothing - | otherwise = Just (v,s:map fst svs) - in mapMaybe conv (eqClasses eq @tdpToTds) - loc.directDep = toList (@nonts.directDep Seq.>< @nonts.additionalDep) - loc.instDep = toList @nonts.instDep - loc.aroundDep = toList @nonts.aroundDep - loc.mergeDep = toList @nonts.mergeDep - loc.info = let def [] = -1 - def (v:vs) = v - in Info { tdsToTdp = Array.array (0,@nonts.acount-1) @tdsToTdp - , tdpToTds = Array.array (0,@nonts.vcount-1) @tdpToTds - , attrTable = @attrTable - , ruleTable = @ruleTable - , lmh = toList @nonts.aranges - , nonts = @nonts.nonts - , wraps = @wrappers - } - - loc.(cInterfaceMap,cVisitsMap,cyclesErrors) = - case computeSequential @info @directDep (@instDep ++ @aroundDep ++ @loc.mergeDep) of - CycleFree cim cvm -> ( cim - , cvm - , [] - ) - LocalCycle errs -> ( error "No interfaces for AG with local cycles" - , error "No visit sub-sequences for AG with local cycles" - , map (localCycleErr @ruleTable (visit @lhs.options)) errs - ) - InstCycle errs -> ( error "No interfaces for AG with cycles through insts" - , error "No visit sub-sequences for AG with cycles through insts" - , map (instCycleErr @ruleTable (visit @lhs.options)) errs - ) - DirectCycle errs -> ( error "No interfaces for AG with direct cycles" - , error "No visit sub-sequences for AG with direct cycles" - , directCycleErrs @attrTable @ruleTable (visit @lhs.options) errs - ) - InducedCycle cim errs -> ( cim - , error "No visit sub-sequences for AG with induced cycles" - , inducedCycleErrs @attrTable @ruleTable cim errs - ) - lhs.errors = (if withCycle @lhs.options then Seq.fromList @cyclesErrors else Seq.empty) - Seq.>< @nonts.errors - ------------------------------------------------------------------- --- Generate CGrammar ------------------------------------------------------------------- --- Pass InterfaceMap down and select the Interface in the Nonterminal -ATTR Nonterminals Nonterminal [ cInterfaceMap : CInterfaceMap | | ] -SEM Nonterminal - | Nonterminal loc.cInter = if @lhs.o_dovisit - then findWithErr1 "Nonterminal.cInter" @nt @lhs.cInterfaceMap - else CInterface [CSegment @inh @syn] - --- Pass VisitMap down and select the CVisits in the Production -ATTR Nonterminals Nonterminal Productions Production [ cVisitsMap : CVisitsMap | | ] -SEM Production - | Production loc.cVisits = if @lhs.o_dovisit - then let prodsVisitsMap = findWithErr1 "Production.cVisits.nt" @lhs.nt @lhs.cVisitsMap - visits = findWithErr1 "Production.cVisits.con" @con prodsVisitsMap - in visits - else let vss = nubBy eqCRuleDefines @gathRules ++ @children.singlevisits - in [CVisit @lhs.inh @lhs.syn vss [] False] - --- Declarations for single visits -ATTR Child Children [ | | singlevisits USE {++} {[]}: {[CRule]}] -SEM Child - | Child lhs.singlevisits = if @maptolocal - then [] - else [CChildVisit @name (getNtName @tp) 0 @loc.inh @loc.syn True] - --- Now just build the CGrammar -SEM Grammar [ | | output : CGrammar ] - | Grammar lhs.output = CGrammar @typeSyns @derivings @wrappers @nonts.cNonterminals @pragmas @paramMap @contextMap @quantMap @loc.aroundMap @loc.mergeMap @loc.o_dovisit -SEM Nonterminals [ | | cNonterminals : CNonterminals ] - | Cons lhs.cNonterminals = @hd.cNonterminal : @tl.cNonterminals - | Nil lhs.cNonterminals = [] -SEM Nonterminal [ | | cNonterminal : CNonterminal ] - | Nonterminal lhs.cNonterminal = CNonterminal @nt @params @inh @syn @prods.cProductions @cInter -SEM Productions [ | | cProductions : CProductions ] - | Cons lhs.cProductions = @hd.cProduction : @tl.cProductions - | Nil lhs.cProductions = [] -SEM Production [ | | cProduction : CProduction ] - | Production lhs.cProduction = CProduction @con @cVisits @children.fields @children.terminals - -SEM Grammar - | Grammar loc.aroundMap = Map.map (Map.map Map.keysSet) @aroundsMap - loc.mergeMap = Map.map (Map.map (Map.map (\(nt,srcs,_) -> (nt,srcs)))) @mergeMap - --- Collect terminals -ATTR Children Child [ | | terminals USE {++} {[]} : {[Identifier]} ] -SEM Child - | Child lhs.terminals = if @maptolocal - then [@name] - else [] - - --- Collecting nts -ATTR Nonterminal Nonterminals - Production Productions - Rule Rules - Child Children [allnts:{[Identifier]} | | ] - -SEM Grammar - | Grammar nonts.allnts = map fst (@nonts.nonts) - --- Collecting fields -ATTR Rule Rules - Child Children [allfields:{[(Identifier,Type,ChildKind)]} attrs:{[(Identifier,Identifier)]} | | ] - -SEM Production - | Production loc.allfields = @children.fields - .attrs = map ((,) _LOC) @rules.locVars ++ - map ((,) _INST) @rules.instVars ++ - map ((,) _LHS) @inhnames ++ - concat [map ((,) nm) (Map.keys as) | (nm,_,as) <- @children.attributes] - .inhnames = Map.keys @lhs.inh - .synnames = Map.keys @lhs.syn - -ATTR Children [ | | attributes USE {++} {[]} : {[(Identifier,Attributes,Attributes)]} ] -SEM Child [ | | attributes:{[(Identifier,Attributes,Attributes)]} ] - | Child lhs.attributes = [(@name, @loc.inh, @loc.syn)] - - -SEM Child [ | | field : {(Identifier,Type,ChildKind)} ] - | Child lhs.field = (@name, @tp, @kind) - -SEM Children [ | | fields : {[(Identifier,Type,ChildKind)]} ] - | Cons lhs.fields = @hd.field : @tl.fields - | Nil lhs.fields = [] - -ATTR Rules Rule Patterns Pattern [ | | locVars USE {++} {[]}:{[Identifier]} instVars USE {++} {[]} : {[Identifier]} ] - -SEM Pattern - | Alias lhs.locVars = if @field == _LOC - then [@attr] - else [] - lhs.instVars = if @field == _INST - then [@attr] - else [] - -{ -swap (a,b) = (b,a) - -showPath :: Table CRule -> [Vertex] -> [String] -showPath ruleTable path - = let look a | inRange (bounds ruleTable) a = [showOrigin (ruleTable ! a)] - | otherwise = ["Vertex " ++ show a] - showOrigin cr | getHasCode cr && getName (getAttr cr) /= "self" = prettyCRule cr ++ " (" ++ show (getPos (getAttr cr)) ++ ")" - | otherwise = prettyCRule cr - in concatMap look path - - -showPathLocal :: Table CRule -> [Vertex] -> [String] -showPathLocal _ [] = [] -showPathLocal ruleTable xs = showP (xs++[-1]) - where showP [] = [] - showP (v1:v2:vs) = let line = step v1 v2 - lines = showP vs - in line:lines - step v1 v2 = " - " ++ a1 - where r1 = ruleTable ! v1 - a1 = show (getAttr r1) - - -limitTo :: Int -> [String] -> [String] -limitTo _ [] = [] -limitTo 0 _ = ["....etcetera, etcetera...."] -limitTo n (x:xs) = x : limitTo (n-1) xs - -showPathNice :: Table CRule -> [Vertex] -> [String] -showPathNice _ [] = [] -showPathNice ruleTable xs = limitTo 100 (showP ((-1):xs++[-1])) - where [maxf, maxa, maxn, maxc] = maxWidths ruleTable (take 100 xs) - showP [] = [] - showP (v1:v2:vs) = let line = step v1 v2 - lines = showP vs - in if null line then lines else line:lines - step v1 v2 | last && first = induced - | last && isSyn r1 = "pass up " ++ alignR maxf "" ++ " " ++ alignL maxa a1 ++ " in " ++ alignR maxn n1 ++ "|" ++ c1 ++ induced - | first&& not(isSyn r2) = "get from above " ++ alignR maxf "" ++ " " ++ alignL maxa a2 ++ " in " ++ alignR maxn n2 ++ "|" ++ c2 - | last = "pass down " ++ alignR maxf f1 ++ "." ++ a1 ++ induced - | isSyn r2 = "get from below " ++ alignR maxf f2 ++ "." ++ alignL maxa a2 ++ " in " ++ alignR maxn n2 ++ "|" ++ c2 - | isLocal r1 = if head a1 == '_' - then "" - else "calculate " ++ alignR maxf "loc" ++ "." ++ a1 - | otherwise = "pass down " ++ alignR maxf f1 ++ "." ++ alignL maxa a1 ++ " to " ++ alignR maxn n2 ++ "|" ++ c2 - where - first = v1<0 - last = v2<0 - r1 = ruleTable ! v1 - r2 = ruleTable ! v2 - a1 = show (getAttr r1) - a2 = show (getAttr r2) - f1 = show (getField r1) - f2 = show (getField r2) - n1 = show (getLhsNt r1) - n2 = show (getLhsNt r2) - c1 = show (getCon r1) - c2 = show (getCon r2) - induced | v2== -2 = " INDUCED dependency to " - | otherwise = "" - - -maxWidths ruleTable vs - = map maximum (transpose (map getWidth vs)) - where getWidth v | v<0 = [0,0,0,0] - | otherwise = map (length . show . ($ (ruleTable!v))) [getField, getAttr, getLhsNt, getCon] - -alignL n xs | k Bool -> Route -> Error -localCycleErr ruleTable o_visit (s:path) - = let cr = ruleTable ! s - attr = getAttr cr - nt = getLhsNt cr - con = getCon cr - in LocalCirc nt con attr o_visit (showPathLocal ruleTable path) - -instCycleErr :: Table CRule -> Bool -> Route -> Error -instCycleErr ruleTable o_visit (s:path) - = let cr = ruleTable ! s - attr = getAttr cr - nt = getLhsNt cr - con = getCon cr - in InstCirc nt con attr o_visit (showPathLocal ruleTable path) - -directCycleErrs :: Table NTAttr -> Table CRule -> Bool -> [EdgeRoutes] -> [Error] -directCycleErrs attrTable ruleTable o_visit xs - = let getNont v = case attrTable ! v of - NTASyn nt _ _ -> nt - NTAInh nt _ _ -> nt - getAttr v = case attrTable ! v of - NTASyn _ a _ -> a - NTAInh _ a _ -> a - sameNont ((v1,_),_,_) ((v2,_),_,_) = getNont v1 == getNont v2 - procCycle ((v1,v2),p1,p2) = ((getAttr v1, getAttr v2), showPathNice ruleTable p1, showPathNice ruleTable p2) - wrapGroup gr@(((v1,_),_,_):_) = DirectCirc (getNont v1) o_visit (map procCycle gr) - in map wrapGroup (groupBy sameNont xs) - -inducedCycleErrs :: Table NTAttr -> Table CRule -> CInterfaceMap -> [EdgeRoutes] -> [Error] -inducedCycleErrs attrTable ruleTable cim xs - = let getNont v = case attrTable ! v of - NTASyn nt _ _ -> nt - NTAInh nt _ _ -> nt - getAttr v = case attrTable ! v of - NTASyn _ a _ -> a - NTAInh _ a _ -> a - sameNont ((v1,_),_,_) ((v2,_),_,_) = getNont v1 == getNont v2 - procCycle ((v1,v2),p1,p2) = ((getAttr v1, getAttr v2), showPathNice ruleTable p1, showPathNice ruleTable p2) - wrapGroup gr@(((v1,_),_,_):_) = InducedCirc (getNont v1) (findWithErr1 "inducedCycleErr.cinter" (getNont v1) cim) (map procCycle gr) - in map wrapGroup (groupBy sameNont xs) -} diff --git a/src-ag/Patterns.ag b/src-ag/Patterns.ag deleted file mode 100644 --- a/src-ag/Patterns.ag +++ /dev/null @@ -1,25 +0,0 @@ -imports -{ --- Patterns.ag imports -import UU.Scanner.Position(Pos) -import CommonTypes (ConstructorIdent,Identifier) -} - -TYPE Patterns = [Pattern] - -DATA Pattern | Constr name : {ConstructorIdent} - pats : Patterns - | Product pos : {Pos} - pats : Patterns - | Alias field : {Identifier} - attr : {Identifier} - pat : Pattern - | Irrefutable pat : Pattern - | Underscore pos : {Pos} - -DERIVING Pattern:Show - -ATTR AllPattern [ | | copy : SELF ] - -SET AllPattern - = Pattern Patterns diff --git a/src-ag/PrintCleanCode.ag b/src-ag/PrintCleanCode.ag deleted file mode 100644 --- a/src-ag/PrintCleanCode.ag +++ /dev/null @@ -1,563 +0,0 @@ -PRAGMA strictdata -PRAGMA optimize -PRAGMA bangpats -PRAGMA strictwrap - -INCLUDE "Code.ag" -INCLUDE "Patterns.ag" - -imports -{ -import Data.Char (isAlphaNum) -import Pretty -import Code -import Options -import CommonTypes (attrname, _LOC, nullIdent) -import Data.List(intersperse) -import System.IO -import System.Directory -import System.FilePath -import CommonTypes(BlockInfo, BlockKind(..)) -} - -{ -type PP_Docs = [PP_Doc] -} - -{ -ppMultiSeqH :: [PP_Doc] -> PP_Doc -> PP_Doc -ppMultiSeqH = ppMultiSeq' (>#<) - -ppMultiSeqV :: [PP_Doc] -> PP_Doc -> PP_Doc -ppMultiSeqV = ppMultiSeq' (>-<) - -ppMultiSeq' :: (PP_Doc -> PP_Doc -> PP_Doc) -> [PP_Doc] -> PP_Doc -> PP_Doc -ppMultiSeq' next strictArgs expr - = foldr (\v r -> (v >#< "`seq`") `next` pp_parens r) expr strictArgs -} - -ATTR Expr Exprs Decl Decls CaseAlt CaseAlts Lhs [ outputfile : {String} | | ] - -SEM Chunk - | Chunk - loc.outputfile = if sepSemMods @lhs.options - then replaceBaseName @lhs.mainFile (takeBaseName @lhs.mainFile ++ "_" ++ @name) - else @lhs.mainFile - -ATTR Program [ options:{Options} | | output:{PP_Docs} ] - -ATTR Expr Exprs Decl Decls Chunk Chunks CaseAlts CaseAlt Lhs Pattern Patterns [ options:{Options} | | ] - -ATTR Expr Decl DataAlt Type NamedType Lhs [ nested:{Bool} | | pp:{PP_Doc} ] -ATTR Decl DataAlt NamedType [ | | ppa USE {>-<} {empty} : {PP_Doc}] - -ATTR Exprs DataAlts Types NamedTypes Decls Chunk Chunks [ nested:{Bool} | | pps : {PP_Docs} ] -ATTR DataAlts NamedTypes [ | | ppas : {PP_Docs} ] - -ATTR CaseAlt CaseAlts [ nested:{Bool} | | pps: {PP_Docs} ] - -ATTR Type Types [ | | copy : SELF] - -SEM Program | Program - loc.options = @lhs.options { breadthFirst = breadthFirst @lhs.options && visit @lhs.options && cases @lhs.options && @ordered } - -SEM Program - | Program chunks.nested = nest @lhs.options - -SEM Exprs - | Cons lhs.pps = @hd.pp : @tl.pps - | Nil lhs.pps = [] - -SEM CaseAlts - | Cons lhs.pps = @hd.pps ++ @tl.pps - | Nil lhs.pps = [] - -SEM DataAlts - | Cons lhs.pps = @hd.pp : @tl.pps - lhs.ppas = @hd.ppa : @tl.ppas - | Nil lhs.pps = [] - lhs.ppas = [] - -SEM Types - | Cons lhs.pps = @hd.pp : @tl.pps - | Nil lhs.pps = [] - -SEM NamedTypes - | Cons lhs.pps = @hd.pp : @tl.pps - lhs.ppas = @hd.ppa : @tl.ppas - | Nil lhs.pps = [] - lhs.ppas = [] - -SEM Decls - | Cons lhs.pps = @hd.pp : @tl.pps - | Nil lhs.pps = [] - -SEM Chunks - | Cons lhs.pps = @hd.pps ++ @tl.pps - | Nil lhs.pps = [] - - -SEM Program - | Program lhs.output = @chunks.pps - -SEM Chunk - | Chunk lhs.pps = @comment.pp - : @info.pps - ++ @dataDef.pps - ++ @cataFun.pps - ++ @semDom.pps - ++ @semWrapper.pps - ++ @semFunctions.pps - ++ [Map.findWithDefault empty (BlockOther, Just $ identifier @name) @lhs.textBlockMap] - -SEM Decl - | Decl lhs.pp = @left.pp >#< "=" - >-< indent 4 @rhs.pp - | Bind lhs.pp = @left.pp >#< "<-" >#< @rhs.pp - | BindLet lhs.pp = "let" >#< @left.pp >#< "=" >#< @rhs.pp - | Data lhs.pp = "::" >#< hv_sp (@name : @params) - >#< ( case @alts.pps of - [] -> empty - (x:xs) -> "=" >#< x - >-< vlist (map ("|" >#<) xs) - >-< if null @derivings - then empty - else "deriving" >#< ppTuple False (map text @derivings) - ) - >-< foldr (>-<) empty @alts.ppas - - | NewType lhs.pp = "::" >#< hv_sp (@name : @params) >#< "=" >#< @con >#< pp_parens @tp.pp - | Type lhs.pp = "::" >#< hv_sp (@name : @params) >#< ":==" >#< @tp.pp - | TSig lhs.pp = @name >#< "::" >#< @tp.pp - | Comment lhs.pp = if '\n' `elem` @txt - then "/*" >-< vlist (lines @txt) >-< "*/" - else "//" >#< @txt - | PragmaDecl lhs.pp = "/*#" >#< text @txt >#< "#*/" -- Not used in Clean - | Resume lhs.pp = if @monadic - then @left.pp >#< "<-" >#< @rhs.pp - else @left.pp >#< "=" >-< indent 4 @rhs.pp - | EvalDecl loc.strat = if breadthFirstStrict @lhs.options - then "stepwiseEval" - else "lazyEval" - lhs.pp = if breadthFirst @lhs.options - then @left.pp >#< "=" >#< "case" >#< @loc.strat >#< pp_parens @rhs.pp >#< "of" - >-< indent 4 ( - pp_parens (@nt >|< "_Syn" >#< "_val") >#< "-> _val" - ) - else @left.pp >#< "=" >#< @rhs.pp - -SEM Expr - | Let lhs.pp = pp_parens ( "let" >#< (vlist @decls.pps) - >-< "in " >#< @body.pp - ) - | Case lhs.pp = pp_parens ( "case" >#< pp_parens @expr.pp >#< "of" - >-< (vlist @alts.pps) - ) - | Do lhs.pp = pp_parens ( "do" >#< ( vlist @stmts.pps - >-< ("return" >#< @body.pp)) - ) - | Lambda loc.strictParams = if strictSems @lhs.options - then @args.pps - else [] - loc.addBang = if bangpats @lhs.options - then \p -> pp_parens ("!" >|< p) - else id - lhs.pp = pp_parens ( "\\" >#< (vlist (map @loc.addBang @args.pps)) >#< "->" - >-< indent 4 (@loc.strictParams `ppMultiSeqV` @body.pp) - ) - | TupleExpr lhs.pp = ppTuple @lhs.nested @exprs.pps - | UnboxedTupleExpr lhs.pp = ppUnboxedTuple @lhs.nested @exprs.pps - | App lhs.pp = pp_parens $ @name >#< hv_sp @args.pps - | SimpleExpr lhs.pp = text @txt - | TextExpr lhs.pp = vlist (map text @lns) - | Trace lhs.pp = "trace" >#< ( pp_parens ("\"" >|< text @txt >|< "\"") - >-< pp_parens @expr.pp - ) - | PragmaExpr lhs.pp = let pragmaDoc = "/*#" >#< @txt >#< "#*/" -- Not used in Clean - op = if @onNewLine - then (>-<) - else (>#<) - leftOp x y = if @onLeftSide - then x `op` y - else y - rightOp x y = if @onLeftSide - then x - else x `op` y - in pp_parens (pragmaDoc `leftOp` @expr.pp `rightOp` pragmaDoc) - | LineExpr lhs.pp = @expr.pp >-< "/*# LINE" >#< ppWithLineNr (\n -> pp $ show $ n + 1) >#< show @lhs.outputfile >#< "#*/" - >-< "" - | TypedExpr lhs.pp = pp_parens (@expr.pp >#< "::" >#< @tp.pp) - | ResultExpr lhs.pp = if breadthFirst @lhs.options - then "final" >#< - pp_parens (@nt >|< "_Syn" >#< pp_parens @expr.pp) - else @expr.pp - | InvokeExpr lhs.pp = if breadthFirst @lhs.options - then "invoke" >#< pp_parens @expr.pp >#< pp_parens ( - @nt >|< "_Inh" >#< pp_parens (ppTuple False @args.pps)) - else @expr.pp >#< hv_sp @args.pps - | ResumeExpr lhs.pp = if breadthFirst @lhs.options - then pp_parens ("resume" >#< pp_parens @expr.pp - >-< indent 2 (pp_parens ( "\\" >|< - pp_parens ("~" >|< pp_parens (@nt >|< "_Syn" >#< "_inh_arg")) - >#< "->" - >-< indent 2 ( "let" >#< @left.pp >#< "= _inh_arg" - >-< indent 2 ("in" >#< @rhs.pp) - )))) - else pp_parens ( "case" >#< pp_parens @expr.pp >#< "of" - >-< ("{" >#< @left.pp >#< "->") - >-< indent 4 (@rhs.pp >#< "}") - ) - | SemFun loc.strictParams = if strictSems @lhs.options - then @args.pps - else [] - loc.addBang = if bangpats @lhs.options - then \p -> pp_parens ("!" >|< p) - else id - lhs.pp = if breadthFirst @lhs.options - then "Child" >#< pp_parens ( "\\" >|< - pp_parens (@nt >|< "_Inh" >#< - ppTuple False (map @loc.addBang @args.pps)) >#< "->" - >-< indent 2 (@loc.strictParams `ppMultiSeqV` @body.pp)) - else if null @args.pps - then @body.pp - else pp_parens ( "\\" >#< (vlist (map @loc.addBang @args.pps)) >#< "->" - >-< indent 4 (@loc.strictParams `ppMultiSeqV` @body.pp) - ) - -SEM CaseAlt - | CaseAlt lhs.pps = ["{" >#< @left.pp >#< "->", @expr.pp >#< "}"] - -SEM DataAlt - | DataAlt lhs.pp = @name >#< hv_sp (map ((@lhs.strictPre >|<) . pp_parens) @args.pps) - lhs.ppa = empty - | Record lhs.pp = @name >#< hv_sp (map ((@lhs.strictPre >|<) . pp_parens) @args.pps) -- @name >#< pp_block "{" "}" "," @args.pps - lhs.ppa = let f n d = d >#< (pp_block ("(" ++ @name) ")" "" $ map pp (ppat n)) - >#< pp "=" >#< pp "x" - ppat n = replicate (length @args.ppas - n - 1) (pp " _") ++ [pp " x"] ++ replicate n (pp " _") - in snd $ foldr (\x (n, xs) -> (n + 1, f n x >-< xs)) (0, empty) @args.ppas - -SEM NamedType - | Named lhs.pp = -- @name >#< "::" >#< - if @strict - then "!" >|< pp_parens @tp.pp - else @tp.pp - lhs.ppa = pp @name - -SEM Lhs - | Pattern3 TupleLhs UnboxedTupleLhs - loc.addStrictGuard = if strictCases @lhs.options && @loc.hasStrictVars then \v -> v >#< "|" >#< @loc.strictGuard else id - | Pattern3 - loc.strictGuard = @pat3.strictVars `ppMultiSeqH` (pp "True") - loc.hasStrictVars = not (null @pat3.strictVars) - | TupleLhs UnboxedTupleLhs - loc.strictGuard = if stricterCases @lhs.options && not @lhs.isDeclOfLet - then map text @comps `ppMultiSeqH` (pp "True") - else pp "True" - loc.hasStrictVars = not (null @comps) - - | Fun - loc.addStrictGuard = if strictSems @lhs.options && @loc.hasStrictVars then \v -> v >#< "|" >#< @loc.strictGuard else id - loc.hasStrictVars = not (null @args.pps) - loc.strictGuard = @args.pps `ppMultiSeqH` (pp "True") - - | TupleLhs UnboxedTupleLhs Fun - loc.addBang = if bangpats @lhs.options - then \p -> "!" >|< p - else id - - | Pattern3 lhs.pp = @loc.addStrictGuard @pat3.pp - | Pattern3SM lhs.pp = @pat3.pp' - | TupleLhs lhs.pp = @loc.addStrictGuard $ ppTuple @lhs.nested (map (@loc.addBang . text) @comps) - | UnboxedTupleLhs lhs.pp = @loc.addStrictGuard $ ppUnboxedTuple @lhs.nested (map (@loc.addBang . text) @comps) - | Fun lhs.pp = @loc.addStrictGuard (@name >#< hv_sp (map @loc.addBang @args.pps)) - | Unwrap lhs.pp = pp_parens (@name >#< @sub.pp) - -SEM Type [ | | prec:Int ] - | Arr lhs.prec = 2 - .pp = case @right.copy of - Arr{} -> @loc.l >-< @loc.r - _ -> @loc.l >#< "->" >-< @loc.r - loc.l = if @left.prec <= 2 then pp_parens @left.pp else @left.pp - .r = if @right.prec < 2 then pp_parens @right.pp else @right.pp - - | TypeApp - lhs.pp = pp "(" >#< hv_sp (@func.pp : @args.pps) >#< pp ")"-- TODO: Check - - | CtxApp - lhs.pp = @right.pp >#< " | " >#< (pp_block "" "" "&" $ map (\(n,ns) -> hv_sp $ map pp (n:ns)) @left) - | QuantApp - lhs.pp = @left >#< @right.pp - - | TupleType lhs.prec = 5 - .pp = ppTuple @lhs.nested @tps.pps - - | UnboxedTupleType lhs.prec = 5 - .pp = ppUnboxedTuple @lhs.nested @tps.pps - - | List lhs.prec = 5 - .pp = "[" >|< @tp.pp >|< "]" - - | SimpleType lhs.prec = 5 - .pp = if reallySimple @txt then text @txt else pp_parens (text @txt) - - | NontermType lhs.prec = 5 - lhs.pp = @loc.prefix >|< text @name >#< hv_sp @params - loc.prefix = if @deforested - then text "T_" - else empty - | TMaybe lhs.prec = 5 - lhs.pp = text "Maybe" >#< pp_parens @tp.pp - | TEither lhs.prec = 5 - lhs.pp = text "Either" >#< pp_parens @left.pp >#< pp_parens @right.pp - | TMap lhs.prec = 5 - lhs.pp = text "'Data.Map'.Map" >#< pp_parens @key.pp >#< pp_parens @value.pp - | TIntMap lhs.prec = 5 - lhs.pp = text "'Data.IntMap'.IntMap" >#< pp_parens @value.pp - | TSet lhs.prec = 5 - lhs.pp = text "'Data.Set'.Set" >#< pp_parens @tp.pp - | TIntSet lhs.prec = 5 - lhs.pp = text "'Data.IntSet'.IntSet" - - -{ - -reallySimple :: String -> Bool -reallySimple = and . map (\x -> isAlphaNum x || x=='_') - -ppTuple :: Bool -> [PP_Doc] -> PP_Doc -ppTuple _ [x] = pp x -ppTuple True pps = "(" >|< pp_block " " (replicate (length pps `max` 1) ')') ",(" pps -ppTuple False pps = "(" >|< pp_block " " ")" "," pps -ppUnboxedTuple :: Bool -> [PP_Doc] -> PP_Doc -ppUnboxedTuple = ppTuple ---ppUnboxedTuple True pps = "(# " >|< pp_block " " (concat $ replicate (length pps `max` 1) " #)") ",(# " pps ---ppUnboxedTuple False pps = "(# " >|< pp_block " " " #)" "," pps - -} - - -------------------------------------------------------------------------------- --- Strict data fields -------------------------------------------------------------------------------- - -ATTR DataAlt DataAlts [ strictPre: PP_Doc | | ] - -SEM Decl - | Data alts.strictPre = if @strict then pp "!" else empty - -------------------------------------------------------------------------------- --- Strict variables -------------------------------------------------------------------------------- - -ATTR Pattern Patterns [ | | strictVars USE {++} {[]} : {[PP_Doc]} ] -SEM Pattern - | Alias - loc.strictVar - = if strictCases @lhs.options && not @lhs.isDeclOfLet - then [@loc.ppVar] - else [] - loc.strictPatVars - = if stricterCases @lhs.options && not @lhs.isDeclOfLet - then @pat.strictVars - else [] - lhs.strictVars - = @loc.strictVar ++ @loc.strictPatVars - | Irrefutable - lhs.strictVars = [] - -------------------------------------------------------------------------------- --- Pretty printing patterns -------------------------------------------------------------------------------- - -SEM Patterns [ | | pps : {[PP_Doc]} ] - | Cons lhs.pps = @hd.pp : @tl.pps - | Nil lhs.pps = [] - -SEM Pattern - | Constr Product Alias - loc.addBang = if bangpats @lhs.options && not @lhs.isDeclOfLet && not @lhs.belowIrrefutable - then \p -> "!" >|< p - else id - -SEM Pattern [ | | pp:PP_Doc ] - | Constr lhs.pp = @loc.addBang $ pp_parens $ @name >#< hv_sp @pats.pps - | Product lhs.pp = @loc.addBang $ pp_block "(" ")" "," @pats.pps - | Alias loc.ppVar = pp (attrname @lhs.options False @field @attr) - loc.ppVarBang = @loc.addBang $ @loc.ppVar - lhs.pp = if @pat.isUnderscore - then @loc.ppVarBang - else @loc.ppVarBang >|< "@" >|< @pat.pp - | Irrefutable lhs.pp = text "~" >|< pp_parens @pat.pp - | Underscore lhs.pp = text "_" - -SEM Pattern [ | | isUnderscore:{Bool}] - | Constr lhs.isUnderscore = False - | Product lhs.isUnderscore = False - | Alias lhs.isUnderscore = False - | Underscore lhs.isUnderscore = True - -ATTR Pattern Patterns [ belowIrrefutable : Bool | | ] -SEM Pattern - | Irrefutable - pat.belowIrrefutable = True - -SEM Lhs - | Pattern3 Pattern3SM - pat3.belowIrrefutable = False - -------------------------------------------------------------------------------- --- Pretty printing patterns for SM -------------------------------------------------------------------------------- - -SEM Patterns [ | | pps' : {[PP_Doc]} ] - | Cons lhs.pps' = @hd.pp' : @tl.pps' - | Nil lhs.pps' = [] - -SEM Pattern [ | | pp':PP_Doc ] - | Constr lhs.pp' = pp_parens $ @name >#< hv_sp (map pp_parens @pats.pps') - | Product lhs.pp' = pp_block "(" ")" "," @pats.pps' - | Alias lhs.pp' = let attribute | @field == _LOC || @field == nullIdent = locname' @attr - | otherwise = attrname @lhs.options False @field @attr - in attribute >|< "@" >|< @pat.pp' - | Irrefutable lhs.pp' = text "~" >|< pp_parens @pat.pp - | Underscore lhs.pp' = text "_" - -{ -locname' :: Identifier -> [Char] -locname' n = "_loc_" ++ getName n -} - -------------------------------------------------------------------------------- --- Determine if inside a Let -------------------------------------------------------------------------------- - -ATTR Chunks Chunk Decls Decl Lhs Pattern Patterns [ isDeclOfLet : Bool | | ] -SEM Program - | Program - chunks.isDeclOfLet = False - -SEM Expr - | Let - decls.isDeclOfLet = True - | Do - stmts.isDeclOfLet = False - | ResumeExpr - left.isDeclOfLet = False - -SEM CaseAlt - | CaseAlt - left.isDeclOfLet = False - - - -------------------------------------------------------------------------------- --- Alternative code printing to separate modules -------------------------------------------------------------------------------- - -ATTR Program [ mainBlocksDoc : PP_Doc | | genIO : {IO ()} ] -ATTR Program Chunks Chunk - [ importBlocks : PP_Doc - pragmaBlocks : String - textBlocks : PP_Doc - textBlockMap : {Map BlockInfo PP_Doc} - optionsLine : String - mainFile : String - mainName : String - moduleHeader : {String -> String -> String -> Bool -> String} - | | ] - -SEM Program - | Program - loc.mainModuleFile = @lhs.mainFile - loc.genMainModule - = writeModule @loc.mainModuleFile - ( [ pp $ @lhs.pragmaBlocks - , pp $ @lhs.optionsLine - , pp $ @lhs.moduleHeader @lhs.mainName "" "" False - , pp $ ("import " ++ @lhs.mainName ++ "_common\n") - ] - ++ map pp @chunks.imports - ++ map vlist @chunks.appendMain - ++ [@lhs.mainBlocksDoc] - ) - - loc.commonFile = replaceBaseName @lhs.mainFile (takeBaseName @lhs.mainFile ++ "_common") - loc.genCommonModule - = writeModule @loc.commonFile - ( [ pp $ @lhs.pragmaBlocks - , pp $ @lhs.optionsLine - , pp $ @lhs.moduleHeader @lhs.mainName "_common" "" True - , @lhs.importBlocks - , @lhs.textBlocks - ] - ++ map vlist @chunks.appendCommon - ) - - lhs.genIO = do @loc.genMainModule - @loc.genCommonModule - @chunks.genSems - -{ -renderDocs :: [PP_Doc] -> String -renderDocs pps = foldr (.) id (map (\d -> (disp d 50000) . ( '\n':) ) pps) "" -} - -ATTR Chunk Chunks [ | | imports USE {++} {[]} : {[String]} ] -SEM Chunk - | Chunk - lhs.imports = ["import " ++ @lhs.mainName ++ "_" ++ @name ++ "\n"] - -ATTR Chunk Chunks [ | | appendCommon, appendMain USE {++} {[]} : {[[PP_Doc]]} ] - -SEM Chunk - | Chunk - lhs.appendCommon - = [ [@comment.pp] - , @dataDef.pps - , @semDom.pps - , if reference @lhs.options then @semWrapper.pps else [] - ] - lhs.appendMain - = [ [@comment.pp] - , @cataFun.pps - , if reference @lhs.options then [] else @semWrapper.pps - ] - -ATTR Chunk Chunks [ | | genSems USE {>>} {return ()} : {IO ()} ] - -SEM Chunk - | Chunk - lhs.genSems - = writeModule @loc.outputfile - [ pp $ @lhs.pragmaBlocks - , pp $ Map.findWithDefault empty (BlockPragma, Just $ identifier @name) @lhs.textBlockMap - , pp $ @lhs.optionsLine - , pp $ @lhs.moduleHeader @lhs.mainName ("_" ++ @name) @loc.exports True - , pp $ ("import " ++ @lhs.mainName ++ "_common\n") - , pp $ Map.findWithDefault empty (BlockImport, Just $ identifier @name) @lhs.textBlockMap - , @comment.pp - , vlist_sep "" @info.pps - , vlist_sep "" @semFunctions.pps - , Map.findWithDefault empty (BlockOther, Just $ identifier @name) @lhs.textBlockMap - ] - -SEM Chunk - | Chunk - loc.exports = concat $ intersperse "," @semNames - -{ -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 -} - diff --git a/src-ag/PrintCode.ag b/src-ag/PrintCode.ag deleted file mode 100644 --- a/src-ag/PrintCode.ag +++ /dev/null @@ -1,542 +0,0 @@ -PRAGMA strictdata -PRAGMA optimize -PRAGMA bangpats -PRAGMA strictwrap - -INCLUDE "Code.ag" -INCLUDE "Patterns.ag" - -imports -{ -import Data.Char (isAlphaNum) -import Pretty -import Code -import Options -import CommonTypes (attrname, _LOC, nullIdent) -import Data.List(intersperse) -import System.IO -import System.Directory -import System.FilePath -import CommonTypes(BlockInfo, BlockKind(..)) -} - -{ -type PP_Docs = [PP_Doc] -} - -{ -ppMultiSeqH :: [PP_Doc] -> PP_Doc -> PP_Doc -ppMultiSeqH = ppMultiSeq' (>#<) - -ppMultiSeqV :: [PP_Doc] -> PP_Doc -> PP_Doc -ppMultiSeqV = ppMultiSeq' (>-<) - -ppMultiSeq' :: (PP_Doc -> PP_Doc -> PP_Doc) -> [PP_Doc] -> PP_Doc -> PP_Doc -ppMultiSeq' next strictArgs expr - = foldr (\v r -> (v >#< "`seq`") `next` pp_parens r) expr strictArgs -} - -ATTR Expr Exprs Decl Decls CaseAlt CaseAlts Lhs [ outputfile : {String} | | ] - -SEM Chunk - | Chunk - loc.outputfile = if sepSemMods @lhs.options - then replaceBaseName @lhs.mainFile (takeBaseName @lhs.mainFile ++ "_" ++ @name) - else @lhs.mainFile - -ATTR Program [ options:{Options} | | output:{PP_Docs} ] - -ATTR Expr Exprs Decl Decls Chunk Chunks CaseAlts CaseAlt Lhs Pattern Patterns [ options:{Options} | | ] - -ATTR Expr Decl DataAlt Type NamedType Lhs [ nested:{Bool} | | pp:{PP_Doc} ] - -ATTR Exprs DataAlts Types NamedTypes Decls Chunk Chunks [ nested:{Bool} | | pps : {PP_Docs} ] - -ATTR CaseAlt CaseAlts [ nested:{Bool} | | pps: {PP_Docs} ] - -SEM Program | Program - loc.options = @lhs.options { breadthFirst = breadthFirst @lhs.options && visit @lhs.options && cases @lhs.options && @ordered } - -SEM Program - | Program chunks.nested = nest @lhs.options - -SEM Exprs - | Cons lhs.pps = @hd.pp : @tl.pps - | Nil lhs.pps = [] - -SEM CaseAlts - | Cons lhs.pps = @hd.pps ++ @tl.pps - | Nil lhs.pps = [] - -SEM DataAlts - | Cons lhs.pps = @hd.pp : @tl.pps - | Nil lhs.pps = [] - -SEM Types - | Cons lhs.pps = @hd.pp : @tl.pps - | Nil lhs.pps = [] - -SEM NamedTypes - | Cons lhs.pps = @hd.pp : @tl.pps - | Nil lhs.pps = [] - -SEM Decls - | Cons lhs.pps = @hd.pp : @tl.pps - | Nil lhs.pps = [] - -SEM Chunks - | Cons lhs.pps = @hd.pps ++ @tl.pps - | Nil lhs.pps = [] - - -SEM Program - | Program lhs.output = @chunks.pps - -SEM Chunk - | Chunk lhs.pps = @comment.pp - : @info.pps - ++ @dataDef.pps - ++ @cataFun.pps - ++ @semDom.pps - ++ @semWrapper.pps - ++ @semFunctions.pps - ++ [Map.findWithDefault empty (BlockOther, Just $ identifier @name) @lhs.textBlockMap] - -SEM Decl - | Decl lhs.pp = @left.pp >#< "=" - >-< indent 4 @rhs.pp - | Bind lhs.pp = @left.pp >#< "<-" >#< @rhs.pp - | BindLet lhs.pp = "let" >#< @left.pp >#< "=" >#< @rhs.pp - | Data lhs.pp = "data" >#< hv_sp (@name : @params) - >#< ( case @alts.pps of - [] -> empty - (x:xs) -> "=" >#< x - >-< vlist (map ("|" >#<) xs) - >-< if null @derivings - then empty - else "deriving" >#< ppTuple False (map text @derivings) - ) - | NewType lhs.pp = "newtype" >#< hv_sp (@name : @params) >#< "=" >#< @con >#< pp_parens @tp.pp - | Type lhs.pp = "type" >#< hv_sp (@name : @params) >#< "=" >#< @tp.pp - | TSig lhs.pp = @name >#< "::" >#< @tp.pp - | Comment lhs.pp = if '\n' `elem` @txt - then "{-" >-< vlist (lines @txt) >-< "-}" - else "--" >#< @txt - | PragmaDecl lhs.pp = "{-#" >#< text @txt >#< "#-}" - | Resume lhs.pp = if @monadic - then @left.pp >#< "<-" >#< @rhs.pp - else @left.pp >#< "=" >-< indent 4 @rhs.pp - | EvalDecl loc.strat = if breadthFirstStrict @lhs.options - then "stepwiseEval" - else "lazyEval" - lhs.pp = if breadthFirst @lhs.options - then @left.pp >#< "=" >#< "case" >#< @loc.strat >#< pp_parens @rhs.pp >#< "of" - >-< indent 4 ( - pp_parens (@nt >|< "_Syn" >#< "_val") >#< "-> _val" - ) - else @left.pp >#< "=" >#< @rhs.pp - -SEM Expr - | Let lhs.pp = pp_parens ( "let" >#< (vlist @decls.pps) - >-< "in " >#< @body.pp - ) - | Case lhs.pp = pp_parens ( "case" >#< pp_parens @expr.pp >#< "of" - >-< (vlist @alts.pps) - ) - | Do lhs.pp = pp_parens ( "do" >#< ( vlist @stmts.pps - >-< ("return" >#< @body.pp)) - ) - | Lambda loc.strictParams = if strictSems @lhs.options - then @args.pps - else [] - loc.addBang = if bangpats @lhs.options - then \p -> pp_parens ("!" >|< p) - else id - lhs.pp = pp_parens ( "\\" >#< (vlist (map @loc.addBang @args.pps)) >#< "->" - >-< indent 4 (@loc.strictParams `ppMultiSeqV` @body.pp) - ) - | TupleExpr lhs.pp = ppTuple @lhs.nested @exprs.pps - | UnboxedTupleExpr lhs.pp = ppUnboxedTuple @lhs.nested @exprs.pps - | App lhs.pp = pp_parens $ @name >#< hv_sp @args.pps - | SimpleExpr lhs.pp = text @txt - | TextExpr lhs.pp = vlist (map text @lns) - | Trace lhs.pp = "trace" >#< ( pp_parens ("\"" >|< text @txt >|< "\"") - >-< pp_parens @expr.pp - ) - | PragmaExpr lhs.pp = let pragmaDoc = "{-#" >#< @txt >#< "#-}" - op = if @onNewLine - then (>-<) - else (>#<) - leftOp x y = if @onLeftSide - then x `op` y - else y - rightOp x y = if @onLeftSide - then x - else x `op` y - in pp_parens (pragmaDoc `leftOp` @expr.pp `rightOp` pragmaDoc) - | LineExpr lhs.pp = @expr.pp >-< "{-# LINE" >#< ppWithLineNr (\n -> pp $ show $ n + 1) >#< show @lhs.outputfile >#< "#-}" - >-< "" - | TypedExpr lhs.pp = pp_parens (@expr.pp >#< "::" >#< @tp.pp) - | ResultExpr lhs.pp = if breadthFirst @lhs.options - then "final" >#< - pp_parens (@nt >|< "_Syn" >#< pp_parens @expr.pp) - else @expr.pp - | InvokeExpr lhs.pp = if breadthFirst @lhs.options - then "invoke" >#< pp_parens @expr.pp >#< pp_parens ( - @nt >|< "_Inh" >#< pp_parens (ppTuple False @args.pps)) - else @expr.pp >#< hv_sp @args.pps - | ResumeExpr lhs.pp = if breadthFirst @lhs.options - then pp_parens ("resume" >#< pp_parens @expr.pp - >-< indent 2 (pp_parens ( "\\" >|< - pp_parens ("~" >|< pp_parens (@nt >|< "_Syn" >#< "_inh_arg")) - >#< "->" - >-< indent 2 ( "let" >#< @left.pp >#< "= _inh_arg" - >-< indent 2 ("in" >#< @rhs.pp) - )))) - else pp_parens ( "case" >#< pp_parens @expr.pp >#< "of" - >-< ("{" >#< @left.pp >#< "->") - >-< indent 4 (@rhs.pp >#< "}") - ) - | SemFun loc.strictParams = if strictSems @lhs.options - then @args.pps - else [] - loc.addBang = if bangpats @lhs.options - then \p -> pp_parens ("!" >|< p) - else id - lhs.pp = if breadthFirst @lhs.options - then "Child" >#< pp_parens ( "\\" >|< - pp_parens (@nt >|< "_Inh" >#< - ppTuple False (map @loc.addBang @args.pps)) >#< "->" - >-< indent 2 (@loc.strictParams `ppMultiSeqV` @body.pp)) - else if null @args.pps - then @body.pp - else pp_parens ( "\\" >#< (vlist (map @loc.addBang @args.pps)) >#< "->" - >-< indent 4 (@loc.strictParams `ppMultiSeqV` @body.pp) - ) - -SEM CaseAlt - | CaseAlt lhs.pps = ["{" >#< @left.pp >#< "->", @expr.pp >#< "}"] - -SEM DataAlt - | DataAlt lhs.pp = @name >#< hv_sp (map ((@lhs.strictPre >|<) . pp_parens) @args.pps) - | Record lhs.pp = @name >#< pp_block "{" "}" "," @args.pps - -SEM NamedType - | Named lhs.pp = if @strict - then @name >#< "::" >#< "!" >|< pp_parens @tp.pp - else @name >#< "::" >#< @tp.pp - -SEM Lhs - | Pattern3 TupleLhs UnboxedTupleLhs - loc.addStrictGuard = if strictCases @lhs.options && @loc.hasStrictVars then \v -> v >#< "|" >#< @loc.strictGuard else id - | Pattern3 - loc.strictGuard = @pat3.strictVars `ppMultiSeqH` (pp "True") - loc.hasStrictVars = not (null @pat3.strictVars) - | TupleLhs UnboxedTupleLhs - loc.strictGuard = if stricterCases @lhs.options && not @lhs.isDeclOfLet - then map text @comps `ppMultiSeqH` (pp "True") - else pp "True" - loc.hasStrictVars = not (null @comps) - - | Fun - loc.addStrictGuard = if strictSems @lhs.options && @loc.hasStrictVars then \v -> v >#< "|" >#< @loc.strictGuard else id - loc.hasStrictVars = not (null @args.pps) - loc.strictGuard = @args.pps `ppMultiSeqH` (pp "True") - - | TupleLhs UnboxedTupleLhs Fun - loc.addBang = if bangpats @lhs.options - then \p -> "!" >|< p - else id - - | Pattern3 lhs.pp = @loc.addStrictGuard @pat3.pp - | Pattern3SM lhs.pp = @pat3.pp' - | TupleLhs lhs.pp = @loc.addStrictGuard $ ppTuple @lhs.nested (map (@loc.addBang . text) @comps) - | UnboxedTupleLhs lhs.pp = @loc.addStrictGuard $ ppUnboxedTuple @lhs.nested (map (@loc.addBang . text) @comps) - | Fun lhs.pp = @loc.addStrictGuard (@name >#< hv_sp (map @loc.addBang @args.pps)) - | Unwrap lhs.pp = pp_parens (@name >#< @sub.pp) - -SEM Type [ | | prec:Int ] - | Arr lhs.prec = 2 - .pp = @loc.l >#< "->" >-< @loc.r - loc.l = if @left.prec <= 2 then pp_parens @left.pp else @left.pp - .r = if @right.prec < 2 then pp_parens @right.pp else @right.pp - - | TypeApp - lhs.pp = hv_sp (@func.pp : @args.pps) - - | CtxApp - lhs.pp = (pp_block "(" ")" "," $ map (\(n,ns) -> hv_sp $ map pp (n:ns)) @left) >#< "=>" >#< @right.pp - | QuantApp - lhs.pp = @left >#< @right.pp - - | TupleType lhs.prec = 5 - .pp = ppTuple @lhs.nested @tps.pps - - | UnboxedTupleType lhs.prec = 5 - .pp = ppUnboxedTuple @lhs.nested @tps.pps - - | List lhs.prec = 5 - .pp = "[" >|< @tp.pp >|< "]" - - | SimpleType lhs.prec = 5 - .pp = if reallySimple @txt then text @txt else pp_parens (text @txt) - - | NontermType lhs.prec = 5 - lhs.pp = @loc.prefix >|< text @name >#< hv_sp @params - loc.prefix = if @deforested - then text "T_" - else empty - | TMaybe lhs.prec = 5 - lhs.pp = text "Maybe" >#< pp_parens @tp.pp - | TEither lhs.prec = 5 - lhs.pp = text "Either" >#< pp_parens @left.pp >#< pp_parens @right.pp - | TMap lhs.prec = 5 - lhs.pp = text "Data.Map.Map" >#< pp_parens @key.pp >#< pp_parens @value.pp - | TIntMap lhs.prec = 5 - lhs.pp = text "Data.IntMap.IntMap" >#< pp_parens @value.pp - | TSet lhs.prec = 5 - lhs.pp = text "Data.Set.Set" >#< pp_parens @tp.pp - | TIntSet lhs.prec = 5 - lhs.pp = text "Data.IntSet.IntSet" - - -{ - -reallySimple :: String -> Bool -reallySimple = and . map (\x -> isAlphaNum x || x=='_') - -ppTuple :: Bool -> [PP_Doc] -> PP_Doc -ppTuple True pps = "(" >|< pp_block " " (replicate (length pps `max` 1) ')') ",(" pps -ppTuple False pps = "(" >|< pp_block " " ")" "," pps -ppUnboxedTuple :: Bool -> [PP_Doc] -> PP_Doc -ppUnboxedTuple True pps = "(# " >|< pp_block " " (concat $ replicate (length pps `max` 1) " #)") ",(# " pps -ppUnboxedTuple False pps = "(# " >|< pp_block " " " #)" "," pps - -} - - -------------------------------------------------------------------------------- --- Strict data fields -------------------------------------------------------------------------------- - -ATTR DataAlt DataAlts [ strictPre: PP_Doc | | ] - -SEM Decl - | Data alts.strictPre = if @strict then pp "!" else empty - -------------------------------------------------------------------------------- --- Strict variables -------------------------------------------------------------------------------- - -ATTR Pattern Patterns [ | | strictVars USE {++} {[]} : {[PP_Doc]} ] -SEM Pattern - | Alias - loc.strictVar - = if strictCases @lhs.options && not @lhs.isDeclOfLet - then [@loc.ppVar] - else [] - loc.strictPatVars - = if stricterCases @lhs.options && not @lhs.isDeclOfLet - then @pat.strictVars - else [] - lhs.strictVars - = @loc.strictVar ++ @loc.strictPatVars - | Irrefutable - lhs.strictVars = [] - -------------------------------------------------------------------------------- --- Pretty printing patterns -------------------------------------------------------------------------------- - -SEM Patterns [ | | pps : {[PP_Doc]} ] - | Cons lhs.pps = @hd.pp : @tl.pps - | Nil lhs.pps = [] - -SEM Pattern - | Constr Product Alias - loc.addBang = if bangpats @lhs.options && not @lhs.isDeclOfLet && not @lhs.belowIrrefutable - then \p -> "!" >|< p - else id - -SEM Pattern [ | | pp:PP_Doc ] - | Constr lhs.pp = @loc.addBang $ pp_parens $ @name >#< hv_sp @pats.pps - | Product lhs.pp = @loc.addBang $ pp_block "(" ")" "," @pats.pps - | Alias loc.ppVar = pp (attrname @lhs.options False @field @attr) - loc.ppVarBang = @loc.addBang $ @loc.ppVar - lhs.pp = if @pat.isUnderscore - then @loc.ppVarBang - else @loc.ppVarBang >|< "@" >|< @pat.pp - | Irrefutable lhs.pp = text "~" >|< pp_parens @pat.pp - | Underscore lhs.pp = text "_" - -SEM Pattern [ | | isUnderscore:{Bool}] - | Constr lhs.isUnderscore = False - | Product lhs.isUnderscore = False - | Alias lhs.isUnderscore = False - | Underscore lhs.isUnderscore = True - -ATTR Pattern Patterns [ belowIrrefutable : Bool | | ] -SEM Pattern - | Irrefutable - pat.belowIrrefutable = True - -SEM Lhs - | Pattern3 Pattern3SM - pat3.belowIrrefutable = False - -------------------------------------------------------------------------------- --- Pretty printing patterns for SM -------------------------------------------------------------------------------- - -SEM Patterns [ | | pps' : {[PP_Doc]} ] - | Cons lhs.pps' = @hd.pp' : @tl.pps' - | Nil lhs.pps' = [] - -SEM Pattern [ | | pp':PP_Doc ] - | Constr lhs.pp' = pp_parens $ @name >#< hv_sp (map pp_parens @pats.pps') - | Product lhs.pp' = pp_block "(" ")" "," @pats.pps' - | Alias lhs.pp' = let attribute | @field == _LOC || @field == nullIdent = locname' @attr - | otherwise = attrname @lhs.options False @field @attr - in attribute >|< "@" >|< @pat.pp' - | Irrefutable lhs.pp' = text "~" >|< pp_parens @pat.pp - | Underscore lhs.pp' = text "_" - -{ -locname' :: Identifier -> [Char] -locname' n = "_loc_" ++ getName n -} - -------------------------------------------------------------------------------- --- Determine if inside a Let -------------------------------------------------------------------------------- - -ATTR Chunks Chunk Decls Decl Lhs Pattern Patterns [ isDeclOfLet : Bool | | ] -SEM Program - | Program - chunks.isDeclOfLet = False - -SEM Expr - | Let - decls.isDeclOfLet = True - | Do - stmts.isDeclOfLet = False - | ResumeExpr - left.isDeclOfLet = False - -SEM CaseAlt - | CaseAlt - left.isDeclOfLet = False - - - -------------------------------------------------------------------------------- --- Alternative code printing to separate modules -------------------------------------------------------------------------------- - -ATTR Program [ mainBlocksDoc : PP_Doc | | genIO : {IO ()} ] -ATTR Program Chunks Chunk - [ importBlocks : PP_Doc - pragmaBlocks : String - textBlocks : PP_Doc - textBlockMap : {Map BlockInfo PP_Doc} - optionsLine : String - mainFile : String - mainName : String - moduleHeader : {String -> String -> String -> Bool -> String} - | | ] - -SEM Program - | Program - loc.mainModuleFile = @lhs.mainFile - loc.genMainModule - = writeModule @loc.mainModuleFile - ( [ pp $ @lhs.pragmaBlocks - , pp $ @lhs.optionsLine - , pp $ @lhs.moduleHeader @lhs.mainName "" "" False - , pp $ ("import " ++ @lhs.mainName ++ "_common\n") - ] - ++ map pp @chunks.imports - ++ map vlist @chunks.appendMain - ++ [@lhs.mainBlocksDoc] - ) - - loc.commonFile = replaceBaseName @lhs.mainFile (takeBaseName @lhs.mainFile ++ "_common") - loc.genCommonModule - = writeModule @loc.commonFile - ( [ pp $ @lhs.pragmaBlocks - , pp $ @lhs.optionsLine - , pp $ @lhs.moduleHeader @lhs.mainName "_common" "" True - , @lhs.importBlocks - , @lhs.textBlocks - ] - ++ map vlist @chunks.appendCommon - ) - - lhs.genIO = do @loc.genMainModule - @loc.genCommonModule - @chunks.genSems - -{ -renderDocs :: [PP_Doc] -> String -renderDocs pps = foldr (.) id (map (\d -> (disp d 50000) . ( '\n':) ) pps) "" -} - -ATTR Chunk Chunks [ | | imports USE {++} {[]} : {[String]} ] -SEM Chunk - | Chunk - lhs.imports = ["import " ++ @lhs.mainName ++ "_" ++ @name ++ "\n"] - -ATTR Chunk Chunks [ | | appendCommon, appendMain USE {++} {[]} : {[[PP_Doc]]} ] - -SEM Chunk - | Chunk - lhs.appendCommon - = [ [@comment.pp] - , @dataDef.pps - , @semDom.pps - , if reference @lhs.options then @semWrapper.pps else [] - ] - lhs.appendMain - = [ [@comment.pp] - , @cataFun.pps - , if reference @lhs.options then [] else @semWrapper.pps - ] - -ATTR Chunk Chunks [ | | genSems USE {>>} {return ()} : {IO ()} ] - -SEM Chunk - | Chunk - lhs.genSems - = writeModule @loc.outputfile - [ pp $ @lhs.pragmaBlocks - , pp $ Map.findWithDefault empty (BlockPragma, Just $ identifier @name) @lhs.textBlockMap - , pp $ @lhs.optionsLine - , pp $ @lhs.moduleHeader @lhs.mainName ("_" ++ @name) @loc.exports True - , pp $ ("import " ++ @lhs.mainName ++ "_common\n") - , pp $ Map.findWithDefault empty (BlockImport, Just $ identifier @name) @lhs.textBlockMap - , @comment.pp - , vlist_sep "" @info.pps - , vlist_sep "" @semFunctions.pps - , Map.findWithDefault empty (BlockOther, Just $ identifier @name) @lhs.textBlockMap - ] - -SEM Chunk - | Chunk - loc.exports = concat $ intersperse "," @semNames - -{ -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 -} - diff --git a/src-ag/PrintErrorMessages.ag b/src-ag/PrintErrorMessages.ag deleted file mode 100644 --- a/src-ag/PrintErrorMessages.ag +++ /dev/null @@ -1,656 +0,0 @@ -INCLUDE "ErrorMessages.ag" - -imports -{ -import UU.Scanner.Position(Pos(..), noPos) -import ErrorMessages -import Data.List(mapAccumL) -import GrammarInfo -import qualified Control.Monad.Error.Class as Err -} - - -{ -instance Err.Error Error where - noMsg = Err.strMsg "error" - strMsg = CustomError False noPos . pp -} - - -{ -isError :: Options -> Error -> Bool -isError _ (ParserError _ _ _ ) = True -isError _ (DupAlt _ _ _ ) = False -isError _ (DupSynonym _ _ ) = False -isError _ (DupSet _ _ ) = False -isError _ (DupInhAttr _ _ _ ) = True -isError _ (DupSynAttr _ _ _ ) = True -isError _ (DupChild _ _ _ _ ) = False -isError _ (DupRule _ _ _ _ _) = True -isError _ (DupSig _ _ _ ) = False -isError _ (UndefNont _ ) = True -isError _ (UndefAlt _ _ ) = True -isError _ (UndefChild _ _ _ ) = True -isError _ (MissingRule _ _ _ _ ) = False -isError _ (SuperfluousRule _ _ _ _ ) = False -isError _ (UndefLocal _ _ _ ) = True -isError _ (ChildAsLocal _ _ _ ) = False -isError _ (UndefAttr _ _ _ _ _) = True -isError _ (CyclicSet _ ) = True -isError _ (CustomError w _ _ ) = not w -isError opts (LocalCirc _ _ _ _ _) = cycleIsDangerous opts -isError opts (InstCirc _ _ _ _ _) = cycleIsDangerous opts -isError opts (DirectCirc _ _ _ ) = cycleIsDangerous opts -isError opts (InducedCirc _ _ _ ) = cycleIsDangerous opts -isError _ (MissingTypeSig _ _ _ ) = False -isError _ (MissingInstSig _ _ _ ) = True -isError _ (DupUnique _ _ _ ) = False -isError _ (MissingUnique _ _ ) = True -isError _ (MissingSyn _ _ ) = True -isError _ (MissingNamedRule _ _ _) = True -isError _ (DupRuleName _ _ _) = True -isError _ (HsParseError _ _) = True -isError _ (Cyclic _ _ _) = True -isError _ (IncompatibleVisitKind _ _ _ _) = True -isError _ (IncompatibleRuleKind _ _) = True -isError _ (IncompatibleAttachKind _ _) = True - -cycleIsDangerous :: Options -> Bool -cycleIsDangerous opts - = any ($ opts) [ wignore, bangpats, cases, strictCases, stricterCases, strictSems, withCycle ] -} - - - - - - -ATTR Error [ options:{Options} verbose:{Bool} | | pp :{PP_Doc} - me :SELF - ] - -ATTR Errors [ options:{Options} dups : {[String]} | | pp USE {>-<} {text ""} : {PP_Doc} - ] - -SEM Errors - | * loc.verbose = verbose @lhs.options - | Cons loc.str = disp @hd.pp 5000 "" - - lhs.pp = if @loc.str `elem` @lhs.dups - then @tl.pp - else @hd.pp >-< @tl.pp - tl.dups = @loc.str : @lhs.dups - | Nil lhs.pp = text "" - - -SEM Error - | ParserError lhs.pp = let mesg = text ("parser expecting " ++ @problem) - pat = text "" - help = text "" - act = text @action - in ppError (isError @lhs.options @me) @pos mesg pat help act @lhs.verbose - - | HsParseError lhs.pp = ppError True @pos (text @msg) (text "") (text "") (text "Correct the syntax of the Haskell code.") @lhs.verbose - - | DupAlt lhs.pp = let mesg = wfill ["Repeated definition for alternative", getName @con - ,"of nonterminal", getName @nt, "." - ] >-< - wfill ["First definition:", (showPos @occ1),"."] >-< - wfill ["Other definition:", (showPos @con),"."] - pat = "DATA" >#< getName @nt - >-< indent 2 ("|" >#< getName @con >#< "...") - >-< indent 2 ("|" >#< getName @con >#< "...") - - help = wfill ["The nonterminal",getName @nt,"has more than one alternative that" - ,"is labelled with the constructor name",getName @con,"." - ,"You should either rename or remove enough of them to make all" - ,"constructors of",getName @nt,"uniquely named." - ] - - act = wfill [ "The first alternative of name",getName @con - ,"you have given for nonterminal",getName @nt - ,"is considered valid. All other alternatives have been discarded." - ] - - in ppError (isError @lhs.options @me) (getPos @con) mesg pat help act @lhs.verbose - - | DupSynonym lhs.pp = let mesg = wfill ["Definition of type synonym", getName @nt, "clashes with another" - ,"type synonym." - ] >-< - wfill ["First definition:", (showPos @occ1),"."] >-< - wfill ["Type synonym :" , (showPos @nt),"."] - pat = "DATA" >#< getName @nt - >-< indent 2 ("|" >#< "...") - >-< "TYPE" >#< getName @nt >#< "=" >#< "..." - help = wfill ["A type synonym with name", getName @nt - ,"has been given while there already is TYPE" - ,"definition with the same name." - ,"You should either rename or remove the type synonym." - ] - act = wfill [ "The clashing type synonym will be ignored." - ] - in ppError (isError @lhs.options @me) (getPos @nt) mesg pat help act @lhs.verbose - - | DupSet lhs.pp = let mesg = wfill ["Definition of nonterminal set", getName @name, "clashes with another" - ,"set, a type synonym or a data definition." - ] >-< - wfill ["First definition:", (showPos @occ1),"."] >-< - wfill ["Set definition:" , (showPos @name),"."] - pat = "SET" >#< getName @name >#< "=" >#< "..." - >-< "SET" >#< getName @name >#< "=" >#< "..." - help = wfill ["A nonterminal set with name", getName @name - ,"has been given while there already is a SET, DATA, or TYPE" - ,"definition with the same name." - ,"You should either rename or remove the nonterminal set." - ] - act = wfill [ "The clashing nonterminal set will be ignored." - ] - in ppError (isError @lhs.options @me) (getPos @name) mesg pat help act @lhs.verbose - - | DupInhAttr lhs.pp = let mesg = wfill ["Repeated declaration of inherited attribute", getName @attr - , "of nonterminal", getName @nt, "." - ] >-< - wfill ["First definition:", (showPos @occ1),"."] >-< - wfill ["Other definition:", (showPos @attr),"."] - pat = "ATTR" >#< getName @nt >#< "[" >#< getName @attr >|< ":...," - >#< getName @attr >|< ":... | | ]" - - help = wfill ["The identifier" , getName @attr ,"has been declared" - ,"as an inherited (or chained) attribute for nonterminal" - ,getName @nt , "more than once, with possibly different types." - ,"Delete all but one or rename them to make them unique." - ] - act = wfill ["One declaration with its corresponding type is considered valid." - ,"All others have been discarded. The generated program will probably not run." - ] - - in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose - - | DupSynAttr lhs.pp = let mesg = wfill ["Repeated declaration of synthesized attribute", getName @attr - , "of nonterminal", getName @nt, "." - ] >-< - wfill ["First definition:", (showPos @occ1),"."] >-< - wfill ["Other definition:", (showPos @attr),"."] - pat = "ATTR" >#< getName @nt >#< "[ | |" >#< getName @attr >|< ":...," - >#< getName @attr >|< ":... ]" - - help = wfill ["The identifier" , getName @attr ,"has been declared" - ,"as a synthesized (or chained) attribute for nonterminal" - ,getName @nt , "more than once, with possibly different types." - ,"Delete all but one or rename them to make them unique." - ] - act = wfill ["One declaration with its corresponding type is considered valid." - ,"All others have been discarded. The generated program will probably not run." - ] - - in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose - - | DupChild lhs.pp = let mesg = wfill ["Repeated declaration for field", getName @name, "of alternative" - ,getName @con, "of nonterminal", getName @nt, "." - ] >-< - wfill ["First definition:", (showPos @occ1),"."] >-< - wfill ["Other definition:", (showPos @name),"."] - pat = "DATA" >#< getName @nt - >-< indent 2 ("|" >#< getName @con >#< (getName @name >|< ":..." >-< getName @name >|< ":...")) - - - help = wfill ["The alternative" ,getName @con , "of nonterminal" ,getName @nt - ,"has more than one field that is named" - , getName @name ++ ". Possibly they have different types." - ,"You should either rename or remove enough of them to make all fields of" - ,getName @con , "for nonterminal " , getName @nt , "uniquely named." - ] - act = wfill ["The last declaration with its corresponding type is considered valid." - ,"All others have been discarded." - ] - in ppError (isError @lhs.options @me) (getPos @name) mesg pat help act @lhs.verbose - - | DupRule lhs.pp = let mesg = wfill ["At constructor",getName @con, "of nonterminal", getName @nt, "there are two or more rules for" - ,showAttrDef @field @attr,"." - ] >-< - wfill ["First rule:", (showPos @occ1),"."] >-< - wfill ["Other rule:", (showPos @attr),"."] - - pat = "SEM" >#< getName @nt - >-< indent 2 ("|" >#< getName @con >#< ppAttr @field @attr >#< "= ...") - >-< indent 2 ("|" >#< getName @con >#< ppAttr @field @attr >#< "= ...") - - help = wfill ["In the rules for alternative" , getName @con , "of nonterminal" , getName @nt - ,", there is more than one rule for the" , showAttrDef @field @attr - ,". You should either rename or remove enough of them to make all rules for alternative" - ,getName @con , "of nonterminal " ,getName @nt , "uniquely named." - ] - act = wfill ["The last rule given is considered valid. All others have been discarded."] - in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose - - | DupRuleName lhs.pp = let mesg = wfill ["At constructor",getName @con, "of nonterminal", getName @nt, "there are two or more rule names for" - ,show @nm,"." - ] - - pat = "SEM" >#< getName @nt - >-< indent 2 ("|" >#< getName @con >#< show @nm >#< ": ... = ...") - >-< indent 2 ("|" >#< getName @con >#< show @nm >#< ": ... = ...") - - help = wfill ["In the rules for alternative" , getName @con , "of nonterminal" , getName @nt - ,", there is more than one rule name " , show @nm - ,". You should either rename or remove enough of them." - ] - act = wfill ["Compilation cannot continue."] - in ppError (isError @lhs.options @me) (getPos @nm) mesg pat help act @lhs.verbose - - | DupSig lhs.pp = let mesg = wfill ["At constructor",getName @con, "of nonterminal", getName @nt, "there are two or more typesignatures for" - ,showAttrDef _LOC @attr,"." - ] >-< - wfill ["First signature:", (showPos @attr),"."] - - pat = "SEM" >#< getName @nt - >-< indent 2 ("|" >#< getName @con >#< ppAttr _LOC @attr >#< "= ...") - >-< indent 2 ("|" >#< getName @con >#< ppAttr _LOC @attr >#< "= ...") - - help = wfill ["In the rules for alternative" , getName @con , "of nonterminal" , getName @nt - ,", there is more than one rule for the" , showAttrDef _LOC @attr - ,". You should remove enough of them to make all typesignatures for alternative" - ,getName @con , "of nonterminal " ,getName @nt , "unique." - ] - act = wfill ["The last typesignature given is considered valid. All others have been discarded."] - in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose - - | UndefNont lhs.pp = let mesg = wfill ["Nonterminal", getName @nt, "is not defined." - ] - pat = "DATA" >#< getName @nt >#< "..." - - help = wfill ["There are attributes and/or rules for nonterminal" , getName @nt ,", but there is no definition" - , "for" ,getName @nt, ". Maybe you misspelled it? Otherwise insert a definition." - ] - act = wfill ["Everything regarding the unknown nonterminal has been ignored."] - in ppError (isError @lhs.options @me) (getPos @nt) mesg pat help act @lhs.verbose - - | UndefAlt lhs.pp = let mesg = wfill ["Constructor", getName @con, "of nonterminal" ,getName @nt, "is not defined." - ] - pat = "DATA" >#< getName @nt - >-< indent 2 ("|" >#< getName @con >#< "...") - - help = wfill ["There are rules for alternative", getName @con , "of nonterminal" ,getName @nt - ,", but there is no definition for this alternative in the definitions of the" - ,"nonterminal" , getName @nt, ". Maybe you misspelled it? Otherwise insert a definition." - ] - act = wfill ["All rules for the unknown alternative have been ignored."] - in ppError (isError @lhs.options @me) (getPos @con) mesg pat help act @lhs.verbose - - | UndefChild lhs.pp = let mesg = wfill ["Constructor", getName @con, "of nonterminal" ,getName @nt - , "does not have a nontrivial field named", getName @name , "." - ] - pat = "SEM" >#< @nt - >-< indent 2 ("|" >#< getName @con >#< ppAttr @name (identifier "") >#< "= ...") - - help = wfill ["There are rules that define or use attributes of field" , getName @name - ,"in alternative" , getName @con , "of nonterminal" , getName @nt - ,", but there is no field with AG-type in the definition of the alternative." - ,"Maybe you misspelled it? Otherwise insert the field into the definition," - ,"or change its type from an HS-type to an AG-type." - ] - act = wfill ["All rules for the unknown field have been ignored."] - in ppError (isError @lhs.options @me) (getPos @name) mesg pat help act @lhs.verbose - - | MissingRule lhs.pp = let mesg = wfill ["Missing rule for", showAttrDef @field @attr , "in alternative" - , getName @con , "of nonterminal",getName @nt ,"." - ] - pat = "SEM" >#< @nt - >-< indent 2 ("|" >#< getName @con >#< ppAttr @field @attr >#< "= ...") - - help = wfill ["The", showAttrDef @field @attr, "in alternative", getName @con - , "of nonterminal", getName @nt, "is missing and cannot be inferred" - ,"by a copy rule, so you should add an appropriate rule." - ] - act = wfill ["The value of the attribute has been set to undefined."] - in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose - - | MissingNamedRule lhs.pp = let mesg = wfill ["Missing rule name ", show @name , "in alternative" - , getName @con , "of nonterminal",getName @nt ,"." - ] - pat = "SEM" >#< @nt - >-< indent 2 ("|" >#< getName @con >#< show @name >#< ": ... = ...") - - help = wfill ["There is a dependency on a rule with name ", show @name , "in alternative" - , getName @con , "of nonterminal",getName @nt ,", but no rule has been defined with this name. Maybe you misspelled it?" - ] - act = wfill ["Compilation cannot continue."] - in ppError (isError @lhs.options @me) (getPos @name) mesg pat help act @lhs.verbose - - | SuperfluousRule lhs.pp = let mesg = wfill ["Rule for non-existing", showAttrDef @field @attr , "at alternative" - , getName @con , "of nonterminal",getName @nt, "." - ] - pat = "SEM" >#< getName @nt - >-< indent 2 ("|" >#< getName @con >#< ppAttr @field @attr >#< "= ...") - - - help = wfill ["There is a rule for" , showAttrDef @field @attr , "in the definitions for alternative" , getName @con - ,"of nonterminal" , getName @nt, ", but this attribute does not exist. Maybe you misspelled it?" - ,"Otherwise either remove the rule or add an appropriate attribute definition." - ] - act = wfill ["The rule has been ignored."] - in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose - - | UndefLocal lhs.pp = let mesg = wfill ["Undefined local variable or field",getName @var, "at constructor" - , getName @con , "of nonterminal",getName @nt, "." - ] - pat = "SEM" >#< getName @nt - >-< indent 2 ("|" >#< getName @con >#< ". = " - >#< "..." >#< "@" >|< getName @var >#< "..." ) - - help = wfill ["A rule in the definitions for alternative" , getName @con ,"of nonterminal" - , getName @nt , "contains a local variable or field name that is not defined. " - ,"Maybe you misspelled it?" - ,"Otherwise either remove the rule or add an appropriate definition." - ] - act = wfill ["The generated program will not run."] - in ppError (isError @lhs.options @me) (getPos @var) mesg pat help act @lhs.verbose - - | ChildAsLocal lhs.pp = let mesg = wfill ["Nontrivial field ",getName @var, "is used as local at constructor" - , getName @con , "of nonterminal",getName @nt, "." - ] - pat = "SEM" >#< getName @nt - >-< indent 2 ("|" >#< getName @con >#< "... = " - >#< "..." >#< "@" >|< getName @var >#< "..." ) - - help = wfill ["A rule in the definitions for alternative" , getName @con ,"of nonterminal" - , getName @nt , "contains a nontrivial field name", getName @var, "." - ,"You should use @", getName @var, ".self instead, where self is a SELF-attribute." - ] - act = wfill ["The generated program probably contains a type error or has undefined variables."] - in ppError (isError @lhs.options @me) (getPos @var) mesg pat help act @lhs.verbose - - | UndefAttr lhs.pp = let mesg = wfill ["Undefined" - , if @isOut - then showAttrDef @field @attr - else showAttrUse @field @attr - , "at constructor" - , getName @con , "of nonterminal",getName @nt, "." - ] - pat = "SEM" >#< getName @nt - >-< indent 2 ("|" >#< getName @con >#< ". = " - >#< "..." >#< ppAttrUse @field @attr >#< "...") - - help = wfill ["A rule in the definitions for alternative" , getName @con ,"of nonterminal" - ,getName @nt , "contains an attribute that is not defined" - ,"Maybe you misspelled it?" - ,"Otherwise either remove the rule or add an appropriate attribute definition." - ] - act = wfill ["The generated program will not run."] - in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose - - | CyclicSet lhs.pp = let mesg = wfill ["Cyclic definition for nonterminal set", getName @name] - pat = "SET" >#< getName @name >#< "=" >#< "..." >#< getName @name >#< "..." - help = wfill ["The defintion for a nonterminal set named" , getName @name - ,"directly or indirectly refers to itself." - ,"Adapt the definition of the nonterminal set, to remove the cyclic dependency." - ] - act = wfill ["The nonterminal set", getName @name, "is considered to be empty."] - in ppError (isError @lhs.options @me) (getPos @name) mesg pat help act @lhs.verbose - - | Cyclic lhs.pp = let pos = getPos @nt - mesg = text "Circular dependency for nonterminal" >#< getName @nt - >#< ( case @mbCon of - Nothing -> empty - Just con -> text "and constructor" >#< con - ) - >#< ( case @verts of - v : _ -> text "including vertex" >#< text v - _ -> empty - ) - pat = text "cyclic rule definition" - help = hlist (text "The following attributes are all cyclic: " : map text @verts) - act = wfill ["code cannot be generated until the cycle is removed."] - in ppError (isError @lhs.options @me) pos mesg pat help act False - - | CustomError lhs.pp = let pat = text "unknown" - help = wfill ["not available."] - act = wfill ["unknown"] - in ppError (isError @lhs.options @me) @pos @mesg pat help act False - - | LocalCirc lhs.pp = let mesg = wfill ["Circular dependency for local attribute", getName @attr - , "of alternative", getName @con, "of nonterminal", getName @nt] - pat = "SEM" >#< getName @nt - >-< indent 2 ("|" >#< getName @con >#< "loc." >|< getName @attr >#< "=" - >#< "..." >#< "@loc." >|< getName @attr >#< "...") - help = if null @path - then text "the definition is directly circular" - else hlist ("The following attributes are involved in the cycle:": @path) - act | @o_visit = text "An unoptimized version was generated. It might hang when run." - | otherwise = text "The generated program might hang when run." - in ppError (isError @lhs.options @me) (getPos (@attr)) mesg pat help act @lhs.verbose - - | InstCirc lhs.pp = let mesg = wfill ["Circular dependency for inst attribute", getName @attr - , "of alternative", getName @con, "of nonterminal", getName @nt] - pat = "SEM" >#< getName @nt - >-< indent 2 ("|" >#< getName @con >#< "inst." >|< getName @attr >#< "=" - >#< "..." >#< "@s." >#< "...") - help = if null @path - then text "the definition is directly circular" - else hlist ("The following attributes are involved in the cycle:": @path) - act | @o_visit = text "An unoptimized version was generated. It might hang when run." - | otherwise = text "The generated program might hang when run." - in ppError (isError @lhs.options @me) (getPos (@attr)) mesg pat help act @lhs.verbose - - | DirectCirc lhs.pp = let mesg = wfill ["In nonterminal", getName @nt, "synthesized and inherited attributes are mutually dependent" ] - >-< vlist (map showEdge @cyclic) - pat = text "" - help = vlist (map showEdgeLong @cyclic) - act | @o_visit = text "An unoptimized version was generated. It might hang when run." - | otherwise = text "The generated program might hang when run." - in ppError (isError @lhs.options @me) noPos mesg pat help act @lhs.verbose - - | InducedCirc lhs.pp = let mesg = wfill ["After scheduling, in nonterminal", getName @nt, "synthesized and inherited attributes have an INDUCED mutual dependency" ] - >-< vlist (map showEdge @cyclic) - pat = text "" - showInter (CInterface segs) = concat (snd (mapAccumL (\i c -> (succ i :: Integer,("visit " ++ show i) : map ind (showsSegment c))) 0 segs)) - help = vlist (("Interface for nonterminal " ++ getName @nt ++ ":") : map ind (showInter @cinter)) - >-< vlist (map showEdgeLong @cyclic) - act = text "An unoptimized version was generated. It might hang when run." - in ppError (isError @lhs.options @me) noPos mesg pat help act @lhs.verbose - - | MissingTypeSig lhs.pp = let mesg = wfill ["Type signature needed, but not found for", showAttrDef _LOC @attr , "in alternative" - , getName @con , "of nonterminal",getName @nt ,"." - ]>-< - wfill ["Location:", (showPos @attr),"."] - pat = "SEM" >#< @nt - >-< indent 2 ("|" >#< getName @con >#< ppAttr _LOC @attr >#< ": ...") - help = wfill ["The", showAttrDef _LOC @attr, "in alternative", getName @con - ,"of nonterminal", getName @nt, "is needed in two separate visits to", getName @nt - ,"so its type is needed to generate type signatures." - ,"Please supply its type." - ] - act = wfill ["The type signatures of semantic functions are not generated."] - in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose - - | MissingInstSig lhs.pp = let mesg = wfill ["Type signature needed, but not found for", showAttrDef _INST @attr , "in alternative" - , getName @con , "of nonterminal",getName @nt ,"." - ]>-< - wfill ["Location:", (showPos @attr),"."] - pat = "SEM" >#< @nt - >-< indent 2 ("|" >#< getName @con >#< ppAttr _INST @attr >#< ": ...") - help = wfill ["The", showAttrDef _INST @attr, "in alternative", getName @con - ,"of nonterminal", getName @nt, "is a non-terminal attribute, so " - ,"its type is needed to attribute its value." - ,"Please supply its type." - ] - act = wfill ["It is not possible to proceed without this signature."] - in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose - - | MissingUnique lhs.pp = let mesg = wfill ["Missing unique counter (chained attribute)" - , getName @attr - , "at nonterminal" - , getName @nt, "." - ] - pat = "ATTR" >#< getName @nt >#< "[ |" >#< getName @attr >#< " : ... | ]" - - help = wfill ["A unique attribute signature in a constructor for nonterminal" , getName @nt - , "refers to an unique counter (chained attribute) named " - , getName @attr - ,"Maybe you misspelled it?" - ,"Otherwise either remove the signature or add an appropriate attribute definition." - ] - act = wfill ["It is not possible to proceed without this declaration."] - in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose - - | DupUnique lhs.pp = let mesg = wfill ["At constructor",getName @con, "of nonterminal", getName @nt, "there are two or more unique-attribute signatures for" - ,showAttrDef _LOC @attr,"." - ] >-< - wfill ["First signature:", (showPos @attr),"."] - - pat = "SEM" >#< getName @nt - >-< indent 2 ("|" >#< getName @con >#< ppAttr _LOC @attr >#< " : UNIQUEREF ...") - >-< indent 2 ("|" >#< getName @con >#< ppAttr _LOC @attr >#< " : UNIQUEREF ...") - - help = wfill ["In the rules for alternative" , getName @con , "of nonterminal" , getName @nt - ,", there is more than one unique-attribute signature for the" , showAttrDef _LOC @attr - ,". You should remove enough of them to make all unique-signatures for alternative" - ,getName @con , "of nonterminal " ,getName @nt , "unique." - ] - act = wfill ["Unpredicatable sharing of unique numbers may occur."] - in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose - - | MissingSyn lhs.pp = let mesg = wfill ["Missing synthesized attribute" - , getName @attr - , "at nonterminal" - , getName @nt, "." - ] - pat = "ATTR" >#< getName @nt >#< "[ | | " >#< getName @attr >#< " : ... ]" - - help = wfill ["An augment rule for a constructor for nonterminal" , getName @nt - , "refers to a synthesized attribute named " - , getName @attr - ,"Maybe you misspelled it?" - ,"Otherwise add an appropriate attribute definition." - ] - act = wfill ["It is not possible to proceed without this declaration."] - in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose - | IncompatibleVisitKind - lhs.pp = let mesg = "visit" >#< @vis >#< "of child" >#< @child >#< " with kind" >#< show @to >#< " cannot be called from a visit with kind " >#< show @from - pat = empty - help = empty - act = text "It is not possible to proceed without fixing this kind error." - in ppError (isError @lhs.options @me) (getPos @child) mesg pat help act @lhs.verbose - | IncompatibleRuleKind - lhs.pp = let mesg = "rule" >#< @rule >#< "cannot be called from a visit with kind " >#< show @kind - pat = empty - help = empty - act = text "It is not possible to proceed without fixing this kind error." - in ppError (isError @lhs.options @me) (getPos @rule) mesg pat help act @lhs.verbose - - | IncompatibleAttachKind - lhs.pp = let mesg = "child" >#< @child >#< "cannot be called from a visit with kind " >#< show @kind - pat = empty - help = empty - act = text "It is not possible to proceed without fixing this kind error." - in ppError (isError @lhs.options @me) (getPos @child) mesg pat help act @lhs.verbose - -{ -toWidth :: Int -> String -> String -toWidth n xs | k PP_Doc -showEdge ((inh,syn),_,_) - = text ("inherited attribute " ++ toWidth 20 (getName inh) ++ " with synthesized attribute " ++ getName syn) - -showEdgeLong :: ((Identifier,Identifier),[String],[String]) -> PP_Doc -showEdgeLong ((inh,syn),path1,path2) - = text ("inherited attribute " ++ getName inh ++ " is needed for " ++ "synthesized attribute " ++ getName syn) - >-< indent 4 (vlist (map text path2)) - >-< text "and back: " - >-< indent 4 (vlist (map text path1)) - -attrText :: Identifier -> Identifier -> String -attrText inh syn - = if inh == syn - then "threaded attribute " ++ getName inh - else "inherited attribute " ++ getName inh ++ " and synthesized attribute " ++getName syn - -showLineNr :: Int -> String -showLineNr i | i==(-1) = "CR" - | otherwise = show i - -showAttrDef :: Identifier -> Identifier -> String -showAttrDef f a | f == _LHS = "synthesized attribute " ++ getName a - | f == _LOC = "local attribute " ++ getName a - | f == _INST = "inst attribute " ++ getName a - | otherwise = "inherited attribute " ++ getName a ++ " of field " ++ getName f - -showAttrUse :: Identifier -> Identifier -> String -showAttrUse f a | f == _LHS = "inherited attribute " ++ getName a - | f == _LOC = "local attribute " ++ getName a - | f == _INST = "inst attribute " ++ getName a - | otherwise = "synthesized attribute " ++ getName a ++ " of field " ++ getName f - -ppAttr :: Identifier -> Identifier -> PP_Doc -ppAttr f a = text (getName f++"."++getName a) -ppAttrUse :: Identifier -> Identifier -> PP_Doc -ppAttrUse f a = "@" >|< ppAttr f a -} --- Printing of error messages - -{ -infixr 5 +#+ -(+#+) :: String -> String -> String -(+#+) s t = s ++ " " ++ t - -infixr 5 +.+ -(+.+) :: Identifier -> Identifier -> String -(+.+) s t = getName s ++ "." ++ getName t - -wfill :: [String] -> PP_Doc -wfill = fill . addSpaces. concat . map words - where addSpaces (x:xs) = x:map addSpace xs - addSpaces [] = [] - addSpace [x] | x `elem` ".,;:!?" = [x] - addSpace xs = ' ':xs - -ppError :: Bool -- class of the error, True:error False:warning - -> Pos -- source position - -> PP_Doc -- error message - -> PP_Doc -- pattern - -> PP_Doc -- help, more info - -> PP_Doc -- action taken by AG - -> Bool -- verbose? show help and action? - -> PP_Doc -ppError isErr pos mesg pat hlp act verb - = let position = case pos of - Pos l c f | l >= 0 -> f >|< ":" >|< show l >|< ":" >|< show c - | otherwise -> pp "uuagc" - tp = if isErr then "error" else "warning" - header = position >|< ":" >#< tp >|< ":" >#< mesg - pattern = "pattern :" >#< pat - help = "help :" >#< hlp - action = "action :" >#< act - in if verb - then vlist [text "",header,pattern,help,action] - else header - -{- --- old error reporting code - = let - cl = if isError then "ERROR" else "Warning" - position = case pos of - (Pos l c f) | l >= 0 -> f >|< ": line " >|< show l >|< ", column " >|< show c - | otherwise -> empty - header = "*** UU.AG" >#< cl >#< position >#< "***" - message = "problem :" >#< mesg - pattern = "pattern :" >#< pat - help = "help :" >#< hlp - action = "action :" >#< act - in - if verbose - then vlist [text "",header,message,pattern,help,action] - else vlist [text "",header,message] --} - -showPos :: Identifier -> String -showPos = show . getPos - -ppInterface :: Show a => a -> PP_Doc -ppInterface inter = wfill ["interface:", show inter] - -} - diff --git a/src-ag/PrintOcamlCode.ag b/src-ag/PrintOcamlCode.ag deleted file mode 100644 --- a/src-ag/PrintOcamlCode.ag +++ /dev/null @@ -1,222 +0,0 @@ -PRAGMA strictdata -PRAGMA optimize -PRAGMA bangpats -PRAGMA strictwrap - -INCLUDE "Code.ag" -INCLUDE "Patterns.ag" - -imports -{ -import Pretty -import Code -import Patterns -import Options -import CommonTypes hiding (List,Type,Map,Maybe,IntMap,Either) -import Data.List(intersperse,intercalate) -import Data.Char(toLower) -} - - -{ -type PP_Docs = [PP_Doc] - -ppMultiSeqH :: [PP_Doc] -> PP_Doc -> PP_Doc -ppMultiSeqH = ppMultiSeq' (>#<) - -ppMultiSeqV :: [PP_Doc] -> PP_Doc -> PP_Doc -ppMultiSeqV = ppMultiSeq' (>-<) - -ppMultiSeq' :: (PP_Doc -> PP_Doc -> PP_Doc) -> [PP_Doc] -> PP_Doc -> PP_Doc -ppMultiSeq' next strictArgs expr - = foldr (\v r -> (v >#< "`seq`") `next` pp_parens r) expr strictArgs - -ppTuple :: Bool -> [PP_Doc] -> PP_Doc -ppTuple True pps = "(" >|< pp_block " " (replicate (length pps `max` 1) ')') ",(" pps -ppTuple False pps = "(" >|< pp_block " " ")" "," pps -} - - --- --- Pass options down --- - -ATTR Program Expr Exprs Decl Decls Chunk Chunks CaseAlts CaseAlt Lhs Pattern Patterns [ options:{Options} | | ] - -ATTR Program Chunks Chunk [ textBlockMap : {Map BlockInfo PP_Doc} | | ] - - --- --- Collect outputs --- - -ATTR Program [ | | output:{PP_Docs} ] -ATTR Expr Decl DataAlt CaseAlt Type NamedType Lhs Pattern [ | | pp:{PP_Doc} ] -ATTR Exprs DataAlts CaseAlts Types NamedTypes Decls Chunk Chunks Patterns [ | | pps : {PP_Docs} ] - -SEM Program - | Program lhs.output = @chunks.pps - -SEM Exprs - | Cons lhs.pps = @hd.pp : @tl.pps - | Nil lhs.pps = [] - -SEM CaseAlts - | Cons lhs.pps = @hd.pp : @tl.pps - | Nil lhs.pps = [] - -SEM DataAlts - | Cons lhs.pps = @hd.pp : @tl.pps - | Nil lhs.pps = [] - -SEM Types - | Cons lhs.pps = @hd.pp : @tl.pps - | Nil lhs.pps = [] - -SEM NamedTypes - | Cons lhs.pps = @hd.pp : @tl.pps - | Nil lhs.pps = [] - -SEM Decls - | Cons lhs.pps = @hd.pp : @tl.pps - | Nil lhs.pps = [] - -SEM Chunks - | Cons lhs.pps = @hd.pps ++ @tl.pps - | Nil lhs.pps = [] - -SEM Patterns - | Cons lhs.pps = @hd.pp : @tl.pps - | Nil lhs.pps = [] - --- --- Individual cases --- - -SEM Chunk - | Chunk lhs.pps = @comment.pp - : @info.pps - ++ @dataDef.pps - ++ @semDom.pps - ++ @semFunctions.pps - ++ @semWrapper.pps - ++ @cataFun.pps - ++ [Map.findWithDefault empty (BlockOther, Just $ identifier @name) @lhs.textBlockMap] - -SEM Decl - | Decl lhs.pp = if @lhs.isToplevel - then "let" >#< @left.pp >#< "=" - >-< indent 4 @rhs.pp >#< ";;" - else "let" >#< @left.pp >#< "=" - >-< indent 4 @rhs.pp >#< "in" - | Bind lhs.pp = error "pp of Decl.Bind not supported" - | BindLet lhs.pp = error "pp of Decl.BindLet not supported" - | Data lhs.pp = "type" >#< hv_sp (map (\p -> "'" >|< p) @params ++ [text $ toOcamlTC @name]) - >#< ( case @alts.pps of - [] -> empty - (x:xs) -> "=" >#< x - >-< vlist (map ("|" >#<) xs) - ) - >#< ";;" - | NewType lhs.pp = error "pp of Decl.NewType not supported" - | Type lhs.pp = "type" >#< hv_sp (map (\p -> "'" >|< p) @params ++ [text $ toOcamlTC @name]) >#< "=" >#< @tp.pp >#< ";;" - | TSig lhs.pp = "(*" >#< @name >#< ":" >#< @tp.pp >#< "*)" - | Comment lhs.pp = if '\n' `elem` @txt - then "(* " >-< vlist (lines @txt) >-< "*)" - else "(*" >#< @txt >#< "*)" - | PragmaDecl lhs.pp = error "pp of Decl.PragmaDecl not supported" - - - SEM Expr - | Let lhs.pp = pp_parens $ vlist (@decls.pps ++ [@body.pp]) - | Case lhs.pp = pp_parens ( "match" >#< @expr.pp >#< "with" - >-< indent 2 ( case @alts.pps of - [] -> empty - (x:xs) -> " " >#< x - >-< vlist (map ("|" >#<) xs) - ) - ) - | Do lhs.pp = error "pp of Expr.Do not supported" - | Lambda lhs.pp = pp_parens ( pp "fun" >#< hv_sp @args.pps >#< "->" - >-< indent 2 @body.pp ) - | TupleExpr lhs.pp = ppTuple False @exprs.pps - | UnboxedTupleExpr lhs.pp = error "pp of Expr.UnboxedTupleExpr not supported" - | App lhs.pp = pp_parens $ @name >#< hv_sp @args.pps - | SimpleExpr lhs.pp = text @txt - | TextExpr lhs.pp = vlist (map text @lns) - | Trace lhs.pp = @expr.pp - | PragmaExpr lhs.pp = @expr.pp - | LineExpr lhs.pp = @expr.pp - | TypedExpr lhs.pp = @expr.pp - -SEM Lhs - | Pattern3 lhs.pp = @pat3.pp - | Pattern3SM lhs.pp = error "pp of Lhs.Pattern3SM not supported" - | TupleLhs lhs.pp = ppTuple False (map text @comps) - | UnboxedTupleLhs lhs.pp = error "pp of Lhs.UnboxedTupleLhs not supported" - | Fun lhs.pp = @name >#< hv_sp @args.pps - | Unwrap lhs.pp = pp_parens (@name >#< @sub.pp) - -SEM Type - | Arr lhs.pp = pp_parens (@left.pp >#< "->" >#< @right.pp) - | CtxApp lhs.pp = error "pp of Type.CtxApp not supported" - | TypeApp lhs.pp = pp_parens (hv_sp (@args.pps ++ [@func.pp])) - | TupleType lhs.pp = pp_block "(" ")" "," @tps.pps - | UnboxedTupleType - lhs.pp = error "pp of Type.UnboxedTupleType is not supported" - | List lhs.pp = @tp.pp >#< "list" - | SimpleType lhs.pp = text @txt - | NontermType lhs.pp = pp_block "(" ")" " " (map text @params ++ [text $ toOcamlTC @name]) - | TMaybe lhs.pp = @tp.pp >#< "opt" - | TEither lhs.pp = error "pp of Type.TEither is not supported" - | TMap lhs.pp = error "pp of Type.TMap is not supported" - | TIntMap lhs.pp = error "pp of Type.TIntMap is not supported" - | TSet lhs.pp = error "pp of Type.TSet is not supported" - | TIntSet lhs.pp = error "pp of Type.TIntSet is not supported" - -{ -toOcamlTC :: String -> String -toOcamlTC (c:cs) = toLower c : cs -toOcamlTC xs = xs -} - -SEM CaseAlt - | CaseAlt lhs.pp = @left.pp >#< "->" >#< @expr.pp - -SEM DataAlt - | DataAlt lhs.pp = @name >#< "of" >#< pp_block "" "" " * " (map pp_parens @args.pps) - | Record lhs.pp = pp_block "{" "}" ";" @args.pps - -SEM NamedType - | Named lhs.pp = @name >#< ":" >#< @tp.pp - -SEM Pattern - | Constr lhs.pp = pp_parens $ @name >#< hv_sp @pats.pps - | Product lhs.pp = pp_block "(" ")" "," @pats.pps - | Alias -- assuming here that there is only an underscore under an alias - lhs.pp = if @pat.isUnderscore - then pp (attrname @lhs.options False @field @attr) - else error "pp of Pattern.Alias is only supported in the form (x@_)" - | Irrefutable lhs.pp = error "pp of Pattern.Irrefutable not supported" - | Underscore lhs.pp = text "_" - -SEM Pattern [ | | isUnderscore:{Bool}] - | Constr lhs.isUnderscore = False - | Product lhs.isUnderscore = False - | Alias lhs.isUnderscore = False - | Underscore lhs.isUnderscore = True - --- --- Determine if a declaration is toplevel --- - -ATTR Chunks Chunk Decls Decl [ isToplevel : Bool | | ] -SEM Program - | Program - chunks.isToplevel = True - -SEM Expr - | Let - decls.isToplevel = False - | Do - stmts.isToplevel = False diff --git a/src-ag/PrintVisitCode.ag b/src-ag/PrintVisitCode.ag deleted file mode 100644 --- a/src-ag/PrintVisitCode.ag +++ /dev/null @@ -1,53 +0,0 @@ -PRAGMA strictwrap -PRAGMA strictdata -PRAGMA optimize - -INCLUDE "CodeSyntax.ag" -INCLUDE "Patterns.ag" -INCLUDE "DeclBlocks.ag" - -imports -{ -import CommonTypes -import SequentialTypes -import Options -import CodeSyntax -import ErrorMessages -import GrammarInfo -import DeclBlocks -import Pretty - -import qualified Data.Map as Map -import Data.Map(Map) -import qualified Data.Set as Set -import Data.Set(Set) -import qualified Data.Sequence as Seq -import Data.Sequence(Seq) -import UU.Scanner.Position - -import Data.List(partition,intersperse,intersect,(\\)) -import Data.Maybe(fromJust,isJust) -} - -{ -type PP_Docs = [PP_Doc] - -ppMultiSeqH :: [PP_Doc] -> PP_Doc -> PP_Doc -ppMultiSeqH = ppMultiSeq' (>#<) - -ppMultiSeqV :: [PP_Doc] -> PP_Doc -> PP_Doc -ppMultiSeqV = ppMultiSeq' (>-<) - -ppMultiSeq' :: (PP_Doc -> PP_Doc -> PP_Doc) -> [PP_Doc] -> PP_Doc -> PP_Doc -ppMultiSeq' next strictArgs expr - = foldr (\v r -> (v >#< "`seq`") `next` pp_parens r) expr strictArgs -} - - -WRAPPER CGrammar - -ATTR CGrammar [ options:{Options} | | output:{PP_Docs} ] - -SEM CGrammar - | CGrammar - lhs.output = [] diff --git a/src-ag/ResolveLocals.ag b/src-ag/ResolveLocals.ag deleted file mode 100644 --- a/src-ag/ResolveLocals.ag +++ /dev/null @@ -1,157 +0,0 @@ -INCLUDE "AbstractSyntax.ag" -INCLUDE "Patterns.ag" -INCLUDE "Expression.ag" -INCLUDE "DistChildAttr.ag" - - --- --- Checks right-hand sides for missing attributes. --- Attribute references @xxx are now explicitly mapped to @loc.xxx if there is such --- an attribute in scope and there is no terminal @xxx. --- - - -imports -{ -import qualified Data.Set as Set -import qualified Data.Map as Map -import Data.Map(Map) -import qualified Data.Sequence as Seq -import Data.Sequence(Seq,(><)) -import CommonTypes -import Patterns -import ErrorMessages -import AbstractSyntax -import Expression -import Options -import HsToken(HsTokensRoot(HsTokensRoot)) -import SemHsTokens(sem_HsTokensRoot,wrap_HsTokensRoot, Syn_HsTokensRoot(..),Inh_HsTokensRoot(..)) -import Data.Maybe -} - -WRAPPER Grammar - - --- --- Main attributes --- - -ATTR Grammar Nonterminals Nonterminal Productions Production Rule Rules Expression - [ options:{Options} | | ] - -ATTR Grammar Nonterminals Nonterminal Productions Production Rule Rules Pattern Patterns Expression - [ | | errors USE {Seq.><} {Seq.empty} : {Seq Error} ] - -ATTR Grammar Nonterminals Nonterminal Productions Production Child Children Rule Rules Pattern Patterns TypeSig TypeSigs Expression - [ | | output : SELF ] - --- --- Collect inputs to expressions --- - --- Collecting nts -ATTR Nonterminal Nonterminals - Production Productions - Rule Rules - Child Children [allnts:{[Identifier]} | | ] - -SEM Grammar - | Grammar nonts.allnts = map fst (@nonts.nonts) - -ATTR Nonterminals Nonterminal [ | | nonts USE {++} {[]} : {[(NontermIdent,[ConstructorIdent])]} ] -SEM Nonterminal - | Nonterminal lhs.nonts = [(@nt,@prods.cons)] -ATTR Productions Production [ | | cons USE {++} {[]} : {[ConstructorIdent]} ] -SEM Production - | Production lhs.cons = [@con] - --- Collecting fields -ATTR Rule Rules - Child Children [allfields:{[(Identifier,Type,ChildKind)]} attrs:{[(Identifier,Identifier)]} | | ] - -SEM Production - | Production loc.allfields = @children.fields - .attrs = map ((,) _LOC) @rules.locVars ++ - map ((,) _INST) @rules.instVars ++ - map ((,) _LHS) @inhnames ++ - concat [map ((,) nm) (Map.keys as) | (nm,_,as) <- @children.attributes] - .inhnames = Map.keys @lhs.inh - .synnames = Map.keys @lhs.syn - -ATTR Children [ | | attributes USE {++} {[]} : {[(Identifier,Attributes,Attributes)]} ] -SEM Child [ | | attributes:{[(Identifier,Attributes,Attributes)]} ] - | Child lhs.attributes = [(@name, @loc.inh, @loc.syn)] - -SEM Child [ | | field : {(Identifier,Type,ChildKind)} ] - | Child lhs.field = (@name, @tp, @kind) - -SEM Children [ | | fields : {[(Identifier,Type,ChildKind)]} ] - | Cons lhs.fields = @hd.field : @tl.fields - | Nil lhs.fields = [] - -ATTR Rules Rule Patterns Pattern [ | | locVars USE {++} {[]}:{[Identifier]} instVars USE {++} {[]} : {[Identifier]} ] - -SEM Pattern - | Alias lhs.locVars = if @field == _LOC - then [@attr] - else [] - lhs.instVars = if @field == _INST - then [@attr] - else [] - --- Distributing name of nonterminal and names of attributes -ATTR Productions Production Child Children Rules Rule Patterns Pattern [ nt : {Identifier} inh,syn : {Attributes} | | ] -ATTR Child Children Rules Rule Patterns Pattern [ con : {Identifier} | | ] - -SEM Production - | Production children . con = @con -SEM Production - | Production rules . con = @con -SEM Nonterminal - | Nonterminal prods . nt = @nt - -SEM Nonterminal - | Nonterminal prods.inh = @inh - prods.syn = @syn - --- merge map -SEM Grammar - | Grammar nonts.mergeMap = Map.map (Map.map (Map.map (\(nt,srcs,_) -> (nt,srcs)))) @mergeMap - -ATTR Nonterminals Nonterminal - [ mergeMap : {Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier])))} | | ] - -ATTR Productions Production - [ mergeMap : {Map ConstructorIdent (Map Identifier (Identifier,[Identifier]))} | | ] - -SEM Nonterminal | Nonterminal loc.mergeMap = Map.findWithDefault Map.empty @nt @lhs.mergeMap -SEM Production | Production loc.mergeMap = Map.findWithDefault Map.empty @con @lhs.mergeMap - -ATTR Rules Rule Children Child Expression [ mergeMap : {Map Identifier (Identifier,[Identifier])} | | ] - - --- --- Handling Expressions --- - -ATTR Expression [ nt,con :{Identifier} - allfields:{[(Identifier,Type,ChildKind)]} - allnts :{[Identifier]} - attrs :{[(Identifier,Identifier)]} - || ] - -SEM Expression - | Expression loc.(errors,newTks) - = let mergedChildren = [ x | (_,xs) <- Map.elems @lhs.mergeMap, x <- xs ] - attrsIn = filter (\(fld,_) -> not (fld `elem` mergedChildren)) @lhs.attrs - inherited = Inh_HsTokensRoot - { attrs_Inh_HsTokensRoot = attrsIn - , con_Inh_HsTokensRoot = @lhs.con - , allfields_Inh_HsTokensRoot = @lhs.allfields - , allnts_Inh_HsTokensRoot = @lhs.allnts - , nt_Inh_HsTokensRoot = @lhs.nt - , options_Inh_HsTokensRoot = @lhs.options - } - synthesized = wrap_HsTokensRoot (sem_HsTokensRoot (HsTokensRoot @tks)) inherited - in (errors_Syn_HsTokensRoot synthesized, output_Syn_HsTokensRoot synthesized) - lhs.output = Expression @pos @loc.newTks diff --git a/src-ag/SemHsTokens.ag b/src-ag/SemHsTokens.ag deleted file mode 100644 --- a/src-ag/SemHsTokens.ag +++ /dev/null @@ -1,144 +0,0 @@ -INCLUDE "HsToken.ag" - -imports -{ -import qualified Data.Sequence as Seq -import Data.Sequence(Seq,empty,singleton,(><)) -import Data.Foldable(toList) -import Pretty - -import TokenDef -import HsToken -import ErrorMessages -} - -ATTR HsTokensRoot - [ - | | - errors USE {Seq.><} {Seq.empty}:{Seq Error} - usedLocals:{[Identifier]} - usedAttrs :{[(Identifier,Identifier)]} - textLines :{[String]} - usedFields:{[Identifier]} - ] - -------------------------------------------------------------------------------- --- Context information -------------------------------------------------------------------------------- -ATTR HsTokensRoot - HsTokens HsToken [ nt,con : {Identifier} - allfields : {[(Identifier,Type,ChildKind)]} - allnts : {[Identifier]} - attrs : {[(Identifier,Identifier)]} - options : {Options} - || - ] - -ATTR HsTokens HsToken [ fieldnames : {[Identifier]} | | ] -SEM HsTokensRoot - | HsTokensRoot tokens.fieldnames = map (\(n,_,_) -> n) @lhs.allfields - -------------------------------------------------------------------------------- --- Errors -------------------------------------------------------------------------------- -ATTR HsTokens HsToken [ | | errors USE {Seq.><} {Seq.empty}:{Seq Error} ] - -------------------------------------------------------------------------------- --- Syntax errors -------------------------------------------------------------------------------- - -SEM HsToken - | Err lhs.errors = let m = text @mesg - in Seq.singleton (CustomError False @pos m) - -------------------------------------------------------------------------------- --- Undefined variables -------------------------------------------------------------------------------- - -{ -isNTname allnts (Just (NT nt _ _)) = nt `elem` allnts -isNTname allnts _ = False -} - - --- An AGLocal is either a local variable or a terminal -SEM HsToken - | AGLocal loc.tkAsLocal = AGLocal @var @pos @rdesc -- refers to the terminal - loc.tkAsField = AGField _LOC @var @pos @rdesc -- refers to the (local) attribute - loc.(errors,output,tok,usedLocals) = - if @var `elem` @lhs.fieldnames -- check if @var occurs as a terminal - then if isNTname @lhs.allnts (lookup @var (map (\(n,t,_) -> (n,t)) @lhs.allfields)) - then (Seq.singleton(ChildAsLocal @lhs.nt @lhs.con @var), @loc.tkAsLocal,(@pos,fieldname @var), [] ) - else (Seq.empty, @loc.tkAsLocal, (@pos,fieldname @var), [] ) - else if (_LOC,@var) `elem` @lhs.attrs - then (Seq.empty , @loc.tkAsField, (@pos,locname @lhs.options @var), [@var]) - else (Seq.singleton(UndefLocal @lhs.nt @lhs.con @var), @loc.tkAsField, (@pos,locname @lhs.options @var), [] ) - -SEM HsToken - | AGField lhs.errors = if (@field,@attr) `elem` @lhs.attrs - then Seq.empty - else if not(@field `elem` (_LHS : _LOC: @lhs.fieldnames)) - then Seq.singleton (UndefChild @lhs.nt @lhs.con @field) - else Seq.singleton (UndefAttr @lhs.nt @lhs.con @field @attr False) - -------------------------------------------------------------------------------- --- Used variables -------------------------------------------------------------------------------- - -ATTR HsTokens HsToken [ | | usedLocals USE {++} {[]} : {[Identifier]} - usedAttrs USE {++} {[]} : {[(Identifier,Identifier)]} ] - -SEM HsToken - | AGField (lhs.usedAttrs,lhs.usedLocals) - = if @field == _LOC - then ([], [@attr]) - else ([(@field,@attr)], []) - - -------------------------------------------------------------------------------- --- Used fields -------------------------------------------------------------------------------- -ATTR HsTokens HsToken [ | | usedFields USE {Seq.><} {Seq.empty} : {Seq Identifier} ] - -SEM HsToken - | AGLocal lhs.usedFields = if @var `elem` @lhs.fieldnames - then Seq.singleton @var - else Seq.empty -SEM HsTokensRoot - | HsTokensRoot lhs.usedFields = toList @tokens.usedFields - -------------------------------------------------------------------------------- --- Pretty printing -------------------------------------------------------------------------------- - -SEM HsTokensRoot - | HsTokensRoot lhs.textLines = showTokens @tokens.tks - -SEM HsTokens [ || tks : {[(Pos,String)]} ] - | Cons lhs.tks = @hd.tok : @tl.tks - | Nil lhs.tks = [] - -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 @lhs.options 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, "") - -------------------------------------------------------------------------------- --- Desugar (resolve AGLocals to explicit AGFields) -------------------------------------------------------------------------------- - -ATTR HsTokensRoot [ | | output : {[HsToken]} ] -ATTR HsTokens HsToken [ | | output : SELF ] - diff --git a/src-ag/TfmToVisage.ag b/src-ag/TfmToVisage.ag deleted file mode 100644 --- a/src-ag/TfmToVisage.ag +++ /dev/null @@ -1,147 +0,0 @@ --- !!!! The Visage AST does not support nonterminals with type variables! --- !!!! Type variables in data type declarations are ignored. - -INCLUDE "AbstractSyntax.ag" -INCLUDE "Patterns.ag" -INCLUDE "Expression.ag" -INCLUDE "DistChildAttr.ag" - -imports { -import AbstractSyntax -import VisagePatterns -import VisageSyntax -import qualified Data.Map as Map -import Data.Map (Map) -} - -{ --- Maps a rule to a pair --- Later, I expect to map to a list of rules, because we might need to unfold. - - --- Checks that a certain alias is in fact a Var in the old representation of the AG system -isVar (Alias _ _ (Underscore _)) = True -isVar _ = False - -type VisageRuleMap = [(String, VisageRule)] - -splitVRules :: [VisageRule] -> VisageRuleMap -splitVRules vrs = concat (map unfoldvrs vrs) - -unfoldvrs :: VisageRule -> VisageRuleMap -unfoldvrs vr@(VRule attrfields _ _ _ _) = zip (map (getName . fst) attrfields) (map (copyRule vr) attrfields) - -copyRule :: VisageRule -> (Identifier,Identifier) -> VisageRule -copyRule (VRule attrfields _ pat expr owrt) (field,attr) = VRule attrfields attr pat expr owrt - -getForField :: String -> VisageRuleMap -> [VisageRule] -getForField field xs = map snd (filter ((field ==) . fst) xs) - -{- - Delivers a map from fieldname to VisageRule with all references to others underscored. - So, (lhs.x, rt.y, loc.z) = (0,1,2) becomes something like - [("lhs", (lhs.x,_,_) = (0,1,2) - - At this point, we do not use this anymore. - -allways :: VisageRule -> VisageRuleMap -allways vr@(VRule vrfields _ _ _ _) = zip vrfields (map (underScoreRule vr) (nub vrfields)) - -splitVRules :: [VisageRule] -> VisageRuleMap -splitVRules vrs = concat (map allways vrs) - -underScoreRule :: VisageRule -> String -> VisageRule -underScoreRule (VRule fields pat expr owrt rule) s = VRule fields (underScore s pat) expr owrt rule - -underScore :: String -> VisagePattern -> VisagePattern -underScore field (VConstr name pats) = VConstr name (map (underScore field) pats) -underScore field (VProduct pos pats) = VProduct pos (map (underScore field) pats) -underScore field vp@(VVar vfield attr) = - if (field == getName vfield) - then vp - else (VUnderscore (getPos vfield)) --- Should I recurse into the pat of VAlias? -underScore field vp@(VAlias afield attr pat) = - if (field == getName afield) - then vp - else (VUnderscore (getPos afield)) -underScore field vp@(VUnderscore pos) = vp - --} -} - - -ATTR Expression Pattern Patterns [ | | self : SELF ] - -ATTR Grammar [ || visage:{VisageGrammar} ] -ATTR Nonterminal [ || vnont:{VisageNonterminal} ] -ATTR Nonterminals [ || vnonts:{[VisageNonterminal]} ] -ATTR Production [ || vprod:{VisageProduction} ] -ATTR Productions [ || vprods:{[VisageProduction]} ] -ATTR Rule [ || vrule : {VisageRule} ] -ATTR Rules [ || vrules : {[VisageRule]} ] -ATTR Child [ rulemap : {VisageRuleMap} || vchild:{VisageChild} ] -ATTR Children [ rulemap : {VisageRuleMap} || vchildren:{[VisageChild]} ] -ATTR Pattern [ || vpat:{VisagePattern} ] -ATTR Patterns [ || vpats: {[VisagePattern]} ] - -SEM Grammar - | Grammar - lhs.visage = VGrammar @nonts.vnonts - -SEM Nonterminals - | Cons - lhs.vnonts = @hd.vnont : @tl.vnonts - | Nil - lhs.vnonts = [] - -SEM Nonterminal - | Nonterminal - lhs.vnont = VNonterminal @nt @inh @syn @prods.vprods - -SEM Productions - | Cons - lhs.vprods = @hd.vprod : @tl.vprods - | Nil - lhs.vprods = [] - -SEM Production - | Production - lhs.vprod = VProduction @con @children.vchildren @lhsrules @locrules - loc.splitVRules = splitVRules @rules.vrules - loc.locrules = getForField "loc" @splitVRules - loc.lhsrules = getForField "lhs" @splitVRules - children.rulemap = @splitVRules - -SEM Children - | Cons lhs.vchildren = @hd.vchild : @tl.vchildren - | Nil lhs.vchildren = [] - -SEM Child - | Child lhs.vchild = VChild @name @tp @loc.inh @loc.syn (getForField (getName @name) @lhs.rulemap) - -SEM Rules - | Cons lhs.vrules = @hd.vrule : @tl.vrules - | Nil lhs.vrules = [] - --- The undefined may seem strange, but it really belongs there. -SEM Rule - | Rule lhs.vrule = VRule @pattern.fieldattrs undefined @pattern.vpat @rhs.self @owrt - -SEM Patterns - | Cons lhs.vpats = @hd.vpat : @tl.vpats - | Nil lhs.vpats = [] - -SEM Pattern - | Constr lhs.vpat = VConstr @name @pats.vpats - | Product lhs.vpat = VProduct @pos @pats.vpats - | Alias lhs.vpat = if (isVar @self) - then VVar @field @attr - else VAlias @field @attr @pat.vpat - | Underscore lhs.vpat = VUnderscore @pos - --- All (field,attrs) in a pattern -ATTR Patterns -> Pattern [ | | fieldattrs USE { ++ } { [] } : { [(Identifier,Identifier)] } ] - -SEM Pattern - | Alias lhs.fieldattrs = [(@field, @attr)] diff --git a/src-ag/Transform.ag b/src-ag/Transform.ag deleted file mode 100644 --- a/src-ag/Transform.ag +++ /dev/null @@ -1,1371 +0,0 @@ -PRAGMA strictdata -PRAGMA strictwrap - -INCLUDE "ConcreteSyntax.ag" -INCLUDE "Patterns.ag" - -imports -{ -import Control.Monad(mplus,mzero) -import Data.List (partition, nub,intersperse, union) -import Data.Maybe -import qualified Data.Map as Map -import Data.Map (Map) -import Data.Set as Set (Set, member, union, toList, fromList, empty, singleton, member, unions, size, fold, intersection, difference, insert, elems) -import qualified Data.Sequence as Seq -import Data.Sequence(Seq, (><)) -import UU.Scanner.Position(noPos) - -import ConcreteSyntax -import AbstractSyntax -import ErrorMessages -import Patterns (Patterns,Pattern(..)) -import Expression (Expression(..)) -import HsToken - -import RhsCheck -import Debug.Trace -} - - -------------------------------------------------------------------------------- --- Main goal -------------------------------------------------------------------------------- - --- Given some options, we want to construct a Grammar, that is, a structure that conforms to AbstractSyntax -ATTR AG [ | | output : Grammar ] -ATTR AG Elems Elem SemAlts SemAlt SemDefs SemDef Attrs [ options : Options | | ] - --- as a side effect, we generate error messages and Haskell code blocks that need to be embedded in the final code -ATTR AG Elems Elem SemAlts SemAlt Attrs NontSet ConstructorSet SemDefs SemDef - [ | | errors USE {Seq.><}{Seq.empty}:{Seq Error} ] -ATTR AG Elems Elem - [ | | blocks USE {`mapUnionWithPlusPlus`} {Map.empty}: {Blocks} ] - - --- The output is produced by calling a function that constructs the Grammar, --- given various datastructures that are collected from the concrete AG. - -SEM AG - | AG lhs.output = constructGrammar @loc.allNonterminals - @elems.paramsCollect - @loc.allConParams - @loc.allFields - @loc.prodOrder - @loc.allConstraints - @loc.allAttrDecls - @elems.useMap - @elems.derivings - (if wrappers @lhs.options then @loc.allNonterminals else @elems.wrappers) - @loc.checkedRules - @loc.checkedSigs - @loc.checkedInsts - @elems.typeSyns - @elems.semPragmasCollect - @elems.attrOrderCollect - @elems.ctxCollect - @elems.quantCollect - @loc.checkedUniques - @loc.checkedAugments - @loc.checkedArounds - @loc.checkedMerges - @loc.allMacros - - -------------------------------------------------------------------------------- --- Main data flow -------------------------------------------------------------------------------- - -{- Information is collected bottom-up (in multiple phases) - After checking for consistency, datastructures are createad from it, - which are passed down for the other phases. --} - - --- Names that are in use - - -- bottom-up collection -ATTR Elem Elems [ | | collectedSetNames USE {`Set.union`} {Set.empty} : {Set Identifier} ] -ATTR Elem Elems NontSet [ | | collectedNames USE {`Set.union`} {Set.empty} : {Set Identifier} ] - -- top-down distribution -ATTR Elem Elems Attrs Alts Alt Fields Field NontSet [ allNonterminals : {Set NontermIdent} | | ] - - --- Constructors that are in use - -- bottom-up collection -ATTR Alt Alts ConstructorSet [ | | collectedConstructorNames USE {`Set.union`} {Set.empty} : {Set ConstructorIdent} ] -ATTR Elem Elems [ | | collectedConstructorsMap USE {`mapUnionWithSetUnion`} {Map.empty} : {Map NontermIdent (Set ConstructorIdent)} ] - -- top-down distribution -ATTR Elem Elems Alts Alt [ allConstructors : {Map NontermIdent (Set ConstructorIdent)} | | ] - - - --- Nonterminal sets that are defined -{type DefinedSets = Map Identifier (Set NontermIdent) } - -- bottom-up collection -ATTR Elem Elems - [ | defSets:{Map Identifier (Set NontermIdent,Set Identifier)} | ] - -- top-down distribution -ATTR Elem Elems NontSet - [ definedSets:{DefinedSets} | | ] - - - --- Interpreting nonterminal sets -ATTR NontSet [ | | nontSet : {Set NontermIdent} ] - - --- Interpreting constructor sets -ATTR ConstructorSet [ | | constructors : {(Set ConstructorIdent->Set ConstructorIdent)} ] - - - --- Contextfree structure -{type FieldMap = [(Identifier, Type)] } -{type DataTypes = Map.Map NontermIdent (Map.Map ConstructorIdent FieldMap) } - -- bottom-up collection -ATTR Alt Alts Elem Elems - [ | | collectedFields USE {++} {[]} : {[(NontermIdent, ConstructorIdent, FieldMap)]} - collectedConstraints USE {++} {[]} : {[(NontermIdent, ConstructorIdent, [Type])]} - collectedConParams USE {++} {[]} : {[(NontermIdent, ConstructorIdent, Set Identifier)]} - ] - -- top-down distribution -ATTR Elem Elems Attrs SemAlt SemAlts NontSet - [ allFields : {DataTypes} | | ] - - - --- Attribute declarations - -- bottom-up collection -ATTR Elems Elem Attrs - [ - | attrDecls:{Map NontermIdent (Attributes, Attributes)} - | useMap USE {`merge`} {Map.empty}:{Map NontermIdent (Map Identifier (String,String,String))} - ] - - --- Attribute definitions -{type AttrName = (Identifier,Identifier) } -{type RuleInfo = (Maybe Identifier, [AttrName]->Pattern, Expression, [AttrName], Bool, String, Bool, Bool) } -{type SigInfo = (Identifier,Type) } -{type UniqueInfo = (Identifier,Identifier) } -{type AugmentInfo = (Identifier,Expression)} -{type AroundInfo = (Identifier,Expression)} -{type MergeInfo = (Identifier, Identifier, [Identifier], Expression)} - -- bottom-up collection -ATTR Elem Elems SemAlt SemAlts - [ | | collectedRules USE {++} {[]} : {[ (NontermIdent, ConstructorIdent, RuleInfo)]} - collectedSigs USE {++} {[]} : {[ (NontermIdent, ConstructorIdent, SigInfo) ]} - collectedInsts USE {++} {[]} : {[ (NontermIdent, ConstructorIdent, [Identifier]) ]} - collectedUniques USE {++} {[]} : {[ (NontermIdent, ConstructorIdent, [UniqueInfo]) ]} - collectedAugments USE {++} {[]} : {[ (NontermIdent, ConstructorIdent, [AugmentInfo]) ]} - collectedArounds USE {++} {[]} : {[ (NontermIdent, ConstructorIdent, [AroundInfo]) ]} - collectedMerges USE {++} {[]} : {[ (NontermIdent, ConstructorIdent, [MergeInfo]) ]} - ] - - - -------------------------------------------------------------------------------- --- Passing nonterminals -------------------------------------------------------------------------------- - --- Pass the name of the associated nonterminal to everyone -ATTR Alt Alts SemAlt SemAlts [ nts:{Set NontermIdent} | | ] - -SEM Elem - | Data alts.nts = @names.nontSet - | Sem alts.nts = @names.nontSet - - - -------------------------------------------------------------------------------- --- Calculation of code blocks -- -------------------------------------------------------------------------------- - -SEM Elem - | Txt loc.blockInfo = ( @kind - , @mbNt - ) - loc.blockValue = [(@lines, @pos)] - lhs.blocks = Map.singleton @loc.blockInfo @loc.blockValue - lhs.errors = if checkParseBlock @lhs.options - then let ex = Expression @pos tks - tks = [tk] - tk = HsToken (unlines @lines) @pos - in Seq.fromList $ checkBlock $ ex - else Seq.empty - - -------------------------------------------------------------------------------- --- Check for duplicates and report error -------------------------------------------------------------------------------- - -{ - -checkDuplicate :: (Identifier -> Identifier -> Error) - -> Identifier -> val -> Map Identifier val -> (Map Identifier val,Seq Error) -checkDuplicate dupError key val m - = case Map.lookupIndex key m of - Just ix -> let (key',_) = Map.elemAt ix m - in (m,Seq.singleton (dupError key key')) - Nothing -> (Map.insert key val m,Seq.empty) - -checkDuplicates :: (Identifier -> Identifier -> Error) - -> [(Identifier, val)] -> Map Identifier val -> (Map Identifier val,Seq Error) -checkDuplicates dupError new m = foldErrors check m new - where check = uncurry (checkDuplicate dupError) - -foldErrors :: (b -> t -> (t, Seq Error)) -> t -> [b] -> (t, Seq Error) -foldErrors f n xs = foldl g (n,Seq.empty) xs - where g ~(e,es) x = let (e',es') = f x e - in (e', es >< es') - - -checkForDuplicates :: (Identifier -> Identifier -> Error) -> [Identifier] -> [Error] -checkForDuplicates _ [] = [] -checkForDuplicates err (x:xs) = let (same,other) = partition (equalId x) xs - in map (err x) same ++ checkForDuplicates err other - -equalId :: Identifier -> Identifier -> Bool -equalId x y = getName x == getName y - -} - -------------------------------------------------------------------------------- --- Collecting DATA's and type synonyms -------------------------------------------------------------------------------- - - -SEM Alt - | Alt lhs.collectedFields = [ (nt, con, @fields.collectedFields) - | nt <- Set.toList @lhs.nts - , con <- Set.toList (@names.constructors (Map.findWithDefault Set.empty nt @lhs.allConstructors)) - ] - lhs.collectedConstraints = [ (nt, con, @fields.collectedConstraints) - | nt <- Set.toList @lhs.nts - , con <- Set.toList (@names.constructors (Map.findWithDefault Set.empty nt @lhs.allConstructors)) - ] - lhs.collectedConParams = [ (nt, con, Set.fromList @tyvars) - | nt <- Set.toList @lhs.nts - , con <- Set.toList (@names.constructors (Map.findWithDefault Set.empty nt @lhs.allConstructors)) - ] - -SEM Elem - | Type lhs.collectedFields = map (\(x,y)->(@name, x, y)) @loc.expanded - -SEM AG - | AG - loc.prodOrder = let f (nt,con,_) = Map.insertWith g nt [con] - g [con] lst | con `elem` lst = lst - | otherwise = con : lst - g _ _ = error "This is not possible" - in foldr f Map.empty @elems.collectedFields - loc.allFields = let f (nt,con,fm) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con fm) - in foldr f (Map.empty) @elems.collectedFields - - loc.allConstraints = let f (nt,con,fm) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con fm) - in foldr f (Map.empty) @elems.collectedConstraints - - loc.allConParams = let f (nt,con,fm) = Map.insertWith (Map.unionWith Set.union) nt (Map.singleton con fm) - in foldr f (Map.empty) @elems.collectedConParams - - loc.allConstrs = let f (nt,con,_) = Map.insertWith (++) nt [con] - in foldr f (Map.empty) @elems.collectedFields - - loc.allRules = let f (nt,con,r) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con [r]) - in foldr f (Map.empty) @elems.collectedRules - - loc.allSigs = let f (nt,con,t) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con [t]) - typeof nt r = Map.findWithDefault (Haskell "") r $ fst $ Map.findWithDefault (Map.empty,Map.empty) nt @loc.allAttrDecls - in foldr f (Map.empty) ( @elems.collectedSigs - ++ [ (nt, con, (ident,typeof nt ref)) | (nt, con, us) <- @elems.collectedUniques, (ident,ref) <- us ] - ) - - loc.allInsts = let f (nt,con,is) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con is) - in foldr f (Map.empty) @elems.collectedInsts - - loc.allUniques = let f (nt,con,us) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con us) - in foldr f (Map.empty) @elems.collectedUniques - loc.allAugments = let f (nt,con,as) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con as) - in foldr f Map.empty @elems.collectedAugments - loc.allArounds = let f (nt,con,as) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con as) - in foldr f Map.empty @elems.collectedArounds - loc.allMerges = let f (nt,con,as) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con as) - in foldr f Map.empty @elems.collectedMerges - - loc.augmentSigs = let gen _ = [] -- TODO: generate type signatures here for the augments - in Map.map (Map.map gen) @loc.allAugments - - loc.allRulesErrs = Map.mapWithKey (Map.mapWithKey . (checkRules @allAttrDecls @allFields @allInsts @loc.allSigs @loc.allMerges)) @loc.allRules - loc.allNamesErrs = Map.mapWithKey (Map.mapWithKey . checkRuleNames) @loc.allRules - loc.allSigsErrs = Map.mapWithKey (Map.mapWithKey . (checkSigs )) @loc.allSigs - loc.allInstsErrs = Map.mapWithKey (Map.mapWithKey . (checkInsts @loc.allNonterminals @loc.allSigs @allFields )) @loc.allInsts - loc.allUniquesErrs = Map.mapWithKey (Map.mapWithKey . (checkUniques @allAttrDecls )) @loc.allUniques - loc.allAugmentErrs = Map.mapWithKey (Map.mapWithKey . (checkAugments @allAttrDecls )) @loc.allAugments - loc.allAroundsErrs = Map.mapWithKey (Map.mapWithKey . (checkArounds @loc.allFields)) @loc.allArounds - loc.allMergesErrs = Map.mapWithKey (Map.mapWithKey . (checkMerges @loc.allNonterminals @loc.allInsts @loc.allFields)) @loc.allMerges - - loc.checkedRulesPre = Map.map (Map.map fst) @loc.allRulesErrs - loc.checkedSigs = Map.map (Map.map fst) @loc.allSigsErrs `unionunionplusplus` @loc.augmentSigs - loc.checkedInsts = Map.map (Map.map fst) @loc.allInstsErrs - loc.checkedUniques = Map.map (Map.map fst) @loc.allUniquesErrs - loc.checkedAugments = Map.map (Map.map fst) @loc.allAugmentErrs - loc.checkedArounds = Map.map (Map.map fst) @loc.allAroundsErrs - loc.checkedRules = Map.unionWith (Map.unionWith (++)) @loc.checkedRulesPre (Map.mapWithKey (Map.mapWithKey . (mkUniqueRules @lhs.options @loc.allRules @loc.allFields @loc.checkedInsts @loc.allAttrDecls)) @loc.checkedUniques) - loc.checkedMerges = Map.map (Map.map fst) @loc.allMergesErrs - - loc.errs1 = let f = checkForDuplicates (DupSynonym) - in Seq.fromList . f . map fst $ @elems.typeSyns -- forbid duplicate type synonyms - - loc.errs2 = let g nt (con,fm) = checkForDuplicates (DupChild nt con) (map fst fm) - f (nt,cfm) = concat . map (g nt) . Map.toList $ cfm - in Seq.fromList . concat . map f . Map.toList $ @allFields -- forbid duplicate fields - - loc.errs3 = let -- f (nt,cons) = checkForDuplicates (DupAlt nt) cons - in Seq.empty -- allow duplicate constructors, merging their fields - -- Seq.fromList . concat . map f . Map.toList $ @allConstrs -- forbid duplicate constructors - - loc.errs4 = let f m s = Map.fold ((><) . snd) s m - in Map.fold f Seq.empty @loc.allRulesErrs - - loc.errs5 = let f m s = Map.fold ((><) . snd) s m - in Map.fold f Seq.empty @loc.allSigsErrs - - loc.errs6 = let f m s = Map.fold ((><) . snd) s m - in Map.fold f Seq.empty @loc.allInstsErrs - - loc.errs7 = let f m s = Map.fold ((><) . snd) s m - in Map.fold f Seq.empty @loc.allUniquesErrs - - loc.errs8 = let f m s = Map.fold ((><) . snd) s m - in Map.fold f Seq.empty @loc.allAugmentErrs - - loc.errs9 = let f m s = Map.fold ((><) . snd) s m - in Map.fold f Seq.empty @loc.allAroundsErrs - - loc.errs10 = let f m s = Map.fold ((><)) s m - in Map.fold f Seq.empty @loc.allNamesErrs - - loc.errs11 = let f m s = Map.fold ((><) . snd) s m - in Map.fold f Seq.empty @loc.allMergesErrs - - lhs.errors = @elems.errors >< @errs1 >< @errs2 >< @errs3 >< @errs4 >< @errs5 >< @errs6 >< @errs7 >< @errs8 >< @errs9 >< @errs10 >< @errs11 - -{ -type RulesAndErrors = ([Rule], Seq Error) -type SigsAndErrors = ([TypeSig], Seq Error) -type InstsAndErrors = ([(Identifier, Type)], Seq Error) -type UniquesAndErrors = (Map Identifier Identifier, Seq Error) -type AugmentsAndErrors = (Map Identifier [Expression], Seq Error) -type AroundsAndErrors = (Map Identifier [Expression], Seq Error) -type MergesAndErrors = (Map Identifier (Identifier, [Identifier], Expression), Seq Error) -type AttrOverwrite = Map AttrName Bool -type AccumRuleCheck = (RulesAndErrors, AttrOverwrite) -type AccumDefiCheck = (Seq Error, AttrOverwrite, [AttrName], [AttrName]) - -checkRules :: Map NontermIdent (Attributes, Attributes) -> DataTypes -> - Map NontermIdent (Map ConstructorIdent [Identifier]) -> Map NontermIdent (Map ConstructorIdent [SigInfo]) -> - Map NontermIdent (Map ConstructorIdent [MergeInfo]) -> - NontermIdent -> ConstructorIdent -> [RuleInfo] -> RulesAndErrors -checkRules attributes fields allinsts allsigs _ nt con rs - = let fieldmap :: FieldMap - fieldmap = (_LHS, NT nt [] False) : (_LOC, NT nullIdent [] False) : (_INST, NT nullIdent [] False) : (_FIRST, NT nullIdent [] False) : (_LAST, NT nullIdent [] False) - : Map.findWithDefault [] con (Map.findWithDefault Map.empty nt fields) - ++ mapMaybe (\instNm -> lookup instNm sigs >>= \tp -> return (instNm, tp)) (Map.findWithDefault [] con (Map.findWithDefault Map.empty nt allinsts)) - -- merged children are not allowed to have any inherited attrs defined: do not include - - sigs = Map.findWithDefault [] con (Map.findWithDefault Map.empty nt allsigs) - - hasAttrib f tp attr = Map.member attr (f (Map.findWithDefault (Map.empty,Map.empty) tp attributes)) - - checkRule :: RuleInfo -> AccumRuleCheck -> AccumRuleCheck - checkRule (mbNm, pat,ex,as,owrt,str, pur, eager) ((r1,e1),m1) - = let (e2,m2,u2,_) = foldr (checkDefi owrt) (e1,m1,[],[]) as - in ( (Rule mbNm (pat u2) ex owrt str True pur False Nothing eager : r1, e2), m2) - - checkDefi :: Bool -> AttrName -> AccumDefiCheck -> AccumDefiCheck - checkDefi owrt fa@(field,attr) (e,m,u,bs) - = case lookup field fieldmap - of Just (NT tp _ _) -> - let tp' = maybe tp id (deforestedNt tp) - in if field == _LOC || field == _INST || field == _FIRST || field == _LAST - || hasAttrib (if getName field==getName _LHS then snd else fst) tp' attr - then case Map.lookupIndex fa m of - Just ix -> let ((_,attr2),b) = Map.elemAt ix m - in if b && not (fa `elem` bs) - then ( e, Map.insert fa owrt m, fa:u, fa:bs) - else (((Seq.<|)) (DupRule nt con field attr2 attr) e, m, fa:u, bs) - Nothing -> ( e, Map.insert fa owrt m, u, fa:bs) - else (((Seq.<|)) (SuperfluousRule nt con field attr) e, m, fa:u, bs) - _ -> (((Seq.<|)) (UndefChild nt con field) e, m, fa:u, bs ) - - in fst (foldr checkRule (([],Seq.empty),Map.empty) rs) - -checkRuleNames :: NontermIdent -> ConstructorIdent -> [RuleInfo] -> Seq Error -checkRuleNames nt con - = fst . foldr checkRule (Seq.empty, Set.empty) - where - checkRule (Just nm,_,_,_,_,_,_,_) (errs, nms) - | nm `Set.member` nms = (DupRuleName nt con nm Seq.<| errs, nms) - | otherwise = (errs, Set.insert nm nms) - checkRule (Nothing,_,_,_,_,_,_,_) inp = inp - -checkSigs :: NontermIdent -> ConstructorIdent -> [SigInfo] -> SigsAndErrors -checkSigs nt con sis - = let checkSig (ide,typ) (sigs,errs) - = if ide `elem` map (\(TypeSig n _)-> n) sigs - then (sigs, ((Seq.<|)) (DupSig nt con ide) errs) - -- else if not (ide `elem` locattrdefs) - -- then (sigs, ((Seq.<|)) (SupSig nt con ide) errs) - else (TypeSig ide typ:sigs, errs) - in foldr checkSig ([],Seq.empty) sis - -checkInsts :: Set NontermIdent -> Map NontermIdent (Map ConstructorIdent [SigInfo]) -> DataTypes -> NontermIdent -> ConstructorIdent -> [Identifier] -> InstsAndErrors -checkInsts allNts sigMap _ nt con - = foldr (\inst (insts, errs) -> - maybe (insts, Seq.singleton (MissingInstSig nt con inst) >< errs) - (\info@(k, NT nm args _) -> - case findInst k insts of - Just k' -> (insts, Seq.singleton (DupChild nt con k k') >< errs) - Nothing -> case nm `Set.member` allNts of - True -> (info : insts, errs) - False | take 2 (getName nm) == "T_" -> let nm' = Ident (drop 2 (getName nm)) (getPos nm) - info' = (k, NT nm' args True) -- this should be the only place at which 'for' with value True can be generated - in case nm' `Set.member` allNts of - True -> (info' : insts, errs) - False -> (insts, Seq.singleton (UndefNont nm') >< errs) - | otherwise -> (insts, Seq.singleton (UndefNont nm) >< errs) - ) - $ findSig inst - ) ([], Seq.empty) - where - sigs = Map.findWithDefault [] con (Map.findWithDefault Map.empty nt sigMap) - - findSig name - = do tp@(NT _ _ _) <- lookup name sigs - return (name, tp) - - findInst _ [] = Nothing - findInst k ((k', _): r) - | k == k' = Just k' - | otherwise = findInst k r - -checkUniques :: Map NontermIdent (Attributes, Attributes) -> NontermIdent -> ConstructorIdent -> [UniqueInfo] -> UniquesAndErrors -checkUniques allAttrs nt con uniques - = let checkUnique (ident,ref) (us,errs) - = if ident `Map.member` us - then (us, ((Seq.<|)) (DupUnique nt con ident) errs) - else if Map.member ref inhs && Map.member ref syns - then (Map.insert ident ref us, errs) - else (us, ((Seq.<|)) (MissingUnique nt ref) errs) - - (inhs,syns) = Map.findWithDefault (Map.empty,Map.empty) nt allAttrs - in foldr checkUnique (Map.empty, Seq.empty) uniques - -checkAugments :: Map NontermIdent (Attributes, Attributes) -> NontermIdent -> ConstructorIdent -> [AugmentInfo] -> AugmentsAndErrors -checkAugments allAttrs nt _ augments - = let checkAugment (ident,expr) (as,errs) - = if ident `Map.member` as - then (Map.update (\vs -> Just (vs ++ [expr])) ident as, errs) - else if Map.member ident syns - then (Map.insert ident [expr] as, errs) - else (as, ((Seq.<|)) (MissingSyn nt ident) errs) - - (_,syns) = Map.findWithDefault (Map.empty,Map.empty) nt allAttrs - in foldr checkAugment (Map.empty, Seq.empty) augments - -checkArounds :: DataTypes -> NontermIdent -> ConstructorIdent -> [AroundInfo] -> AroundsAndErrors -checkArounds fieldMap nt con arounds - = let checkAround (ident,expr) (as,errs) - = if ident `Map.member` as - then (Map.update (\vs -> Just (vs ++ [expr])) ident as, errs) - else case lookup ident fields of - Just (NT _ _ _) -> (Map.insert ident [expr] as, errs) - _ -> (as, ((Seq.<|)) (UndefChild nt con ident) errs) - fields = Map.findWithDefault [] con (Map.findWithDefault Map.empty nt fieldMap) - in foldr checkAround (Map.empty, Seq.empty) arounds - -checkMerges :: Set NontermIdent -> Map NontermIdent (Map ConstructorIdent [Identifier]) -> DataTypes -> NontermIdent -> ConstructorIdent -> [MergeInfo] -> MergesAndErrors -checkMerges allNts allInsts fieldMap _ con merges - = let checkMerge (target,nt,sources,expr) (m,errs) - = let fields = Map.findWithDefault [] con (Map.findWithDefault Map.empty nt fieldMap) - insts = Map.findWithDefault [] con (Map.findWithDefault Map.empty nt allInsts) - allFields = insts ++ map fst fields -- note: sources of merge may not contain a target (for simplicity) - in if target `Map.member` m -- check for duplicate with self - then (m, DupChild nt con target (fst $ Map.elemAt (Map.findIndex target m) m) Seq.<| errs) - else if target `elem` allFields - then (m, DupChild nt con target (head $ filter (== target) allFields) Seq.<| errs) - else let missing = filter (\s -> not (s `elem` allFields)) sources - in if null missing - then if nt `Set.member` allNts -- check if the nonterm is defined - then (Map.insert target (nt, sources, expr) m, errs) -- all ok.. - else (m, UndefNont nt Seq.<| errs) - else (m, (Seq.fromList $ map (UndefChild nt con) missing) Seq.>< errs) - in foldr checkMerge (Map.empty, Seq.empty) merges - -unionunionplusplus :: Map NontermIdent (Map ConstructorIdent [a]) -> Map NontermIdent (Map ConstructorIdent [a]) -> Map NontermIdent (Map ConstructorIdent [a]) -unionunionplusplus = Map.unionWith (Map.unionWith (++)) -} - - -{ -mkUniqueRules :: Options -> Map NontermIdent (Map ConstructorIdent [RuleInfo]) -> DataTypes -> Map NontermIdent (Map ConstructorIdent [(Identifier, Type)]) -> Map NontermIdent (Attributes,Attributes) -> NontermIdent -> ConstructorIdent -> Map Identifier Identifier -> [Rule] -mkUniqueRules opts allRules allFields allInsts allAttrDecls nt con usMap - = map apply groups - where - fields = Map.findWithDefault [] con (Map.findWithDefault Map.empty nt allFields) - ++ Map.findWithDefault [] con (Map.findWithDefault Map.empty nt allInsts) - -- may have duplicates - - attrDefs = let projectDefs (_,_,_,defs,_,_,_,_) = defs - in concatMap projectDefs $ Map.findWithDefault [] con $ Map.findWithDefault Map.empty nt allRules - - groups = Map.assocs $ Map.foldrWithKey (\i r m -> Map.insertWith (++) r [i] m) Map.empty usMap - apply (ref,us) = mkRule ref (findOutField ref) us - findOutField ref = case [ chld | (chld, NT tp _ _) <- fields, tp `hasSyn` ref] of - [] -> _LHS - (x:_) -> x - hasSyn tp ref = Map.member ref $ snd $ Map.findWithDefault (Map.empty,Map.empty) tp allAttrDecls - mkRule ref outFld locAttrs - = let locs = filter (not . existsLoc) locAttrs - outAttr = attr outFld ref - defs = (if hasOut then [] else [outAttr]) ++ [attr _LOC u | u <- locs ] - pat = Product noPos defs - rhs = Expression noPos $ wrap ref $ foldr gencase (finalout hasOut locs) locs - -- [HsToken ("mkUniques" ++ show (length locAttrs) ++ " ") noPos, AGField _LHS ref noPos Nothing] - rul = Rule Nothing pat rhs False "-- generated by the unique rule mechanism." False True False Nothing False - hasOut = exists outAttr - exists (Alias fld a _) = (fld,a) `elem` attrDefs - exists _ = False - existsLoc nm = exists (attr _LOC nm) - in rul - attr fld a = Alias fld a (Underscore noPos) - gencase nm outp - = h ("case " ++ uniqueDispenser opts ++ " __cont of { (__cont, " ++ getName nm ++ ") -> ") ++ outp ++ h "}" - h s = [HsToken s noPos] - finalout noGenCont us = h ("(" ++ concat (intersperse "," ( (if noGenCont then [] else ["__cont"]) ++ map getName us)) ++ ")") - wrap ref inp = h "let __cont = " ++ [AGField _LHS ref noPos Nothing] ++ h " in seq __cont ( " ++ inp ++ h " )" -} - - -------------------------------------------------------------------------------- --- Checking RHSs of rules (optional) -------------------------------------------------------------------------------- - -SEM SemDef | Def MergeDef - lhs.errors = if checkParseRhs @lhs.options - then Seq.fromList $ checkRhs @rhs - else Seq.empty - --- type of a type signature - -SEM SemDef | TypeDef - lhs.errors = if checkParseTy @lhs.options - then case @tp of - Haskell s -> let ex = Expression @pos tks - tks = [tk] - tk = HsToken s @pos - in Seq.fromList $ checkTy ex - _ -> Seq.empty - else Seq.empty - -------------------------------------------------------------------------------- --- Collecting fields -------------------------------------------------------------------------------- - -ATTR Fields Field [ | | collectedFields USE {++} {[]} : {[(Identifier, Type)]} ] - -SEM Field | FChild - lhs.collectedFields = [(@name, makeType @lhs.allNonterminals @tp)] - -------------------------------------------------------------------------------- --- Collecting constraints -------------------------------------------------------------------------------- - -ATTR Fields Field [ | | collectedConstraints USE {++} {[]} : {[Type]} ] - -SEM Field | FCtx - lhs.collectedConstraints = @tps - -------------------------------------------------------------------------------- --- Collecting Set names and Nonterminal names -------------------------------------------------------------------------------- - - - -SEM Elem - | Set lhs.collectedSetNames = Set.singleton @name - -SEM Elem - | Type lhs.collectedNames = Set.singleton @name - -SEM NontSet - | NamedSet lhs.collectedNames = Set.singleton @name - -SEM AG - | AG loc.allNonterminals = @elems.collectedNames `Set.difference` @elems.collectedSetNames - - - - - - -SEM ConstructorSet - | CName lhs.collectedConstructorNames = Set.singleton @name - ---SEM Alt --- | Alt lhs.collectedConstructorNames = Set.singleton @name - -SEM Elem - | Data lhs.collectedConstructorsMap = Map.fromList - [ (n, @alts.collectedConstructorNames) - | n <- Set.toList @names.nontSet - ] - -SEM AG - | AG elems.allConstructors = @elems.collectedConstructorsMap - - - -------------------------------------------------------------------------------- --- Type synonyms -------------------------------------------------------------------------------- - -{- At the moment type synonyms are only supported for list types - This means that only synonyms of the form: - TYPE = [ ] - are allowed --} - - -ATTR Elem Elems [ | | typeSyns USE {++} {[]} : {TypeSyns} ] - -{- Put this synonym in the typeSyns list and - add the implicit Cons and Nil productions for the type synonym - - A synonym of the form: - TYPE = [ ] - is translated into: - DATA | Cons hd: tl: - | Nil --} - -SEM Elem - | Type loc.expanded = case @argType of - List tp -> [(Ident "Cons" @pos, [(Ident "hd" @pos, tp) - ,(Ident "tl" @pos, NT @name (map getName @params) False) - ] - ) - ,(Ident "Nil" @pos, []) - ] - Maybe tp -> [(Ident "Just" @pos, [(Ident "just" @pos, tp) - ] - ) - ,(Ident "Nothing" @pos, []) - ] - Either tp1 tp2 -> [ - (Ident "Left" @pos, [(Ident "left" @pos, tp1) ]) - , (Ident "Right" @pos, [(Ident "right" @pos, tp2) ]) - ] - Map tp1 tp2 -> [ (Ident "Entry" @pos, [ (Ident "key" @pos, tp1) - , (Ident "val" @pos, tp2) - , (Ident "tl" @pos, NT @name (map getName @params) False) - ]) - , (Ident "Nil" @pos, []) - ] - IntMap tp -> [ (Ident "Entry" @pos, [ (Ident "key" @pos, Haskell "Int") - , (Ident "val" @pos, tp) - , (Ident "tl" @pos, NT @name (map getName @params) False) - ]) - , (Ident "Nil" @pos, []) - ] - OrdSet tp -> [ (Ident "Entry" @pos, [ (Ident "val" @pos, tp) - , (Ident "tl" @pos, NT @name (map getName @params) False) ]) - , (Ident "Nil" @pos, []) - ] - IntSet -> [ (Ident "Entry" @pos, [ (Ident "val" @pos, Haskell "Int") - , (Ident "tl" @pos, NT @name (map getName @params) False) ]) - , (Ident "Nil" @pos, []) - ] - Tuple xs -> [(Ident "Tuple" @pos, xs)] - loc.argType = case @type of - Maybe tp -> Maybe ( makeType @lhs.allNonterminals tp) - Either tp1 tp2 -> Either ( makeType @lhs.allNonterminals tp1) (makeType @lhs.allNonterminals tp2) - List tp -> List ( makeType @lhs.allNonterminals tp) - Tuple xs -> Tuple [(f,makeType @lhs.allNonterminals tp) | (f,tp) <- xs] - Map tp1 tp2 -> Map ( makeType @lhs.allNonterminals tp1) (makeType @lhs.allNonterminals tp2) - IntMap tp -> IntMap ( makeType @lhs.allNonterminals tp) - OrdSet tp -> OrdSet ( makeType @lhs.allNonterminals tp) - IntSet -> IntSet - lhs.typeSyns = [(@name,@argType)] - -------------------------------------------------------------------------------- --- Interpreting Nonterminal sets -------------------------------------------------------------------------------- - - -SEM AG - | AG - elems.defSets = Map.fromList (map (\x->(x,(Set.singleton x, Set.empty))) (Set.toList @loc.allNonterminals)) - elems.definedSets = Map.map fst @elems.defSets - - -SEM Elem - | Set loc.(defSets2,errs) = let allUsedNames = Set.unions [ maybe (Set.singleton n) - snd - (Map.lookup n @lhs.defSets) - | n <- Set.toList @set.collectedNames - ] - (nontSet,e1) | Set.member @name allUsedNames - = (Set.empty, Seq.singleton(CyclicSet @name)) - | otherwise = (@set.nontSet, Seq.empty) - (res, e2) = let toAdd = (nontSet,Set.insert @name allUsedNames) - un (a,b) (c,d) = (a `Set.union` c, b `Set.union` d) - in if Set.member @name @lhs.allNonterminals || not @merge - then checkDuplicate DupSet @name toAdd @lhs.defSets - else (Map.insertWith un @name toAdd @lhs.defSets, Seq.empty) - in (res, e1 Seq.>< e2) - lhs.defSets = @defSets2 - .errors = @errs >< @set.errors - -SEM NontSet - | All lhs.nontSet = @lhs.allNonterminals - | NamedSet loc.(nontSet,errors) = case Map.lookup @name @lhs.definedSets of - Nothing -> (Set.empty, Seq.singleton (UndefNont @name)) - Just set -> (set, Seq.empty) - | Union lhs.nontSet = Set.union @set1.nontSet @set2.nontSet - | Intersect lhs.nontSet = Set.intersection @set1.nontSet @set2.nontSet - | Difference lhs.nontSet = Set.difference @set1.nontSet @set2.nontSet - | Path lhs.nontSet = let table = flattenDatas @lhs.allFields - in path table @from @to - lhs.errors = let check name | Set.member name @lhs.allNonterminals - = Seq.empty - | otherwise = Seq.singleton (UndefNont name) - in check @from >< check @to - - -{ -flattenDatas :: DataTypes -> Map NontermIdent (Set NontermIdent) -flattenDatas ds = Map.map flatten ds - where flatten cs = Set.fromList [ nt | (_, NT nt _ _) <- concatMap snd (Map.toList cs)] - -reachableFrom :: Map NontermIdent (Set NontermIdent) -> Set NontermIdent -> Set NontermIdent -reachableFrom table = reach - where reach nts = let nts' = Set.unions (nts : [ ns | nt <- Set.toList nts - , let ns = Map.findWithDefault Set.empty nt table ]) - in if Set.size nts' > Set.size nts - then reach nts' - else nts -invert :: Map NontermIdent (Set NontermIdent) -> Map NontermIdent (Set NontermIdent) -invert = foldr inv Map.empty . Map.toList - where inv (x,ns) m = fold (\n m' -> Map.insertWith Set.union n (Set.singleton x) m') m ns - -path :: Map NontermIdent (Set NontermIdent) -> NontermIdent -> NontermIdent -> Set NontermIdent -path table from to = let children = Map.findWithDefault Set.empty from table - forward = reachableFrom table children - backward = reachableFrom (invert table) - (Set.singleton to) - in Set.intersection forward backward -} - -------------------------------------------------------------------------------- --- Interpreting Constructor Sets -------------------------------------------------------------------------------- - - -SEM ConstructorSet - | CName lhs.constructors = \_ -> Set.singleton @name - | CUnion lhs.constructors = \ds -> @set1.constructors ds `Set.union` @set2.constructors ds - | CDifference lhs.constructors = \ds -> @set1.constructors ds `Set.difference` @set2.constructors ds - | CAll lhs.constructors = \ds -> ds - -------------------------------------------------------------------------------- --- Collecting wrappers -------------------------------------------------------------------------------- - -ATTR Elem Elems [ | | wrappers USE {`Set.union`} {Set.empty} :{Set NontermIdent}] - -SEM Elem - | Wrapper lhs.wrappers = @set.nontSet - -------------------------------------------------------------------------------- --- Collecting nocatas -------------------------------------------------------------------------------- - -SEM Elem - | Nocatas lhs.pragmas = \o -> o { nocatas = @set.nontSet `Set.union` nocatas o } - -------------------------------------------------------------------------------- --- Collecting pragmas -------------------------------------------------------------------------------- - -ATTR AG Elem Elems [ | | pragmas USE {.} {id} :{Options -> Options}] - -SEM Elem - | Pragma lhs.pragmas = let mk n o = case getName n of - "gencatas" -> o { folds = True } - "nogencatas" -> o { folds = False } - "gendatas" -> o { dataTypes = True } - "datarecords" -> o { dataRecords = True } - "nogendatas" -> o { dataTypes = False } - "gensems" -> o { semfuns = True } - "nogensems" -> o { semfuns = False } - "gentypesigs" -> o { typeSigs = True } - "nogentypesigs"-> o { typeSigs = False } - "nocycle" -> o { withCycle = False, loag = False } - "cycle" -> o { withCycle = True } - "nostrictdata" -> o { strictData = False } - "strictdata" -> o { strictData = True } - "nostrictcase" -> o { strictCases = False } - "strictcase" -> o { strictCases = True } - "strictercase" -> o { strictCases = True, stricterCases = True } - "nostrictwrap" -> o { strictWrap = False } - "strictwrap" -> o { strictWrap = True } - "novisit" -> o { visit = False, loag = False } - "visit" -> o { visit = True } - "nocase" -> o { cases = False } - "case" -> o { cases = True } - "noseq" -> o { withSeq = False } - "seq" -> o { withSeq = True } - "nounbox" -> o { unbox = False } - "unbox" -> o { unbox = True } - "bangpats" -> o { bangpats = True } - "breadthfirst" -> o { breadthFirst = True } - "breadthfirstStrict" -> o { breadthFirstStrict = True } - "nooptimize" -> o { cases = False , visit = False } - "optimize" -> o { cases = True , visit = True } - "strictsem" -> o { strictSems = True } - "gentraces" -> o { genTraces = True } - "genusetraces" -> o { genUseTraces = True } - "splitsems" -> o { splitSems = True } - "gencostcentres" -> o { genCostCentres = True } - "sepsemmods" -> sepSemModsOpt o - "genlinepragmas" -> o { genLinePragmas = True } - "newtypes" -> o { newtypes = True } - "nonewtypes" -> o { newtypes = False } - "nooptimizations" -> o { noOptimizations = True } - "kennedywarren" -> o { kennedyWarren = True } - "aspectag" -> o { genAspectAG = True } - 'n':'o':'g':'r':'o':'u':'p':'_':atts - -> o { noGroup = extract atts ++ noGroup o } - "rename" -> o { rename = True } - "parallel" -> o { parallelInvoke = True } - "monadicwrappers" -> o { monadicWrappers = True } - - "dummytokenvisit" -> o { dummyTokenVisit = True } - "tupleasdummytoken" -> o { tupleAsDummyToken = True } - "stateasdummytoken" -> o { tupleAsDummyToken = False } - "strictdummytoken" -> o { strictDummyToken = True } - "noperruletypesigs" -> o { noPerRuleTypeSigs = True } - "noperstatetypesigs" -> o { noPerStateTypeSigs = True } - "noeagerblackholing" -> o { noEagerBlackholing = True } - "noperrulecostcentres" -> o { noPerRuleCostCentres = True } - "nopervisitcostcentres" -> o { noPerVisitCostCentres = True } - "helpinlining" -> o { helpInlining = True } - "noinlinepragmas" -> o { noInlinePragmas = True } - "aggressiveinlinepragmas" -> o { aggressiveInlinePragmas = True } - "latehigherorderbindings" -> o { lateHigherOrderBinding = True } - "ocaml" -> ocamlOpt o - "cleanlang" -> cleanOpt o - - s -> trace ("uuagc: ignoring unknown pragma: " ++ s) o - in \o -> foldr mk o @names - -{ -extract :: String -> [String] -extract s = case dropWhile isSeparator s of - "" -> [] - s' -> w : extract s'' - where (w, s'') = break isSeparator s' -isSeparator :: Char -> Bool -isSeparator x = x == '_' -} - -ATTR Elem Elems SemAlts SemAlt [ | | semPragmasCollect USE {`pragmaMapUnion`} {Map.empty} : {PragmaMap} ] - -SEM SemAlt - | SemAlt - loc.pragmaNames = Set.fromList @rules.pragmaNamesCollect - lhs.semPragmasCollect = foldr pragmaMapUnion Map.empty [ pragmaMapSingle nt con @loc.pragmaNames - | (nt, conset, _) <- @loc.coninfo - , con <- Set.toList conset - ] - -ATTR SemDefs SemDef [ | | pragmaNamesCollect USE {++} {[]} : {[Identifier]} ] - -SEM SemDef - | SemPragma - lhs.pragmaNamesCollect = @names - -{ -pragmaMapUnion :: PragmaMap -> PragmaMap -> PragmaMap -pragmaMapUnion = Map.unionWith (Map.unionWith Set.union) - -pragmaMapSingle :: NontermIdent -> ConstructorIdent -> Set Identifier -> PragmaMap -pragmaMapSingle nt con nms = Map.singleton nt (Map.singleton con nms) -} - -------------------------------------------------------------------------------- --- Collecting attribute orders -------------------------------------------------------------------------------- - -ATTR Elem Elems SemAlts SemAlt [ | | attrOrderCollect USE {`orderMapUnion`} {Map.empty} : {AttrOrderMap} ] -ATTR Elem Elems SemAlts SemAlt [ allAttrDecls : {Map NontermIdent (Attributes, Attributes)} | | ] - -SEM SemAlt - | SemAlt - loc.attrOrders - = [ orderMapSingle nt con @rules.orderDepsCollect - | (nt, conset, _) <- @loc.coninfo - , con <- Set.toList conset - ] - - lhs.attrOrderCollect = foldr orderMapUnion Map.empty @loc.attrOrders - -ATTR SemDefs SemDef [ | | orderDepsCollect USE {`Set.union`} {Set.empty} : {Set Dependency} ] - -SEM SemDef - | AttrOrderBefore - loc.dependency = [ Dependency b a | b <- @before, a <- @after ] - lhs.orderDepsCollect = Set.fromList @loc.dependency - -{ -orderMapUnion :: AttrOrderMap -> AttrOrderMap -> AttrOrderMap -orderMapUnion = Map.unionWith (Map.unionWith Set.union) - -orderMapSingle :: NontermIdent -> ConstructorIdent -> Set Dependency -> AttrOrderMap -orderMapSingle nt con deps = Map.singleton nt (Map.singleton con deps) -} - -------------------------------------------------------------------------------- --- Collecting nonterminal type parameters -------------------------------------------------------------------------------- - -ATTR Elem Elems [ | | paramsCollect USE {`mergeParams`} {Map.empty} : {ParamMap}] - -SEM Elem - | Data - lhs.paramsCollect = if null @params - then Map.empty - else Map.fromList [(nt, @params) | nt <- Set.toList @names.nontSet] - -SEM Elem - | Type - lhs.paramsCollect = if null @params - then Map.empty - else Map.singleton @name @params - -{ -mergeParams :: ParamMap -> ParamMap -> ParamMap -mergeParams = Map.unionWith (++) -} - -------------------------------------------------------------------------------- --- Collecting class contexts of semantic functions -------------------------------------------------------------------------------- - -ATTR Elem Elems [ | | ctxCollect USE {`mergeCtx`} {Map.empty} : {ContextMap}] - -SEM Elem - | Sem Data Attr - lhs.ctxCollect = if null @ctx - then Map.empty - else Map.fromList [(nt, @ctx) | nt <- Set.toList @names.nontSet] - -SEM Elem - | Type - lhs.ctxCollect = if null @ctx - then Map.empty - else Map.singleton @name @ctx - -{ -mergeCtx :: ContextMap -> ContextMap -> ContextMap -mergeCtx - = Map.unionWith nubconcat - where nubconcat a b = nub (a ++ b) -} - -------------------------------------------------------------------------------- --- Collecting quantifiers of semantic functions -------------------------------------------------------------------------------- - -ATTR Elem Elems [ | | quantCollect USE {`mergeQuant`} {Map.empty} : {QuantMap}] - -SEM Elem - | Sem Attr - lhs.quantCollect = if null @quants - then Map.empty - else Map.fromList [(nt, @quants) | nt <- Set.toList @names.nontSet] - -{ -mergeQuant :: QuantMap -> QuantMap -> QuantMap -mergeQuant = Map.unionWith (++) -} - -------------------------------------------------------------------------------- --- Collecting derivings -------------------------------------------------------------------------------- - -ATTR Elem Elems [ | | derivings USE {`mergeDerivings`} {Map.empty} :{Derivings}] - -{ -mergeDerivings :: Derivings -> Derivings -> Derivings -mergeDerivings m1 m2 = foldr (\(n,cs) m -> Map.insertWith Set.union n cs m) m2 (Map.toList m1) -} - -SEM Elem - | Deriving lhs.derivings = Map.fromList [(nt,Set.fromList @classes) | nt <- Set.toList @set.nontSet] - -------------------------------------------------------------------------------- --- Collecting ATTR declarations -------------------------------------------------------------------------------- - -{ -merge ::(Ord k, Ord k1) => Map k (Map k1 a) -> Map k (Map k1 a) -> Map k (Map k1 a) -merge x y = foldr f y (Map.toList x) - where f ~(k,v) m = Map.insertWith (Map.union) k v m -} - -SEM AG - | AG elems.attrDecls = Map.empty - -SEM Elem - | Data attrs.nts = @names.nontSet - | Attr attrs.nts = @names.nontSet - | Sem attrs.nts = @names.nontSet - - -SEM Attrs [ nts:{Set NontermIdent} | | ] - | Attrs loc.(attrDecls,errors) = checkAttrs @lhs.allFields (Set.toList @lhs.nts) @inherited @synthesized @lhs.attrDecls - - .(inherited,synthesized,useMap) = let splitAttrs xs = unzip [ ((n,makeType @lhs.allNonterminals t),(n,ud)) - | (n,t,ud) <- xs - ] - (inh,_) = splitAttrs @inh - (chn,uses1) = splitAttrs @chn - (syn,uses2) = splitAttrs @syn - isUse (_,(e1,e2,_)) = not (null e1 || null e2) - in (inh++chn,chn++syn, Map.fromList (Prelude.filter isUse (uses1++uses2))) - lhs.useMap = Map.fromList (zip (Set.toList @lhs.nts) (repeat @useMap)) - - loc.errors1 = if checkParseTy @lhs.options - then let attrs = @inh ++ @syn ++ @chn - items = map (\(ident,tp,_) -> (getPos ident, tp)) attrs - errs = map check items - check (pos,Haskell s) = - let ex = Expression pos tks - tks = [tk] - tk = HsToken s pos - in Seq.fromList $ checkTy ex - check _ = Seq.empty - in foldr (Seq.><) Seq.empty errs - else Seq.empty - lhs.errors = @loc.errors Seq.>< @loc.errors1 - - -{ -checkAttrs :: DataTypes -> [NontermIdent] -> [(Identifier, a)] -> [(Identifier, b)] -> Map NontermIdent (Map Identifier a, Map Identifier b) -> (Map NontermIdent (Map Identifier a, Map Identifier b), Seq Error) -checkAttrs allFields nts inherited synthesized decls' = foldErrors check decls' nts where - check nt decls | not (nt `Map.member` allFields) = (decls,Seq.singleton(UndefNont nt)) - | otherwise = let (inh,syn) = Map.findWithDefault (Map.empty,Map.empty) nt decls - (inh',einh) = checkDuplicates (DupInhAttr nt) inherited inh - (syn',esyn) = checkDuplicates (DupSynAttr nt) synthesized syn - in (Map.insert nt (inh',syn') decls,einh >< esyn) -} - - --- Add declaration of self-attribute for each nonterminal: ATTR [ | | self:SELF] -{ -addSelf :: Ord k1 => k1 -> Map k1 (Map k a, Attributes) -> Map k1 (Map k a, Attributes) -addSelf name atMap = let (eInh,eSyn) = Map.findWithDefault(Map.empty,Map.empty) name atMap - in Map.insert name (eInh, Map.insert (Ident "self" noPos) Self eSyn)atMap -} - - -SEM AG - | AG loc.allAttrDecls = if withSelf @lhs.options - then foldr addSelf @elems.attrDecls (Set.toList @loc.allNonterminals) - else @elems.attrDecls - -------------------------------------------------------------------------------- --- Collecting rules -------------------------------------------------------------------------------- - - -ATTR SemDef SemDefs [ | | ruleInfos USE {++} {[]} : {[RuleInfo]} - sigInfos USE {++} {[]} : {[SigInfo]} - uniqueInfos USE {++} {[]} : {[UniqueInfo]} - augmentInfos USE {++} {[]} : {[AugmentInfo]} - aroundInfos USE {++} {[]} : {[AroundInfo]} - mergeInfos USE {++} {[]} : {[MergeInfo]} - ] - - -SEM SemAlt - | SemAlt loc.coninfo = [ (nt, conset, conkeys) - | nt <- Set.toList @lhs.nts - , let conmap = Map.findWithDefault Map.empty nt @lhs.allFields - , let conkeys = Set.fromList (Map.keys conmap) - , let conset = @constructorSet.constructors conkeys - ] - - lhs.errors = Seq.fromList - [ UndefAlt nt con - | (nt, conset, conkeys) <- @loc.coninfo - , con <- Set.toList (Set.difference conset conkeys) - ] - Seq.>< @rules.errors - lhs.collectedRules - = [ (nt,con,r) - | (nt, conset, _) <- @loc.coninfo - , con <- Set.toList conset - , r <- @rules.ruleInfos - ] - lhs.collectedSigs - = [ (nt,con,ts) - | (nt, conset, _) <- @loc.coninfo - , con <- Set.toList conset - , ts <- @rules.sigInfos - ] - - lhs.collectedInsts - = [ (nt,con,@rules.definedInsts) - | (nt, conset, _) <- @loc.coninfo - , con <- Set.toList conset - ] - - lhs.collectedUniques - = [ (nt,con,@rules.uniqueInfos) - | (nt, conset, _) <- @loc.coninfo - , con <- Set.toList conset - ] - - lhs.collectedAugments - = [ (nt, con, @rules.augmentInfos) - | (nt, conset, _) <- @loc.coninfo - , con <- Set.toList conset - ] - - lhs.collectedArounds - = [ (nt, con, @rules.aroundInfos) - | (nt, conset, _) <- @loc.coninfo - , con <- Set.toList conset - ] - - lhs.collectedMerges - = [ (nt, con, @rules.mergeInfos) - | (nt, conset, _) <- @loc.coninfo - , con <- Set.toList conset - ] - -SEM SemDef - | Def lhs.ruleInfos = [ (@mbName, @pattern.patunder, @rhs, @pattern.definedAttrs, @owrt, show @pattern.stpos, @pure, @eager) ] - -SEM SemDef - | TypeDef lhs.sigInfos = [ (@ident, @tp) ] - -SEM SemDef - | UniqueDef lhs.uniqueInfos = [ (@ident, @ref) ] - -SEM SemDef - | AugmentDef lhs.augmentInfos = [ (@ident, @rhs) ] - -SEM SemDef - | AroundDef lhs.aroundInfos = [ (@ident, @rhs) ] - -SEM SemDef - | MergeDef lhs.mergeInfos = [ (@target, @nt, @sources, @rhs) ] - - -ATTR SemDef SemDefs Pattern Patterns [|| definedInsts USE {++} {[]} : {[Identifier]} ] -ATTR Pattern Patterns [ | | definedAttrs USE {++} {[]} : {[AttrName]} ] -ATTR Pattern [ | | patunder : {[AttrName]->Pattern} ] -ATTR Patterns [ | | patunder : {[AttrName]->Patterns} ] - -SEM Pattern - | Alias lhs.definedAttrs = (@field, @attr) : @pat.definedAttrs - lhs.patunder = \us -> if ((@field,@attr) `elem` us) then Underscore noPos else @copy - lhs.definedInsts = (if @field == _INST then [@attr] else []) ++ @pat.definedInsts - | Underscore lhs.patunder = \_ -> @copy - | Constr lhs.patunder = \us -> Constr @name (@pats.patunder us) - | Product lhs.patunder = \us -> Product @pos (@pats.patunder us) - | Irrefutable lhs.patunder = \us -> Irrefutable (@pat.patunder us) - -SEM Patterns - | Nil lhs.patunder = \_ -> [] - | Cons lhs.patunder = \us -> (@hd.patunder us) : (@tl.patunder us) - -ATTR Pattern [ | | stpos : Pos ] - -SEM Pattern - | Constr lhs.stpos = getPos @name - | Product lhs.stpos = @pos - | Alias lhs.stpos = getPos @field - | Underscore lhs.stpos = @pos - -------------------------------------------------------------------------------- --- Collect module declaration -------------------------------------------------------------------------------- - -ATTR AG Elems Elem [ | | moduleDecl USE {`flipmplus`} {mzero} : {Maybe (String,String,String)} ] - -SEM Elem - | Module - lhs.moduleDecl = Just (@name, @exports, @imports) - -{ --- We want the last Just in the list -flipmplus = flip mplus -} - -------------------------------------------------------------------------------- --- Constructing transformed syntax tree -------------------------------------------------------------------------------- -{ -makeType :: Set NontermIdent -> Type -> Type -makeType nts tp@(NT x _ _) | Set.member x nts = tp - | otherwise = Haskell (typeToHaskellString Nothing [] tp) -makeType _ tp = tp -} -{ -constructGrammar :: Set NontermIdent - -> ParamMap - -> Map NontermIdent (Map ConstructorIdent (Set Identifier)) - -> DataTypes - -> Map NontermIdent [ConstructorIdent] - -> Map NontermIdent (Map ConstructorIdent [Type]) - -> Map NontermIdent (Attributes, Attributes) - -> Map NontermIdent (Map Identifier (String, String, String)) - -> Derivings - -> Set NontermIdent - -> Map NontermIdent (Map ConstructorIdent [Rule]) - -> Map NontermIdent (Map ConstructorIdent [TypeSig]) - -> Map NontermIdent (Map ConstructorIdent [(Identifier, Type)]) - -> TypeSyns - -> PragmaMap - -> AttrOrderMap - -> ContextMap - -> QuantMap - -> UniqueMap - -> Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression])) - -> Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression])) - -> Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier, [Identifier], Expression))) - -> Map NontermIdent (Map ConstructorIdent MaybeMacro) - -> Grammar - -constructGrammar _ ntParams prodParams gram prodOrder constraints attrs uses derivings wrap allrules tsigs allinsts tsyns pragmaMap orderMap contextMap quantMap uniqueMap augmentsMap aroundsMap mergeMap macros = - let gr = [ (nt,alts) | (nt,alts) <- Map.toList gram] - nonts = map nont gr - nont (nt,alts) = let (inh,syn) = Map.findWithDefault (Map.empty,Map.empty) nt attrs - rmap = Map.findWithDefault Map.empty nt allrules - tsmap = Map.findWithDefault Map.empty nt tsigs - instsmap = Map.findWithDefault Map.empty nt allinsts - params = Map.findWithDefault [] nt ntParams - mergemap = Map.findWithDefault Map.empty nt mergeMap - macromap = Map.findWithDefault Map.empty nt macros - csmap = Map.findWithDefault Map.empty nt constraints - psmap = Map.findWithDefault Map.empty nt prodParams - prs = Map.findWithDefault [] nt prodOrder - alt con = - let flds = Map.findWithDefault [] con alts - rules = Map.findWithDefault [] con rmap - tsigs' = Map.findWithDefault [] con tsmap - insts = Map.findWithDefault [] con instsmap - merges = [ (n, NT t [] False) | (n, (t, _, _)) <- Map.assocs $ maybe Map.empty id (Map.lookup con mergemap) ] - cs = Map.findWithDefault [] con csmap - ps = Set.elems $ Map.findWithDefault Set.empty con psmap - mbMacro = Map.findWithDefault Nothing con macromap - - -- important: keep order of children - cldrn = map child (flds ++ filter (not . existsAsField) insts ++ merges) - child (nm, tp) = - let tpI = if existsAsInst nm - then fromJust $ lookup nm insts - else tp - virt = if existsAsInst nm - then case lookup nm flds of - Just tp' -> ChildReplace tp' - Nothing -> ChildAttr - else if existsAsMerge nm - then ChildAttr - else ChildSyntax - in Child nm tpI virt - existsAsInst nm = maybe False (const True) (lookup nm insts) - existsAsField (nm,_) = maybe False (const True) (lookup nm flds) - existsAsMerge nm = maybe False (const True) (lookup nm merges) - in Production con ps cs cldrn rules tsigs' mbMacro - in Nonterminal nt params inh syn (map alt prs) - in Grammar tsyns uses derivings wrap nonts pragmaMap orderMap ntParams contextMap quantMap uniqueMap augmentsMap aroundsMap mergeMap -} - -{ -mapUnionWithSetUnion :: Map NontermIdent (Set ConstructorIdent) -> Map NontermIdent (Set ConstructorIdent) -> Map NontermIdent (Set ConstructorIdent) -mapUnionWithSetUnion = Map.unionWith Set.union -mapUnionWithPlusPlus :: Map BlockInfo [a] -> Map BlockInfo [a] -> Map BlockInfo [a] -mapUnionWithPlusPlus = Map.unionWith (++) -} - - ---marcos -------------------------------------------------------------------------------- --- Collecting Macro information -------------------------------------------------------------------------------- - -ATTR Alt Alts Elem Elems - [ | | collectedMacros USE {++} {[]} : {[(NontermIdent, ConstructorIdent, MaybeMacro)]}] - - -SEM Alt - | Alt lhs.collectedMacros = [ (nt, con, @macro) - | nt <- Set.toList @lhs.nts - , con <- Set.toList (@names.constructors (Map.findWithDefault Set.empty nt @lhs.allConstructors)) - ] - - -SEM AG - | AG - - loc.allMacros = let f (nt,con,m) = Map.insertWith (Map.union) nt (Map.singleton con m) - in foldr f (Map.empty) @elems.collectedMacros - - -------------------------------------------------------------------------------- --- Collecting the AGI information -------------------------------------------------------------------------------- - -ATTR AG [ | | agi : {(Set NontermIdent, DataTypes, Map NontermIdent (Attributes, Attributes))} ] - -ATTR Elem Elems SemAlts SemAlt [ allAttrs : {Map NontermIdent (Attributes, Attributes)} | | ] - -SEM AG - | AG lhs.agi = (@loc.allNonterminals,@loc.allFields,@loc.allAttrs) - - loc.allAttrs = if withSelf @lhs.options - then foldr addSelf @elems.attrs (Set.toList @loc.allNonterminals) - else @elems.attrs - -ATTR Elems Elem Attrs - [ | attrs : {Map NontermIdent (Attributes, Attributes)} | ] - -SEM AG - | AG elems.attrs = Map.empty - - -SEM Attrs - | Attrs lhs.attrs = let ins decls nt = if Map.member nt decls - then Map.update (\(inh,syn) -> Just ( Map.union inh $ Map.fromList @inherited - , Map.union syn $ Map.fromList @synthesized)) nt decls - else Map.insert nt (Map.fromList @inherited, Map.fromList @synthesized) decls - - in foldl ins @lhs.attrs (Set.toList @lhs.nts) - - -------------------------------------------------------------------------------- --- Collecting the data type information -------------------------------------------------------------------------------- - -ATTR AG Elems Elem - [ | | constructorTypeMap USE {`Map.union`} {Map.empty} : {Map NontermIdent ConstructorType} ] - -SEM Elem - | Data lhs.constructorTypeMap = Set.fold (\nm mp -> Map.insert nm @contype mp) Map.empty @names.collectedNames diff --git a/src-ag/Visage.ag b/src-ag/Visage.ag deleted file mode 100644 --- a/src-ag/Visage.ag +++ /dev/null @@ -1,122 +0,0 @@ -INCLUDE "VisageSyntax.ag" -INCLUDE "VisagePatterns.ag" -INCLUDE "Expression.ag" - - -imports { -import UU.Scanner.Position(Pos(..)) -import CommonTypes -import ATermAbstractSyntax -import Expression -import VisagePatterns -import VisageSyntax -import qualified Data.Map as Map -import Data.Map(Map) -import Data.List(intersperse) -import TokenDef -} - -{ -convert :: String -> String -convert [] = [] -convert (c:ct) | c == '\n' = '\\' : 'n' : convert ct - | otherwise = c : convert ct - -sQ :: String -> String -sQ [] = [] -sQ (x:xs) = if (x=='"') then rest else x:rest - where - rest = if not (null xs) && last xs == '"' then init xs else xs - -showAGPos :: Pos -> String -showAGPos (Pos l c f) | l == (-1) = "" - | otherwise = let file = if null f then "" else f -- No show of f - lc = "(line " ++ show l ++ ", column " ++ show c ++")" - in file ++ lc - -showMap :: (Show a, Show b) => Map a b -> String -showMap - = braces . concat . intersperse "," . map (uncurry assign) . Map.assocs - where - braces s = "{" ++ s ++ "}" - assign a b = show a ++ ":=" ++ show b -} - -WRAPPER VisageGrammar - -ATTR VisageGrammar VisageNonterminal VisageProduction - VisageChild VisageRule Expression VisagePattern [ || aterm:{ATerm} ] -ATTR VisageNonterminals VisageProductions VisageChildren - VisageRules VisagePatterns [ || aterms:{[ATerm]} ] -ATTR VisageRules -> VisageRule [ isLoc : Bool | | ] - -SEM VisageGrammar - | VGrammar lhs.aterm = AAppl "Productions" @nonts.aterms - - -SEM VisageNonterminals - | Cons lhs.aterms = @hd.aterm : @tl.aterms - | Nil lhs.aterms = [] - - -SEM VisageNonterminal - | VNonterminal lhs.aterm = AAppl "Production" [AString (sQ (getName @nt)), AString (sQ(showMap @inh)), - AString (sQ(showMap @syn)), AAppl "Alternatives" @alts.aterms] - - -SEM VisageProductions - | Cons lhs.aterms = @hd.aterm : @tl.aterms - | Nil lhs.aterms = [] - - -SEM VisageProduction - | VProduction lhs.aterm = AAppl "Alternative" [AString (sQ (getName @con)), AAppl "Children" @children.aterms, - AAppl "Rules" @rules.aterms, - AAppl "LocRules" @locrules.aterms] - locrules.isLoc = True - rules.isLoc = False - -SEM VisageChildren - | Cons lhs.aterms = @hd.aterm : @tl.aterms - | Nil lhs.aterms = [] - - -SEM VisageChild - | VChild lhs.aterm = AAppl "Child" [AString (sQ (getName @name)), AString (sQ (show @tp)), - AString (sQ (showMap @inh)), - AString (sQ (showMap @syn)), - AAppl "Rules" @rules.aterms] - rules.isLoc = False - -SEM VisageRules - | Cons lhs.aterms = @hd.aterm : @tl.aterms - | Nil lhs.aterms = [] - - -SEM VisageRule - | VRule lhs.aterm = AAppl (if @lhs.isLoc then "LocRule" else "Rule") - ([AString (sQ (getName @attr)), @pat.aterm, @rhs.aterm] ++ if @lhs.isLoc then [AString (sQ (show @owrt))] else []) - - - -SEM Expression - | Expression lhs.aterm = AAppl "Expression" [AString (sQ (showAGPos @pos)), AString (sQ (unlines . showTokens . tokensToStrings $ @tks))] - - -SEM VisagePatterns - | Cons lhs.aterms = @hd.aterm : @tl.aterms - | Nil lhs.aterms = [] - - -SEM VisagePattern - | VConstr lhs.aterm = AAppl "Pattern" [AAppl "Constr" [AString (sQ (showAGPos (getPos @name))), - AString (sQ (getName @name)), - AAppl "Patterns" @pats.aterms]] - | VProduct lhs.aterm = AAppl "Pattern" [AAppl "Product" [AString (sQ (showAGPos @pos)), - AAppl "Patterns" @pats.aterms]] - | VVar lhs.aterm = AAppl "Pattern" [AAppl "Var" [AString (sQ (showAGPos (getPos @field))), - AString (sQ (getName @field ++ "." ++ getName @attr))]] - | VAlias lhs.aterm = AAppl "Pattern" [AAppl "Alias" [AString (sQ (showAGPos (getPos @field))), - AString (sQ (getName @field ++ "." ++ getName @attr)), @pat.aterm]] - | VUnderscore lhs.aterm = AAppl "Pattern" [AAppl "Underscore" [AString (sQ (showAGPos @pos))]] - diff --git a/src-ag/VisagePatterns.ag b/src-ag/VisagePatterns.ag deleted file mode 100644 --- a/src-ag/VisagePatterns.ag +++ /dev/null @@ -1,19 +0,0 @@ -imports -{ -import UU.Scanner.Position(Pos) -import CommonTypes -} - -TYPE VisagePatterns = [VisagePattern] - -DATA VisagePattern | VConstr name : {ConstructorIdent} - pats : VisagePatterns - | VProduct pos : {Pos} - pats : VisagePatterns - | VVar field : {Identifier} - attr : {Identifier} - | VAlias field : {Identifier} - attr : {Identifier} - pat : VisagePattern - | VUnderscore pos : {Pos} - diff --git a/src-ag/VisageSyntax.ag b/src-ag/VisageSyntax.ag deleted file mode 100644 --- a/src-ag/VisageSyntax.ag +++ /dev/null @@ -1,42 +0,0 @@ -imports -{ -import CommonTypes -import UU.Pretty -import AbstractSyntax -import VisagePatterns -import Expression -} - -DATA VisageGrammar | VGrammar nonts : VisageNonterminals - -TYPE VisageNonterminals = [VisageNonterminal] - -TYPE VisageProductions = [VisageProduction] - -TYPE VisageChildren = [VisageChild] - -TYPE VisageRules = [VisageRule] - -DATA VisageNonterminal | VNonterminal nt : {NontermIdent} - inh : {Attributes} - syn : {Attributes} - alts : VisageProductions - -DATA VisageProduction | VProduction con : {ConstructorIdent} - children : VisageChildren - rules : VisageRules - locrules : VisageRules - - -DATA VisageChild | VChild name : {Identifier} - tp : {Type} - inh : {Attributes} - syn : {Attributes} - rules : VisageRules - -DATA VisageRule | VRule fieldattrs : {[(Identifier,Identifier)]} - attr : {Identifier} - pat : VisagePattern - rhs : Expression - owrt : {Bool} - diff --git a/src-generated/AbstractSyntax.hs b/src-generated/AbstractSyntax.hs --- a/src-generated/AbstractSyntax.hs +++ b/src-generated/AbstractSyntax.hs @@ -1,6 +1,6 @@ --- UUAGC 0.9.51.1 (src-ag/AbstractSyntax.ag) +-- UUAGC 0.9.51 (src-ag/AbstractSyntax.ag) module AbstractSyntax where {-# LINE 2 "src-ag/AbstractSyntax.ag" #-} diff --git a/src-generated/Code.hs b/src-generated/Code.hs --- a/src-generated/Code.hs +++ b/src-generated/Code.hs @@ -1,6 +1,6 @@ --- UUAGC 0.9.51.1 (src-ag/Code.ag) +-- UUAGC 0.9.51 (src-ag/Code.ag) module Code where {-# LINE 2 "src-ag/Code.ag" #-} diff --git a/src-generated/CodeSyntax.hs b/src-generated/CodeSyntax.hs --- a/src-generated/CodeSyntax.hs +++ b/src-generated/CodeSyntax.hs @@ -1,6 +1,6 @@ --- UUAGC 0.9.51.1 (src-ag/CodeSyntax.ag) +-- UUAGC 0.9.51 (src-ag/CodeSyntax.ag) module CodeSyntax where {-# LINE 2 "src-ag/CodeSyntax.ag" #-} diff --git a/src-generated/ConcreteSyntax.hs b/src-generated/ConcreteSyntax.hs --- a/src-generated/ConcreteSyntax.hs +++ b/src-generated/ConcreteSyntax.hs @@ -1,6 +1,6 @@ --- UUAGC 0.9.51.1 (src-ag/ConcreteSyntax.ag) +-- UUAGC 0.9.51 (src-ag/ConcreteSyntax.ag) module ConcreteSyntax where {-# LINE 2 "src-ag/ConcreteSyntax.ag" #-} diff --git a/src-generated/DeclBlocks.hs b/src-generated/DeclBlocks.hs --- a/src-generated/DeclBlocks.hs +++ b/src-generated/DeclBlocks.hs @@ -1,6 +1,6 @@ --- UUAGC 0.9.51.1 (src-ag/DeclBlocks.ag) +-- UUAGC 0.9.51 (src-ag/DeclBlocks.ag) module DeclBlocks where {-# LINE 2 "src-ag/DeclBlocks.ag" #-} diff --git a/src-generated/ErrorMessages.hs b/src-generated/ErrorMessages.hs --- a/src-generated/ErrorMessages.hs +++ b/src-generated/ErrorMessages.hs @@ -1,6 +1,6 @@ --- UUAGC 0.9.51.1 (src-ag/ErrorMessages.ag) +-- UUAGC 0.9.51 (src-ag/ErrorMessages.ag) module ErrorMessages where {-# LINE 2 "src-ag/ErrorMessages.ag" #-} diff --git a/src-generated/ExecutionPlan.hs b/src-generated/ExecutionPlan.hs --- a/src-generated/ExecutionPlan.hs +++ b/src-generated/ExecutionPlan.hs @@ -1,6 +1,6 @@ --- UUAGC 0.9.51.1 (src-ag/ExecutionPlan.ag) +-- UUAGC 0.9.51 (src-ag/ExecutionPlan.ag) module ExecutionPlan where {-# LINE 2 "src-ag/ExecutionPlan.ag" #-} diff --git a/src-generated/Expression.hs b/src-generated/Expression.hs --- a/src-generated/Expression.hs +++ b/src-generated/Expression.hs @@ -1,6 +1,6 @@ --- UUAGC 0.9.51.1 (src-ag/Expression.ag) +-- UUAGC 0.9.51 (src-ag/Expression.ag) module Expression where {-# LINE 2 "src-ag/Expression.ag" #-} diff --git a/src-generated/HsToken.hs b/src-generated/HsToken.hs --- a/src-generated/HsToken.hs +++ b/src-generated/HsToken.hs @@ -1,6 +1,6 @@ --- UUAGC 0.9.51.1 (src-ag/HsToken.ag) +-- UUAGC 0.9.51 (src-ag/HsToken.ag) module HsToken where {-# LINE 2 "src-ag/HsToken.ag" #-} diff --git a/src-generated/Interfaces.hs b/src-generated/Interfaces.hs --- a/src-generated/Interfaces.hs +++ b/src-generated/Interfaces.hs @@ -1,6 +1,6 @@ --- UUAGC 0.9.51.1 (src-ag/Interfaces.ag) +-- UUAGC 0.9.51 (src-ag/Interfaces.ag) module Interfaces where {-# LINE 2 "src-ag/Interfaces.ag" #-} diff --git a/src-generated/LOAG/Order.hs b/src-generated/LOAG/Order.hs --- a/src-generated/LOAG/Order.hs +++ b/src-generated/LOAG/Order.hs @@ -106,35 +106,22 @@ {-# LINE 292 "src-ag/LOAG/Prepare.ag" #-} --- | Replace the references to local attributes, by his attrs dependencies, --- | rendering the local attributes 'transparent'. +-- | Replace the references to local attributes, by his attrs dependencies repLocRefs :: SF_P -> SF_P -> SF_P repLocRefs lfp sfp = - Map.map (setConcatMap $ rep Set.empty) sfp - where rep :: Set.Set MyOccurrence -> MyOccurrence -> Set.Set MyOccurrence - rep done occ | occ `Set.member` done = Set.empty - | isLoc occ = setConcatMap (rep $ Set.insert occ done) $ - findWithErr lfp "repping locals" occ - | otherwise = Set.singleton occ - --- | Add dependencies from a higher order child to all its attributes -addHigherOrders :: SF_P -> SF_P -> SF_P -addHigherOrders lfp sfp = - Map.mapWithKey f $ Map.map (setConcatMap (\mo -> f mo (Set.singleton mo))) sfp - where f :: MyOccurrence -> Set.Set MyOccurrence -> Set.Set MyOccurrence - f mo@(MyOccurrence (p,f) _) deps = - let ho = ((p,"inst") >.< (f,AnyDir)) - in if ho `Map.member` lfp - then ho `Set.insert` deps - else deps -{-# LINE 131 "dist/build/LOAG/Order.hs" #-} + Map.map (setConcatMap rep) sfp + where rep :: MyOccurrence -> Set.Set MyOccurrence + rep occ | isLoc occ = setConcatMap rep $ + findWithErr lfp "repping locals" occ + | otherwise = Set.singleton occ +{-# LINE 118 "dist/build/LOAG/Order.hs" #-} {-# LINE 42 "src-ag/LOAG/Order.ag" #-} fst' (a,_,_) = a snd' (_,b,_) = b trd' (_,_,c) = c -{-# LINE 138 "dist/build/LOAG/Order.hs" #-} +{-# LINE 125 "dist/build/LOAG/Order.hs" #-} {-# LINE 95 "src-ag/LOAG/Order.ag" #-} @@ -164,7 +151,7 @@ ppOcc pmp v = text f >|< text "." >|< fst a where (MyOccurrence ((t,p),f) a) = findWithErr pmp "ppOcc" v -{-# LINE 168 "dist/build/LOAG/Order.hs" #-} +{-# LINE 155 "dist/build/LOAG/Order.hs" #-} {-# LINE 239 "src-ag/LOAG/Order.ag" #-} @@ -226,10 +213,10 @@ writeSTRef introed (Set.insert child intros) let occ = (ps,"inst") >.< (child, AnyDir) preds = Set.toList $ setConcatMap rep $ - lfp Map.! occ + findWithErr lfp "woot4" occ rep :: MyOccurrence -> Set.Set MyOccurrence rep occ | isLoc occ = Set.insert occ $ - setConcatMap rep $ lfp Map.! occ + setConcatMap rep $ findWithErr lfp "woot3" occ | otherwise = Set.singleton occ rest <- forM preds (visit ref introed ruleref vnrsref) @@ -242,9 +229,9 @@ where cvisit= ChildVisit (identifier child) ntid visnr child = snd $ argsOf o ntid = ((\(NT name _ _ )-> name) . fromMyTy) nt - visnr = (\x-> visMap IMap.! x) (nmpr Map.! (nt <.> attr o)) - nt = fty Map.! (ps,child) -{-# LINE 248 "dist/build/LOAG/Order.hs" #-} + visnr = (\x-> findWithErr' visMap (show (inOutput,o,x)) x) (findWithErr nmpr "woot3" (nt <.> attr o)) + nt = findWithErr fty "woot" (ps,child) +{-# LINE 235 "dist/build/LOAG/Order.hs" #-} {-# LINE 356 "src-ag/LOAG/Order.ag" #-} @@ -326,7 +313,7 @@ syns = map (((genA A.!) &&& id).(pmpr Map.!))$ Set.toList ss -{-# LINE 330 "dist/build/LOAG/Order.hs" #-} +{-# LINE 317 "dist/build/LOAG/Order.hs" #-} -- CGrammar ---------------------------------------------------- -- wrapper data Inh_CGrammar = Inh_CGrammar { } @@ -1106,13 +1093,13 @@ case tp_ of NT nt _ _ -> Set.singleton nt _ -> mempty - {-# LINE 1110 "dist/build/LOAG/Order.hs"#-} + {-# LINE 1097 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule33 #-} {-# LINE 34 "src-ag/ExecutionPlanCommon.ag" #-} rule33 = \ _isHigherOrder _refNts -> {-# LINE 34 "src-ag/ExecutionPlanCommon.ag" #-} if _isHigherOrder then _refNts else mempty - {-# LINE 1116 "dist/build/LOAG/Order.hs"#-} + {-# LINE 1103 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule34 #-} {-# LINE 35 "src-ag/ExecutionPlanCommon.ag" #-} rule34 = \ kind_ -> @@ -1120,7 +1107,7 @@ case kind_ of ChildSyntax -> False _ -> True - {-# LINE 1124 "dist/build/LOAG/Order.hs"#-} + {-# LINE 1111 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule35 #-} {-# LINE 95 "src-ag/ExecutionPlanCommon.ag" #-} rule35 = \ ((_lhsIaroundMap) :: Map Identifier [Expression]) name_ -> @@ -1128,19 +1115,19 @@ case Map.lookup name_ _lhsIaroundMap of Nothing -> False Just as -> not (null as) - {-# LINE 1132 "dist/build/LOAG/Order.hs"#-} + {-# LINE 1119 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule36 #-} {-# LINE 123 "src-ag/ExecutionPlanCommon.ag" #-} rule36 = \ ((_lhsImergeMap) :: Map Identifier (Identifier, [Identifier], Expression)) name_ -> {-# LINE 123 "src-ag/ExecutionPlanCommon.ag" #-} maybe Nothing (\(_,ms,_) -> Just ms) $ Map.lookup name_ _lhsImergeMap - {-# LINE 1138 "dist/build/LOAG/Order.hs"#-} + {-# LINE 1125 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule37 #-} {-# LINE 124 "src-ag/ExecutionPlanCommon.ag" #-} rule37 = \ ((_lhsImergedChildren) :: Set Identifier) name_ -> {-# LINE 124 "src-ag/ExecutionPlanCommon.ag" #-} name_ `Set.member` _lhsImergedChildren - {-# LINE 1144 "dist/build/LOAG/Order.hs"#-} + {-# LINE 1131 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule38 #-} {-# LINE 135 "src-ag/ExecutionPlanCommon.ag" #-} rule38 = \ _hasArounds _isMerged _merges kind_ name_ tp_ -> @@ -1148,56 +1135,56 @@ case tp_ of NT _ _ _ -> EChild name_ tp_ kind_ _hasArounds _merges _isMerged _ -> ETerm name_ tp_ - {-# LINE 1152 "dist/build/LOAG/Order.hs"#-} + {-# LINE 1139 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule39 #-} {-# LINE 174 "src-ag/LOAG/Prepare.ag" #-} rule39 = \ ((_lhsIflab) :: Int) -> {-# LINE 174 "src-ag/LOAG/Prepare.ag" #-} _lhsIflab + 1 - {-# LINE 1158 "dist/build/LOAG/Order.hs"#-} + {-# LINE 1145 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule40 #-} {-# LINE 175 "src-ag/LOAG/Prepare.ag" #-} rule40 = \ tp_ -> {-# LINE 175 "src-ag/LOAG/Prepare.ag" #-} toMyTy tp_ - {-# LINE 1164 "dist/build/LOAG/Order.hs"#-} + {-# LINE 1151 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule41 #-} {-# LINE 177 "src-ag/LOAG/Prepare.ag" #-} rule41 = \ _atp ((_lhsIan) :: MyType -> MyAttributes) ((_lhsIpll) :: PLabel) name_ -> {-# LINE 177 "src-ag/LOAG/Prepare.ag" #-} map ((FieldAtt _atp _lhsIpll (getName name_)) . alab) $ _lhsIan _atp - {-# LINE 1171 "dist/build/LOAG/Order.hs"#-} + {-# LINE 1158 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule42 #-} {-# LINE 179 "src-ag/LOAG/Prepare.ag" #-} rule42 = \ _flab -> {-# LINE 179 "src-ag/LOAG/Prepare.ag" #-} _flab - {-# LINE 1177 "dist/build/LOAG/Order.hs"#-} + {-# LINE 1164 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule43 #-} {-# LINE 180 "src-ag/LOAG/Prepare.ag" #-} rule43 = \ name_ -> {-# LINE 180 "src-ag/LOAG/Prepare.ag" #-} getName name_ - {-# LINE 1183 "dist/build/LOAG/Order.hs"#-} + {-# LINE 1170 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule44 #-} {-# LINE 181 "src-ag/LOAG/Prepare.ag" #-} rule44 = \ _ident ((_lhsIpll) :: PLabel) -> {-# LINE 181 "src-ag/LOAG/Prepare.ag" #-} (_lhsIpll, _ident ) - {-# LINE 1189 "dist/build/LOAG/Order.hs"#-} + {-# LINE 1176 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule45 #-} {-# LINE 182 "src-ag/LOAG/Prepare.ag" #-} rule45 = \ _atp _label ((_lhsIain) :: MyType -> MyAttributes) -> {-# LINE 182 "src-ag/LOAG/Prepare.ag" #-} Set.fromList $ handAllOut _label $ _lhsIain _atp - {-# LINE 1195 "dist/build/LOAG/Order.hs"#-} + {-# LINE 1182 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule46 #-} {-# LINE 183 "src-ag/LOAG/Prepare.ag" #-} rule46 = \ _atp _label ((_lhsIasn) :: MyType -> MyAttributes) -> {-# LINE 183 "src-ag/LOAG/Prepare.ag" #-} Set.fromList $ handAllOut _label $ _lhsIasn _atp - {-# LINE 1201 "dist/build/LOAG/Order.hs"#-} + {-# LINE 1188 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule47 #-} {-# LINE 184 "src-ag/LOAG/Prepare.ag" #-} rule47 = \ _foccsI _foccsS _label -> @@ -1205,7 +1192,7 @@ if Set.null _foccsI && Set.null _foccsS then Map.empty else Map.singleton _label (_foccsS ,_foccsI ) - {-# LINE 1209 "dist/build/LOAG/Order.hs"#-} + {-# LINE 1196 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule48 #-} {-# LINE 187 "src-ag/LOAG/Prepare.ag" #-} rule48 = \ _ident ((_lhsIpll) :: PLabel) kind_ -> @@ -1213,19 +1200,19 @@ case kind_ of ChildAttr -> Map.singleton _lhsIpll (Set.singleton _ident ) _ -> Map.empty - {-# LINE 1217 "dist/build/LOAG/Order.hs"#-} + {-# LINE 1204 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule49 #-} {-# LINE 190 "src-ag/LOAG/Prepare.ag" #-} rule49 = \ _atp ((_lhsIpll) :: PLabel) name_ -> {-# LINE 190 "src-ag/LOAG/Prepare.ag" #-} Map.singleton (_lhsIpll, getName name_) _atp - {-# LINE 1223 "dist/build/LOAG/Order.hs"#-} + {-# LINE 1210 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule50 #-} {-# LINE 223 "src-ag/LOAG/Prepare.ag" #-} rule50 = \ name_ -> {-# LINE 223 "src-ag/LOAG/Prepare.ag" #-} Set.singleton $ getName name_ - {-# LINE 1229 "dist/build/LOAG/Order.hs"#-} + {-# LINE 1216 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule51 #-} rule51 = \ ((_fattsIap) :: A_P) -> _fattsIap @@ -1607,56 +1594,56 @@ rule120 = \ ((_lhsIflab) :: Int) -> {-# LINE 161 "src-ag/LOAG/Prepare.ag" #-} _lhsIflab + 1 - {-# LINE 1611 "dist/build/LOAG/Order.hs"#-} + {-# LINE 1598 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule121 #-} {-# LINE 162 "src-ag/LOAG/Prepare.ag" #-} rule121 = \ ((_lhsIpll) :: PLabel) -> {-# LINE 162 "src-ag/LOAG/Prepare.ag" #-} fst _lhsIpll - {-# LINE 1617 "dist/build/LOAG/Order.hs"#-} + {-# LINE 1604 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule122 #-} {-# LINE 164 "src-ag/LOAG/Prepare.ag" #-} rule122 = \ _atp ((_lhsIan) :: MyType -> MyAttributes) ((_lhsIpll) :: PLabel) -> {-# LINE 164 "src-ag/LOAG/Prepare.ag" #-} map ((FieldAtt _atp _lhsIpll "lhs") . alab) $ _lhsIan _atp - {-# LINE 1624 "dist/build/LOAG/Order.hs"#-} + {-# LINE 1611 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule123 #-} {-# LINE 166 "src-ag/LOAG/Prepare.ag" #-} rule123 = \ _flab -> {-# LINE 166 "src-ag/LOAG/Prepare.ag" #-} _flab - {-# LINE 1630 "dist/build/LOAG/Order.hs"#-} + {-# LINE 1617 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule124 #-} {-# LINE 167 "src-ag/LOAG/Prepare.ag" #-} rule124 = \ ((_lhsIpll) :: PLabel) -> {-# LINE 167 "src-ag/LOAG/Prepare.ag" #-} (_lhsIpll, "lhs") - {-# LINE 1636 "dist/build/LOAG/Order.hs"#-} + {-# LINE 1623 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule125 #-} {-# LINE 168 "src-ag/LOAG/Prepare.ag" #-} rule125 = \ _atp _label ((_lhsIain) :: MyType -> MyAttributes) -> {-# LINE 168 "src-ag/LOAG/Prepare.ag" #-} Set.fromList $ handAllOut _label $ _lhsIain _atp - {-# LINE 1642 "dist/build/LOAG/Order.hs"#-} + {-# LINE 1629 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule126 #-} {-# LINE 169 "src-ag/LOAG/Prepare.ag" #-} rule126 = \ _atp _label ((_lhsIasn) :: MyType -> MyAttributes) -> {-# LINE 169 "src-ag/LOAG/Prepare.ag" #-} Set.fromList $ handAllOut _label $ _lhsIasn _atp - {-# LINE 1648 "dist/build/LOAG/Order.hs"#-} + {-# LINE 1635 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule127 #-} {-# LINE 170 "src-ag/LOAG/Prepare.ag" #-} rule127 = \ _foccsI _foccsS _label -> {-# LINE 170 "src-ag/LOAG/Prepare.ag" #-} Map.singleton _label (_foccsI , _foccsS ) - {-# LINE 1654 "dist/build/LOAG/Order.hs"#-} + {-# LINE 1641 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule128 #-} {-# LINE 171 "src-ag/LOAG/Prepare.ag" #-} rule128 = \ _label ((_lhsIdty) :: MyType) -> {-# LINE 171 "src-ag/LOAG/Prepare.ag" #-} Map.singleton _label _lhsIdty - {-# LINE 1660 "dist/build/LOAG/Order.hs"#-} + {-# LINE 1647 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule129 #-} rule129 = \ ((_fattsIap) :: A_P) -> _fattsIap @@ -1773,25 +1760,25 @@ rule148 = \ tks_ -> {-# LINE 273 "src-ag/LOAG/Prepare.ag" #-} HsTokensRoot tks_ - {-# LINE 1777 "dist/build/LOAG/Order.hs"#-} + {-# LINE 1764 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule149 #-} {-# LINE 274 "src-ag/LOAG/Prepare.ag" #-} rule149 = \ ((_lhsIpll) :: PLabel) -> {-# LINE 274 "src-ag/LOAG/Prepare.ag" #-} _lhsIpll - {-# LINE 1783 "dist/build/LOAG/Order.hs"#-} + {-# LINE 1770 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule150 #-} {-# LINE 275 "src-ag/LOAG/Prepare.ag" #-} rule150 = \ ((_lhsIpts) :: Set.Set (FLabel)) -> {-# LINE 275 "src-ag/LOAG/Prepare.ag" #-} _lhsIpts - {-# LINE 1789 "dist/build/LOAG/Order.hs"#-} + {-# LINE 1776 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule151 #-} {-# LINE 276 "src-ag/LOAG/Prepare.ag" #-} rule151 = \ ((_tokensIused) :: Set.Set MyOccurrence) -> {-# LINE 276 "src-ag/LOAG/Prepare.ag" #-} _tokensIused - {-# LINE 1795 "dist/build/LOAG/Order.hs"#-} + {-# LINE 1782 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule152 #-} rule152 = \ pos_ tks_ -> Expression pos_ tks_ @@ -1879,61 +1866,61 @@ rule156 = \ ((_lhsIolab) :: Int) -> {-# LINE 193 "src-ag/LOAG/Prepare.ag" #-} _lhsIolab + 1 - {-# LINE 1883 "dist/build/LOAG/Order.hs"#-} + {-# LINE 1870 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule157 #-} {-# LINE 194 "src-ag/LOAG/Prepare.ag" #-} rule157 = \ _att ((_lhsInmprf) :: NMP_R) -> {-# LINE 194 "src-ag/LOAG/Prepare.ag" #-} findWithErr _lhsInmprf "getting attr label" _att - {-# LINE 1889 "dist/build/LOAG/Order.hs"#-} + {-# LINE 1876 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule158 #-} {-# LINE 195 "src-ag/LOAG/Prepare.ag" #-} rule158 = \ a_ t_ -> {-# LINE 195 "src-ag/LOAG/Prepare.ag" #-} t_ <.> a_ - {-# LINE 1895 "dist/build/LOAG/Order.hs"#-} + {-# LINE 1882 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule159 #-} {-# LINE 196 "src-ag/LOAG/Prepare.ag" #-} rule159 = \ a_ f_ p_ -> {-# LINE 196 "src-ag/LOAG/Prepare.ag" #-} (p_, f_) >.< a_ - {-# LINE 1901 "dist/build/LOAG/Order.hs"#-} + {-# LINE 1888 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule160 #-} {-# LINE 197 "src-ag/LOAG/Prepare.ag" #-} rule160 = \ _occ _olab -> {-# LINE 197 "src-ag/LOAG/Prepare.ag" #-} Map.singleton _olab _occ - {-# LINE 1907 "dist/build/LOAG/Order.hs"#-} + {-# LINE 1894 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule161 #-} {-# LINE 198 "src-ag/LOAG/Prepare.ag" #-} rule161 = \ _occ _olab -> {-# LINE 198 "src-ag/LOAG/Prepare.ag" #-} Map.singleton _occ _olab - {-# LINE 1913 "dist/build/LOAG/Order.hs"#-} + {-# LINE 1900 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule162 #-} {-# LINE 199 "src-ag/LOAG/Prepare.ag" #-} rule162 = \ _alab _olab -> {-# LINE 199 "src-ag/LOAG/Prepare.ag" #-} Map.singleton _alab [_olab ] - {-# LINE 1919 "dist/build/LOAG/Order.hs"#-} + {-# LINE 1906 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule163 #-} {-# LINE 200 "src-ag/LOAG/Prepare.ag" #-} rule163 = \ _alab _olab -> {-# LINE 200 "src-ag/LOAG/Prepare.ag" #-} Map.singleton _olab _alab - {-# LINE 1925 "dist/build/LOAG/Order.hs"#-} + {-# LINE 1912 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule164 #-} {-# LINE 201 "src-ag/LOAG/Prepare.ag" #-} rule164 = \ _occ p_ -> {-# LINE 201 "src-ag/LOAG/Prepare.ag" #-} Map.singleton p_ [_occ ] - {-# LINE 1931 "dist/build/LOAG/Order.hs"#-} + {-# LINE 1918 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule165 #-} {-# LINE 202 "src-ag/LOAG/Prepare.ag" #-} rule165 = \ ((_lhsIflab) :: Int) _olab -> {-# LINE 202 "src-ag/LOAG/Prepare.ag" #-} [(_olab , _lhsIflab)] - {-# LINE 1937 "dist/build/LOAG/Order.hs"#-} + {-# LINE 1924 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule166 #-} rule166 = \ (_ :: ()) -> Map.empty @@ -2265,49 +2252,49 @@ rule205 = \ ((_nontsIntDeps) :: Map NontermIdent (Set NontermIdent)) -> {-# LINE 40 "src-ag/ExecutionPlanCommon.ag" #-} closeMap _nontsIntDeps - {-# LINE 2269 "dist/build/LOAG/Order.hs"#-} + {-# LINE 2256 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule206 #-} {-# LINE 41 "src-ag/ExecutionPlanCommon.ag" #-} rule206 = \ ((_nontsIntHoDeps) :: Map NontermIdent (Set NontermIdent)) -> {-# LINE 41 "src-ag/ExecutionPlanCommon.ag" #-} closeMap _nontsIntHoDeps - {-# LINE 2275 "dist/build/LOAG/Order.hs"#-} + {-# LINE 2262 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule207 #-} {-# LINE 42 "src-ag/ExecutionPlanCommon.ag" #-} rule207 = \ _closedHoNtDeps -> {-# LINE 42 "src-ag/ExecutionPlanCommon.ag" #-} revDeps _closedHoNtDeps - {-# LINE 2281 "dist/build/LOAG/Order.hs"#-} + {-# LINE 2268 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule208 #-} {-# LINE 51 "src-ag/ExecutionPlanCommon.ag" #-} rule208 = \ contextMap_ -> {-# LINE 51 "src-ag/ExecutionPlanCommon.ag" #-} contextMap_ - {-# LINE 2287 "dist/build/LOAG/Order.hs"#-} + {-# LINE 2274 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule209 #-} {-# LINE 92 "src-ag/ExecutionPlanCommon.ag" #-} rule209 = \ aroundsMap_ -> {-# LINE 92 "src-ag/ExecutionPlanCommon.ag" #-} aroundsMap_ - {-# LINE 2293 "dist/build/LOAG/Order.hs"#-} + {-# LINE 2280 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule210 #-} {-# LINE 117 "src-ag/ExecutionPlanCommon.ag" #-} rule210 = \ mergeMap_ -> {-# LINE 117 "src-ag/ExecutionPlanCommon.ag" #-} mergeMap_ - {-# LINE 2299 "dist/build/LOAG/Order.hs"#-} + {-# LINE 2286 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule211 #-} {-# LINE 9 "src-ag/ExecutionPlanPre.ag" #-} rule211 = \ (_ :: ()) -> {-# LINE 9 "src-ag/ExecutionPlanPre.ag" #-} 0 - {-# LINE 2305 "dist/build/LOAG/Order.hs"#-} + {-# LINE 2292 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule212 #-} {-# LINE 38 "src-ag/LOAG/Prepare.ag" #-} rule212 = \ ((_nontsIpmp) :: PMP) -> {-# LINE 38 "src-ag/LOAG/Prepare.ag" #-} if Map.null _nontsIpmp then 1 else fst $ Map.findMin _nontsIpmp - {-# LINE 2311 "dist/build/LOAG/Order.hs"#-} + {-# LINE 2298 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule213 #-} {-# LINE 40 "src-ag/LOAG/Prepare.ag" #-} rule213 = \ _ain _an _asn _initO _nmp _nmpr ((_nontsIap) :: A_P) ((_nontsIfieldMap) :: FMap) ((_nontsIfsInP) :: FsInP) ((_nontsIfty) :: FTY) ((_nontsIgen) :: Map Int Int) ((_nontsIinss) :: Map Int [Int]) ((_nontsIofld) :: [(Int, Int)]) ((_nontsIpmp) :: PMP) ((_nontsIpmpr) :: PMP_R) ((_nontsIps) :: [PLabel]) _sfp -> @@ -2321,145 +2308,145 @@ Map.toList $ _nontsIinss) (A.array (_initO , _initO + length _nontsIofld) $ _nontsIofld) _nontsIfty _nontsIfieldMap _nontsIfsInP - {-# LINE 2325 "dist/build/LOAG/Order.hs"#-} + {-# LINE 2312 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule214 #-} {-# LINE 49 "src-ag/LOAG/Prepare.ag" #-} rule214 = \ _atts -> {-# LINE 49 "src-ag/LOAG/Prepare.ag" #-} Map.fromList $ zip [1..] _atts - {-# LINE 2331 "dist/build/LOAG/Order.hs"#-} + {-# LINE 2318 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule215 #-} {-# LINE 50 "src-ag/LOAG/Prepare.ag" #-} rule215 = \ _atts -> {-# LINE 50 "src-ag/LOAG/Prepare.ag" #-} Map.fromList $ zip _atts [1..] - {-# LINE 2337 "dist/build/LOAG/Order.hs"#-} + {-# LINE 2324 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule216 #-} {-# LINE 51 "src-ag/LOAG/Prepare.ag" #-} rule216 = \ _ain _asn -> {-# LINE 51 "src-ag/LOAG/Prepare.ag" #-} Map.unionWith (++) _ain _asn - {-# LINE 2343 "dist/build/LOAG/Order.hs"#-} + {-# LINE 2330 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule217 #-} {-# LINE 52 "src-ag/LOAG/Prepare.ag" #-} rule217 = \ ((_nontsIinhs) :: AI_N) -> {-# LINE 52 "src-ag/LOAG/Prepare.ag" #-} _nontsIinhs - {-# LINE 2349 "dist/build/LOAG/Order.hs"#-} + {-# LINE 2336 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule218 #-} {-# LINE 53 "src-ag/LOAG/Prepare.ag" #-} rule218 = \ ((_nontsIsyns) :: AS_N) -> {-# LINE 53 "src-ag/LOAG/Prepare.ag" #-} _nontsIsyns - {-# LINE 2355 "dist/build/LOAG/Order.hs"#-} + {-# LINE 2342 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule219 #-} {-# LINE 54 "src-ag/LOAG/Prepare.ag" #-} rule219 = \ _an -> {-# LINE 54 "src-ag/LOAG/Prepare.ag" #-} concat $ Map.elems _an - {-# LINE 2361 "dist/build/LOAG/Order.hs"#-} + {-# LINE 2348 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule220 #-} {-# LINE 55 "src-ag/LOAG/Prepare.ag" #-} rule220 = \ ((_nontsIap) :: A_P) -> {-# LINE 55 "src-ag/LOAG/Prepare.ag" #-} concat $ Map.elems _nontsIap - {-# LINE 2367 "dist/build/LOAG/Order.hs"#-} + {-# LINE 2354 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule221 #-} {-# LINE 56 "src-ag/LOAG/Prepare.ag" #-} rule221 = \ manualAttrOrderMap_ -> {-# LINE 56 "src-ag/LOAG/Prepare.ag" #-} manualAttrOrderMap_ - {-# LINE 2373 "dist/build/LOAG/Order.hs"#-} + {-# LINE 2360 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule222 #-} {-# LINE 87 "src-ag/LOAG/Prepare.ag" #-} rule222 = \ _ain -> {-# LINE 87 "src-ag/LOAG/Prepare.ag" #-} map2F _ain - {-# LINE 2379 "dist/build/LOAG/Order.hs"#-} + {-# LINE 2366 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule223 #-} {-# LINE 88 "src-ag/LOAG/Prepare.ag" #-} rule223 = \ _asn -> {-# LINE 88 "src-ag/LOAG/Prepare.ag" #-} map2F _asn - {-# LINE 2385 "dist/build/LOAG/Order.hs"#-} + {-# LINE 2372 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule224 #-} {-# LINE 89 "src-ag/LOAG/Prepare.ag" #-} rule224 = \ ((_nontsIpmp) :: PMP) -> {-# LINE 89 "src-ag/LOAG/Prepare.ag" #-} _nontsIpmp - {-# LINE 2391 "dist/build/LOAG/Order.hs"#-} + {-# LINE 2378 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule225 #-} {-# LINE 90 "src-ag/LOAG/Prepare.ag" #-} rule225 = \ ((_nontsIpmpr) :: PMP_R) -> {-# LINE 90 "src-ag/LOAG/Prepare.ag" #-} _nontsIpmpr - {-# LINE 2397 "dist/build/LOAG/Order.hs"#-} + {-# LINE 2384 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule226 #-} {-# LINE 91 "src-ag/LOAG/Prepare.ag" #-} rule226 = \ ((_nontsIlfp) :: SF_P) -> {-# LINE 91 "src-ag/LOAG/Prepare.ag" #-} _nontsIlfp - {-# LINE 2403 "dist/build/LOAG/Order.hs"#-} + {-# LINE 2390 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule227 #-} {-# LINE 92 "src-ag/LOAG/Prepare.ag" #-} rule227 = \ ((_nontsIhoMap) :: HOMap) -> {-# LINE 92 "src-ag/LOAG/Prepare.ag" #-} _nontsIhoMap - {-# LINE 2409 "dist/build/LOAG/Order.hs"#-} + {-# LINE 2396 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule228 #-} {-# LINE 93 "src-ag/LOAG/Prepare.ag" #-} rule228 = \ ((_nontsIfty) :: FTY) -> {-# LINE 93 "src-ag/LOAG/Prepare.ag" #-} _nontsIfty - {-# LINE 2415 "dist/build/LOAG/Order.hs"#-} + {-# LINE 2402 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule229 #-} {-# LINE 94 "src-ag/LOAG/Prepare.ag" #-} rule229 = \ ((_nontsIfty) :: FTY) -> {-# LINE 94 "src-ag/LOAG/Prepare.ag" #-} _nontsIfty - {-# LINE 2421 "dist/build/LOAG/Order.hs"#-} + {-# LINE 2408 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule230 #-} {-# LINE 103 "src-ag/LOAG/Prepare.ag" #-} rule230 = \ ((_nontsIps) :: [PLabel]) -> {-# LINE 103 "src-ag/LOAG/Prepare.ag" #-} _nontsIps - {-# LINE 2427 "dist/build/LOAG/Order.hs"#-} + {-# LINE 2414 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule231 #-} {-# LINE 150 "src-ag/LOAG/Prepare.ag" #-} rule231 = \ _an -> {-# LINE 150 "src-ag/LOAG/Prepare.ag" #-} map2F _an - {-# LINE 2433 "dist/build/LOAG/Order.hs"#-} + {-# LINE 2420 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule232 #-} {-# LINE 151 "src-ag/LOAG/Prepare.ag" #-} rule232 = \ _nmpr -> {-# LINE 151 "src-ag/LOAG/Prepare.ag" #-} _nmpr - {-# LINE 2439 "dist/build/LOAG/Order.hs"#-} + {-# LINE 2426 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule233 #-} {-# LINE 152 "src-ag/LOAG/Prepare.ag" #-} rule233 = \ _nmp -> {-# LINE 152 "src-ag/LOAG/Prepare.ag" #-} if Map.null _nmp then 0 else (fst $ Map.findMax _nmp ) - {-# LINE 2445 "dist/build/LOAG/Order.hs"#-} + {-# LINE 2432 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule234 #-} {-# LINE 153 "src-ag/LOAG/Prepare.ag" #-} rule234 = \ (_ :: ()) -> {-# LINE 153 "src-ag/LOAG/Prepare.ag" #-} 0 - {-# LINE 2451 "dist/build/LOAG/Order.hs"#-} + {-# LINE 2438 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule235 #-} {-# LINE 207 "src-ag/LOAG/Prepare.ag" #-} rule235 = \ ((_nontsIlfp) :: SF_P) ((_nontsIsfp) :: SF_P) -> {-# LINE 207 "src-ag/LOAG/Prepare.ag" #-} - repLocRefs _nontsIlfp $ addHigherOrders _nontsIlfp _nontsIsfp - {-# LINE 2457 "dist/build/LOAG/Order.hs"#-} + repLocRefs _nontsIlfp _nontsIsfp + {-# LINE 2444 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule236 #-} {-# LINE 54 "src-ag/LOAG/Order.ag" #-} rule236 = \ _schedRes -> {-# LINE 54 "src-ag/LOAG/Order.ag" #-} either Seq.singleton (const Seq.empty) _schedRes - {-# LINE 2463 "dist/build/LOAG/Order.hs"#-} + {-# LINE 2450 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule237 #-} {-# LINE 55 "src-ag/LOAG/Order.ag" #-} rule237 = \ ((_lhsIoptions) :: Options) ((_nontsIpmp) :: PMP) _schedRes -> @@ -2467,25 +2454,25 @@ case either (const []) trd' _schedRes of [] -> Nothing ads -> Just $ ppAds _lhsIoptions _nontsIpmp ads - {-# LINE 2471 "dist/build/LOAG/Order.hs"#-} + {-# LINE 2458 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule238 #-} {-# LINE 58 "src-ag/LOAG/Order.ag" #-} rule238 = \ ((_nontsIenonts) :: ENonterminals) derivings_ typeSyns_ wrappers_ -> {-# LINE 58 "src-ag/LOAG/Order.ag" #-} ExecutionPlan _nontsIenonts typeSyns_ wrappers_ derivings_ - {-# LINE 2477 "dist/build/LOAG/Order.hs"#-} + {-# LINE 2464 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule239 #-} {-# LINE 60 "src-ag/LOAG/Order.ag" #-} rule239 = \ _schedRes -> {-# LINE 60 "src-ag/LOAG/Order.ag" #-} either (const Map.empty) snd' _schedRes - {-# LINE 2483 "dist/build/LOAG/Order.hs"#-} + {-# LINE 2470 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule240 #-} {-# LINE 61 "src-ag/LOAG/Order.ag" #-} rule240 = \ _schedRes -> {-# LINE 61 "src-ag/LOAG/Order.ag" #-} either (error "no tdp") (fromJust.fst') _schedRes - {-# LINE 2489 "dist/build/LOAG/Order.hs"#-} + {-# LINE 2476 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule241 #-} {-# LINE 63 "src-ag/LOAG/Order.ag" #-} rule241 = \ _ag ((_lhsIoptions) :: Options) _loagRes ((_nontsIads) :: [Edge]) _self ((_smfIself) :: LOAGRep) -> @@ -2495,38 +2482,38 @@ then AOAG.schedule _smfIself _self _ag _nontsIads else _loagRes else Right (Nothing,Map.empty,[]) - {-# LINE 2499 "dist/build/LOAG/Order.hs"#-} + {-# LINE 2486 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule242 #-} {-# LINE 68 "src-ag/LOAG/Order.ag" #-} rule242 = \ _ag ((_lhsIoptions) :: Options) -> {-# LINE 68 "src-ag/LOAG/Order.ag" #-} let putStrLn s = when (verbose _lhsIoptions) (IO.putStrLn s) in Right $ unsafePerformIO $ scheduleLOAG _ag putStrLn _lhsIoptions - {-# LINE 2506 "dist/build/LOAG/Order.hs"#-} + {-# LINE 2493 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule243 #-} {-# LINE 70 "src-ag/LOAG/Order.ag" #-} rule243 = \ _self ((_smfIself) :: LOAGRep) -> {-# LINE 70 "src-ag/LOAG/Order.ag" #-} repToAg _smfIself _self - {-# LINE 2512 "dist/build/LOAG/Order.hs"#-} + {-# LINE 2499 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule244 #-} {-# LINE 72 "src-ag/LOAG/Order.ag" #-} rule244 = \ _schedRes -> {-# LINE 72 "src-ag/LOAG/Order.ag" #-} either (const []) trd' _schedRes - {-# LINE 2518 "dist/build/LOAG/Order.hs"#-} + {-# LINE 2505 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule245 #-} {-# LINE 133 "src-ag/LOAG/Order.ag" #-} rule245 = \ ((_nontsIvisMap) :: IMap.IntMap Int) -> {-# LINE 133 "src-ag/LOAG/Order.ag" #-} _nontsIvisMap - {-# LINE 2524 "dist/build/LOAG/Order.hs"#-} + {-# LINE 2511 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule246 #-} {-# LINE 134 "src-ag/LOAG/Order.ag" #-} rule246 = \ (_ :: ()) -> {-# LINE 134 "src-ag/LOAG/Order.ag" #-} 0 - {-# LINE 2530 "dist/build/LOAG/Order.hs"#-} + {-# LINE 2517 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule247 #-} rule247 = \ ((_nontsIinhmap) :: Map.Map NontermIdent Attributes) -> _nontsIinhmap @@ -2616,7 +2603,7 @@ True -> Set.empty False -> Set.singleton $ (_lhsIpll, getName _LOC) >.< (getName var_, drhs _LOC) - {-# LINE 2620 "dist/build/LOAG/Order.hs"#-} + {-# LINE 2607 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule258 #-} rule258 = \ pos_ rdesc_ var_ -> AGLocal var_ pos_ rdesc_ @@ -2644,7 +2631,7 @@ {-# LINE 289 "src-ag/LOAG/Prepare.ag" #-} Set.singleton $ (_lhsIpll, getName field_) >.< (getName attr_, drhs field_) - {-# LINE 2648 "dist/build/LOAG/Order.hs"#-} + {-# LINE 2635 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule261 #-} rule261 = \ attr_ field_ pos_ rdesc_ -> AGField field_ attr_ pos_ rdesc_ @@ -3039,51 +3026,51 @@ rule294 = \ ((_lhsInmp) :: NMP) inhAttr_ -> {-# LINE 225 "src-ag/LOAG/Order.ag" #-} Map.keysSet$ Map.unions $ map (vertexToAttr _lhsInmp) inhAttr_ - {-# LINE 3043 "dist/build/LOAG/Order.hs"#-} + {-# LINE 3030 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule295 #-} {-# LINE 226 "src-ag/LOAG/Order.ag" #-} rule295 = \ ((_lhsInmp) :: NMP) synAttr_ -> {-# LINE 226 "src-ag/LOAG/Order.ag" #-} Map.keysSet$ Map.unions $ map (vertexToAttr _lhsInmp) synAttr_ - {-# LINE 3049 "dist/build/LOAG/Order.hs"#-} + {-# LINE 3036 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule296 #-} {-# LINE 227 "src-ag/LOAG/Order.ag" #-} rule296 = \ inhOccs_ -> {-# LINE 227 "src-ag/LOAG/Order.ag" #-} maybe (error "segment not instantiated") id inhOccs_ - {-# LINE 3055 "dist/build/LOAG/Order.hs"#-} + {-# LINE 3042 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule297 #-} {-# LINE 228 "src-ag/LOAG/Order.ag" #-} rule297 = \ synOccs_ -> {-# LINE 228 "src-ag/LOAG/Order.ag" #-} maybe (error "segment not instantiated") id synOccs_ - {-# LINE 3061 "dist/build/LOAG/Order.hs"#-} + {-# LINE 3048 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule298 #-} {-# LINE 229 "src-ag/LOAG/Order.ag" #-} rule298 = \ visnr_ -> {-# LINE 229 "src-ag/LOAG/Order.ag" #-} visnr_ - {-# LINE 3067 "dist/build/LOAG/Order.hs"#-} + {-# LINE 3054 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule299 #-} {-# LINE 230 "src-ag/LOAG/Order.ag" #-} rule299 = \ ((_lhsIoptions) :: Options) -> {-# LINE 230 "src-ag/LOAG/Order.ag" #-} if monadic _lhsIoptions then VisitMonadic else VisitPure True - {-# LINE 3073 "dist/build/LOAG/Order.hs"#-} + {-# LINE 3060 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule300 #-} {-# LINE 231 "src-ag/LOAG/Order.ag" #-} rule300 = \ _inhs _kind ((_lhsIvisitnum) :: Int) _steps _syns -> {-# LINE 231 "src-ag/LOAG/Order.ag" #-} Visit _lhsIvisitnum _lhsIvisitnum (_lhsIvisitnum+1) _inhs _syns _steps _kind - {-# LINE 3080 "dist/build/LOAG/Order.hs"#-} + {-# LINE 3067 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule301 #-} {-# LINE 233 "src-ag/LOAG/Order.ag" #-} rule301 = \ ((_lhsIoptions) :: Options) _vss -> {-# LINE 233 "src-ag/LOAG/Order.ag" #-} if monadic _lhsIoptions then [Sim _vss ] else [PureGroup _vss True] - {-# LINE 3087 "dist/build/LOAG/Order.hs"#-} + {-# LINE 3074 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule302 #-} {-# LINE 235 "src-ag/LOAG/Order.ag" #-} rule302 = \ ((_lhsIdone) :: (Set.Set MyOccurrence, Set.Set FLabel @@ -3092,7 +3079,7 @@ (runST $ getVss _lhsIdone _lhsIps _lhsItdp _synsO _lhsIlfpf _lhsInmprf _lhsIpmpf _lhsIpmprf _lhsIfty _lhsIvisMapf _lhsIruleMap _lhsIhoMapf) - {-# LINE 3096 "dist/build/LOAG/Order.hs"#-} + {-# LINE 3083 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule303 #-} rule303 = \ inhAttr_ inhOccs_ synAttr_ synOccs_ visnr_ -> MySegment visnr_ inhAttr_ synAttr_ inhOccs_ synOccs_ @@ -3197,14 +3184,14 @@ , Set.Set Identifier, Set.Set (FLabel,Int))) -> {-# LINE 220 "src-ag/LOAG/Order.ag" #-} _lhsIdone - {-# LINE 3201 "dist/build/LOAG/Order.hs"#-} + {-# LINE 3188 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule308 #-} {-# LINE 221 "src-ag/LOAG/Order.ag" #-} rule308 = \ ((_hdIdone) :: (Set.Set MyOccurrence, Set.Set FLabel ,Set.Set Identifier, Set.Set (FLabel,Int))) -> {-# LINE 221 "src-ag/LOAG/Order.ag" #-} _hdIdone - {-# LINE 3208 "dist/build/LOAG/Order.hs"#-} + {-# LINE 3195 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule309 #-} rule309 = \ ((_hdIevisits) :: Visit) ((_tlIevisits) :: Visits) -> _hdIevisits : _tlIevisits @@ -3491,43 +3478,43 @@ rule347 = \ ((_prodsIrefNts) :: Set NontermIdent) nt_ -> {-# LINE 16 "src-ag/ExecutionPlanCommon.ag" #-} Map.singleton nt_ _prodsIrefNts - {-# LINE 3495 "dist/build/LOAG/Order.hs"#-} + {-# LINE 3482 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule348 #-} {-# LINE 17 "src-ag/ExecutionPlanCommon.ag" #-} rule348 = \ ((_prodsIrefHoNts) :: Set NontermIdent) nt_ -> {-# LINE 17 "src-ag/ExecutionPlanCommon.ag" #-} Map.singleton nt_ _prodsIrefHoNts - {-# LINE 3501 "dist/build/LOAG/Order.hs"#-} + {-# LINE 3488 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule349 #-} {-# LINE 19 "src-ag/ExecutionPlanCommon.ag" #-} rule349 = \ ((_lhsIclosedNtDeps) :: Map NontermIdent (Set NontermIdent)) nt_ -> {-# LINE 19 "src-ag/ExecutionPlanCommon.ag" #-} Map.findWithDefault Set.empty nt_ _lhsIclosedNtDeps - {-# LINE 3507 "dist/build/LOAG/Order.hs"#-} + {-# LINE 3494 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule350 #-} {-# LINE 20 "src-ag/ExecutionPlanCommon.ag" #-} rule350 = \ ((_lhsIclosedHoNtDeps) :: Map NontermIdent (Set NontermIdent)) nt_ -> {-# LINE 20 "src-ag/ExecutionPlanCommon.ag" #-} Map.findWithDefault Set.empty nt_ _lhsIclosedHoNtDeps - {-# LINE 3513 "dist/build/LOAG/Order.hs"#-} + {-# LINE 3500 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule351 #-} {-# LINE 21 "src-ag/ExecutionPlanCommon.ag" #-} rule351 = \ ((_lhsIclosedHoNtRevDeps) :: Map NontermIdent (Set NontermIdent)) nt_ -> {-# LINE 21 "src-ag/ExecutionPlanCommon.ag" #-} Map.findWithDefault Set.empty nt_ _lhsIclosedHoNtRevDeps - {-# LINE 3519 "dist/build/LOAG/Order.hs"#-} + {-# LINE 3506 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule352 #-} {-# LINE 23 "src-ag/ExecutionPlanCommon.ag" #-} rule352 = \ _closedNtDeps nt_ -> {-# LINE 23 "src-ag/ExecutionPlanCommon.ag" #-} nt_ `Set.member` _closedNtDeps - {-# LINE 3525 "dist/build/LOAG/Order.hs"#-} + {-# LINE 3512 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule353 #-} {-# LINE 24 "src-ag/ExecutionPlanCommon.ag" #-} rule353 = \ _closedHoNtDeps nt_ -> {-# LINE 24 "src-ag/ExecutionPlanCommon.ag" #-} nt_ `Set.member` _closedHoNtDeps - {-# LINE 3531 "dist/build/LOAG/Order.hs"#-} + {-# LINE 3518 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule354 #-} {-# LINE 25 "src-ag/ExecutionPlanCommon.ag" #-} rule354 = \ _closedHoNtDeps _closedHoNtRevDeps _nontrivAcyc -> @@ -3536,57 +3523,57 @@ , hoNtRevDeps = _closedHoNtRevDeps , hoAcyclic = _nontrivAcyc } - {-# LINE 3540 "dist/build/LOAG/Order.hs"#-} + {-# LINE 3527 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule355 #-} {-# LINE 54 "src-ag/ExecutionPlanCommon.ag" #-} rule355 = \ ((_lhsIclassContexts) :: ContextMap) nt_ -> {-# LINE 54 "src-ag/ExecutionPlanCommon.ag" #-} Map.findWithDefault [] nt_ _lhsIclassContexts - {-# LINE 3546 "dist/build/LOAG/Order.hs"#-} + {-# LINE 3533 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule356 #-} {-# LINE 88 "src-ag/ExecutionPlanCommon.ag" #-} rule356 = \ ((_lhsIaroundMap) :: Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))) nt_ -> {-# LINE 88 "src-ag/ExecutionPlanCommon.ag" #-} Map.findWithDefault Map.empty nt_ _lhsIaroundMap - {-# LINE 3552 "dist/build/LOAG/Order.hs"#-} + {-# LINE 3539 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule357 #-} {-# LINE 113 "src-ag/ExecutionPlanCommon.ag" #-} rule357 = \ ((_lhsImergeMap) :: Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier, [Identifier], Expression)))) nt_ -> {-# LINE 113 "src-ag/ExecutionPlanCommon.ag" #-} Map.findWithDefault Map.empty nt_ _lhsImergeMap - {-# LINE 3558 "dist/build/LOAG/Order.hs"#-} + {-# LINE 3545 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule358 #-} {-# LINE 149 "src-ag/ExecutionPlanCommon.ag" #-} rule358 = \ inh_ nt_ -> {-# LINE 149 "src-ag/ExecutionPlanCommon.ag" #-} Map.singleton nt_ inh_ - {-# LINE 3564 "dist/build/LOAG/Order.hs"#-} + {-# LINE 3551 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule359 #-} {-# LINE 150 "src-ag/ExecutionPlanCommon.ag" #-} rule359 = \ nt_ syn_ -> {-# LINE 150 "src-ag/ExecutionPlanCommon.ag" #-} Map.singleton nt_ syn_ - {-# LINE 3570 "dist/build/LOAG/Order.hs"#-} + {-# LINE 3557 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule360 #-} {-# LINE 159 "src-ag/ExecutionPlanCommon.ag" #-} rule360 = \ ((_prodsIlocalSigMap) :: Map.Map ConstructorIdent (Map.Map Identifier Type)) nt_ -> {-# LINE 159 "src-ag/ExecutionPlanCommon.ag" #-} Map.singleton nt_ _prodsIlocalSigMap - {-# LINE 3576 "dist/build/LOAG/Order.hs"#-} + {-# LINE 3563 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule361 #-} {-# LINE 65 "src-ag/LOAG/Prepare.ag" #-} rule361 = \ inh_ nt_ -> {-# LINE 65 "src-ag/LOAG/Prepare.ag" #-} let dty = TyData (getName nt_) in Map.singleton dty (toMyAttr Inh dty inh_) - {-# LINE 3583 "dist/build/LOAG/Order.hs"#-} + {-# LINE 3570 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule362 #-} {-# LINE 67 "src-ag/LOAG/Prepare.ag" #-} rule362 = \ nt_ syn_ -> {-# LINE 67 "src-ag/LOAG/Prepare.ag" #-} let dty = TyData (getName nt_) in Map.singleton dty (toMyAttr Syn dty syn_) - {-# LINE 3590 "dist/build/LOAG/Order.hs"#-} + {-# LINE 3577 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule363 #-} {-# LINE 69 "src-ag/LOAG/Prepare.ag" #-} rule363 = \ ((_lhsIaugM) :: Map.Map Identifier (Map.Map Identifier (Set.Set Dependency))) nt_ -> @@ -3594,51 +3581,51 @@ case Map.lookup nt_ _lhsIaugM of Nothing -> Map.empty Just a -> a - {-# LINE 3598 "dist/build/LOAG/Order.hs"#-} + {-# LINE 3585 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule364 #-} {-# LINE 131 "src-ag/LOAG/Prepare.ag" #-} rule364 = \ nt_ -> {-# LINE 131 "src-ag/LOAG/Prepare.ag" #-} TyData (getName nt_) - {-# LINE 3604 "dist/build/LOAG/Order.hs"#-} + {-# LINE 3591 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule365 #-} {-# LINE 82 "src-ag/LOAG/Order.ag" #-} rule365 = \ ((_prodsIfdps) :: Map.Map ConstructorIdent (Set Dependency)) nt_ -> {-# LINE 82 "src-ag/LOAG/Order.ag" #-} Map.singleton nt_ _prodsIfdps - {-# LINE 3610 "dist/build/LOAG/Order.hs"#-} + {-# LINE 3597 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule366 #-} {-# LINE 138 "src-ag/LOAG/Order.ag" #-} rule366 = \ ((_lhsIvisitnum) :: Int) -> {-# LINE 138 "src-ag/LOAG/Order.ag" #-} _lhsIvisitnum - {-# LINE 3616 "dist/build/LOAG/Order.hs"#-} + {-# LINE 3603 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule367 #-} {-# LINE 139 "src-ag/LOAG/Order.ag" #-} rule367 = \ _initial _segments -> {-# LINE 139 "src-ag/LOAG/Order.ag" #-} zipWith const [_initial ..] _segments - {-# LINE 3622 "dist/build/LOAG/Order.hs"#-} + {-# LINE 3609 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule368 #-} {-# LINE 140 "src-ag/LOAG/Order.ag" #-} rule368 = \ _vnums -> {-# LINE 140 "src-ag/LOAG/Order.ag" #-} _vnums - {-# LINE 3628 "dist/build/LOAG/Order.hs"#-} + {-# LINE 3615 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule369 #-} {-# LINE 141 "src-ag/LOAG/Order.ag" #-} rule369 = \ _initial _vnums -> {-# LINE 141 "src-ag/LOAG/Order.ag" #-} Map.fromList $ (_initial + length _vnums, NoneVis) : [(v, OneVis v) | v <- _vnums ] - {-# LINE 3635 "dist/build/LOAG/Order.hs"#-} + {-# LINE 3622 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule370 #-} {-# LINE 143 "src-ag/LOAG/Order.ag" #-} rule370 = \ _initial _vnums -> {-# LINE 143 "src-ag/LOAG/Order.ag" #-} Map.fromList $ (_initial , NoneVis) : [(v+1, OneVis v) | v <- _vnums ] - {-# LINE 3642 "dist/build/LOAG/Order.hs"#-} + {-# LINE 3629 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule371 #-} {-# LINE 145 "src-ag/LOAG/Order.ag" #-} rule371 = \ _initial _mysegments -> @@ -3646,7 +3633,7 @@ let op vnr (MySegment visnr ins syns _ _) = IMap.fromList $ zip syns (repeat vnr) in IMap.unions $ zipWith op [_initial ..] _mysegments - {-# LINE 3650 "dist/build/LOAG/Order.hs"#-} + {-# LINE 3637 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule372 #-} {-# LINE 148 "src-ag/LOAG/Order.ag" #-} rule372 = \ _classContexts _hoInfo _initial _initialVisit _nextVis _prevVis ((_prodsIeprods) :: EProductions) _recursive nt_ params_ -> @@ -3662,14 +3649,14 @@ _prodsIeprods _recursive _hoInfo ] - {-# LINE 3666 "dist/build/LOAG/Order.hs"#-} + {-# LINE 3653 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule373 #-} {-# LINE 322 "src-ag/LOAG/Order.ag" #-} rule373 = \ ((_lhsIsched) :: InterfaceRes) nt_ -> {-# LINE 322 "src-ag/LOAG/Order.ag" #-} findWithErr _lhsIsched "could not const. interfaces" (getName nt_) - {-# LINE 3673 "dist/build/LOAG/Order.hs"#-} + {-# LINE 3660 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule374 #-} {-# LINE 324 "src-ag/LOAG/Order.ag" #-} rule374 = \ _assigned ((_lhsIsched) :: InterfaceRes) -> @@ -3678,7 +3665,7 @@ then 0 else let mx = fst $ IMap.findMax _assigned in if even mx then mx else mx + 1 - {-# LINE 3682 "dist/build/LOAG/Order.hs"#-} + {-# LINE 3669 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule375 #-} {-# LINE 329 "src-ag/LOAG/Order.ag" #-} rule375 = \ _assigned _mx -> @@ -3688,7 +3675,7 @@ (maybe [] id $ IMap.lookup (i-1) _assigned ) Nothing Nothing) [_mx ,_mx -2 .. 2] - {-# LINE 3692 "dist/build/LOAG/Order.hs"#-} + {-# LINE 3679 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule376 #-} {-# LINE 335 "src-ag/LOAG/Order.ag" #-} rule376 = \ ((_lhsInmp) :: NMP) _mysegments -> @@ -3697,7 +3684,7 @@ CSegment (Map.unions $ map (vertexToAttr _lhsInmp) is) (Map.unions $ map (vertexToAttr _lhsInmp) ss)) _mysegments - {-# LINE 3701 "dist/build/LOAG/Order.hs"#-} + {-# LINE 3688 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule377 #-} rule377 = \ ((_prodsIads) :: [Edge]) -> _prodsIads @@ -4557,7 +4544,7 @@ let isLocal = (field_ == _LOC || field_ == _INST) in [(getName field_, (getName attr_, dlhs field_), isLocal)] ++ _patIafs - {-# LINE 4561 "dist/build/LOAG/Order.hs"#-} + {-# LINE 4548 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule552 #-} rule552 = \ ((_patIcopy) :: Pattern) attr_ field_ -> Alias field_ attr_ _patIcopy @@ -4892,31 +4879,31 @@ rule576 = \ ((_lhsIaroundMap) :: Map ConstructorIdent (Map Identifier [Expression])) con_ -> {-# LINE 89 "src-ag/ExecutionPlanCommon.ag" #-} Map.findWithDefault Map.empty con_ _lhsIaroundMap - {-# LINE 4896 "dist/build/LOAG/Order.hs"#-} + {-# LINE 4883 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule577 #-} {-# LINE 114 "src-ag/ExecutionPlanCommon.ag" #-} rule577 = \ ((_lhsImergeMap) :: Map ConstructorIdent (Map Identifier (Identifier, [Identifier], Expression))) con_ -> {-# LINE 114 "src-ag/ExecutionPlanCommon.ag" #-} Map.findWithDefault Map.empty con_ _lhsImergeMap - {-# LINE 4902 "dist/build/LOAG/Order.hs"#-} + {-# LINE 4889 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule578 #-} {-# LINE 120 "src-ag/ExecutionPlanCommon.ag" #-} rule578 = \ _mergeMap -> {-# LINE 120 "src-ag/ExecutionPlanCommon.ag" #-} Set.unions [ Set.fromList ms | (_,ms,_) <- Map.elems _mergeMap ] - {-# LINE 4908 "dist/build/LOAG/Order.hs"#-} + {-# LINE 4895 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule579 #-} {-# LINE 160 "src-ag/ExecutionPlanCommon.ag" #-} rule579 = \ ((_typeSigsIlocalSigMap) :: Map Identifier Type) con_ -> {-# LINE 160 "src-ag/ExecutionPlanCommon.ag" #-} Map.singleton con_ _typeSigsIlocalSigMap - {-# LINE 4914 "dist/build/LOAG/Order.hs"#-} + {-# LINE 4901 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule580 #-} {-# LINE 115 "src-ag/LOAG/Prepare.ag" #-} rule580 = \ ((_lhsIdty) :: MyType) con_ -> {-# LINE 115 "src-ag/LOAG/Prepare.ag" #-} (_lhsIdty,getName con_) - {-# LINE 4920 "dist/build/LOAG/Order.hs"#-} + {-# LINE 4907 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule581 #-} {-# LINE 117 "src-ag/LOAG/Prepare.ag" #-} rule581 = \ ((_childrenIpmpr) :: PMP_R) ((_lhsIaugM) :: Map.Map Identifier (Set.Set Dependency)) _pll con_ -> @@ -4924,37 +4911,37 @@ case Map.lookup con_ _lhsIaugM of Nothing -> [] Just a -> Set.toList $ Set.map (depToEdge _childrenIpmpr _pll ) a - {-# LINE 4928 "dist/build/LOAG/Order.hs"#-} + {-# LINE 4915 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule582 #-} {-# LINE 120 "src-ag/LOAG/Prepare.ag" #-} rule582 = \ ((_lhsIdty) :: MyType) -> {-# LINE 120 "src-ag/LOAG/Prepare.ag" #-} _lhsIdty - {-# LINE 4934 "dist/build/LOAG/Order.hs"#-} + {-# LINE 4921 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule583 #-} {-# LINE 214 "src-ag/LOAG/Prepare.ag" #-} rule583 = \ ((_lhsIdty) :: MyType) con_ -> {-# LINE 214 "src-ag/LOAG/Prepare.ag" #-} (_lhsIdty,getName con_) - {-# LINE 4940 "dist/build/LOAG/Order.hs"#-} + {-# LINE 4927 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule584 #-} {-# LINE 215 "src-ag/LOAG/Prepare.ag" #-} rule584 = \ _pll -> {-# LINE 215 "src-ag/LOAG/Prepare.ag" #-} _pll - {-# LINE 4946 "dist/build/LOAG/Order.hs"#-} + {-# LINE 4933 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule585 #-} {-# LINE 216 "src-ag/LOAG/Prepare.ag" #-} rule585 = \ ((_childrenIpts) :: Set.Set FLabel) -> {-# LINE 216 "src-ag/LOAG/Prepare.ag" #-} _childrenIpts - {-# LINE 4952 "dist/build/LOAG/Order.hs"#-} + {-# LINE 4939 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule586 #-} {-# LINE 217 "src-ag/LOAG/Prepare.ag" #-} rule586 = \ ((_childrenIfieldMap) :: FMap) _pll -> {-# LINE 217 "src-ag/LOAG/Prepare.ag" #-} Map.singleton _pll $ Map.keys _childrenIfieldMap - {-# LINE 4958 "dist/build/LOAG/Order.hs"#-} + {-# LINE 4945 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule587 #-} {-# LINE 89 "src-ag/LOAG/Order.ag" #-} rule587 = \ ((_lhsIdty) :: MyType) ((_lhsIpmpf) :: PMP) ((_lhsIres_ads) :: [Edge]) con_ -> @@ -4965,19 +4952,19 @@ | otherwise = ds in Map.singleton con_ $ foldr op Set.empty _lhsIres_ads - {-# LINE 4969 "dist/build/LOAG/Order.hs"#-} + {-# LINE 4956 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule588 #-} {-# LINE 167 "src-ag/LOAG/Order.ag" #-} rule588 = \ ((_rulesIruleMap) :: Map.Map MyOccurrence Identifier) -> {-# LINE 167 "src-ag/LOAG/Order.ag" #-} _rulesIruleMap - {-# LINE 4975 "dist/build/LOAG/Order.hs"#-} + {-# LINE 4962 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule589 #-} {-# LINE 168 "src-ag/LOAG/Order.ag" #-} rule589 = \ (_ :: ()) -> {-# LINE 168 "src-ag/LOAG/Order.ag" #-} (Set.empty, Set.empty, Set.empty, Set.empty) - {-# LINE 4981 "dist/build/LOAG/Order.hs"#-} + {-# LINE 4968 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule590 #-} {-# LINE 169 "src-ag/LOAG/Order.ag" #-} rule590 = \ ((_childrenIself) :: Children) -> @@ -4986,7 +4973,7 @@ | kind == ChildAttr = Nothing | otherwise = Just $ ChildIntro nm in catMaybes $ map intro _childrenIself - {-# LINE 4990 "dist/build/LOAG/Order.hs"#-} + {-# LINE 4977 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule591 #-} {-# LINE 174 "src-ag/LOAG/Order.ag" #-} rule591 = \ ((_childrenIechilds) :: EChildren) _intros ((_rulesIerules) :: ERules) ((_segsIevisits) :: Visits) con_ constraints_ params_ -> @@ -5003,7 +4990,7 @@ _rulesIerules _childrenIechilds visits ] - {-# LINE 5007 "dist/build/LOAG/Order.hs"#-} + {-# LINE 4994 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule592 #-} {-# LINE 346 "src-ag/LOAG/Order.ag" #-} rule592 = \ ((_lhsImysegments) :: MySegments) ((_lhsInmp) :: NMP) ((_lhsIpmprf) :: PMP_R) _ps -> @@ -5017,7 +5004,7 @@ handAllOut (_ps ,"lhs") $ map (_lhsInmp Map.!) syns) ) _lhsImysegments - {-# LINE 5021 "dist/build/LOAG/Order.hs"#-} + {-# LINE 5008 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule593 #-} rule593 = \ ((_childrenIap) :: A_P) -> _childrenIap @@ -5337,13 +5324,13 @@ rule649 = \ ((_lhsIvisitnum) :: Int) -> {-# LINE 192 "src-ag/LOAG/Order.ag" #-} _lhsIvisitnum - {-# LINE 5341 "dist/build/LOAG/Order.hs"#-} + {-# LINE 5328 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule650 #-} {-# LINE 193 "src-ag/LOAG/Order.ag" #-} rule650 = \ ((_hdIvisitnum) :: Int) -> {-# LINE 193 "src-ag/LOAG/Order.ag" #-} _hdIvisitnum - {-# LINE 5347 "dist/build/LOAG/Order.hs"#-} + {-# LINE 5334 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule651 #-} rule651 = \ ((_hdIads) :: [Edge]) ((_tlIads) :: [Edge]) -> ((++) _hdIads _tlIads) @@ -5785,31 +5772,31 @@ explicit_ pure_ mbError_ - {-# LINE 5789 "dist/build/LOAG/Order.hs"#-} + {-# LINE 5776 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule752 #-} {-# LINE 12 "src-ag/ExecutionPlanPre.ag" #-} rule752 = \ ((_lhsIrulenumber) :: Int) -> {-# LINE 12 "src-ag/ExecutionPlanPre.ag" #-} _lhsIrulenumber + 1 - {-# LINE 5795 "dist/build/LOAG/Order.hs"#-} + {-# LINE 5782 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule753 #-} {-# LINE 13 "src-ag/ExecutionPlanPre.ag" #-} rule753 = \ ((_lhsIrulenumber) :: Int) mbName_ -> {-# LINE 13 "src-ag/ExecutionPlanPre.ag" #-} maybe (identifier $ "rule" ++ show _lhsIrulenumber) id mbName_ - {-# LINE 5801 "dist/build/LOAG/Order.hs"#-} + {-# LINE 5788 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule754 #-} {-# LINE 230 "src-ag/LOAG/Prepare.ag" #-} rule754 = \ ((_rhsIused) :: Set.Set MyOccurrence) -> {-# LINE 230 "src-ag/LOAG/Prepare.ag" #-} Set.filter (\(MyOccurrence (_,f) _) -> f == "loc") _rhsIused - {-# LINE 5807 "dist/build/LOAG/Order.hs"#-} + {-# LINE 5794 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule755 #-} {-# LINE 231 "src-ag/LOAG/Prepare.ag" #-} rule755 = \ _usedLocals -> {-# LINE 231 "src-ag/LOAG/Prepare.ag" #-} not $ Set.null _usedLocals - {-# LINE 5813 "dist/build/LOAG/Order.hs"#-} + {-# LINE 5800 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule756 #-} {-# LINE 233 "src-ag/LOAG/Prepare.ag" #-} rule756 = \ ((_lhsIlfpf) :: SF_P) ((_lhsIpll) :: PLabel) ((_patternIafs) :: [(FLabel, ALabel, Bool)]) ((_rhsIused) :: Set.Set MyOccurrence) _rulename _usedLocals _usesLocals -> @@ -5833,7 +5820,7 @@ (Set.singleton att) m) lr _rhsIused) else (sfpins,rm,l,lr)) (Map.empty,Map.empty,Map.empty,Map.empty) _patternIafs - {-# LINE 5837 "dist/build/LOAG/Order.hs"#-} + {-# LINE 5824 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule757 #-} rule757 = \ ((_rhsIused) :: Set.Set MyOccurrence) -> _rhsIused @@ -6159,7 +6146,7 @@ rule795 = \ name_ tp_ -> {-# LINE 161 "src-ag/ExecutionPlanCommon.ag" #-} Map.singleton name_ tp_ - {-# LINE 6163 "dist/build/LOAG/Order.hs"#-} + {-# LINE 6150 "dist/build/LOAG/Order.hs"#-} {-# INLINE rule796 #-} rule796 = \ name_ tp_ -> TypeSig name_ tp_ diff --git a/src-generated/LOAG/Rep.hs b/src-generated/LOAG/Rep.hs --- a/src-generated/LOAG/Rep.hs +++ b/src-generated/LOAG/Rep.hs @@ -1,6 +1,6 @@ --- UUAGC 0.9.51.1 (src-ag/LOAG/Rep.ag) +-- UUAGC 0.9.51 (src-ag/LOAG/Rep.ag) module LOAG.Rep where import CommonTypes diff --git a/src-generated/Macro.hs b/src-generated/Macro.hs --- a/src-generated/Macro.hs +++ b/src-generated/Macro.hs @@ -1,6 +1,6 @@ --- UUAGC 0.9.51.1 (src-ag/Macro.ag) +-- UUAGC 0.9.51 (src-ag/Macro.ag) module Macro where {-# LINE 4 "src-ag/Macro.ag" #-} diff --git a/src-generated/Patterns.hs b/src-generated/Patterns.hs --- a/src-generated/Patterns.hs +++ b/src-generated/Patterns.hs @@ -1,6 +1,6 @@ --- UUAGC 0.9.51.1 (src-ag/Patterns.ag) +-- UUAGC 0.9.51 (src-ag/Patterns.ag) module Patterns where {-# LINE 2 "src-ag/Patterns.ag" #-} diff --git a/src-generated/Transform.hs b/src-generated/Transform.hs --- a/src-generated/Transform.hs +++ b/src-generated/Transform.hs @@ -866,57 +866,57 @@ {-# LINE 328 "src-ag/Transform.ag" #-} rule33 = \ _allRulesErrs -> {-# LINE 328 "src-ag/Transform.ag" #-} - let f m s = Map.fold ((><) . snd) s m - in Map.fold f Seq.empty _allRulesErrs + let f m s = Map.foldr ((><) . snd) s m + in Map.foldr f Seq.empty _allRulesErrs {-# LINE 872 "dist/build/Transform.hs"#-} {-# INLINE rule34 #-} {-# LINE 331 "src-ag/Transform.ag" #-} rule34 = \ _allSigsErrs -> {-# LINE 331 "src-ag/Transform.ag" #-} - let f m s = Map.fold ((><) . snd) s m - in Map.fold f Seq.empty _allSigsErrs + let f m s = Map.foldr ((><) . snd) s m + in Map.foldr f Seq.empty _allSigsErrs {-# LINE 879 "dist/build/Transform.hs"#-} {-# INLINE rule35 #-} {-# LINE 334 "src-ag/Transform.ag" #-} rule35 = \ _allInstsErrs -> {-# LINE 334 "src-ag/Transform.ag" #-} - let f m s = Map.fold ((><) . snd) s m - in Map.fold f Seq.empty _allInstsErrs + let f m s = Map.foldr ((><) . snd) s m + in Map.foldr f Seq.empty _allInstsErrs {-# LINE 886 "dist/build/Transform.hs"#-} {-# INLINE rule36 #-} {-# LINE 337 "src-ag/Transform.ag" #-} rule36 = \ _allUniquesErrs -> {-# LINE 337 "src-ag/Transform.ag" #-} - let f m s = Map.fold ((><) . snd) s m - in Map.fold f Seq.empty _allUniquesErrs + let f m s = Map.foldr ((><) . snd) s m + in Map.foldr f Seq.empty _allUniquesErrs {-# LINE 893 "dist/build/Transform.hs"#-} {-# INLINE rule37 #-} {-# LINE 340 "src-ag/Transform.ag" #-} rule37 = \ _allAugmentErrs -> {-# LINE 340 "src-ag/Transform.ag" #-} - let f m s = Map.fold ((><) . snd) s m - in Map.fold f Seq.empty _allAugmentErrs + let f m s = Map.foldr ((><) . snd) s m + in Map.foldr f Seq.empty _allAugmentErrs {-# LINE 900 "dist/build/Transform.hs"#-} {-# INLINE rule38 #-} {-# LINE 343 "src-ag/Transform.ag" #-} rule38 = \ _allAroundsErrs -> {-# LINE 343 "src-ag/Transform.ag" #-} - let f m s = Map.fold ((><) . snd) s m - in Map.fold f Seq.empty _allAroundsErrs + let f m s = Map.foldr ((><) . snd) s m + in Map.foldr f Seq.empty _allAroundsErrs {-# LINE 907 "dist/build/Transform.hs"#-} {-# INLINE rule39 #-} {-# LINE 346 "src-ag/Transform.ag" #-} rule39 = \ _allNamesErrs -> {-# LINE 346 "src-ag/Transform.ag" #-} - let f m s = Map.fold ((><)) s m - in Map.fold f Seq.empty _allNamesErrs + let f m s = Map.foldr ((><)) s m + in Map.foldr f Seq.empty _allNamesErrs {-# LINE 914 "dist/build/Transform.hs"#-} {-# INLINE rule40 #-} {-# LINE 349 "src-ag/Transform.ag" #-} rule40 = \ _allMergesErrs -> {-# LINE 349 "src-ag/Transform.ag" #-} - let f m s = Map.fold ((><) . snd) s m - in Map.fold f Seq.empty _allMergesErrs + let f m s = Map.foldr ((><) . snd) s m + in Map.foldr f Seq.empty _allMergesErrs {-# LINE 921 "dist/build/Transform.hs"#-} {-# INLINE rule41 #-} {-# LINE 352 "src-ag/Transform.ag" #-} diff --git a/src-generated/VisagePatterns.hs b/src-generated/VisagePatterns.hs --- a/src-generated/VisagePatterns.hs +++ b/src-generated/VisagePatterns.hs @@ -1,6 +1,6 @@ --- UUAGC 0.9.51.1 (src-ag/VisagePatterns.ag) +-- UUAGC 0.9.51 (src-ag/VisagePatterns.ag) module VisagePatterns where {-# LINE 2 "src-ag/VisagePatterns.ag" #-} diff --git a/src-generated/VisageSyntax.hs b/src-generated/VisageSyntax.hs --- a/src-generated/VisageSyntax.hs +++ b/src-generated/VisageSyntax.hs @@ -1,6 +1,6 @@ --- UUAGC 0.9.51.1 (src-ag/VisageSyntax.ag) +-- UUAGC 0.9.51 (src-ag/VisageSyntax.ag) module VisageSyntax where {-# LINE 2 "src-ag/VisageSyntax.ag" #-} diff --git a/src/ATermWrite.hs b/src/ATermWrite.hs --- a/src/ATermWrite.hs +++ b/src/ATermWrite.hs @@ -6,7 +6,7 @@ writeATerm :: ATerm -> String writeATerm t = writeAT 0 t -writeAT :: Int -> ATerm -> String +writeAT :: Int -> ATerm -> String writeAT n (AAppl c ts) = (if (n > 0) then "\n" else "") ++ replicate n ' ' ++ writeATermAux c (map (writeAT (n+2)) ts) @@ -15,14 +15,14 @@ writeAT _ (AString s) = quote s writeATermAux :: [Char] -> [[Char]] -> [Char] -writeATermAux c [] = c++(parenthesise "") -writeATermAux c ts = c++(parenthesise (commaSep ts)) +writeATermAux c [] = c++(parenthesise "") +writeATermAux c ts = c++(parenthesise (commaSep ts)) commaSep :: [[Char]] -> [Char] -commaSep strs = concat (intersperse "," strs) +commaSep strs = concat (intersperse "," strs) bracket :: [Char] -> [Char] -bracket str = "["++str++"]" +bracket str = "["++str++"]" parenthesise :: [Char] -> [Char] -parenthesise str = "("++str++")" +parenthesise str = "("++str++")" quote :: [Char] -> [Char] -quote str = "\""++str++"\"" +quote str = "\""++str++"\"" diff --git a/src/KennedyWarren.hs b/src/KennedyWarren.hs --- a/src/KennedyWarren.hs +++ b/src/KennedyWarren.hs @@ -20,6 +20,7 @@ import qualified Data.Set as Set import Data.Map (Map) import qualified Data.Map as Map +import qualified Data.Map.Strict as MapStrict import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap import Data.IntSet (IntSet) @@ -161,11 +162,11 @@ -- | Pretty print a vertex in GraphViz format toGVVertex :: Bool -> Vertex -> ST s PP_Doc toGVVertex l (VAttr t a b) = return $ (text $ "attr_" ++ show t ++ "_" ++ show a ++ "_" ++ show b) >#< if l - then text ("[shape=box,label=\"" ++ show t ++ " @" ++ show a ++ "." ++ show b ++ "\"]") else empty + then text ("[shape=box,label=\"" ++ show t ++ " @" ++ show a ++ "." ++ show b ++ "\"]") else empty toGVVertex l (VChild c) = return $ (text $ "child_" ++ show c) >#< if l - then text ("[shape=ellipse,label=\"Child " ++ show c ++ "\"]") else empty + then text ("[shape=ellipse,label=\"Child " ++ show c ++ "\"]") else empty toGVVertex l (VRule r) = return $ (text $ "rule_" ++ show r) >#< if l - then text ("[shape=diamond,label=\"" ++ show r ++ "\"]") else empty + then text ("[shape=diamond,label=\"" ++ show r ++ "\"]") else empty -- | Pretty print an edge in GraphViz format toGVEdge :: Edge -> ST s PP_Doc @@ -400,7 +401,7 @@ let (VGNode from,vgto) = imLookup vs edges -- from must be equal to the current state childvs <- gets vgChildVisits let rchildv = imLookup edg childvs - vgInST $ modifySTRef rchildv $ Map.insertWith' (++) (ide,p) [vgto] + vgInST $ modifySTRef rchildv $ MapStrict.insertWith (++) (ide,p) [vgto] ndis <- gets vgNDI let rndi = imLookup from ndis ndi <- vgInST $ readSTRef rndi @@ -766,10 +767,10 @@ -- Return execution plan for this production return $ EProduction (pdgProduction $ pdgmOrig prod) (pdgParams $ pdgmOrig prod) - (pdgConstraints $ pdgmOrig prod) + (pdgConstraints $ pdgmOrig prod) (pdgRules $ pdgmOrig prod) (pdgChilds $ pdgmOrig prod) - visits + visits -- Find initial state for this nonterminal VGNode init <- vgFindInitial $ ndiNonterminal $ ndimOrig ndi -- Construct an environment that specifies the next visit of the states that have exactly one diff --git a/src/Knuth1.hs b/src/Knuth1.hs --- a/src/Knuth1.hs +++ b/src/Knuth1.hs @@ -28,8 +28,8 @@ -- Vertices data AttrType = Inh | Syn | Loc deriving (Eq, Ord, Show) data Vertex = VAttr AttrType Identifier Identifier - | VChild Identifier - | VRule Identifier deriving (Eq, Ord) + | VChild Identifier + | VRule Identifier deriving (Eq, Ord) instance Show Vertex where show (VAttr ty ch at) = show ty ++ " @" ++ show ch ++ "." ++ show at @@ -39,7 +39,7 @@ -- | Check if a vertex is an attribute isVertexAttr :: Vertex -> Bool isVertexAttr (VAttr _ _ _) = True -isVertexAttr _ = False +isVertexAttr _ = False -- | Get the child name of an attribute getAttrChildName :: Vertex -> Identifier diff --git a/src/Pretty.hs b/src/Pretty.hs --- a/src/Pretty.hs +++ b/src/Pretty.hs @@ -34,10 +34,10 @@ data Doc = Emp | Emp1 - | Str !String -- basic string - | Hor Doc !Doc -- horizontal positioning - | Ver Doc !Doc -- vertical positioning - | Ind !Int Doc -- indent + | Str !String -- basic string + | Hor Doc !Doc -- horizontal positioning + | Ver Doc !Doc -- vertical positioning + | Ind !Int Doc -- indent | Line (Int -> Doc) -- line nr type PP_Doc = Doc diff --git a/uuagc.cabal b/uuagc.cabal --- a/uuagc.cabal +++ b/uuagc.cabal @@ -1,7 +1,7 @@ cabal-version: >= 1.8 build-type: Custom name: uuagc -version: 0.9.52.1 +version: 0.9.52.2 license: BSD3 license-file: LICENSE maintainer: Jeroen Bransen @@ -38,7 +38,7 @@ build-depends: uuagc-cabal >= 1.0.2.0 build-depends: base >= 4, base < 5 -- Self dependency, depend on library below - build-depends: uuagc == 0.9.52.1 + build-depends: uuagc main-is: Main.hs hs-source-dirs: src-main