ruler-0.4.0.0: src/Main1AG.cag
-------------------------------------------------------------------------
-- Main for AG, pass 1
-------------------------------------------------------------------------
%%[1 hs module (Main1AG)
%%]
%%[1 hs import (Data.Maybe, Data.Char, Data.List, qualified Data.Set as Set, qualified Data.Map as Map, UHC.Util.Pretty)
%%]
%%[1 hs import (UHC.Util.FPath, UHC.Util.Utils, Err, Common, Opts, LaTeXFmtUtils, Expr.Utils)
%%]
%%[1 hs import (ARule.Utils, ViewSel.Utils, Config( cfgStrSel, cfgFmFmtCmdAsc ), FmGam, RwExprGam, ECnstrGam)
%%]
%%[1 hs import (AbsSyn.AbsSyn1, qualified AbsSyn.AbsSyn2 as AS2, qualified Main2AG as M2)
%%]
%%[1 hs import (Utils, Admin, MkAdmin)
%%]
-------------------------------------------------------------------------
-- Inclusion of split off parts
-------------------------------------------------------------------------
%%[1 ag import ({AbsSyn/AbsSyn1AG}, {AbsSyn/CommonAG}, {FmGamAG}, {AS1/Misc}, {AS1/ViewDpd}, {AS1/SchemeDpd}, {AS1/Pretty}, {AS1/RlSel})
%%]
%%[1 ag import ({AS1/GenAS2})
%%]
%%[1 ag import ({Expr/AbsSynAG}, {Expr/IsRwAG}, {Expr/NmSAG}, {Expr/FmGamAG}, {Expr/PrettyPrintAG}, {Expr/SelfAG}, {Ty/AbsSynAG}, {Ty/SelfAG})
%%]
%%[1 ag
-------------------------------------------------------------------------
-- Interfacing to AST
-------------------------------------------------------------------------
WRAPPER AGItf
-------------------------------------------------------------------------
-- Error
-------------------------------------------------------------------------
ATTR AllAS1 AGItf [ | | errL USE {++} {[]}: {[Err]} ]
SEM AGItf
| AGItf lhs . errL = @errDupSc ++ @errMutSc ++ @errBldDt ++ @errBldSc ++ @errDupRs ++ @errBldRs ++ @decls.errL
SEM RExpr
| Judge lhs . errL = errFirst [@errSc,@errVwSc,@errJd,@eqns.errL]
SEM RExprEqn
| Expr lhs . errL = errFirst [@errMt,@errJd]
SEM Decl
| ShpJudge lhs . errL = errFirst [@errVwSc,@errUndefs]
| Scheme lhs . errL = @errDupVw ++ @decls.errL
| Rule lhs . errL = @errDupVw ++ @decls.errL
-------------------------------------------------------------------------
-- Data/AST
-------------------------------------------------------------------------
ATTR AllFldIntro [ seqNr: Int | | dtFldGam USE {`gamUnion`} {emptyGam}: DtFldGam ]
SEM FldIntros
| Cons tl . seqNr = @lhs.seqNr + 1
SEM Decl
| DataASTAlt loc . seqNr = 1
SEM FldIntro
| Intro lhs . dtFldGam = gamSingleton @nm (DtFldInfo @nm @ty.self @lhs.seqNr)
ATTR AllDecl [ | | dtAltGam USE {`gamUnion`} {emptyGam}: DtAltGam ]
SEM Decl
| DataASTAlt lhs . dtAltGam = gamSingleton @nm (DtAltInfo @nm @ruleNm @mbBasedOnNm @fldIntros.dtFldGam)
ATTR AllDecl [ | | vwDtGam USE {`gamUnion`} {emptyGam}: DtVwGam ]
SEM Decl
| DataASTView lhs . vwDtGam = gamSingleton @nm (DtVwInfo @nm @decls.dtAltGam emptyGam)
ATTR AllDecl [ | | gathDtGam USE {`gamUnion`} {emptyGam}: DtGam ]
ATTR AGItf [ | | dtInvGam: DtInvGam ]
SEM Decl
| DataAST lhs . gathDtGam = gamSingleton @nm (DtInfo @nm @schemeNms @decls.vwDtGam)
SEM AGItf
| AGItf loc . (dtGam,errBldDt)
= gamFoldWithKey
(\n i (g,e)
-> let (i',e') = bldDtInfo @vwDpdGr i
in (gamInsertShadow n i' g,e'++e)
)
(@decls.gathDtGam,[])
@decls.gathDtGam
. dtInvGam = dtGamInv @dtGam
-------------------------------------------------------------------------
-- Attr
-------------------------------------------------------------------------
{
atGamUpdDirs :: ([AtDir] -> Bool) -> [AtDir] -> AtGam -> AtGam
atGamUpdDirs f d = gamMap (\i -> if f (atDirs i) then i {atDirs = d} else i)
}
ATTR AllAttrIntroDecl AllDecl [ | | atGam USE {`gamUnion`} {emptyGam}: AtGam ]
ATTR AllAttrIntroDecl AllDecl [ | | atBldL USE {++} {[]}: {[ScAtBld]} ]
-- ATTR AllAttrIntro [ atDirs: {[AtDir]} | | ]
SEM AttrIntro
| Intro loc . atGam = let (pd,pr) = partition (`Set.member` propsDir) @props
in gamSingleton @nm (AtInfo @nm pd pr @ty)
SEM AttrIntroDecl
| Attrs loc . atGam = let t = const True
in atGamUpdDirs t [AtInh] @inhs.atGam `gamUnion` atGamUpdDirs t [AtInh,AtSyn] @inhsyns.atGam `gamUnion` atGamUpdDirs t [AtSyn] @syns.atGam
| AttrsProp loc . atGam = atGamUpdDirs null [AtInh,AtSyn] @intros.atGam
| AttrsProp Attrs lhs . atBldL = [ScAtBldDirect @atGam]
| Scheme lhs . atBldL = [ScAtBldScheme @nm @pos @renames.atRnmL]
ATTR AllAttrRename [ | | atRnmL USE {++} {[]}: {[ScAtBldRename]} ]
SEM AttrRename
| Rename lhs . atRnmL = [ScAtBldRename @nmNew @nmOld]
| EqualTo lhs . atRnmL = [ScAtBldEqualTo @nmLeft @nmRight]
-------------------------------------------------------------------------
-- Externally declared identifiers
-------------------------------------------------------------------------
ATTR AllDecl [ | | gathExtNmS USE {`Set.union`} {Set.empty}: {Set.Set Nm} ]
SEM AGItf
| AGItf loc . extNmS = @decls.gathExtNmS
SEM Decl
| Extern lhs . gathExtNmS = Set.fromList @nms
-------------------------------------------------------------------------
-- View (related to scheme)
-------------------------------------------------------------------------
ATTR AllDecl [ | | vwScGam USE {`gamUnion`} {emptyGam}: {VwScGam Expr} ]
ATTR AllDecl [ | | vwJdShpGam USE {`gamUnion`} {emptyGam}: {JdShpGam Expr} ]
SEM Decl
| ScmView lhs . vwScGam = gamSingleton @nm (VwScInfo @nm @decls.vwJdShpGam @decls.atBldL [] emptyGam emptyGam @decls.explGam)
| ShpJudge lhs . vwJdShpGam = gamSingleton @fmKind (JdShpInfo @expr.self)
loc . cxStr = "judgement for view '" ++ show @lhs.viewNm ++ "' for scheme '" ++ show @lhs.scmNm ++ "'"
. (vwScInfo,errVwSc)
= case scVwGamLookup @lhs.scmNm @lhs.viewNm @lhs.scGam of
Just (_,i) -> (i,[])
Nothing -> (emptyVwScInfo,[Err_UndefNm @pos @cxStr "view" [@lhs.viewNm]])
. errUndefs = let nms = gamKeys (vwscFullAtGam @vwScInfo) \\ Set.toList @expr.nmS
in [] -- if null nms then [] else [Err_UndefNm @pos @cxStr "hole" nms]
| ShpDel lhs . vwJdShpGam = gamFromAssocs [ (k,JdShpDel) | k <- @fmKinds ]
%%]
-------------------------------------------------------------------------
-- Scheme, derived ones are expresses in terms of non-derived ones
-------------------------------------------------------------------------
%%[1 hs
type MkDerivScInfo = (ScInfo Expr -> ScInfo Expr,ScGam Expr -> RsInfo Expr)
type DrvGam = Gam Nm [MkDerivScInfo]
drvGamUnion :: DrvGam -> DrvGam -> DrvGam
drvGamUnion = gamUnionWith (++)
%%]
%%[1 ag
ATTR AllDecl [ drvGam: DrvGam | | gathDrvGam USE {`drvGamUnion`} {emptyGam}: DrvGam ]
SEM Decl
| SchemeDeriv lhs . gathDrvGam = let mkListSc si
= siNw
where siNw = ScInfo @pos @nm @mbAGNm @scKind vGm
vGm
= gamMapWithKey
(\nVw vi
-> let mbNdNm = atGamNode (vwscAtGam vi)
(aGm,ndRenmG)
= case mbNdNm of
Just n -> (n `Map.delete` vwscAtGam vi,fmGamFromList [(n,Expr_Var @nm)])
_ -> (vwscAtGam vi,emptyGam)
aNdGamNw
= if @firstVwNm == nVw
then gamSingleton @nm (AtInfo @nm [AtInh] [AtNode] (nmCapitalize @nm))
else emptyGam
jdG = gamMap (\i -> i {jdshExpr = exprSubst @lhs.opts ndRenmG (jdshExpr i)}) (vwscJdShpGam vi)
in vi {vwscAtBldL = [ScAtBldDirect (aNdGamNw `gamUnion` aGm)], vwscJdShpGam = jdG}
)
(scVwGam si)
mkNm n = n `nmStrApd` Nm "s"
vwSels = dgVertices @lhs.vwDpdGr
mkg :: Ord k => (v -> k) -> [v] -> Gam k v
mkg mkn l = gamFromAssocs [ (mkn i,i) | i <- l ]
mkRsInfo nl scGam
= RsInfo (@nm `nmApd` Nm "base") @pos @nm vwSels ("Rules for " ++ show @nm) (mkg rlNm [rl1])
where rl1
= RlInfo (@nm `nmApd` Nm "cons") emptySPos Nothing (Just "Cons") 0 (Just vwSels) (mkg vwrlNm [vw])
where nHd = Nm "hd"
ndHd = @nm `nmApd` nHd
nTl = Nm "tl"
ndTl = @nm `nmApd` nTl
vw = mkVwRlInfo @firstVwNm emptySPos [RlJdBldDirect Set.empty (mkg reNm [j1,j2]) (mkg reNm [j3])] []
j3 = REInfoJudge @nm @nm Set.empty Set.empty (mkg jaNm [a3]) False
a3 = mkJAInfo @nm e3
e3 = mkExprApp (Expr_ChildOrder 0 (Expr_Var ndHd))
[Expr_ChildOrder 1 (Expr_Var ndTl)]
n2 = maybe nl id $ scVwGamNodeAt nl @firstVwNm scGam
j2 = REInfoJudge nHd nl Set.empty Set.empty (mkg jaNm [a2]) False
a2 = mkJAInfo n2 e2
e2 = Expr_Var ndHd
j1 = REInfoJudge nTl @nm Set.empty Set.empty (mkg jaNm [a1]) False
a1 = mkJAInfo @nm e1
e1 = Expr_Var ndTl
in case @scDeriv of
ScList nl -> (gamSingleton nl [(mkListSc,mkRsInfo nl)])
SEM AGItf
| AGItf loc . drvGam = @decls.gathDrvGam
-------------------------------------------------------------------------
-- Scheme
-------------------------------------------------------------------------
ATTR AllDecl [ | | gathScGam USE {`gamUnion`} {emptyGam}: {ScGam Expr} ]
ATTR AllDecl AllRExpr AllRuleJudgeIntroDecl [ scGam: {ScGam Expr} | | ]
ATTR AGItf [ | | scGam: {ScGam Expr} ]
SEM AGItf
| AGItf loc . (scGam,errBldSc)
= let r = foldr
(\sNm (scGam,scErrs)
-> let scInfo = gamLookupJust sNm scGam
drvScInfoL = maybe [] (\l -> map (($ scInfo) . fst) l) $ gamLookup sNm @drvGam
(ascL,errLL) = unzip [ ((scNm i',i'),e) | i <- (scInfo : drvScInfoL), let (i',e) = bldScInfo @vwDpdGr scGam i ]
in (gamFromAssocs ascL `gamUnionShadow` scGam,concat errLL ++ scErrs)
)
(@decls.gathScGam,[])
(dgTopSort @scDpdGr)
in r
SEM Decl
| Scheme lhs . gathScGam = gamSingleton @nm (ScInfo @pos @nm @mbAGNm @scKind @decls.vwScGam)
-------------------------------------------------------------------------
-- Rule
-------------------------------------------------------------------------
ATTR AllAttrEqn [ | | jaGam USE {`gamUnion`} {emptyGam}: {JAGam Expr} ]
SEM AttrEqn
| Eqn lhs . jaGam = gamSingleton @nm (mkJAInfo @nm @expr.self)
| Del lhs . jaGam = gamSingleton @nm (JAInfoDel @nm)
ATTR RExprEqn [ vwScInfo: {VwScInfo Expr} pos: SPos cxStr: String schemeNm: Nm | | ]
SEM RExprEqn
| Expr loc . (jdshExpr,errJd)
= gamTryLookups (Expr_Empty,[Err_NoJdSpec @lhs.pos @lhs.cxStr [@lhs.schemeNm]])
(\i -> (jdshExpr i,[]))
[FmSpec,FmTeX,FmAll] (vwscJdShpGam @lhs.vwScInfo)
. mt = exprMatch (@lhs.opts {optMatchROpOpnd = False}) emptyGam @expr.self @jdshExpr
. errMt = if mtMatches @mt then [] else [Err_Match @lhs.pos @lhs.cxStr (pp @expr.self) (pp @jdshExpr)]
lhs . jaGam = fmGamToJaGam FmAll (mtFmGam @mt) `gamIntersection` vwscFullAtGam @lhs.vwScInfo
ATTR AllRExpr [ | | reGam USE {`gamUnion`} {emptyGam}: {REGam Expr} ]
SEM RExpr
| Judge eqns . pos = @pos
. schemeNm = @schemeNm
loc . nm = maybe (Nm (strUnd ++ show @lUniq)) id @mbRNm
. cxStr = "judgement for view '" ++ show @lhs.viewNm ++ "' for rule '" ++ show @lhs.ruleNm ++ "'"
. cxStr2 = @cxStr ++ " for scheme '" ++ show @schemeNm ++ "'"
. (scInfo,errSc)
= case gamLookup @schemeNm @lhs.scGam of
Just i -> (i,[])
Nothing -> (emptyScInfo,[Err_UndefNm @pos @cxStr "scheme" [@schemeNm]])
. (vwScInfo,errVwSc)
= case gamLookup @lhs.viewNm (scVwGam @scInfo) of
Just i -> (i,[])
Nothing -> (emptyVwScInfo,[Err_UndefNm @pos @cxStr "view" [@lhs.viewNm]])
. reInfo = REInfoJudge @nm @schemeNm Set.empty Set.empty @eqns.jaGam @isSmallExpr
. errJd = case gamKeys (@eqns.jaGam `gamDifference` vwscFullAtGam @vwScInfo) of
[] -> []
ks -> [Err_NoXXFor @pos @cxStr2 "scheme hole definition" ks]
lhs . reGam = gamSingleton @nm @reInfo
| Del lhs . reGam = gamSingleton (head @nms) (REInfoDel @nms)
-------------------------------------------------------------------------
-- Rules, names
-------------------------------------------------------------------------
ATTR AllRExpr AllDecl AllRuleJudgeIntroDecl [ viewNm: Nm | | ]
ATTR AllRExpr AllDecl AllRuleJudgeIntroDecl [ ruleNm: Nm | | ]
ATTR AllDecl AllAttrIntroDecl AllRuleJudgeIntroDecl [ scmNm: Nm | | ]
SEM Decl
| Rule loc . ruleNm = @nm
SEM Decl
| Scheme loc . scmNm = @nm
SEM Decl
| RulView ScmView loc . viewNm = @nm
SEM AGItf
| AGItf decls . ruleNm = nmNone
. scmNm = nmNone
. viewNm = nmNone
-------------------------------------------------------------------------
-- Rules, views for rule
-------------------------------------------------------------------------
ATTR AllDecl [ | | vwRlGam USE {`gamUnion`} {emptyGam}: {VwRlGam Expr} ]
SEM Decl
| RulView lhs . vwRlGam = gamSingleton @nm (mkVwRlInfo @nm @pos @jdIntros.jdBldL @group)
ATTR AllDecl AllRuleJudgeIntroDecl [ | | jdBldL USE {++} {[]}: {[RlJdBld Expr]} ]
SEM RuleJudgeIntro
| PrePost lhs . jdBldL = [RlJdBldDirect (Set.fromList @extNms) @pre.reGam @post.reGam]
| RulesetRule lhs . jdBldL = [RlJdBldFromRuleset @pos @rsNm @rlNm @schemeRnmL]
-------------------------------------------------------------------------
-- Rules, individual rules for rule set
-------------------------------------------------------------------------
ATTR AllDecl [ | | rlGam USE {`gamUnion`} {emptyGam}: {RlGam Expr} ]
SEM Decl
| Rule lhs . rlGam = gamSingleton @nm (RlInfo @nm @pos @mbBasedOnNm @mbAGNm @lhs.rlSeqNr (fmap (viewSelNmS @lhs.vwDpdGr) @viewSel) @decls.vwRlGam)
-------------------------------------------------------------------------
-- Rules, all rule sets
-------------------------------------------------------------------------
ATTR AllDecl [ rsGam: {RsGam Expr} | | gathRsGam USE {`gamUnion`} {emptyGam}: {RsGam Expr} ]
SEM AGItf
| AGItf loc . (rsGam,errBldRs)
= let r = foldr
(\sNm (rsGam,rsErrs)
-> let (rsGamBldL,errLL)
= unzip
$ map
(\rsInfo
-> let drvRsInfoL = maybe [] (\l -> map (($ @scGam) . snd) l) $ gamLookup sNm @drvGam
(blds,errs)
= unzip [ ((rsNm i',i'),e) | i <- (rsInfo : drvRsInfoL)
, let (i',e) = bldRsInfo @vwDpdGr @extNmS @lhs.opts @dtInvGam @scGam rsGam i
]
in (gamFromAssocs blds,concat errs)
)
$ [ i | i <- gamElems rsGam, rsInfoIsPlain i, rsScNm i == sNm ]
in (gamUnionsShadow rsGamBldL `gamUnionShadow` rsGam,concat errLL ++ rsErrs)
)
(@decls.gathRsGam,[])
(dgTopSort @scDpdGr)
in r
SEM Decl
| Rules lhs . gathRsGam = gamSingleton @nm (RsInfo @nm @pos @schemeNm (viewSelNmS @lhs.vwDpdGr @viewSel) @info @decls.rlGam)
| RulesGroup lhs . gathRsGam = gamSingleton @nm (RsInfoGroup @nm @pos @schemeNm (viewSelNmS @lhs.vwDpdGr @viewSel) @info @rlNms)
-------------------------------------------------------------------------
-- Formats, rewrites
-------------------------------------------------------------------------
ATTR AllDecl [ | | gathFmGam USE {`fmGamUnion`} {emptyGam}: {FmGam Expr} ]
ATTR AGItf [ | | fmGam: {FmGam Expr} ]
ATTR AllDecl [ | | gathRwGam USE {`rwGamUnion`} {emptyGam}: RwExprGam ]
ATTR AllDecl [ rwGam: RwExprGam | | ]
ATTR AGItf [ | | rwGam: RwExprGam ]
SEM AGItf
| AGItf loc . fmGam = @decls.gathFmGam
`gamUnionShadow`
@lhs.fmGam
`gamUnionShadow`
fmGamFromList' FmFmtCmd [ (Nm f,Expr_Var (Nm t)) | (f,t) <- cfgFmFmtCmdAsc ]
. rwGam = @decls.gathRwGam
SEM Decl
| Fmt lhs . (gathFmGam,gathRwGam)
= case @matchExpr.exprIsRw of
ExprIsRw n -> (emptyGam,rwSingleton n @fmKind @atIO (@matchExpr.self,@expr.self))
ExprIsVar n -> (fmSingleton n @fmKind @expr.self,emptyGam)
ExprIsOther -> (emptyGam,emptyGam)
SEM RExprEqn
| Expr loc . fmGam = emptyGam
. rwGam = emptyGam
. ecGam = emptyGam
SEM AttrEqn
| Eqn loc . fmGam = emptyGam
. rwGam = emptyGam
. ecGam = emptyGam
SEM Decl
| Fmt ShpJudge Explain
loc . fmGam = emptyGam
. rwGam = emptyGam
. ecGam = emptyGam
-------------------------------------------------------------------------
-- Explanations
-------------------------------------------------------------------------
ATTR AllDecl [ | | explGam USE {`gamUnion`} {emptyGam}: {ExplGam Expr} ]
SEM Decl
| Explain lhs . explGam = gamSingleton (maybe nmNone id @mbNm) (ExplInfo @expr.self)
-------------------------------------------------------------------------
-- Preambles
-------------------------------------------------------------------------
ATTR AllDecl [ | | paGam USE {`gamUnion`} {emptyGam}: {FmKdGam String} ]
SEM Decl
| Preamble lhs . paGam = gamSingleton @fmKind @preamble
-------------------------------------------------------------------------
-- Error checks for duplicate names
-------------------------------------------------------------------------
SEM AGItf
| AGItf loc . errDupRs = gamCheckDups emptySPos "toplevel" "ruleset/rulegroup" @decls.gathRsGam
. errDupSc = gamCheckDups emptySPos "toplevel" "scheme" @decls.gathScGam
SEM Decl
| Rule loc . errDupVw = gamCheckDups @pos "rule" "view" @decls.vwRlGam
| Scheme loc . errDupVw = gamCheckDups @pos "scheme" "view" @decls.vwScGam
-------------------------------------------------------------------------
-- Wrapping context (stack)
-------------------------------------------------------------------------
{-
ATTR AllExpr [ wrKindStk: {[WrKind]} | | ]
SEM Expr
| Wrap expr . wrKindStk = @wrKind : @lhs.wrKindStk
SEM AGExprItf
| AGItf expr . wrKindStk = [WrNone]
SEM Decl
| Fmt loc . wrKindStk = [WrNone]
SEM RExprEqn
| Expr loc . wrKindStk = [WrNone]
SEM AttrEqn
| Eqn loc . wrKindStk = [WrNone]
SEM AExpr
| Expr loc . wrKindStk = [WrNone]
SEM AEqn
| Err loc . wrKindStk = [WrNone]
SEM Decl
| Fmt ShpJudge Explain
expr . wrKindStk = [WrNone]
-}
%%]