-- This file is included by Transform.ag -- Based on the AST of AstAG.ag -- Generates code for Javascript SEM Program | Program +pp = if genJs @lhs.opts then (@loc.jspp >-<) else id { jsInp 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 jsOutp 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 jsDtSemNm nm = "dnt_" ++ show nm jsVis nm vis = "vis_" ++ show nm ++ "_" ++ show vis jsConNm dt nm = show dt ++ "_" ++ show nm } SEM Program | Program loc.jspp = vlist @blocks.jspps ATTR Block Itf ItfVisit Data Con Field Type AliasType DataSem MaybeBoundCode BoundCode Code Item SemVisit ClausesTop Clauses Clause Stmt Pat ImplStmt Var AttrTypePat AttrTypeCode [ | | jspp : {PP_Doc} ] ATTR ExprField [ | | jsopp : {(Int,PP_Doc)} ] SEM Block | Section lhs.jspp = @code.jspp | Itf lhs.jspp = @itf.jspp | Data lhs.jspp = @data.jspp | Type lhs.jspp = empty | Item lhs.jspp = "var mk" >|< show @name >#< "=" >-< indent 2 @item.jspp | DataSem lhs.jspp = @sem.jspp SEM Itf | Itf lhs.jspp = vlist @visits.jspps SEM ItfVisit | Visit lhs.jspp = empty loc.jsInhNm = "Inh_" >|< jsConNm @loc.itfNm @name loc.jsSynNm = "Syn_" >|< jsConNm @loc.itfNm @name +jspp = ("function" >#< @loc.jsInhNm >#< "() {}" >-< @loc.jsInhNm >|< ".prototype.check = function()" >-< indent 2 (pp_braces ( vlist [ jsTpCheck nm tp | (nm,tp) <- Map.assocs @attrs.gathVisitInhAttrs ] )) >-< "function" >#< @loc.jsSynNm >#< "() {}" >-< @loc.jsSynNm >|< ".prototype.check = function()" >-< indent 2 (pp_braces ( vlist [ jsTpCheck nm tp | (nm,tp) <- Map.assocs @attrs.gathVisitSynAttrs ] )) ) >-< { jsTpCheck nm tp = "var _val = this." >|< show nm >|< ";" >-< "if (_val === undefined) { throw \"Undefined attribute: " >|< show nm >|< "\"; }" >-< if all isSpace tp then empty else "var _assert =" >#< tp >#< ";" >-< "if (!_assert) { throw \"Assert function undefined\"; }" >-< "var _outcome = _assert(_val);" >-< "if (!_outcome) { throw \"Attribute fails predicate: " >|< show nm >|< "\"; }" } SEM Data | Data lhs.jspp = "function" >#< show @name >#< "() {}" >-< vlist @cons.jspps SEM Con | Con lhs.jspp = "function" >#< jsConNm @lhs.data @name >#< pp_block "(" ")" "," @fields.jspps >-< pp_braces ( vlist [ "this." >|< nmPP >#< "=" >#< nmPP >|< ";" | nmPP <- @fields.jspps ] >-< vlist @fields.jsChecksPPs ) >-< jsConNm @lhs.data @name >|< ".prototype = new " >#< show @lhs.data >|< "();" >-< jsConNm @lhs.data @name >|< ".prototype.constructor =" >#< jsConNm @lhs.data @name >|< ";" ATTR Fields Field [ | | jsChecksPPs USE {++} {[]} : {[PP_Doc]} ] ATTR FieldType [ | | jsCheckPP : {Maybe PP_Doc} ] SEM Field | Field lhs.jspp = text $ show @name lhs.jsChecksPPs = [ "var _val = " >#< show @name >|< ";" >-< "if (_val === undefined) { throw \"Field undefined: " >|< show @name >|< "\";}" >-< case @type.jsCheckPP of Nothing -> text "_outcome = true;" Just p -> p >-< "if" >#< pp_parens ("!_outcome") >#< pp_braces ("throw \"Field fails predicate: " >|< show @name >|< "\";") ] SEM FieldType | Term lhs.jsCheckPP = if all isSpace @type then Nothing else Just ("var _assert =" >#< @type >|< ";" >-< "if (!_assert) { throw \"assert function undefined\"; }" >-< "var _outcome = _assert(_val);") | Nonterm lhs.jsCheckPP = case @loc.mbAlias of Nothing -> Just ("var _outcome = _val instanceof" >#< show @name >|< ";") Just alias -> case alias of AliasType_Prod _ -> Just $ text ("var _outcome = _val instanceof Tuple;") AliasType_List _ -> Just $ text ("var _outcome = _val instanceof Array;") AliasType_Maybe _ -> Just $ text ("var _outcome = _val instanceof Maybe;") SEM Type | Alias lhs.jspp = empty SEM AliasType | Prod lhs.jspp = empty | List lhs.jspp = empty | Maybe lhs.jspp = empty SEM DataSem | Sem lhs.jspp = "var dnt_" >|< show @tp >#< "=" >#< pp_parens ( "function ()" >-< pp_braces ( "var" >#< "nt" >|< show @tp >#< "=" >#< @clauses.jspp >|< ";" >-< "return" >#< "nt" >|< show @tp >|< ";" )) >|< ";" SEM BoundCode | Code lhs.jspp = @code.jspp -- deal with binder etc in parent SEM MaybeBoundCode | Nothing lhs.jspp = empty SEM Code | Code lhs.jspp = vlist @items.jspps SEM Item | Plain lhs.jspp = if all isSpace @txt then empty else vlist $ modifySpacing @loc.diff @lhs.indent @txt | Attr lhs.jspp = addSpaces @loc.diff @tp.jspp | Sem CoSem lhs.jspp = addSpaces @loc.diff (pp_parens ( "function ()" >-< pp_braces ( "var" >#< "nt" >|< show @name >#< "=" >#< @first.jspp >|< ";" >-< "return" >#< "nt" >|< show @name >|< ";" ) )) | DataSem lhs.jspp = @sem.jspp | Detach lhs.jspp = addSpaces @loc.diff empty | Brackets lhs.jspp = addSpaces @loc.diff (text "{") >-< vlist @items.jspps >-< addSpaces @loc.diff2 (text "}") | Construct lhs.jspp = addSpaces @loc.diff (pp_parens @loc.jspp) loc.jspp = case @mbAlias of Nothing -> empty Just alias -> case alias of AliasType_Prod _ -> empty AliasType_List _ -> empty AliasType_Maybe _ -> empty SEM SemVisit | Visit lhs.jspp = "function (_inps)" >-< pp_braces ( "_inps.check();" >-< vlist [ "var" >#< jsInp lhsIdent nm >#< "=" >#< "_inps." >|< show nm >|< ";" | (nm,_) <- Map.assocs @loc.inhAttrMap ] >-< jsppStmtBlock @loc.jsGroupedStmts >-< @clauses.jspp ) | Internal lhs.jspp = jsppStmtBlock @loc.jsGroupedStmts >-< @clauses.jspp | End lhs.jspp = if @lhs.fullCyclic then vlist @loc.jsGroupedStmts else jsppStmtBlock @loc.jsGroupedStmts { jsppStmtBlock :: PP a => [[a]] -> PP_Doc jsppStmtBlock = vlist . map ppComp where ppComp [] = empty ppComp [x] = pp x ppComp xs = vlist (map pp xs) } SEM Clauses | Cons lhs.jspp = if @lhs.fullCyclic then @hd.jspp -- only one clause else "try" >#< pp_braces ( @hd.jspp ) >-< "catch (err)" >#< pp_braces ( "if (err == eEval)" >-< pp_braces ( @tl.jspp ) >-< "else" >#< pp_braces ( text "throw err;" ) ) | Nil lhs.jspp = text "throw eEval;" SEM Clause | Clause lhs.jspp = jsppStmtBlock @loc.jsGroupedStmts >-< if @loc.isDeepest then "var _outs = new Syn_" >|< jsConNm (head @lhs.itf) @lhs.visit >|< "();" >-< case @next.mbNextVisit of Just _ -> "_outs._next = " >#< @next.jspp >|< ";" Nothing -> @next.jspp >-< vlist [ "_outs." >|< show nm >#< "=" >#< jsOutp lhsIdent nm >|< ";" | (nm,_) <- Map.assocs @loc.synAttrMap ] >-< "return _outs;" else @next.jspp SEM Stmt | Eval lhs.jspp = ( if not @mode.isMatch then "var _res; try" >#< pp_braces ("_res =" >#< @code.jspp >|< ";") >-< "catch(err) { if (err == eEval) { throw eAbort; } else { throw err; } }" else "var _res = " >#< @code.jspp ) >|< ";" >-< @pat.jspp pat.isMatch = @mode.isMatch | Attach lhs.jspp = "var _semantics =" >#< @loc.jsRhsCode >|< ";" >-< "if (!_semantics) { throw \"Undefined semantics: " >|< show @name >|< "\"; }" >-< "var" >#< jsVis @name @visit >#< "= _semantics();" >-< "if (!" >|< jsVis @name @visit >|< ") { throw \"Undefined attached semantics: " >|< show @name >|< "\"; }" loc.jsRhsCode = if @code.isJust then @code.hpp else text $ jsDtSemNm @type | Invoke lhs.jspp = jsppStmtBlock @loc.jsGroupedStmts >-< "var _args = new Inh_" >|< jsConNm @loc.unqualChildItf @visit >|< "();" >-< vlist [ "_args." >|< show nm >#< "=" >#< jsOutp @name nm >|< ";" | (nm,_) <- Map.assocs @loc.inhAttrMap ] >-< "if (!" >|< jsVis @name @visit >|< ") { throw \"uninitialized semantics: ">|< jsVis @name @visit >#< "(expl)\"; }" >-< "var _res =" >#< jsVis @name @visit >#< pp_parens (text "_args") >|< ";" >-< "_res.check();" >-< vlist [ "var" >#< (jsInp @name nm) >#< "=" >#< "_res." >|< show nm >|< ";" | (nm,_) <- Map.assocs @loc.synAttrMap ] >-< case @loc.mbNextVisit of Nothing -> empty Just next -> "var" >#< jsVis @name next >#< "= _res._next;" | Default lhs.jspp = if @mbCode.isJust then "var _def" >|< show @loc.codeId >#< "=" >#< @mbCode.jspp >|< ";" else empty | Rename lhs.jspp = empty SEM ImplStmt | Invoke lhs.jspp = jsppStmtBlock @loc.jsGroupedStmts >-< "var _args = new Inh_" >|< jsConNm @itf @visit >|< "();" >-< vlist [ "_args." >|< show nm >#< "=" >#< jsOutp @child nm >|< ";" | (nm,_) <- Map.assocs @loc.inhAttrMap ] >-< "if (!" >|< jsVis @child @visit >|< ") { throw \"uninitialized semantics: ">|< jsVis @child @visit >#< " (impl)\"; }" >-< "var _res =" >#< jsVis @child @visit >#< pp_parens (text "_args") >|< ";" >-< "_res.check();" >-< vlist [ "var" >#< (jsInp @child nm) >#< "=" >#< "_res." >|< show nm >|< ";" | (nm,_) <- Map.assocs @loc.synAttrMap ] >-< case @loc.mbNextVisit of Nothing -> empty Just next -> "var" >#< jsVis @child next >#< "= _res._next;" | DefaultChild lhs.jspp = "var" >#< hOutp @child @name >#< "=" >#< @loc.jsApp >|< ";" | DefaultSyn lhs.jspp = "var" >#< hOutp lhsIdent @name >#< "=" >#< @loc.jsApp >|< ";" | DefaultChild DefaultSyn loc.jsApp = case @mbCodeRef of Nothing -> @loc.jsArr >|< "[0]" Just ref -> "_def" >|< show ref >#< pp_parens @loc.jsArr loc.jsArr = pp_block "[" "]" "," (reverse @loc.jsInps) loc.jsInps = (if @loc.lhsHasAttr then [text $ jsInp lhsIdent @name] else []) ++ map (\(c,a) -> text $ jsInp c a) @loc.childAttrs | DefaultVisLocal lhs.jspp = empty ATTR Pat Pats [ isMatch : Bool | | ] SEM Pat | Con lhs.jspp = "if (!(_res instanceof" >#< show @name >|< "))" >#< @loc.jsThrow >-< "var _con = _res;" >-< vlist [ "var _res = _con[" >|< show i >|< "];" >-< jspp | (i, jspp) <- zip [0..] @pats.jspps ] | AttrCon lhs.jspp = case @mbAlias of Nothing -> "if (!(_res instanceof" >#< jsConNm @dt @con >|< "))" >#< @loc.jsThrow >-< "var _val = _res;" >-< vlist @loc.jsFieldPPs Just alias -> case alias of AliasType_Prod _ -> "if (!(_res instanceof Tuple))" >#< @loc.jsThrow >-< "if (_res.length != " >|< (show $ length @loc.fields) >|< ")" >#< @loc.jsThrow >-< "var _val = _res;" >-< vlist @loc.jsFieldPPs AliasType_List _ -> if @con == ident "Cons" then "if (!(_res instanceof Array))" >#< @loc.jsThrow >-< "if (_res.length < 1)" >#< @loc.jsThrow >-< "var" >#< hOutp @name (ident "hd") >#< "= _res[0];" >-< "var" >#< hOutp @name (ident "tl") >#< "= _res.slice(1);" else "if (!(_res instanceof Array))" >#< @loc.jsThrow >-< "if (_res.length != 0)" >#< @loc.jsThrow AliasType_Maybe _ -> if @con == ident "Nothing" then "if (!(_res instanceof Maybe_Nothing))" >#< @loc.jsThrow else "if (!(_res instanceof Maybe_Just))" >#< @loc.jsThrow >-< "var _val = _res;" >-< vlist @loc.jsFieldPPs loc.jsFieldPPs = [ "var" >#< hOutp @name nm >#< "= _val." >|< show nm >|< ";" | (nm,_) <- @loc.fields ] | Attr lhs.jspp = "var" >#< @tp.jspp >#< "=" >#< "_res;" | Tup lhs.jspp = "var _tuple = _res;" >-< "if (_tuple.length !=" >#< length (@pats.jspps) >|< ")" >#< @loc.jsThrow >-< vlist [ "var _res = _tuple[" >|< show i >|< "];" >-< jspp | (i, jspp) <- zip [0..] @pats.jspps ] | List lhs.jspp = "var _arr = _res;" >-< "if (_tuple.length !=" >#< length (@pats.jspps) >|< ")" >#< @loc.jsThrow >-< vlist [ "var _res = _arr[" >|< show i >|< "];" >-< jspp | (i, jspp) <- zip [0..] @pats.jspps ] | Cons lhs.jspp = "var _arr = _res;" >-< "if (_arr.length < 1)" >#< @loc.jsThrow >-< "var _res = _arr[0];" >-< @hd.jspp >-< "var _res = _arr.slice(1);" >-< @tl.jspp | Underscore lhs.jspp = empty | Tup List Cons Con AttrCon loc.jsThrow = if @lhs.isMatch then "throw eEval;" else "throw eAbort;" SEM ExprField | Field lhs.jsopp = (@loc.fieldIndex, pp_parens @code.jspp) SEM Var | Var lhs.jspp = text (show @name) SEM AttrTypePat | * lhs.jspp = text $ jsOutp @lhs.child @lhs.name SEM AttrTypeCode | * lhs.jspp = text $ jsInp @lhs.child @lhs.name ATTR BlocksTop Blocks ItfVisits Items Pats Cons Fields Vars [ | | jspps : {[PP_Doc]} ] SEM BlocksTop | Top lhs.jspps = @blocks.jspps | None lhs.jspps = [] SEM Blocks | Cons lhs.jspps = @hd.jspp : @tl.jspps | Nil lhs.jspps = [] SEM ItfVisits | Cons lhs.jspps = @hd.jspp : @tl.jspps | Nil lhs.jspps = [] SEM Cons | Cons lhs.jspps = @hd.jspp : @tl.jspps | Nil lhs.jspps = [] SEM Fields | Cons lhs.jspps = @hd.jspp : @tl.jspps | Nil lhs.jspps = [] SEM Items | Cons lhs.jspps = @hd.jspp : @tl.jspps | Nil lhs.jspps = [] SEM Pats | Cons lhs.jspps = @hd.jspp : @tl.jspps | Nil lhs.jspps = [] SEM Vars | Cons lhs.jspps = @hd.jspp : @tl.jspps | Nil lhs.jspps = [] -- -- Compute spread of stmts -- ATTR AllFinal [ jsSpilledStmts : {[(Int,PP_Doc)]} | | ] SEM Program | Program blocks.jsSpilledStmts = [] SEM SemVisit | Visit Internal (loc.jsoStmts, clauses.jsSpilledStmts) = partition (rankIsLower @clauses.minRank) (@lhs.jsSpilledStmts ++ @impls.jsopps ++ @stmts.jsopps) loc.jsGroupedStmts = groupPairs @loc.jsoStmts SEM SemVisit | End loc.jsGroupedStmts = groupPairs @lhs.jsSpilledStmts SEM Clause | Clause (loc.jsoStmts, next.jsSpilledStmts) = partition (rankIsLower @next.minRank) (@lhs.jsSpilledStmts ++ @deflts.jsopps ++ @impls.jsopps ++ @stmts.jsopps) loc.jsGroupedStmts = groupPairs @loc.jsoStmts SEM Stmt | Invoke loc.jsGroupedStmts = groupPairs @deflts.jsopps SEM ImplStmt | Invoke loc.jsGroupedStmts = groupPairs @deflts.jsopps -- -- Certain fields need to be ordered -- ATTR Stmts ImplStmts [ | | jsopps : {[(Int, PP_Doc)]} ] SEM ImplStmts | Cons lhs.jsopps = (@hd.rank, @hd.jspp) : @tl.jsopps | Nil lhs.jsopps = [] SEM Stmts | Cons lhs.jsopps = (@hd.rank, @hd.jspp) : @tl.jsopps | Nil lhs.jsopps = [] ATTR ExprFields [ | | jsopps : {[(Int,PP_Doc)]} ] SEM ExprFields | Cons lhs.jsopps = @hd.jsopp : @tl.jsopps | Nil lhs.jsopps = []