adamc@16: (* Copyright (c) 2008, Adam Chlipala adamc@16: * All rights reserved. adamc@16: * adamc@16: * Redistribution and use in source and binary forms, with or without adamc@16: * modification, are permitted provided that the following conditions are met: adamc@16: * adamc@16: * - Redistributions of source code must retain the above copyright notice, adamc@16: * this list of conditions and the following disclaimer. adamc@16: * - Redistributions in binary form must reproduce the above copyright notice, adamc@16: * this list of conditions and the following disclaimer in the documentation adamc@16: * and/or other materials provided with the distribution. adamc@16: * - The names of contributors may not be used to endorse or promote products adamc@16: * derived from this software without specific prior written permission. adamc@16: * adamc@16: * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" adamc@16: * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE adamc@16: * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE adamc@16: * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE adamc@16: * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR adamc@16: * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF adamc@16: * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS adamc@16: * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN adamc@16: * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) adamc@16: * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE adamc@16: * POSSIBILITY OF SUCH DAMAGE. adamc@16: *) adamc@16: adamc@244: (* Pretty-printing core Ur/Web *) adamc@16: adamc@16: structure CorePrint :> CORE_PRINT = struct adamc@16: adamc@16: open Print.PD adamc@16: open Print adamc@16: adamc@16: open Core adamc@16: adamc@16: structure E = CoreEnv adamc@16: adamc@16: val debug = ref false adamc@16: adamc@626: fun p_kind' par env (k, _) = adamc@16: case k of adamc@16: KType => string "Type" adamc@626: | KArrow (k1, k2) => parenIf par (box [p_kind' true env k1, adamc@16: space, adamc@16: string "->", adamc@16: space, adamc@626: p_kind env k2]) adamc@16: | KName => string "Name" adamc@626: | KRecord k => box [string "{", p_kind env k, string "}"] adamc@87: | KUnit => string "Unit" adamc@214: | KTuple ks => box [string "(", adamc@626: p_list_sep (box [space, string "*", space]) (p_kind env) ks, adamc@214: string ")"] adamc@16: adamc@626: | KRel n => ((if !debug then adamc@626: string (E.lookupKRel env n ^ "_" ^ Int.toString n) adamc@626: else adamc@626: string (E.lookupKRel env n)) adamc@626: handle E.UnboundRel _ => string ("UNBOUND_REL" ^ Int.toString n)) adamc@626: | KFun (x, k) => box [string x, adamc@626: space, adamc@626: string "-->", adamc@626: space, adamc@626: p_kind (E.pushKRel env x) k] adamc@626: adamc@626: and p_kind env = p_kind' false env adamc@16: adamc@16: fun p_con' par env (c, _) = adamc@16: case c of adamc@16: TFun (t1, t2) => parenIf par (box [p_con' true env t1, adamc@16: space, adamc@16: string "->", adamc@16: space, adamc@16: p_con env t2]) adamc@16: | TCFun (x, k, c) => parenIf par (box [string x, adamc@16: space, adamc@16: string "::", adamc@16: space, adamc@626: p_kind env k, adamc@16: space, adamc@16: string "->", adamc@16: space, adamc@16: p_con (E.pushCRel env x k) c]) adamc@16: | TRecord (CRecord (_, xcs), _) => box [string "{", adamc@16: p_list (fn (x, c) => adamc@20: box [p_name env x, adamc@16: space, adamc@16: string ":", adamc@16: space, adamc@16: p_con env c]) xcs, adamc@16: string "}"] adamc@16: | TRecord c => box [string "$", adamc@16: p_con' true env c] adamc@16: adamc@16: | CRel n => adamc@39: ((if !debug then adamc@39: string (#1 (E.lookupCRel env n) ^ "_" ^ Int.toString n) adamc@39: else adamc@39: string (#1 (E.lookupCRel env n))) adamc@39: handle E.UnboundRel _ => string ("UNBOUND_" ^ Int.toString n)) adamc@16: | CNamed n => adamc@39: ((if !debug then adamc@39: string (#1 (E.lookupCNamed env n) ^ "__" ^ Int.toString n) adamc@39: else adamc@39: string (#1 (E.lookupCNamed env n))) adamc@480: handle E.UnboundNamed _ => string ("UNBOUNDN_" ^ Int.toString n)) adamc@48: | CFfi (m, x) => box [string "FFI(", string m, string ".", string x, string ")"] adamc@16: adamc@16: | CApp (c1, c2) => parenIf par (box [p_con env c1, adamc@16: space, adamc@16: p_con' true env c2]) adamc@16: | CAbs (x, k, c) => parenIf par (box [string "fn", adamc@16: space, adamc@16: string x, adamc@16: space, adamc@16: string "::", adamc@16: space, adamc@626: p_kind env k, adamc@16: space, adamc@16: string "=>", adamc@16: space, adamc@16: p_con (E.pushCRel env x k) c]) adamc@16: adamc@16: | CName s => box [string "#", string s] adamc@16: adamc@16: | CRecord (k, xcs) => adamc@16: if !debug then adamc@16: parenIf par (box [string "[", adamc@16: p_list (fn (x, c) => adamc@16: box [p_con env x, adamc@16: space, adamc@16: string "=", adamc@16: space, adamc@16: p_con env c]) xcs, adamc@16: string "]::", adamc@626: p_kind env k]) adamc@16: else adamc@16: parenIf par (box [string "[", adamc@16: p_list (fn (x, c) => adamc@16: box [p_con env x, adamc@16: space, adamc@16: string "=", adamc@16: space, adamc@16: p_con env c]) xcs, adamc@16: string "]"]) adamc@16: | CConcat (c1, c2) => parenIf par (box [p_con' true env c1, adamc@16: space, adamc@16: string "++", adamc@16: space, adamc@16: p_con env c2]) adamc@621: | CMap _ => string "map" adamc@87: | CUnit => string "()" adamc@214: adamc@214: | CTuple cs => box [string "(", adamc@214: p_list (p_con env) cs, adamc@214: string ")"] adamc@214: | CProj (c, n) => box [p_con env c, adamc@214: string ".", adamc@214: string (Int.toString n)] adamc@626: adamc@626: | CKAbs (x, c) => box [string x, adamc@626: space, adamc@626: string "==>", adamc@626: space, adamc@626: p_con (E.pushKRel env x) c] adamc@626: | CKApp (c, k) => box [p_con env c, adamc@626: string "[[", adamc@626: p_kind env k, adamc@626: string "]]"] adamc@626: | TKFun (x, c) => box [string x, adamc@626: space, adamc@626: string "-->", adamc@626: space, adamc@626: p_con (E.pushKRel env x) c] adamc@16: adamc@16: and p_con env = p_con' false env adamc@16: adamc@20: and p_name env (all as (c, _)) = adamc@20: case c of adamc@20: CName s => string s adamc@20: | _ => p_con env all adamc@20: adamc@109: fun p_enamed env n = adamc@109: (if !debug then adamc@109: string (#1 (E.lookupENamed env n) ^ "__" ^ Int.toString n) adamc@109: else adamc@109: string (#1 (E.lookupENamed env n))) adamc@109: handle E.UnboundNamed _ => string ("UNBOUNDN_" ^ Int.toString n) adamc@109: adamc@177: fun p_con_named env n = adamc@177: (if !debug then adamc@177: string (#1 (E.lookupConstructor env n) ^ "__" ^ Int.toString n) adamc@177: else adamc@177: string (#1 (E.lookupConstructor env n))) adamc@177: handle E.UnboundNamed _ => string ("CONSTRUCTOR_" ^ Int.toString n) adamc@177: adamc@177: fun p_patCon env pc = adamc@177: case pc of adamc@177: PConVar n => p_con_named env n adamc@186: | PConFfi {mod = m, con, ...} => box [string "FFIC(", adamc@185: string m, adamc@185: string ".", adamc@185: string con, adamc@185: string ")"] adamc@177: adamc@177: fun p_pat' par env (p, _) = adamc@177: case p of adamc@177: PWild => string "_" adamc@182: | PVar (s, _) => string s adamc@177: | PPrim p => Prim.p_t p adamc@192: | PCon (_, n, _, NONE) => p_patCon env n adamc@192: | PCon (_, n, _, SOME p) => parenIf par (box [p_patCon env n, adamc@192: space, adamc@192: p_pat' true env p]) adamc@177: | PRecord xps => adamc@177: box [string "{", adamc@182: p_list_sep (box [string ",", space]) (fn (x, p, _) => adamc@177: box [string x, adamc@177: space, adamc@177: string "=", adamc@177: space, adamc@177: p_pat env p]) xps, adamc@177: string "}"] adamc@177: adamc@177: and p_pat x = p_pat' false x adamc@177: adamc@16: fun p_exp' par env (e, _) = adamc@16: case e of adamc@16: EPrim p => Prim.p_t p adamc@16: | ERel n => adamc@39: ((if !debug then adamc@39: string (#1 (E.lookupERel env n) ^ "_" ^ Int.toString n) adamc@39: else adamc@39: string (#1 (E.lookupERel env n))) adamc@39: handle E.UnboundRel _ => string ("UNBOUND_" ^ Int.toString n)) adamc@109: | ENamed n => p_enamed env n adamc@194: | ECon (_, pc, ts, NONE) => box [string "[", adamc@194: p_patCon env pc, adamc@194: p_list_sep (box []) (fn t => box [space, string "[", p_con env t, string "]"]) ts, adamc@194: string "]"] adamc@194: | ECon (_, pc, ts, SOME e) => box [string "[", adamc@193: p_patCon env pc, adamc@193: space, adamc@193: p_exp' true env e, adamc@194: p_list_sep (box []) (fn t => box [space, string "[", p_con env t, string "]"]) ts, adamc@193: string "]"] adamc@48: | EFfi (m, x) => box [string "FFI(", string m, string ".", string x, string ")"] adamc@48: | EFfiApp (m, x, es) => box [string "FFI(", adamc@48: string m, adamc@48: string ".", adamc@48: string x, adamc@48: string "(", adamc@48: p_list (p_exp env) es, adamc@48: string "))"] adamc@487: | EApp (e1, e2) => parenIf par (box [p_exp' true env e1, adamc@16: space, adamc@16: p_exp' true env e2]) adamc@26: | EAbs (x, t, _, e) => parenIf par (box [string "fn", adamc@26: space, adamc@26: string x, adamc@26: space, adamc@26: string ":", adamc@26: space, adamc@26: p_con env t, adamc@26: space, adamc@26: string "=>", adamc@26: space, adamc@26: p_exp (E.pushERel env x t) e]) adamc@16: | ECApp (e, c) => parenIf par (box [p_exp env e, adamc@16: space, adamc@16: string "[", adamc@16: p_con env c, adamc@16: string "]"]) adamc@16: | ECAbs (x, k, e) => parenIf par (box [string "fn", adamc@16: space, adamc@16: string x, adamc@16: space, adamc@16: string "::", adamc@16: space, adamc@626: p_kind env k, adamc@16: space, adamc@16: string "=>", adamc@16: space, adamc@16: p_exp (E.pushCRel env x k) e]) adamc@16: adamc@16: | ERecord xes => box [string "{", adamc@29: p_list (fn (x, e, _) => adamc@21: box [p_name env x, adamc@16: space, adamc@16: string "=", adamc@16: space, adamc@16: p_exp env e]) xes, adamc@16: string "}"] adamc@16: | EField (e, c, {field, rest}) => adamc@16: if !debug then adamc@16: box [p_exp' true env e, adamc@16: string ".", adamc@16: p_con' true env c, adamc@16: space, adamc@16: string "[", adamc@16: p_con env field, adamc@16: space, adamc@16: string " in ", adamc@16: space, adamc@16: p_con env rest, adamc@16: string "]"] adamc@16: else adamc@16: box [p_exp' true env e, adamc@16: string ".", adamc@16: p_con' true env c] adamc@445: | EConcat (e1, c1, e2, c2) => adamc@339: parenIf par (if !debug then adamc@445: box [p_exp' true env e1, adamc@445: space, adamc@445: string ":", adamc@445: space, adamc@445: p_con env c1, adamc@445: space, adamc@445: string "++", adamc@445: space, adamc@445: p_exp' true env e2, adamc@445: space, adamc@445: string ":", adamc@445: space, adamc@445: p_con env c2] adamc@445: else adamc@445: box [p_exp' true env e1, adamc@339: space, adamc@339: string "with", adamc@339: space, adamc@339: p_exp' true env e2]) adamc@149: | ECut (e, c, {field, rest}) => adamc@149: parenIf par (if !debug then adamc@149: box [p_exp' true env e, adamc@149: space, adamc@149: string "--", adamc@149: space, adamc@149: p_con' true env c, adamc@149: space, adamc@149: string "[", adamc@149: p_con env field, adamc@149: space, adamc@149: string " in ", adamc@149: space, adamc@149: p_con env rest, adamc@149: string "]"] adamc@149: else adamc@149: box [p_exp' true env e, adamc@149: space, adamc@149: string "--", adamc@149: space, adamc@149: p_con' true env c]) adamc@493: | ECutMulti (e, c, {rest}) => adamc@493: parenIf par (if !debug then adamc@493: box [p_exp' true env e, adamc@493: space, adamc@493: string "---", adamc@493: space, adamc@493: p_con' true env c, adamc@493: space, adamc@493: string "[", adamc@493: p_con env rest, adamc@493: string "]"] adamc@493: else adamc@493: box [p_exp' true env e, adamc@493: space, adamc@493: string "---", adamc@493: space, adamc@493: p_con' true env c]) adamc@16: adamc@288: | ECase (e, pes, {disc, result}) => adamc@288: parenIf par (box [string "case", adamc@288: space, adamc@288: p_exp env e, adamc@288: space, adamc@288: if !debug then adamc@288: box [string "in", adamc@288: space, adamc@288: p_con env disc, adamc@288: space, adamc@288: string "return", adamc@288: space, adamc@288: p_con env result, adamc@288: space] adamc@288: else adamc@288: box [], adamc@288: string "of", adamc@288: space, adamc@288: p_list_sep (box [space, string "|", space]) adamc@288: (fn (p, e) => box [p_pat env p, adamc@288: space, adamc@288: string "=>", adamc@288: space, adamc@288: p_exp (E.patBinds env p) e]) pes]) adamc@177: adamc@102: | EWrite e => box [string "write(", adamc@102: p_exp env e, adamc@102: string ")"] adamc@102: adamc@110: | EClosure (n, es) => box [string "CLOSURE(", adamc@110: p_enamed env n, adamc@110: p_list_sep (string "") (fn e => box [string ", ", adamc@110: p_exp env e]) es, adamc@110: string ")"] adamc@110: adamc@450: | ELet (x, t, e1, e2) => box [string "let", adamc@450: space, adamc@450: string x, adamc@450: space, adamc@450: string ":", adamc@450: p_con env t, adamc@450: space, adamc@450: string "=", adamc@450: space, adamc@450: p_exp env e1, adamc@450: space, adamc@450: string "in", adamc@450: newline, adamc@450: p_exp (E.pushERel env x t) e2] adamc@450: adamc@609: | EServerCall (n, es, e, _) => box [string "Server(", adamc@609: p_enamed env n, adamc@609: string ",", adamc@609: space, adamc@609: p_list (p_exp env) es, adamc@609: string ")[", adamc@609: p_exp env e, adamc@609: string "]"] adamc@607: adamc@626: | EKAbs (x, e) => box [string x, adamc@626: space, adamc@626: string "==>", adamc@626: space, adamc@626: p_exp (E.pushKRel env x) e] adamc@626: | EKApp (e, k) => box [p_exp env e, adamc@626: string "[[", adamc@626: p_kind env k, adamc@626: string "]]"] adamc@626: adamc@16: and p_exp env = p_exp' false env adamc@16: adamc@247: fun p_named x n = adamc@247: if !debug then adamc@247: box [string x, adamc@247: string "__", adamc@247: string (Int.toString n)] adamc@247: else adamc@247: string x adamc@247: adamc@125: fun p_vali env (x, n, t, e, s) = adamc@125: let adamc@247: val xp = p_named x n adamc@125: in adamc@125: box [xp, adamc@125: space, adamc@125: string "as", adamc@125: space, adamc@125: string s, adamc@125: space, adamc@125: string ":", adamc@125: space, adamc@125: p_con env t, adamc@125: space, adamc@125: string "=", adamc@125: space, adamc@125: p_exp env e] adamc@125: end adamc@125: adamc@144: fun p_export_kind ck = adamc@144: case ck of adamc@144: Link => string "link" adamc@144: | Action => string "action" adamc@608: | Rpc => string "rpc" adamc@144: adamc@192: fun p_datatype env (x, n, xs, cons) = adamc@163: let adamc@192: val k = (KType, ErrorMsg.dummySpan) adamc@163: val env = E.pushCNamed env x n (KType, ErrorMsg.dummySpan) NONE adamc@192: val env = foldl (fn (x, env) => E.pushCRel env x k) env xs adamc@193: adamc@193: val xp = if !debug then adamc@193: string (x ^ "__" ^ Int.toString n) adamc@193: else adamc@193: string x adamc@163: in adamc@163: box [string "datatype", adamc@163: space, adamc@193: xp, adamc@192: p_list_sep (box []) (fn x => box [space, string x]) xs, adamc@163: space, adamc@163: string "=", adamc@163: space, adamc@163: p_list_sep (box [space, string "|", space]) adamc@163: (fn (x, n, NONE) => if !debug then (string (x ^ "__" ^ Int.toString n)) adamc@163: else string x adamc@193: | (x, n, SOME t) => box [if !debug then (string (x ^ "__" ^ Int.toString n)) adamc@163: else string x, space, string "of", space, p_con env t]) adamc@163: cons] adamc@163: end adamc@163: adamc@125: fun p_decl env (dAll as (d, _) : decl) = adamc@16: case d of adamc@16: DCon (x, n, k, c) => adamc@16: let adamc@16: val xp = if !debug then adamc@16: box [string x, adamc@16: string "__", adamc@16: string (Int.toString n)] adamc@16: else adamc@16: string x adamc@16: in adamc@16: box [string "con", adamc@16: space, adamc@16: xp, adamc@16: space, adamc@16: string "::", adamc@16: space, adamc@626: p_kind env k, adamc@16: space, adamc@16: string "=", adamc@16: space, adamc@16: p_con env c] adamc@16: end adamc@163: | DDatatype x => p_datatype env x adamc@125: | DVal vi => box [string "val", adamc@125: space, adamc@125: p_vali env vi] adamc@125: | DValRec vis => adamc@16: let adamc@125: val env = E.declBinds env dAll adamc@16: in adamc@16: box [string "val", adamc@16: space, adamc@125: string "rec", adamc@16: space, adamc@125: p_list_sep (box [newline, string "and", space]) (p_vali env) vis] adamc@16: end adamc@144: | DExport (ek, n) => box [string "export", adamc@144: space, adamc@144: p_export_kind ek, adamc@144: space, adamc@144: p_enamed env n, adamc@144: space, adamc@144: string "as", adamc@144: space, adamc@482: (p_con env (#2 (E.lookupENamed env n)) adamc@482: handle E.UnboundNamed _ => string "UNBOUND")] adamc@707: | DTable (x, n, c, s, pe, _, ce, _) => box [string "table", adamc@707: space, adamc@707: p_named x n, adamc@707: space, adamc@707: string "as", adamc@707: space, adamc@707: string s, adamc@707: space, adamc@707: string ":", adamc@707: space, adamc@707: p_con env c, adamc@707: space, adamc@707: string "keys", adamc@707: space, adamc@707: p_exp env pe, adamc@707: space, adamc@707: string "constraints", adamc@707: space, adamc@707: p_exp env ce] adamc@338: | DSequence (x, n, s) => box [string "sequence", adamc@338: space, adamc@338: p_named x n, adamc@338: space, adamc@338: string "as", adamc@338: space, adamc@338: string s] adamc@271: | DDatabase s => box [string "database", adamc@271: space, adamc@271: string s] adamc@461: | DCookie (x, n, c, s) => box [string "cookie", adamc@461: space, adamc@461: p_named x n, adamc@461: space, adamc@461: string "as", adamc@461: space, adamc@461: string s, adamc@461: space, adamc@461: string ":", adamc@461: space, adamc@461: p_con env c] adamc@718: | DStyle (x, n, c, s) => box [string "style", adamc@718: space, adamc@718: p_named x n, adamc@718: space, adamc@718: string "as", adamc@718: space, adamc@718: string s, adamc@718: space, adamc@718: string ":", adamc@718: space, adamc@718: p_con env c] adamc@16: adamc@16: fun p_file env file = adamc@16: let adamc@31: val (pds, _) = ListUtil.foldlMap (fn (d, env) => adamc@31: (p_decl env d, adamc@31: E.declBinds env d)) adamc@16: env file adamc@16: in adamc@16: p_list_sep newline (fn x => x) pds adamc@16: end adamc@16: adamc@16: end