uuagc-0.9.50: src-ag/Transform.ag
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 "<unknown>") 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 <NT> = [ <TP> ]
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 <NT> = [ <TP> ]
is translated into:
DATA <NT> | Cons hd:<TP> tl:<NT>
| 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 }
"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 }
"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 <nt> [ | | 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