Prepare.ag

INCLUDE "AbstractSyntax.ag"
INCLUDE "Patterns.ag"
INCLUDE "CodeSyntax.ag"
INCLUDE "Expression.ag"
INCLUDE "HsToken.ag"
INCLUDE "LOAG/Rep"
INCLUDE "ExecutionPlanPre"

MODULE {LOAG.Prepare}
{}
{}

{
-- | Translating UUAGC types to MyTypes
drhs f | f == _LHS               = Inh
       | f == _LOC               = AnyDir
       | f == _INST              = AnyDir
       | otherwise               = Syn
dlhs f | f == _LHS               = Syn
       | f == _LOC               = AnyDir
       | f == _INST              = AnyDir
       | otherwise               = Inh 

depToEdge :: PMP_R -> PLabel -> Dependency -> Edge
depToEdge pmpr p e = 
    (findWithErr pmpr "depToEdge" $ MyOccurrence (p,getName f1) (getName i1, drhs f1),
     findWithErr pmpr "depToEdge" $ MyOccurrence (p,getName f2) (getName i2, dlhs f2))
    where Dependency (OccAttr f1 i1) (OccAttr f2 i2) = e

vertexToAttr :: NMP -> Vertex -> Attributes
vertexToAttr nmp v = Map.singleton (identifier a) (fromMyTy ty)
    where (MyAttribute ty (a,_)) = findWithErr nmp "vertexToAttr" v

}

SEM Grammar | Grammar
    inst.smf : LOAGRep 
    loc.initO= if Map.null @nonts.pmp then 1 else fst $ Map.findMin @nonts.pmp
    inst.smf = 
        LOAGRep @nonts.ps @nonts.ap @loc.an 
           @loc.ain @loc.asn @loc.sfp
           @nonts.pmp @nonts.pmpr @loc.nmp @loc.nmpr
           (A.array (@loc.initO, @loc.initO + Map.size @nonts.gen)  $ 
                Map.toList $ @nonts.gen)
           (A.array (1,Map.size @nonts.inss) $ 
                Map.toList $ @nonts.inss)
           (A.array (@loc.initO, @loc.initO + length @nonts.ofld) $ 
                @nonts.ofld) @nonts.fty @nonts.fieldMap @nonts.fsInP
    loc.nmp  = Map.fromList $ zip [1..] @loc.atts
    loc.nmpr = Map.fromList $ zip @loc.atts [1..]
    loc.an   = Map.unionWith (++) @loc.ain @loc.asn
    loc.ain  = @nonts.inhs
    loc.asn  = @nonts.syns
    loc.atts = concat $ Map.elems @loc.an
    loc.occs = concat $ Map.elems @nonts.ap
    nonts.augM = @manualAttrOrderMap

-- Collecting the attributes 
ATTR Nonterminals Nonterminal [
    augM   : {Map.Map Identifier (Map.Map Identifier (Set.Set Dependency))} ||  
    inhs USE {Map.union} {Map.empty} : AI_N 
    syns USE {Map.union} {Map.empty} : AS_N ]
    
SEM Nonterminal | Nonterminal 
    lhs.inhs = let dty = TyData (getName @nt) 
                in Map.singleton dty (toMyAttr Inh dty @inh)
    lhs.syns = let dty = TyData (getName @nt) 
                in Map.singleton dty (toMyAttr Syn dty @syn)
    prods.augM = case Map.lookup @nt @lhs.augM of
                    Nothing -> Map.empty 
                    Just a  -> a

-- Adding all attribute sets to the AG type 
--   and sending it all down the abstract tree
ATTR Nonterminals Nonterminal Productions Production Children Child 
    MySegments MySegment [
    ain   : {MyType -> MyAttributes} 
    asn   : {MyType -> MyAttributes}
    pmpf  : PMP
    pmprf : PMP_R
    lfpf  : SF_P
    hoMapf: HOMap
    fty   : FTY
    nmp   : NMP || ]

SEM Grammar | Grammar
    nonts.ain  = map2F @loc.ain
    nonts.asn  = map2F @loc.asn
    nonts.pmpf  = @nonts.pmp
    nonts.pmprf = @nonts.pmpr
    nonts.lfpf  = @nonts.lfp
    nonts.hoMapf= @nonts.hoMap
    nonts.ftyf  = @nonts.fty
    nonts.fty   = @nonts.fty

-- Make sure TDP AND LFPRF are passed around correctly to code-generation
ATTR Nonterminals Nonterminal Productions Production [
    ftyf: FTY ||]


-- Calculate the set of production labels
SEM Grammar | Grammar 
     loc.ps = @nonts.ps
ATTR Nonterminals Nonterminal Productions Production [ || 
    ads USE {(++)} {[]}   : {[Edge]}
    fieldMap USE {(Map.union)} {Map.empty} : FMap
    hoMap    USE {(Map.union)} {Map.empty} : HOMap
    fsInP USE {(Map.union)} {Map.empty} : FsInP]

SEM Nonterminals Nonterminal [ ||
    ps  USE {(++)} {([])} : {[PLabel]} ]
SEM Productions [ ||
    ps  USE {:} {([])} : {[PLabel]}  ]
SEM Production [ || ps : PLabel ] | Production 
    loc.ps = (@lhs.dty,getName @con)
    lhs.ads   = 
        case Map.lookup @con @lhs.augM of
         Nothing -> []
         Just a  -> Set.toList $ Set.map (depToEdge @children.pmpr @loc.pll) a
    children.dty = @lhs.dty

ATTR Productions Production [
   augM : {Map.Map Identifier (Set.Set Dependency)} || ]
-- We didnt calculate A_P yet, inheriting A_N we can
ATTR Productions Production Rules Rule [ 
    -- result type of this constructor 
    dty : {MyType} || ]
ATTR Rules Rule Children Child Expression HsTokensRoot HsTokens HsToken [
    pll : {PLabel} || ]
SEM Nonterminal | Nonterminal    
    loc.dty  = TyData (getName @nt)

ATTR Nonterminals Nonterminal Productions Production Children Child 
     FieldAtts FieldAtt [
    an      : {MyType -> MyAttributes} 
    nmprf   : NMP_R|
    olab    : Int --  chained attribute for handing out labels to occurrences
    flab    : Int  |--chained attribute for handing out labels to fields
    ap   USE {Map.unionWith (++)} {Map.empty}   : A_P
    gen  USE {Map.union}          {Map.empty}   : {Map Int Int}
    inss USE {Map.unionWith (++)} {Map.empty}   : {Map Int [Int]}
    pmp  USE {Map.union}          {Map.empty}   : PMP
    pmpr USE {Map.union}          {Map.empty}   : PMP_R
    -- maps for each occurrence to which field it belongs
    ofld USE {(++)}             {[]}        : {[(Int, Int)]}
    fty  USE {Map.union}          {Map.empty}   : FTY
    ]

SEM Grammar | Grammar 
    nonts.an = map2F @loc.an
    nonts.nmprf= @loc.nmpr
    nonts.olab = if Map.null @loc.nmp then 0 else (fst $ Map.findMax @loc.nmp)
    nonts.flab = 0

ATTR Children Child [||
    fieldMap USE {Map.union} {Map.empty} : FMap
    hoMap    USE {Map.unionWith (Set.union)} {Map.empty} : HOMap
    ]
SEM Children [ dty : {MyType} || ]
    | Nil 
    loc.flab    = @lhs.flab + 1
    loc.atp     = fst @lhs.pll
    inst.fatts  : FieldAtts
    inst.fatts  = map ((FieldAtt @loc.atp @lhs.pll "lhs") . alab) $ 
                        @lhs.an @loc.atp
    fatts.flab  = @loc.flab
    loc.label   = (@lhs.pll, "lhs")
    loc.foccsI  = Set.fromList $ handAllOut @loc.label $ @lhs.ain @loc.atp
    loc.foccsS  = Set.fromList $ handAllOut @loc.label $ @lhs.asn @loc.atp
    loc.fieldMap= Map.singleton @loc.label (@loc.foccsI, @loc.foccsS)
    lhs.fty     = Map.singleton @loc.label @lhs.dty

SEM Child | Child
    loc.flab    = @lhs.flab + 1
    loc.atp     = toMyTy @tp
    inst.fatts  : FieldAtts
    inst.fatts  = map ((FieldAtt @loc.atp @lhs.pll (getName @name)) . alab)
                        $ @lhs.an @loc.atp
    fatts.flab  = @loc.flab
    loc.ident   = getName @name
    loc.label   = (@lhs.pll, @loc.ident)
    loc.foccsI  = Set.fromList $ handAllOut @loc.label $ @lhs.ain @loc.atp
    loc.foccsS  = Set.fromList $ handAllOut @loc.label $ @lhs.asn @loc.atp
    loc.fieldMap= if Set.null @loc.foccsI && Set.null @loc.foccsS
                        then Map.empty 
                        else Map.singleton @loc.label (@loc.foccsS,@loc.foccsI)
    loc.hoMap   = case @kind of
                    ChildAttr -> Map.singleton @lhs.pll (Set.singleton @loc.ident)
                    _         -> Map.empty
    lhs.fty     = Map.singleton (@lhs.pll, getName @name) @loc.atp

SEM FieldAtt | FieldAtt
    loc.olab    = @lhs.olab + 1
    loc.alab    = findWithErr @lhs.nmprf "getting attr label" @loc.att
    loc.att     = @t <.> @a
    loc.occ     = (@p, @f) >.< @a
    loc.pmp     = Map.singleton @loc.olab @loc.occ
    loc.pmpr    = Map.singleton @loc.occ  @loc.olab
    loc.inss    = Map.singleton @loc.alab [@loc.olab]
    loc.gen     = Map.singleton @loc.olab @loc.alab
    lhs.ap      = Map.singleton @p [@loc.occ]
    lhs.ofld    = [(@loc.olab, @lhs.flab)]

-- calculate representation of semantic function 
-- definitions per non-terminal and from it, calculate E_P
SEM Grammar | Grammar
     loc.sfp = repLocRefs @nonts.lfp $ addHigherOrders @nonts.lfp @nonts.sfp
ATTR Nonterminals Nonterminal Productions Production Rules Rule [ || 
    sfp  USE {Map.unionWith (Set.union)} {Map.empty} : SF_P  -- deps of non-locals
    ruleMap USE {Map.union} {Map.empty} : {Map.Map MyOccurrence Identifier} 
    lfp  USE {Map.unionWith (Set.union)} {Map.empty} : SF_P  -- deps of local attrs
    lfpr USE {Map.unionWith (Set.union)} {Map.empty} : SF_P ]-- reverse 
SEM Production | Production
    loc.pll   = (@lhs.dty,getName @con)
    rules.pll = @pll 
    rules.pts = @children.pts
    lhs.fsInP = Map.singleton @pll $ Map.keys @children.fieldMap

ATTR Children Child [ ||
    pts USE {Set.union} {Set.empty} : {Set.Set FLabel} ]

SEM Child | Child
    lhs.pts = Set.singleton $ getName @name

ATTR Rules Rule [
    lfpf : SF_P ||
    usedLocals USE {(Set.union)} {Set.empty} : {Set.Set MyOccurrence}]

SEM Rule | Rule
    loc.usedLocals = Set.filter (\(MyOccurrence (_,f) _) -> f == "loc") @rhs.used
    loc.usesLocals = not $ Set.null @loc.usedLocals
    (lhs.sfp,lhs.ruleMap,lhs.lfp,lhs.lfpr) = 
        foldr (\(f, a, b) (m',rm', l', lr') -> 
          let att = (@lhs.pll, f) >.< a
              rm  = Map.insert att @rulename rm' 
              l   = if @loc.usesLocals && not b
                      then Map.insert att @loc.usedLocals l'
                      else l'
              lr  = if @loc.usesLocals && not b
                     then Set.fold (\k m -> Map.insertWith (Set.union) k 
                                 (Set.singleton att) m) lr' @loc.usedLocals
                     else lr'
              sfpins = Map.insert att (@rhs.used `Set.union` fromHO) m'
              fromHO = maybe Set.empty id (Map.lookup hOcc @lhs.lfpf)
                where hOcc = (@lhs.pll, "inst") >.< (f, AnyDir)
              
            in if b
                then (m',rm, Map.insert att @rhs.used l, 
                        Set.fold (\k m -> Map.insertWith (Set.union) k 
                                (Set.singleton att) m) lr @rhs.used)
                else (sfpins,rm,l,lr))
                        (Map.empty,Map.empty,Map.empty,Map.empty) @pattern.afs

ATTR Patterns Pattern [ ||
    -- the boolean represents whether this occurrence is 
    --   an transparent occurrence (only there to pass on dependencies)
    afs USE {++} {[]} : {[(FLabel, ALabel, Bool)]} ]

SEM Pattern | Alias
    lhs.afs = let isLocal = (@field == _LOC || @field == _INST)
               in [(getName @field, (getName @attr, dlhs @field), 
                    isLocal)] ++ @pat.afs

ATTR Rules Rule Expression HsTokensRoot HsTokens HsToken [
    -- the terminals of current production
    pts                : {Set.Set (FLabel)} || ]

ATTR Rule Expression HsTokensRoot HsTokens HsToken [ ||
    used USE {Set.union} {Set.empty} : {Set.Set MyOccurrence} ]

SEM Expression | Expression
    inst.tokens : HsTokensRoot
    inst.tokens = HsTokensRoot @tks
    tokens.pll  = @lhs.pll
    tokens.pts  = @lhs.pts
    lhs.used    = @tokens.used

-- reference to terminals of which some are local attributes 
SEM HsToken | AGLocal 
    lhs.used = 
        case getName @var `Set.member` @lhs.pts of
          True  -> Set.empty 
          -- local found without flabel
          False -> Set.singleton $ (@lhs.pll, getName _LOC) >.< 
                        (getName @var, drhs _LOC)
-- includes both locals and attributes
-- locals will be replaced later by repLocRefs
SEM HsToken | AGField
    lhs.used = Set.singleton $ (@lhs.pll, getName @field) >.< 
                                (getName @attr, drhs @field)
    
{
-- | Replace the references to local attributes, by his attrs dependencies,
-- |    rendering the local attributes 'transparent'.
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
}