-- 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) }