ruler-0.4.0.0: src/AS1/GenAS2.cag
-------------------------------------------------------------------------
-- Utils
-------------------------------------------------------------------------
%%[1 hs
rsSelect :: RlSelIsSel -> RsGam Expr -> [(Nm,RsInfo Expr)]
rsSelect rlSelIsSel rsGam
= rs
where rs = [ (rsNm,rsInfo {rsRlGam = gamFromAssocs rls})
| (rsNm,rsInfo) <- gamAssocsShadow rsGam
, rsInfoIsPlain rsInfo
, rlSelIsSel nmAny rsNm nmAny
, let rls
= [ (rlNm,rlInfo {rlVwGam = gamFromAssocs vws})
| (rlNm,rlInfo) <- gamAssocsShadow (rsRlGam rsInfo)
, rlSelIsSel nmAny nmAny rlNm
, let vws
= [ v
| v@(vwNm,_) <- gamAssocsShadow (rlVwGam rlInfo)
, rlSelIsSel vwNm nmAny nmAny
]
, not (null vws)
]
, not (null rls)
]
rsSelectGroup :: RlSelIsSel -> RsGam Expr -> [(Nm,RsInfo Expr)]
rsSelectGroup rlSelIsSel rsGam
= rs
where rs = [ (rsNm,rsInfo {rsRlNms = rlNms})
| (rsNm,rsInfo) <- gamAssocsShadow rsGam
, rsInfoIsGroup rsInfo
, rlSelIsSel nmAny rsNm nmAny
, let rlNms
= [ r | r@(nRs,nRl) <- rsRlNms rsInfo, rlSelIsSel nmAny nRs nRl ]
, not (null rlNms)
]
scSelect :: RlSelIsSel -> ScGam Expr -> [(Nm,ScInfo Expr)]
scSelect rlSelIsSel scGam
= sc
where sc = [ (scNm,scInfo {scVwGam = gamFromAssocs vws})
| (scNm,scInfo) <- gamAssocsShadow scGam
-- , rlSelIsSel nmAny rsNm nmAny
, let vws
= [ v
| v@(vwNm,_) <- gamAssocsShadow (scVwGam scInfo)
, rlSelIsSel vwNm nmAny nmAny
]
]
jdChangeInfo :: Opts -> (Nm -> Maybe Bool) -> FmGam Expr -> (FmGam Expr,Expr->Expr)
jdChangeInfo opts isChgd jaFmGam
= if null chs then (jaFmGam,id)
else if or chs then (fmGamMap mkChng jaFmGam,id)
else (jaFmGam,Expr_Wrap WrIsSame)
where chs = catMaybes . map isChgd . gamKeys $ jaFmGam
mkChng
= case optMbMarkChange opts of
Just _ -> \nAt -> case isChgd nAt of
Just isCh -> Expr_Wrap (if isCh then WrIsChanged else WrIsSame)
Nothing -> id
Nothing -> \_ -> id
atIsChanged :: VwRlInfo Expr -> Nm -> Nm -> Maybe Bool
atIsChanged vwRlInfo
= case vwrlMbChGam vwRlInfo of
Just g -> \j a -> maybe (Just False) (const (Just True)) $ dblGamLookup id j a g
Nothing -> \_ _ -> Nothing
%%]
%%[1 ag
-------------------------------------------------------------------------
-- Selection
-------------------------------------------------------------------------
SEM AGItf
| AGItf loc . rsSelected = rsSelect @rlSelIsSel @rsGam
. scSelected = scSelect @rlSelIsSel @scGam
. rsGrpSelected
= rsSelectGroup @rlSelIsSel @rsGam
-------------------------------------------------------------------------
-- Generate AS2
-------------------------------------------------------------------------
ATTR AGItf [ | | as2: {AS2.Decls} ]
SEM AGItf
| AGItf loc . fmAS2 = fmAS2Fm (optGenFM @lhs.opts)
lhs . as2 = @as2Preamble ++ @as2ScmMeta ++ @as2RuleSets ++ @as2Explain
-------------------------------------------------------------------------
-- Generate AS2 for scheme related (meta) info
-------------------------------------------------------------------------
SEM AGItf
| AGItf loc . rsMetaSel = let nVwS = dgVertices @vwDpdGr
in gamFromAssocsWith Set.union
[ (rsScNm i,vs) | i <- gamElemsShadow @rsGam
, let vs = Set.filter (\v -> @rlSelIsSel v (rsNm i) nmAny) nVwS, not (Set.null vs)
]
. mkWrapChunk = \ag s v -> AS2.wrapInChunk AS2.Decl_Chunk @lhs.opts (rsSelMapVwNm (optMbRlSel @lhs.opts) v `nmApd` s `nmApd` Nm ag)
. as2ScmATTR = let mkChunk = @mkWrapChunk "ATTR"
mk s v
= case scVwGamLookup s v @scGam of
Just (si,vi) | not (gamIsEmpty agi && gamIsEmpty agsi && gamIsEmpty ags)
-> [AS2.Decl_AttrAG (AS2.AttrAGDecl_Attr (sc2DATA si @dtInvGam) (mkg agi) (mkg agsi) (mkg ags))]
where ag1 = gamFilter (\ai -> AtNode `notElem` atProps ai) (vwscFullAtGam vi)
(agsi,ag2) = gamPartition (\ai -> isJust (atMbSynInh ai)) ag1
(ags,agi) = gamPartition (\ai -> AtSyn `atHasDir` ai) ag2
mkg g = gamAssocsShadow $ gamFromAssocs
$ [ (n,atTy ai) | ai <- gamElemsShadow g, let n = nmSubst @lhs.opts @fmGam $ maybe (atNm ai) id $ atMbSynInh ai ]
_ -> []
in [ mkChunk s v d | (s,vs) <- gamAssocsShadow @rsMetaSel, v <- Set.toList vs, d <- mk s v ]
. as2ScmDATA = let mkChunk = @mkWrapChunk "DATA"
mk s v
= case scVwGamLookup s v @scGam of
Just (si,vi) | not (null alts)
-> [AS2.Decl_DataAG (AS2.DataAGDecl_Data dtNm alts)]
where dtNm = sc2DATA si @dtInvGam
alts
= case dtVwGamLookup dtNm v @dtGam of
Just (dtInfo,dtVwInfo)
-> [ AS2.DataAGAlt_Alt a
[ AS2.DataAGFld_Fld (nmSubst @lhs.opts @fmGam f) (dfTy fi) (tyIsDef (tyTopNm $ dfTy fi))
| (f,fi) <- sortOn (dfSeqNr . snd) $ gamAssocs $ daFldGam ai
]
| (a,ai) <- gamAssocs (vdFullAltGam dtVwInfo)
]
where tyIsDef t = maybe False (const True) $ dtVwGamLookup t v @dtGam
_ -> []
_ -> []
in [ mkChunk s v d | (s,vs) <- gamAssocsShadow @rsMetaSel, v <- Set.toList vs, d <- mk s v ]
. as2ScmMeta = if @fmAS2 == FmAG || @fmAS2 == FmHS
then (if optGenAGData @lhs.opts then @as2ScmDATA else [])
++ (if optGenAGAttr @lhs.opts then @as2ScmATTR else [])
else []
-------------------------------------------------------------------------
-- Generate AS2 for rulesets
-------------------------------------------------------------------------
SEM AGItf
| AGItf loc . as2RuleSets = let topWrap d = [AS2.Decl_RsVw d]
mkRs rsInfo
= case rsInfo of
RsInfo nRs _ nSc vwSel d rlGam
-> topWrap
$ AS2.RsVwDecl_Rs nRs nSc d
[ AS2.VwDecl_Vw v (mkFullVwNm nRs v) rls'
| (v,rls) <- gamAssocsShadow rlGamT
, let rls' = catMaybes [ gamLookup n rls | n <- rlOrder ]
]
where rlGamT = gamTranspose (rlVwGam,mkRl) rlGam
rlOrder = rsRlOrder rsInfo
jdsOf o g = [ maybe (panic "as2RuleSets") id (gamLookup jNm g) | jNm <- o ]
mkRl nRl nVw rlInfo vwRlInfo
= mkChunk nVw rlInfo
$ AS2.RlDecl_Rl nRl fullNm (rlPos rlInfo) (rl2SEM rlInfo @dtInvGam nSc nRl nVw) pre post
where preg = vwrlFullPreGam vwRlInfo
postg = vwrlFullPostGam vwRlInfo
preOrder = concat (vwrlPreScc vwRlInfo)
postOrder = gamKeys postg
(pre,post)
= case @fmAS2 of
FmTeX -> (mkExprJds vwRlInfo preOrder preg,mkExprJds vwRlInfo postOrder postg)
FmAG -> (mkAtsJds preOrder preg,mkAtsJds postOrder postg)
_ -> ([],[])
fullNm = mkFullRlNm nRs nVw nRl
mkChunk nVw rlInfo
= AS2.wrapInChunk AS2.RlDecl_Chunk @lhs.opts (nVwRnm `nmApd` nSc `nmApd` rlNm rlInfo)
where nVwRnm = rsSelMapVwNm (optMbRlSel @lhs.opts) nVw
mkAtsJds order reGam
= [ AS2.Jd_Ats (reNm jInfo) (reScNm jInfo) (mkAts jInfo) | jInfo <- jdsOf order reGam ]
where mkAts jInfo = [ AS2.JdAt_At aNm (jaExpr a) | (aNm,a) <- gamAssocsShadow (reJAGam jInfo) ]
mkExprJds vwRlInfo order reGam
= [ AS2.Jd_Expr (reNm jInfo) (reScNm jInfo) (mkExpr vwRlInfo jInfo) (reIsSmall jInfo) | jInfo <- jdsOf order reGam ]
where mkExpr vwRlInfo jInfo
= wrapFullJd $ exprSubst (@lhs.opts {optSubstOnce=True}) jg' $ e
where (scInfo,vwScInfo) = fromJust (scVwGamLookup (reScNm jInfo) nVw @scGam)
jg = jaGamToFmGam id . reJAGam $ jInfo
(jg',wrapFullJd) = jdChangeInfo @lhs.opts (atIsChanged vwRlInfo (reNm jInfo)) jg
e = jdGamFmExpr @fmAS2 . vwscJdShpGam $ vwScInfo
nVw = vwrlNm vwRlInfo
RsInfoGroup nRs _ nSc vwSel d rlNms | @fmAS2 == FmTeX
-> topWrap
$ AS2.RsVwDecl_Rs nRs nSc d
[ AS2.VwDecl_Vw nVw (mkFullVwNm nRs nVw) (mkRls nVw rlNms) | nVw <- vwOrder ]
where vwOrder = [ v | v <- dgTopSort @vwDpdGr, @rlSelIsSel v nmAny nmAny ]
mkRls nVw rlNms
= [ AS2.RlDecl_LTXAlias (mkFullRlNm nRs nVw nRl) (mkFullRlNm nRs' nVw nRl)
| (nRs',nRl) <- rlNms, rlVwIsDef nRs' nVw nRl
]
rlVwIsDef nRs nVw nRl
= isJust (do rsInfo <- gamLookup nRs @rsGam
rlGam <- rsInfoMbRlGam rsInfo
rlVwGamLookup nRl nVw rlGam
)
_ -> []
mkFullVwNm nRs nVw = nmApd (Nm (optBaseNm @lhs.opts)) $ (if nVw == nmNone then id else nmApd nVw) $ nRs
mkFullRlNm nRs nVw nRl = mkFullVwNm nRs nVw `nmApd` {- mkRlNm -} nRl
mkRlNm = if optDot2Dash @lhs.opts then nmDashed else nmFlatten
in [ d | (nRs,rsInfo) <- @rsSelected ++ @rsGrpSelected, d <- mkRs rsInfo ]
-------------------------------------------------------------------------
-- Generate AS2 for explain (i.e. explanation)
-------------------------------------------------------------------------
SEM AGItf
| AGItf loc . as2Explain = if optGenExpl @lhs.opts
then let explGen
= [ ex | (nSc,scInfo) <- @scSelected, exSc <- mkSc scInfo, ex <- exSc ]
where mkSc scInfo
= [ (maybe [] (\e -> [mkChunk nVw "explain.scheme" $ AS2.Decl_ScVwExplain (fmtex e)]) . gamLookup nmNone . vwscExplGam $ vwInfo)
++ [ mkChunk nVw "explain.holes" $ AS2.Decl_ScVwAtExplain
$ [ (fmte $ Expr_Expr $ Expr_Var $ n, fmtex ei) | (n,ei) <- gamAssocsShadow (vwscExplGam vwInfo `Map.intersection` vwscFullAtGam vwInfo) ]
]
| (nVw,vwInfo) <- gamAssocsShadow (scVwGam scInfo)
]
where mkChunk nVw n = AS2.wrapInChunk AS2.Decl_Chunk @lhs.opts (scNm scInfo `nmApd` nVw `nmApd` Nm n)
fmte = exprSubst (@lhs.opts {optSubstFullNm=False, optGenFM = FmTeX}) @fmGam
fmtex = fmte . explExpr
in explGen
else []
-------------------------------------------------------------------------
-- Generate AS2 for preamble
-------------------------------------------------------------------------
SEM AGItf
| AGItf loc . as2Preamble = if optPreamble @lhs.opts
then fkGamLookup [] (\p -> [AS2.Decl_Preamble p]) [@fmAS2] @decls.paGam
else []
%%]