uuagc-0.9.54: src-ag/Desugar.ag
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 "<ANY>" (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 "<ANY>" (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