ruler-core-1.0: src/TargetHaskell.ag
-- This file is included by Transform.ag
-- Based on the AST of AstAG.ag
-- Generates code for Haskell
SEM Program | Program
+pp = if genHaskell @lhs.opts
then (@loc.hpp >-<)
else id
{
hItfNm nm = "I_" ++ show nm
hCoItfNm nm vis = hItfNm (mkCoIdent nm vis)
hItfVsNm nm vis = "I_" ++ show nm ++ "_" ++ show vis
hCoItfVsNm nm vis = hItfVsNm (mkCoIdent nm vis) vis
hNt x = "_nt_" ++ show x
hVis x = "_vis_" ++ show x
hSemNm k v = "_sem_" ++ show k ++ "_" ++ show v
hInp child name
| show child == "loc" = show child ++ "L" ++ show name
| show child == "lhs" = show child ++ "I" ++ show name
| show child == "vis" = show child ++ "I" ++ show name
| otherwise = show child ++ "S" ++ show name
hOutp child name
| show child == "loc" = show child ++ "L" ++ show name
| show child == "lhs" = show child ++ "S" ++ show name
| show child == "vis" = show child ++ "S" ++ show name
| otherwise = show child ++ "I" ++ show name
hOutpLoc child name = show child ++ "L" ++ show name
hInpLoc child name = show child ++ "L" ++ show name
hInhFldNm nm itf vis = show nm ++ "_Inh_" ++ show itf
hSynFldNm nm itf vis = show nm ++ "_Syn_" ++ show itf
hInhFldNmFull nm itf vis = hInhFldNm nm itf vis ++ "_" ++ show vis
hSynFldNmFull nm itf vis = hSynFldNm nm itf vis ++ "_" ++ show vis
hCoInhFldNm nm itf vis = hInhFldNm nm (mkCoIdent itf vis) vis
hCoSynFldNm nm itf vis = hSynFldNm nm (mkCoIdent itf vis) vis
hCoInhFldNmFull nm itf vis = hCoInhFldNm nm itf vis ++ "_" ++ show vis
hCoSynFldNmFull nm itf vis = hCoSynFldNm nm itf vis ++ "_" ++ show vis
hInhDt itf vis = "Inh_" ++ show itf ++ "_" ++ show vis
hSynDt itf vis = "Syn_" ++ show itf ++ "_" ++ show vis
hCoInhDt itf vis = hInhDt (mkCoIdent itf vis) vis
hCoSynDt itf vis = hSynDt (mkCoIdent itf vis) vis
hInvNm itf nm = "invoke_" ++ show itf ++ "_" ++ show nm
hCoInvNm itf nm = "coinvoke_" ++ show itf ++ "_" ++ show nm
hNextNm itf nm = "next_" ++ show itf ++ "_" ++ show nm
hCurrentNm itf nm = "current_" ++ show itf ++ "_" ++ show nm
hDtNm nm = show nm
hConNm dt nm = show dt ++ "_" ++ show nm
hFldNm dt con nm = show nm ++ "_" ++ show dt ++ "_" ++ show con
hDtSemNm nm = "dnt_" ++ show nm
hDfltNm nm nr = "dflt_" ++ show nm ++ "_" ++ show nr
hCatch :: (PP a, PP b) => a -> b -> PP_Doc
hCatch l r = "catchError"
>-< indent 2 (pp_parens (pp l))
>-< indent 2 (pp_parens (pp r))
hThrow msg = "throwError" >#< pp_parens ("strMsg" >#< show msg)
}
SEM Program | Program
loc.hpp = vlist @blocks.hpps
ATTR Block Itf ItfVisit Data Con Field Type AliasType DataSem MaybeBoundCode BoundCode Code
Item SemVisit ClausesTop Clauses Clause Stmt Pat ImplStmt Var AttrTypePat AttrTypeCode
[ | | hpp : {PP_Doc} ]
ATTR ExprField [ | | hopp : {(Int,PP_Doc)} ]
SEM Block
| Section lhs.hpp = @code.hpp
| Itf lhs.hpp = @itf.hpp
| Data lhs.hpp = if noDataGen @lhs.opts then empty else @data.hpp
| Type lhs.hpp = if noDataGen @lhs.opts then empty else @type.hpp
| Item lhs.hpp = "mk" >|< show @name >#< "::" >#< @item.hppType
>-< "mk" >|< show @name >#< "="
>-< indent 2 @item.hpp
| DataSem lhs.hpp = @sem.hpp
SEM Itf
| Itf lhs.hpp = empty
+hpp = ("type" >#< hItfNm @name >#< "m" >#< "=" >#< hItfVsNm @name @visits.firstVisit >#< "m") >-<
+hpp = vlist @visits.hpps >-<
SEM ItfVisit
| Visit lhs.hpp = empty
loc.hCtx = "(Monad m) => "
loc.hMonad = if @cyclic then empty else text "m"
loc.hConNm = text $ hItfVsNm @loc.itfNm @name
loc.hCoConNm = text $ hCoItfVsNm @loc.itfNm @name
loc.hRepFld = [ hSynFldNmFull repIdent @loc.itfNm @name >#< "::" >#< "!" >|< pp_parens (@loc.hConNm >#< "m") ]
loc.hNextFld = maybe [] (\nm -> [ hSynFldNmFull nextIdent @loc.itfNm @name
>#< "::" >#< "!" >|< pp_parens (hItfVsNm @loc.itfNm nm >#< "m")]) @lhs.mbNextVisit
loc.hArrTp = hInhDt @loc.itfNm @name >#< "m" >#< "->" >#< @loc.hMonad >#< pp_parens (hSynDt @loc.itfNm @name >#< "m")
loc.hCoArrTp = hCoInhDt @loc.itfNm @name >#< "m" >#< "->" >#< @loc.hMonad >#< pp_parens (hCoSynDt @loc.itfNm @name >#< "m")
+hpp = ("newtype" >#< @loc.hCtx >#< @loc.hConNm >#< "m" >#< "=" >#< @loc.hConNm >#< pp_parens @loc.hArrTp) >-<
+hpp = ("newtype" >#< @loc.hCtx >#< @loc.hCoConNm >#< "m" >#< "=" >#< @loc.hCoConNm >#< pp_parens @loc.hCoArrTp) >-<
+hpp = ("data" >#< @loc.hCtx
>#< hInhDt @loc.itfNm @name >#< "m" >#< "=" >#< hInhDt @loc.itfNm @name
>#< pp_block "{" "}" "," @attrs.hInhDeclPPs) >-<
+hpp = ("data" >#< @loc.hCtx
>#< hSynDt @loc.itfNm @name >#< "m" >#< "=" >#< hSynDt @loc.itfNm @name
>#< pp_block "{" "}" "," (@loc.hRepFld ++ @loc.hNextFld ++ @attrs.hSynDeclPPs)
) >-<
+hpp = ("data" >#< @loc.hCtx
>#< hCoInhDt @loc.itfNm @name >#< "m" >#< "=" >#< hCoInhDt @loc.itfNm @name
>#< pp_block "{" "}" "," @attrs.hCoInhDeclPPs) >-<
+hpp = ("data" >#< @loc.hCtx
>#< hCoSynDt @loc.itfNm @name >#< "m" >#< "=" >#< hCoSynDt @loc.itfNm @name
>#< pp_block "{" "}" "," (
(hCoSynFldNmFull repIdent @loc.itfNm @name >#< "::" >#< "!" >|< pp_parens (@loc.hCoConNm >#< "m"))
: @attrs.hCoSynDeclPPs)
) >-<
+hpp = ("type" >#< hCoItfNm @loc.itfNm @name >#< "m" >#< "=" >#< hCoItfVsNm @loc.itfNm @name >#< "m") >-<
+hpp = (hInvNm @loc.itfNm @name >#< "!" >|< pp_parens (@loc.hConNm >#< "!" >|< "__f") >#< "=" >#< "__f") >-<
+hpp = (hCoInvNm @loc.itfNm @name >#< "!" >|< pp_parens (@loc.hCoConNm >#< "!" >|< "__f") >#< "=" >#< "__f") >-<
+hpp = case @lhs.mbNextVisit of
Nothing -> id
Just v -> ((hNextNm @loc.itfNm @name >#< "!" >|< pp_parens (
hSynDt @loc.itfNm @name >#< pp_braces (
hSynFldNmFull nextIdent @loc.itfNm @name >#< "=" >#< "__f")
) >#< "=" >#< "__f" >#< "--" >#< v) >-<)
+hpp = ((hCurrentNm @loc.itfNm @name >#< "!" >|< pp_parens (
hSynDt @loc.itfNm @name >#< pp_braces (hSynFldNmFull repIdent @loc.itfNm @name >#< "=" >#< "__f")
) >#< "=" >#< "__f") >-<)
{
nextIdent :: Ident
nextIdent = ident "next_"
repIdent :: Ident
repIdent = ident "rep_"
}
ATTR Attrs Attr [ | | hInhDeclPPs,hSynDeclPPs,hCoInhDeclPPs,hCoSynDeclPPs USE {++} {[]} : {[PP_Doc]}]
SEM Attr
| Inh Syn loc.hTpPP = stripSpacing @type
loc.pos = identPos @name
loc.hBoxed = if @lhs.visCyclic then empty else text "!"
| Inh loc.hFldNm = hInhFldNm @name @loc.itfNm @loc.visNm
lhs.hInhDeclPPs = [hWrapLinePragma @lhs.opts (identPos @name) (@loc.hFldNm >#< "::" >#< @loc.hBoxed >|< @loc.hTpPP)]
| Syn loc.hFldNm = hSynFldNm @name @loc.itfNm @loc.visNm
lhs.hSynDeclPPs = [hWrapLinePragma @lhs.opts (identPos @name) (@loc.hFldNm >#< "::" >#< @loc.hBoxed >|< @loc.hTpPP)]
| Inh loc.hCoFldNm = hCoSynFldNm @name @loc.itfNm @loc.visNm
lhs.hCoSynDeclPPs = [hWrapLinePragma @lhs.opts (identPos @name) (@loc.hCoFldNm >#< "::" >#< @loc.hBoxed >|< @loc.hTpPP)]
| Syn loc.hCoFldNm = hCoInhFldNm @name @loc.itfNm @loc.visNm
lhs.hCoInhDeclPPs = [hWrapLinePragma @lhs.opts (identPos @name) (@loc.hCoFldNm >#< "::" >#< @loc.hBoxed >|< @loc.hTpPP)]
{
stripSpacing :: String -> PP_Doc
stripSpacing = pp_block "(" ")" " " . map text . lines
}
SEM Data | Data
lhs.hpp = "data" >#< hDtNm @name >#< hlist_sp @vars.hpps >-< indent 2 (vlist @cons.hpps) >-< indent 2 @loc.hExts
loc.hExts = if Set.null @exts.gathExts
then empty
else "deriving" >#< pp_block "(" ")" "," [ text (show i) | i <- Set.toList @exts.gathExts ]
SEM Con | Con
loc.prefix = if @lhs.isFirst then "=" else "|"
lhs.hpp = @loc.prefix >#< @loc.hVarsPP >#< hConNm @lhs.data @name >#< pp_block "{" "}" "," @fields.hpps
loc.hVarsPP = if null @vars.vars
then empty
else "forall" >#< hlist_sp (map (text .show) @vars.vars) >#< "."
SEM Field | Field
loc.txtTp = either show id @type.fldType
lhs.hpp = hFldNm @lhs.data @lhs.con @name >#< "::" >#< "!" >|< hParensWithPos @lhs.opts (identPos @name) (stripSpacing @loc.txtTp)
ATTR Cons Con [ isFirst : Bool | | ]
SEM Data | Data cons.isFirst = True
SEM Cons | Cons tl.isFirst = False
SEM Type | Alias
lhs.hpp = "type" >#< @name >#< hlist_sp @vars.hpps >#< "=" >#< @type.hpp
SEM AliasType
| Prod lhs.hpp = pp_block "(" ")" "," (map (text . show) @fields)
| List lhs.hpp = pp_brackets $ text $ show @type
| Maybe lhs.hpp = "Maybe" >#< pp_parens (text $ show @type)
SEM DataSem | Sem
lhs.hpp = hDtSemNm @tp >#< "::" >#< @loc.hppType
>-< hDtSemNm @tp >#< "="
>-< indent 4 @clauses.hpp
loc.hppType = case @mbMonad of
Nothing -> "(Monad m, MonadError e m, Error e) => " >#< hItfNm @tp >#< "m"
Just t -> hItfNm @tp >#< pp_parens (stripSpacing t)
SEM BoundCode
| Code lhs.hpp = @code.hpp -- deal with binder etc in parent
SEM MaybeBoundCode
| Nothing lhs.hpp = empty
SEM Code
| Code lhs.hpp = vlist @items.hpps
SEM Item
| Plain lhs.hpp = if all isSpace @txt
then empty
else vlist $ modifySpacing @loc.diff @lhs.indent @txt
| Attr lhs.hpp = addSpaces @loc.diff $ @tp.hpp
| Sem CoSem lhs.hpp = addSpaces @loc.diff ( pp_parens (
"let" >#< (hNt @name >#< "::" >#< @loc.hppType)
>-< indent 4 (hNt @name >#< "=")
>-< indent 6 @first.hpp
>-< "in" >#< hNt @name ))
| DataSem lhs.hpp = @sem.hpp
| Detach lhs.hpp = addSpaces @loc.diff (text $ hSemNm @name @visit)
| Brackets lhs.hpp = addSpaces @loc.diff (text "{")
>-< vlist @items.hpps
>-< addSpaces @loc.diff2 (text "}")
| Construct lhs.hpp = addSpaces @loc.diff (pp_parens @loc.hpp)
loc.hFldsPPs = sortPairs @fields.hopps
loc.hpp = case @mbAlias of
Nothing -> hConNm @data @con >#< hlist_sp @loc.hFldsPPs
Just alias -> case alias of
AliasType_Prod _ -> pp_block "(" ")" "," @loc.hFldsPPs
AliasType_List _ -> if @con == ident "Cons"
then "(:)" >#< hlist_sp @loc.hFldsPPs
else text "[]"
AliasType_Maybe _ -> if @con == ident "Nothing"
then "Just" >#< hlist_sp @loc.hFldsPPs
else text "Nothing"
{
hWrapLinePragma :: PP a => Opts -> Pos -> a -> PP_Doc
hWrapLinePragma opts pos doc
| isJust (outputFile opts) && not (hNoLinePragmas opts)
= let nrIn = line pos
nmIn = file pos
nmOut = fromJust (outputFile opts)
in ""
>-< "{-# LINE" >#< show nrIn >#< show nmIn >#< "#-}"
>-< doc
>-< "{-# LINE" >#< ppWithLineNr (\n -> pp $ show $ n + 1) >#< show nmOut >#< "#-}"
>-< ""
| otherwise = pp doc
}
ATTR Item [ | | hppType : PP_Doc ]
SEM Item
| Plain Attr Detach Brackets Construct
loc.hppType = text "{- cannot be used toplevel -}"
| Sem loc.hppType = case @mbMonad of
Nothing -> "(Monad m, MonadError e m, Error e) => " >#< hItfNm @tp >#< "m"
Just t -> hItfNm @tp >#< pp_parens (stripSpacing t)
| CoSem loc.hppType = case @mbMonad of
Nothing -> "(Monad m, MonadError e m, Error e) => " >#< hCoItfNm @tp @visit >#< "m"
Just t -> hCoItfNm @tp @visit >#< pp_parens (stripSpacing t)
| DataSem
loc.hppType = text "{- no type signature for nested datatype semantics -}"
SEM SemVisit
| Visit loc.hChildren = hlist_sp [ hSemNm k v | (k, Just v) <- Map.assocs @loc.myNextVisits ]
loc.hChns = [ hParensWithPos @lhs.opts @pos $ hInp visIdent nm | (nm,_) <- Map.assocs @attrs.gathVisitLocalAttrs ]
loc.hChnsOut = [ hParensWithPos @lhs.opts @pos $ hOutp @name nm | (nm,_) <- Map.assocs @attrs.gathVisitLocalAttrs ]
loc.hInhPPs = [ hInhFldNm nm @loc.itfNm @name >#< "=" >#< hParensWithPos @lhs.opts @pos (hInp lhsIdent nm)
| (nm,_) <- Map.assocs @loc.inhAttrMap ]
loc.hMatch = pp_parens (hInhDt @loc.itfNm @name >#< pp_block "{" "}" "," @loc.hInhPPs)
loc.hVisType = if @lhs.withinCoSem
then text (hCoItfVsNm @lhs.coItf @name)
else text (hItfVsNm @loc.itfNm @name)
lhs.hpp = pp_parens (
"let -- __vis ::" >#< @loc.hVisType
>-< " __vis =" >#< (
"let" >#< ( hVis @name >#< @loc.hChildren >#< @loc.hChns >#< @loc.hMatch
>-< indent 2 (
"=" >#< ( if @loc.fullCyclic
then "let" >#< vlist (concat @loc.hGroupedStmts)
>-< "in" >#< @clauses.hpp
else "do" >#< (
hppStmtBlock @loc.hGroupedStmts
>-< @clauses.hpp
)
)
)
)
>-< "in" >#< hItfVsNm @loc.itfNm @name >#<
pp_parens (hVis @name >#< @loc.hChildren >#< @loc.hChnsOut)
) >-< "in __vis"
)
| Internal lhs.hpp = hppStmtBlock @loc.hGroupedStmts
>-< @clauses.hpp
| End lhs.hpp = if @lhs.fullCyclic
then vlist @loc.hGroupedStmts -- assume these end up in a let-block or do-block
else hppStmtBlock @loc.hGroupedStmts
{
hppStmtBlock :: PP a => [[a]] -> PP_Doc
hppStmtBlock = vlist . map ppComp
where ppComp [] = empty
ppComp [x] = pp x
ppComp xs = "let" >#< vlist (map pp xs)
}
SEM Clauses
| Cons lhs.hpp = if @lhs.fullCyclic
then @hd.hpp -- only one clause
else pp_parens (hCatch @hd.hpp ("\\_ -> " >#< @tl.hpp))
| Nil lhs.hpp = if @lhs.fullCyclic
then text "undefined" -- never generated when there is only one clause
else pp_parens (hThrow ("no applicable clause for " ++ show (head @lhs.itf) ++ "." ++ show @lhs.visit))
SEM Clause
| Clause loc.hChildren = hlist_sp [ hSemNm k v | (k, Just v) <- Map.assocs @lhs.myNextVisits ]
loc.hChns = hlist_sp [ hParensWithPos @lhs.opts @pos $ hInp visIdent nm
| (nm,_) <- Map.assocs @lhs.directVisitLocalAttrs ]
loc.hNext = maybe [] (\nm -> [ hSynFldNmFull nextIdent @loc.itfNm @lhs.visit >#< "= _visNext" ]) @next.mbNextVisit
loc.hVisLocs = [ hInp visIdent @lhs.visit >#< "=" >#< hParensWithPos @lhs.opts @pos (hOutp visIdent nm)
| (nm,_) <- Map.assocs @lhs.directVisitLocalAttrs ]
loc.hRestart = "_visRestart =" >#< hItfVsNm @loc.itfNm @lhs.visit
>#< pp_parens (hVis @lhs.visit >#< @loc.hChildren >#< @loc.hChns)
loc.hResVal = pp_parens ( hSynDt @loc.itfNm @lhs.visit
>#< pp_block "{" "}" "," ( [hSynFldNmFull repIdent @loc.itfNm @lhs.visit >#< "= _visRestart" ] ++
@loc.hNext ++
[ hSynFldNm nm @loc.itfNm @lhs.visit >#< "=" >#<
hParensWithPos @lhs.opts @pos (hOutp lhsIdent nm)
| (nm,_) <- Map.assocs @loc.synAttrMap ] ))
lhs.hpp = if @lhs.fullCyclic
then "let" >#< (
vlist (concat @loc.hGroupedStmts)
>-< vlist @loc.hVisLocs
>-< @loc.hRestart
>-< case @next.mbNextVisit of
Nothing -> @next.hpp -- remaining stmts
Just _ -> "_visNext" >#< "=" >#< @next.hpp
)
>-< "in" >#< @loc.hResVal
else "do" >#< (
hppStmtBlock @loc.hGroupedStmts
>-< if @loc.isDeepest
then vlist (map ("let" >#<) @loc.hVisLocs)
>-< "let" >#< ( "!" >|< @loc.hRestart
>-< case @next.mbNextVisit of
Nothing -> empty
Just _ -> "!" >|< "_visNext" >#< "=" >#< @next.hpp
)
>-< case @next.mbNextVisit of
Nothing -> @next.hpp
Just _ -> empty
>-< "return" >#< @loc.hResVal
else @next.hpp -- continue with the deeper clauses
)
{
hParensWithPos :: PP a => Opts -> Pos -> a -> PP_Doc
hParensWithPos opts pos doc
= ""
>-< "("
>-< indent 2 (hWrapLinePragma opts pos doc)
>-< " )"
>-< ""
}
SEM Stmt
| Eval loc.infoComment = "-- eval stmt:" >#< show (line @loc.pos) >#< ", rank:" >#< @loc.rank
>#< ", dest: " >#< show @loc.destVisit
lhs.hpp = hWrapLinePragma @lhs.opts @loc.pos $
if @loc.isCyclic
then ppBindPos @lhs.opts @loc.pos @loc.isCyclic @pat.hpp @code.hpp >#< "-- rank:" >#< show @loc.rank
else if @mode.isMatch
then ppBindPos @lhs.opts @loc.pos False @pat.hpp (hppWrapRet @code.isFun @code.hpp)
>#< @loc.infoComment
else ppBindPos @lhs.opts @loc.pos False ("!" >|< "__fresh") (hppWrapRet @code.isFun @code.hpp)
>-< "let" >#< pp_parens @pat.hpp >#< "= __fresh" >#< @loc.infoComment
| Attach loc.infoComment = "-- attach stmt:" >#< show (line @pos) >#< ", rank:" >#< @loc.rank
lhs.hpp = ppBind @loc.isCyclic (hSemNm @name @loc.visit) @loc.hRhsCode >#< @loc.infoComment
loc.hRhsCode = if @code.isJust
then hppWrapRet @code.isFun @code.hpp
else "return" >#< pp_parens (text $ hDtSemNm @type)
| Invoke loc.infoComment = "-- invoke stmt:" >#< show (line @pos) >#< ", rank:" >#< @loc.rank
loc.hBang = if @loc.behaveCyclic then empty else text "!"
lhs.hpp = (if @loc.isCyclic
then vlist (concat @loc.hGroupedStmts)
else hppStmtBlock @loc.hGroupedStmts)
>-< if @code.isJust
then ppBind @loc.isCyclic @loc.hPat ("let" >#< @loc.hIter >-< "in" >#< @loc.hRhs) >#< @loc.infoComment
else ppBind @loc.isCyclic (@loc.hBang >|< @loc.hPat)
((\p -> if not @loc.isCyclic && @loc.behaveCyclic then "return" >#< pp_parens p else p) (
("let" >#< @loc.hBang >|< pp_parens (hItfVsNm @loc.unqualChildItf @visit
>#< "!" >|< "__f")
>#< "=" >#< hSemNm @name @visit
>-< "in" >#< "__f" >#< @loc.hfInps)))
>#< @loc.infoComment
loc.hRhsCode = if @code.isJust
then @code.hpp
else "return" >#< pp_parens ("mk" >|< noIterNm @loc.unqualChildItf @visit)
loc.hIter = "__iter" >#< "!" >|< pp_parens (hItfVsNm @loc.unqualChildItf @visit >#< "!" >|< "__f")
>#< @loc.hfInps
>-< indent 2 ( "=" >#< "do" >#< (
"!" >|< ppBind False (hCoItfVsNm @loc.unqualChildItf @visit >#< "!" >|< "__g") @loc.hRhsCode
>-< ppBind @loc.behaveCyclic (@loc.hBang >|< "__res@" >|< @loc.hfOuts) ("__f" >#< @loc.hfInps)
>-< hCatch ("do" >#< (
@loc.hBang >|< ppBind False @loc.hgOuts ("__g" >#< @loc.hgInps)
>-< "__iter" >#< "__f" >#< @loc.hfInps
))
(text "const (return __res)")
))
loc.hfInps = pp_parens (hInhDt @loc.unqualChildItf @visit >#< pp_block "{" "}" ","
[ hInhFldNm nm @loc.unqualChildItf @visit >#< "=" >#<
hParensWithPos @lhs.opts @pos (hOutp @name nm)
| (nm,_) <- Map.assocs @loc.inhAttrMap ] )
loc.hfOuts = pp_parens (hSynDt @loc.unqualChildItf @visit >#< pp_block "{" "}" ","
( (hSynFldNmFull repIdent @loc.unqualChildItf @visit >#< "=" >#< "__f") :
[ hSynFldNm nm @loc.unqualChildItf @visit >#< "=" >#<
hParensWithPos @lhs.opts @pos (hInp @name nm)
| (nm,_) <- Map.assocs @loc.synAttrMap ] ))
loc.hgInps = pp_parens (hCoInhDt @loc.unqualChildItf @visit >#< pp_block "{" "}" ","
[ hCoInhFldNm nm @loc.unqualChildItf @visit >#< "=" >#<
hParensWithPos @lhs.opts @pos (hInp @name nm)
| (nm,_) <- Map.assocs @loc.synAttrMap ] )
loc.hgOuts = pp_parens (hCoSynDt @loc.unqualChildItf @visit >#< pp_block "{" "}" ","
[ hCoSynFldNm nm @loc.unqualChildItf @visit >#< "=" >#<
hParensWithPos @lhs.opts @pos (hOutp @name nm)
| (nm,_) <- Map.assocs @loc.inhAttrMap ] )
loc.hRhs = "__iter" >#< hSemNm @name @visit >#< @loc.hfInps
loc.hPat = pp_parens (
hSynDt @loc.unqualChildItf @visit >#< pp_block "{" "}" "," (
( maybe [] (\nm -> [ hSynFldNmFull nextIdent @loc.unqualChildItf @visit >#< "=" >#< hSemNm @name nm ])
@loc.mbNextVisit) ++
[ hSynFldNm nm @loc.unqualChildItf @visit >#< "=" >#< hInp @name nm
| (nm,_) <- Map.assocs @loc.synAttrMap ]
))
| Default loc.infoComment = "-- default stmt:" >#< show (line @pos) >#< ", rank:" >#< @loc.rank
lhs.hpp = if @loc.isCyclic
then ppBind True (text $ hDfltNm @name @loc.codeId) @mbCode.hpp >#< @loc.infoComment
else if @mbCode.isJust
then ppBindPos @lhs.opts @pos False ("!" >|< "__fresh") (hppWrapRet @mbCode.isFun @mbCode.hpp)
>-< "let" >#< pp_parens (text $ hDfltNm @name @loc.codeId) >#< "= __fresh" >#< @loc.infoComment
else empty
| Rename lhs.hpp = empty
SEM ImplStmt
| Invoke
loc.hBang = if @loc.behaveCyclic then empty else text "!"
lhs.hpp = (if @loc.isCyclic
then vlist (concat @loc.hGroupedStmts)
else hppStmtBlock @loc.hGroupedStmts)
>-< ppBind @loc.isCyclic
(@loc.hBang >|< @loc.hPat)
((\p -> if not @loc.isCyclic && @loc.behaveCyclic then "return" >#< pp_parens p else p) (
"let" >#< @loc.hBang >|< pp_parens (hItfVsNm @itf @visit >#< "!" >|< "__f")
>#< "=" >#< hSemNm @child @visit
>-< "in" >#< "__f" >#< @loc.hfInps))
>#< "-- implicit invoke: " >#< show @child >|< "." >|< show @visit
loc.hfInps = pp_parens (hInhDt @itf @visit >#< pp_block "{" "}" ","
[ hInhFldNm nm @itf @visit >#< "=" >#<
hParensWithPos @lhs.opts @pos (hOutp @child nm)
| (nm,_) <- Map.assocs @loc.inhAttrMap ] )
loc.hPat = pp_parens (
hSynDt @itf @visit >#< pp_block "{" "}" "," (
( maybe [] (\nm -> [ hSynFldNmFull nextIdent @itf @visit >#< "=" >#< hSemNm @child nm ])
@loc.mbNextVisit) ++
[ hSynFldNm nm @itf @visit >#< "=" >#< hParensWithPos @lhs.opts @pos (hInp @child nm)
| (nm,_) <- Map.assocs @loc.synAttrMap ]
))
| DefaultChild
lhs.hpp = @loc.hPrefix >|< hParensWithPos @lhs.opts @pos (hOutp @child @name)
>#< "=" >#< pp_parens @loc.hApp >#< "-- default rule for inh: " >#< show @child >|< "." >|< show @name
| DefaultSyn
lhs.hpp = @loc.hPrefix >|< hParensWithPos @lhs.opts @pos (hOutp lhsIdent @name)
>#< "=" >#< pp_parens @loc.hApp >#< "-- default rule for syn: " >#< show lhsIdent >|< "." >|< show @name
| DefaultChild DefaultSyn
loc.hApp = @loc.hFun >#< pp_block "[" "]" "," (reverse @loc.hInps)
loc.hInps = (if @loc.lhsHasAttr then [text $ hInp lhsIdent @name] else []) ++ map (\(c,a) -> text $ hInp c a) @loc.childAttrs
loc.hFun = case @mbCodeRef of
Nothing -> text "head"
Just ref -> hParensWithPos @lhs.opts @pos $ hDfltNm @name ref
| DefaultVisLocal
lhs.hpp = @loc.hPrefix >|< hParensWithPos @lhs.opts @pos (hOutp visIdent @name) >#< "="
>#< hParensWithPos @lhs.opts @pos (hInp visIdent @name)
>#< "-- default rule for vis-local: " >#< show @name
| DefaultChild DefaultSyn DefaultVisLocal
loc.hPrefix = if @loc.isCyclic then empty else text "let "
{
ppBind :: (PP a, PP b) => Bool -> a -> b -> PP_Doc
ppBind True pat expr = pp_parens (pp pat) >#< "=" >-< indent 2 (pp_parens (pp expr))
ppBind False pat expr = pp_parens (pp pat) >#< "<-" >-< indent 2 (pp_parens (pp expr))
ppBindPos :: (PP a, PP b) => Opts -> Pos -> Bool -> a -> b -> PP_Doc
-- ppBindPos _ _ = ppBind
ppBindPos opts pos True pat expr = hWrapLinePragma opts pos (pp pat) >#< "=" >-< indent 2 (hWrapLinePragma opts pos (pp expr))
ppBindPos opts pos False pat expr = hWrapLinePragma opts pos (pp pat) >#< "<-" >-< indent 2 (hWrapLinePragma opts pos (pp expr))
hppWrapRet :: PP a => Bool -> a -> PP_Doc
hppWrapRet True d = "return" >#< pp_parens (pp d)
hppWrapRet False d = pp d
}
SEM Pat
| Con lhs.hpp = @loc.hBang >|< hParensWithPos @lhs.opts (identPos @name) (@name >#< hlist_sp @pats.hpps)
| AttrCon lhs.hpp = @loc.hBang >|< (pp_parens @loc.hpp)
loc.hFldsPPs = [ hParensWithPos @lhs.opts (identPos @name) (hOutpLoc @name nm) | (nm,_) <- @loc.fields ]
loc.hBangFldsPPs = map (@loc.hBang >|<) @loc.hFldsPPs
loc.hpp = case @mbAlias of
Nothing -> hConNm @dt @con >#< hlist_sp @loc.hFldsPPs
Just alias -> case alias of
AliasType_Prod _ -> pp_block "(" ")" "," @loc.hBangFldsPPs
AliasType_List _ -> if @con == ident "Cons"
then "(:)" >#< hlist_sp @loc.hBangFldsPPs
else text "[]"
AliasType_Maybe _ -> if @con == ident "Nothing"
then text "Nothing"
else "Just" >#< hlist_sp @loc.hBangFldsPPs
| Attr lhs.hpp = @loc.hBang >|< hParensWithPos @lhs.opts (identPos @child) @tp.hpp
| Tup lhs.hpp = @loc.hBang >|< pp_block "(" ")" "," @pats.hpps
| List lhs.hpp = @loc.hBang >|< pp_block "[" "]" "," @pats.hpps
| Cons lhs.hpp = @loc.hBang >|< pp_parens (@hd.hpp >#< ":" >#< pp_parens @tl.hpp)
| Underscore lhs.hpp = @loc.hBang >|< text "_"
| * loc.hBang = if @lhs.isCyclic then empty else text "!"
SEM ExprField | Field
lhs.hopp = (@loc.fieldIndex, pp_parens @code.hpp)
SEM Var | Var
lhs.hpp = text (show @name)
SEM AttrTypePat
| ProdLocal lhs.hpp = text $ hOutpLoc @lhs.child @lhs.name
| VisLocal Lhs Child Visit
lhs.hpp = text $ hOutp @lhs.child @lhs.name
SEM AttrTypeCode
| ProdLocal lhs.hpp = text $ hInpLoc @lhs.child @lhs.name
| VisLocal Lhs Child Visit
lhs.hpp = text $ hInp @lhs.child @lhs.name
ATTR BlocksTop Blocks ItfVisits Items Pats Cons Fields Vars
[ | | hpps : {[PP_Doc]} ]
SEM BlocksTop
| Top lhs.hpps = @blocks.hpps ++ (if noDataGen @lhs.opts then [] else @extra.hpps)
| None lhs.hpps = []
SEM Blocks
| Cons lhs.hpps = @hd.hpp : @tl.hpps
| Nil lhs.hpps = []
SEM ItfVisits
| Cons lhs.hpps = @hd.hpp : @tl.hpps
| Nil lhs.hpps = []
SEM Cons
| Cons lhs.hpps = @hd.hpp : @tl.hpps
| Nil lhs.hpps = []
SEM Fields
| Cons lhs.hpps = @hd.hpp : @tl.hpps
| Nil lhs.hpps = []
SEM Items
| Cons lhs.hpps = @hd.hpp : @tl.hpps
| Nil lhs.hpps = []
SEM Pats
| Cons lhs.hpps = @hd.hpp : @tl.hpps
| Nil lhs.hpps = []
SEM Vars
| Cons lhs.hpps = @hd.hpp : @tl.hpps
| Nil lhs.hpps = []
--
-- Compute spread of stmts
--
ATTR AllFinal [ hSpilledStmts : {[(Int,PP_Doc)]} | | ]
SEM Program | Program blocks.hSpilledStmts = []
SEM SemVisit | Visit Internal
(loc.hoStmts, clauses.hSpilledStmts) = partition (rankIsLower @clauses.minRank)
(@lhs.hSpilledStmts ++ @impls.hopps ++ @stmts.hopps)
loc.hGroupedStmts = groupPairs @loc.hoStmts
SEM SemVisit | End
loc.hGroupedStmts = groupPairs @lhs.hSpilledStmts
SEM Clause | Clause
(loc.hoStmts, next.hSpilledStmts) = partition (rankIsLower @next.minRank)
(@lhs.hSpilledStmts ++ @deflts.hopps ++ @impls.hopps ++ @stmts.hopps)
loc.hGroupedStmts = groupPairs @loc.hoStmts
SEM Stmt | Invoke loc.hGroupedStmts = groupPairs @deflts.hopps
SEM ImplStmt | Invoke loc.hGroupedStmts = groupPairs @deflts.hopps
{
rankIsLower :: Int -> (Int, PP_Doc) -> Bool
rankIsLower m (n,_) = n < m
}
--
-- Certain fields need to be ordered
--
ATTR Stmts ImplStmts
[ | | hopps : {[(Int, PP_Doc)]} ]
SEM ImplStmts
| Cons lhs.hopps = (@hd.rank, @hd.hpp) : @tl.hopps
| Nil lhs.hopps = []
SEM Stmts
| Cons lhs.hopps = (@hd.rank, @hd.hpp) : @tl.hopps
| Nil lhs.hopps = []
ATTR ExprFields
[ | | hopps : {[(Int,PP_Doc)]} ]
SEM ExprFields
| Cons lhs.hopps = @hd.hopp : @tl.hopps
| Nil lhs.hopps = []
{
sortPairs :: [(Int,a)] -> [a]
sortPairs = map snd . sortBy (\(x,_) (y,_) -> x `compare` y)
groupPairs :: [(Int,a)] -> [[a]]
groupPairs = map (map snd) . groupBy (\(x,_) (y,_) -> x == y) . sortBy (\(x,_) (y,_) -> x `compare` y)
}