adamc@3: (* Copyright (c) 2008, Adam Chlipala adamc@3: * All rights reserved. adamc@3: * adamc@3: * Redistribution and use in source and binary forms, with or without adamc@3: * modification, are permitted provided that the following conditions are met: adamc@3: * adamc@3: * - Redistributions of source code must retain the above copyright notice, adamc@3: * this list of conditions and the following disclaimer. adamc@3: * - Redistributions in binary form must reproduce the above copyright notice, adamc@3: * this list of conditions and the following disclaimer in the documentation adamc@3: * and/or other materials provided with the distribution. adamc@3: * - The names of contributors may not be used to endorse or promote products adamc@3: * derived from this software without specific prior written permission. adamc@3: * adamc@3: * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" adamc@3: * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE adamc@3: * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE adamc@3: * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE adamc@3: * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR adamc@3: * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF adamc@3: * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS adamc@3: * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN adamc@3: * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) adamc@3: * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE adamc@3: * POSSIBILITY OF SUCH DAMAGE. adamc@3: *) adamc@3: adamc@244: (* Pretty-printing elaborated Ur/Web *) adamc@3: adamc@3: structure ElabPrint :> ELAB_PRINT = struct adamc@3: adamc@3: open Print.PD adamc@3: open Print adamc@3: adamc@3: open Elab adamc@3: adamc@3: structure E = ElabEnv adamc@3: adamc@11: val debug = ref false adamc@11: adamc@623: fun p_kind' par env (k, _) = adamc@3: case k of adamc@3: KType => string "Type" adamc@623: | KArrow (k1, k2) => parenIf par (box [p_kind' true env k1, adamc@3: space, adamc@3: string "->", adamc@3: space, adamc@623: p_kind env k2]) adamc@3: | KName => string "Name" adamc@623: | KRecord k => box [string "{", p_kind env k, string "}"] adamc@82: | KUnit => string "Unit" adamc@207: | KTuple ks => box [string "(", adamc@623: p_list_sep (box [space, string "*", space]) (p_kind env) ks, adamc@207: string ")"] adamc@3: adamc@3: | KError => string "" adam@1639: | KUnif (_, _, ref (KKnown k)) => p_kind' par env k adamc@76: | KUnif (_, s, _) => string ("") adam@1639: | KTupleUnif (_, _, ref (KKnown k)) => p_kind' par env k adam@1302: | KTupleUnif (_, nks, _) => box [string "(", adam@1302: p_list_sep (box [space, string "*", space]) adam@1302: (fn (n, k) => box [string (Int.toString n ^ ":"), adam@1302: space, adam@1302: p_kind env k]) nks, adam@1302: space, adam@1302: string "*", adam@1302: space, adam@1302: string "...)"] adamc@3: adamc@623: | KRel n => ((if !debug then adamc@623: string (E.lookupKRel env n ^ "_" ^ Int.toString n) adamc@623: else adamc@623: string (E.lookupKRel env n)) adamc@623: handle E.UnboundRel _ => string ("UNBOUND_REL" ^ Int.toString n)) adamc@623: | KFun (x, k) => box [string x, adamc@623: space, adamc@623: string "-->", adamc@623: space, adamc@623: p_kind (E.pushKRel env x) k] adamc@623: adamc@624: and p_kind env = p_kind' false env adamc@3: adamc@3: fun p_explicitness e = adamc@3: case e of adamc@3: Explicit => string "::" adamc@3: | Implicit => string ":::" adamc@3: adamc@3: fun p_con' par env (c, _) = adamc@3: case c of adam@1727: TFun (t1, t2) => parenIf par (box [p_con' true env t1, adamc@3: space, adamc@3: string "->", adamc@3: space, adamc@3: p_con env t2]) adamc@3: | TCFun (e, x, k, c) => parenIf par (box [string x, adamc@3: space, adamc@3: p_explicitness e, adamc@3: space, adamc@623: p_kind env k, adamc@3: space, adamc@3: string "->", adamc@3: space, adamc@3: p_con (E.pushCRel env x k) c]) adamc@628: | TDisjoint (c1, c2, c3) => parenIf par (box [string "[", adamc@628: p_con env c1, adamc@628: space, adamc@628: string "~", adamc@628: space, adamc@628: p_con env c2, adamc@628: string "]", adamc@628: space, adamc@628: string "=>", adamc@628: space, adamc@628: p_con env c3]) adam@1720: | TRecord (CRecord (_, xcs), _) => adam@1720: let adam@1720: fun isTuple (n, xcs) = adam@1720: case xcs of adam@1720: [] => n > 2 adam@1720: | ((CName s, _), _) :: xcs' => adam@1720: s = Int.toString n andalso isTuple (n+1, xcs') adam@1720: | _ => false adam@1720: in adam@1720: if isTuple (1, xcs) then adam@1720: case xcs of adam@1720: (_, c) :: xcs => adam@1720: parenIf par (box [p_con' true env c, adam@1720: p_list_sep (box []) (fn (_, c) => box [space, adam@1720: string "*", adam@1720: space, adam@1720: p_con' true env c]) xcs]) adam@1720: | _ => raise Fail "ElabPrint: surprise empty tuple" adam@1720: else adam@1720: box [string "{", adam@1720: p_list (fn (x, c) => adam@1720: box [p_name env x, adam@1720: space, adam@1720: string ":", adam@1720: space, adam@1720: p_con env c]) xcs, adam@1720: string "}"] adam@1720: end adamc@3: | TRecord c => box [string "$", adamc@3: p_con' true env c] adamc@3: adamc@11: | CRel n => adamc@71: ((if !debug then adamc@71: string (#1 (E.lookupCRel env n) ^ "_" ^ Int.toString n) adamc@71: else adamc@71: string (#1 (E.lookupCRel env n))) adamc@71: handle E.UnboundRel _ => string ("UNBOUND_REL" ^ Int.toString n)) adamc@11: | CNamed n => adamc@34: ((if !debug then adamc@34: string (#1 (E.lookupCNamed env n) ^ "__" ^ Int.toString n) adamc@34: else adamc@34: string (#1 (E.lookupCNamed env n))) adamc@34: handle E.UnboundNamed _ => string ("UNBOUND_NAMED" ^ Int.toString n)) adamc@34: | CModProj (m1, ms, x) => adamc@34: let adamc@88: val m1x = #1 (E.lookupStrNamed env m1) adamc@88: handle E.UnboundNamed _ => "UNBOUND_STR_" ^ Int.toString m1 adamc@88: adamc@34: val m1s = if !debug then adamc@34: m1x ^ "__" ^ Int.toString m1 adamc@34: else adamc@34: m1x adamc@34: in adam@1721: if m1x = "Basis" andalso (case E.lookupC env x of adam@1721: E.Named (n, _) => adam@1721: let adam@1721: val (_, _, co) = E.lookupCNamed env n adam@1721: in adam@1721: case co of adam@1721: SOME (CModProj (m1', [], x'), _) => m1' = m1 andalso x' = x adam@1721: | _ => false adam@1721: end adam@1721: | E.NotBound => true adam@1721: | _ => false) then adam@1721: string x adam@1721: else adam@1721: p_list_sep (string ".") string (m1s :: ms @ [x]) adamc@88: end adamc@3: adamc@3: | CApp (c1, c2) => parenIf par (box [p_con env c1, adamc@3: space, adamc@3: p_con' true env c2]) adamc@147: | CAbs (x, k, c) => parenIf true (box [string "fn", adamc@147: space, adamc@147: string x, adamc@147: space, adamc@147: string "::", adamc@147: space, adamc@623: p_kind env k, adamc@147: space, adamc@147: string "=>", adamc@147: space, adamc@147: p_con (E.pushCRel env x k) c]) adamc@3: adamc@3: | CName s => box [string "#", string s] adamc@3: adamc@12: | CRecord (k, xcs) => adamc@12: if !debug then adamc@12: parenIf par (box [string "[", adamc@12: p_list (fn (x, c) => adam@1716: box [p_name env x, adamc@12: space, adamc@12: string "=", adamc@12: space, adamc@12: p_con env c]) xcs, adamc@12: string "]::", adamc@623: p_kind env k]) adamc@12: else adamc@12: parenIf par (box [string "[", adamc@12: p_list (fn (x, c) => adam@1716: box [p_name env x, adamc@12: space, adamc@12: string "=", adamc@12: space, adamc@12: p_con env c]) xcs, adamc@12: string "]"]) adamc@3: | CConcat (c1, c2) => parenIf par (box [p_con' true env c1, adamc@3: space, adamc@3: string "++", adamc@3: space, adamc@3: p_con env c2]) adamc@621: | CMap _ => string "map" adamc@3: adamc@82: | CUnit => string "()" adamc@82: adamc@207: | CTuple cs => box [string "(", adamc@207: p_list (p_con env) cs, adamc@207: string ")"] adamc@207: | CProj (c, n) => box [p_con env c, adamc@207: string ".", adamc@207: string (Int.toString n)] adamc@207: adamc@3: | CError => string "" adam@1639: | CUnif (nl, _, _, _, ref (Known c)) => p_con' par env (E.mliftConInCon nl c) adam@1303: | CUnif (nl, _, k, s, _) => box [string (" box [] adam@1303: | _ => string ("+" ^ Int.toString nl), adam@1303: string ">"] adamc@623: adamc@623: | CKAbs (x, c) => box [string x, adamc@623: space, adamc@623: string "==>", adamc@623: space, adamc@623: p_con (E.pushKRel env x) c] adamc@623: | CKApp (c, k) => box [p_con env c, adamc@623: string "[[", adamc@623: p_kind env k, adamc@623: string "]]"] adamc@623: | TKFun (x, c) => box [string x, adamc@623: space, adamc@623: string "-->", adamc@623: space, adamc@623: p_con (E.pushKRel env x) c] adamc@623: adamc@3: adamc@3: and p_con env = p_con' false env adamc@3: 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@171: fun p_patCon env pc = adamc@171: case pc of adamc@171: PConVar n => adamc@171: ((if !debug then adamc@171: string (#1 (E.lookupENamed env n) ^ "__" ^ Int.toString n) adamc@171: else adamc@171: string (#1 (E.lookupENamed env n))) adamc@448: handle E.UnboundNamed _ => string ("UNBOUND_NAMED" ^ Int.toString n)) adamc@171: | PConProj (m1, ms, x) => adamc@171: let adamc@171: val m1x = #1 (E.lookupStrNamed env m1) adamc@171: handle E.UnboundNamed _ => "UNBOUND_STR_" ^ Int.toString m1 adamc@171: adamc@171: val m1s = if !debug then adamc@171: m1x ^ "__" ^ Int.toString m1 adamc@171: else adamc@171: m1x adamc@171: in adamc@171: p_list_sep (string ".") string (m1x :: ms @ [x]) adamc@171: end adamc@171: adamc@171: fun p_pat' par env (p, _) = adamc@171: case p of adamc@171: PWild => string "_" adamc@182: | PVar (s, _) => string s adamc@173: | PPrim p => Prim.p_t p adamc@191: | PCon (_, pc, _, NONE) => p_patCon env pc adamc@191: | PCon (_, pc, _, SOME p) => parenIf par (box [p_patCon env pc, adamc@188: space, adamc@188: p_pat' true env p]) adamc@176: | PRecord xps => adamc@176: box [string "{", adamc@1272: p_list_sep (box [string ",", space]) (fn (x, p, t) => adamc@176: box [string x, adamc@176: space, adamc@176: string "=", adamc@176: space, adamc@1272: p_pat env p, adamc@1272: if !debug then adamc@1272: box [space, adamc@1272: string ":", adamc@1272: space, adamc@1272: p_con env t] adamc@1272: else adamc@1272: box []]) xps, adamc@176: string "}"] adamc@171: adamc@175: and p_pat x = p_pat' false x adamc@171: adamc@9: fun p_exp' par env (e, _) = adamc@9: case e of adamc@14: EPrim p => Prim.p_t p adamc@14: | ERel n => adamc@88: ((if !debug then adamc@88: string (#1 (E.lookupERel env n) ^ "_" ^ Int.toString n) adamc@88: else adamc@88: string (#1 (E.lookupERel env n))) adamc@88: handle E.UnboundRel _ => string ("UNBOUND_REL" ^ Int.toString n)) adamc@11: | ENamed n => adamc@88: ((if !debug then adamc@88: string (#1 (E.lookupENamed env n) ^ "__" ^ Int.toString n) adamc@88: else adamc@88: string (#1 (E.lookupENamed env n))) adamc@448: handle E.UnboundNamed _ => string ("UNBOUND_NAMED" ^ Int.toString n)) adamc@34: | EModProj (m1, ms, x) => adamc@34: let adamc@88: val m1x = #1 (E.lookupStrNamed env m1) adamc@88: handle E.UnboundNamed _ => "UNBOUND_STR_" ^ Int.toString m1 adamc@88: adamc@34: val m1s = if !debug then adamc@34: m1x ^ "__" ^ Int.toString m1 adamc@34: else adamc@34: m1x adamc@34: in adamc@34: p_list_sep (string ".") string (m1x :: ms @ [x]) adamc@34: end adamc@34: adamc@9: | EApp (e1, e2) => parenIf par (box [p_exp env e1, adamc@9: space, adamc@9: 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@9: | ECApp (e, c) => parenIf par (box [p_exp env e, adamc@9: space, adamc@9: string "[", adamc@9: p_con env c, adamc@9: string "]"]) adamc@9: | ECAbs (exp, x, k, e) => parenIf par (box [string "fn", adamc@9: space, adamc@9: string x, adamc@9: space, adamc@9: p_explicitness exp, adamc@9: space, adamc@623: p_kind env k, adamc@9: space, adamc@9: string "=>", adamc@9: space, adamc@9: p_exp (E.pushCRel env x k) e]) adamc@9: adamc@12: | ERecord xes => box [string "{", adamc@29: p_list (fn (x, e, _) => adamc@21: box [p_name env x, adamc@12: space, adamc@12: string "=", adamc@12: space, adamc@12: p_exp env e]) xes, adamc@12: string "}"] adamc@12: | EField (e, c, {field, rest}) => adamc@12: if !debug then adamc@12: box [p_exp' true env e, adamc@12: string ".", adamc@12: p_con' true env c, adamc@12: space, adamc@12: string "[", adamc@12: p_con env field, adamc@12: space, adamc@12: string " in ", adamc@12: space, adamc@12: p_con env rest, adamc@12: string "]"] adamc@12: else adamc@12: box [p_exp' true env e, adamc@12: string ".", adamc@12: 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@494: string "++", 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@493: adamc@171: | ECase (e, pes, _) => parenIf par (box [string "case", adamc@171: space, adamc@171: p_exp env e, adamc@171: space, adamc@171: string "of", adamc@171: space, adamc@171: p_list_sep (box [space, string "|", space]) adamc@171: (fn (p, e) => box [p_pat env p, adamc@171: space, adamc@171: string "=>", adamc@171: space, adamc@243: p_exp (E.patBinds env p) e]) pes]) adamc@171: adamc@9: | EError => string "" adamc@228: | EUnif (ref (SOME e)) => p_exp env e adamc@228: | EUnif _ => string "_" adamc@9: adamc@825: | ELet (ds, e, _) => adamc@447: let adamc@447: val (dsp, env) = ListUtil.foldlMap adamc@447: (fn (d, env) => adamc@447: (p_edecl env d, adamc@447: E.edeclBinds env d)) adamc@447: env ds adamc@447: in adamc@447: box [string "let", adamc@447: newline, adamc@447: box [p_list_sep newline (fn x => x) dsp], adamc@447: newline, adamc@447: string "in", adamc@447: newline, adamc@447: box [p_exp env e], adamc@447: newline, adamc@447: string "end"] adamc@447: end adamc@447: adamc@623: | EKAbs (x, e) => box [string x, adamc@623: space, adamc@623: string "==>", adamc@623: space, adamc@623: p_exp (E.pushKRel env x) e] adamc@623: | EKApp (e, k) => box [p_exp env e, adamc@623: string "[[", adamc@623: p_kind env k, adamc@623: string "]]"] adamc@623: adamc@9: and p_exp env = p_exp' false env adamc@9: adamc@447: and p_edecl env (dAll as (d, _)) = adamc@447: case d of adamc@825: EDVal (p, t, e) => box [string "val", adamc@825: space, adamc@825: p_pat env p, adamc@825: space, adamc@825: string ":", adamc@825: space, adamc@825: p_con env t, adamc@825: space, adamc@825: string "=", adamc@825: space, adamc@825: p_exp env e] adamc@447: | EDValRec vis => adamc@447: let adamc@447: val env = E.edeclBinds env dAll adamc@447: in adamc@447: box [string "val", adamc@447: space, adamc@447: string "rec", adamc@447: space, adamc@447: p_list_sep (box [newline, string "and", space]) (p_evali env) vis] adamc@447: end adamc@447: adamc@447: and p_evali env (x, t, e) = box [string x, adamc@447: space, adamc@447: string ":", adamc@447: space, adamc@447: p_con env t, adamc@447: space, adamc@447: string "=", adamc@447: space, adamc@447: p_exp env e] adamc@31: adamc@191: fun p_datatype env (x, n, xs, cons) = adamc@156: let adamc@191: val k = (KType, ErrorMsg.dummySpan) adamc@191: val env = E.pushCNamedAs env x n k NONE adamc@191: val env = foldl (fn (x, env) => E.pushCRel env x k) env xs adamc@156: in adamc@805: box [string x, adamc@191: p_list_sep (box []) (fn x => box [space, string x]) xs, adamc@156: space, adamc@156: string "=", adamc@156: space, adamc@156: p_list_sep (box [space, string "|", space]) adamc@156: (fn (x, _, NONE) => string x adamc@156: | (x, _, SOME t) => box [string x, space, string "of", space, p_con env t]) adamc@156: cons] adamc@156: end adamc@156: adamc@447: fun p_named x n = adamc@447: if !debug then adamc@447: box [string x, adamc@447: string "__", adamc@447: string (Int.toString n)] adamc@447: else adamc@447: string x adamc@447: adamc@805: fun p_sgn_item env (sgiAll as (sgi, _)) = adamc@31: case sgi of adamc@31: SgiConAbs (x, n, k) => box [string "con", adamc@31: space, adamc@31: p_named x n, adamc@31: space, adamc@31: string "::", adamc@31: space, adamc@623: p_kind env k] adamc@31: | SgiCon (x, n, k, c) => box [string "con", adamc@31: space, adamc@31: p_named x n, adamc@31: space, adamc@31: string "::", adamc@31: space, adamc@623: p_kind env k, adamc@31: space, adamc@31: string "=", adamc@31: space, adamc@31: p_con env c] adamc@805: | SgiDatatype x => box [string "datatype", adamc@805: space, adamc@805: p_list_sep (box [space, string "and", space]) (p_datatype (E.sgiBinds env sgiAll)) x] adamc@191: | SgiDatatypeImp (x, _, m1, ms, x', _, _) => adamc@156: let adamc@156: val m1x = #1 (E.lookupStrNamed env m1) adamc@156: handle E.UnboundNamed _ => "UNBOUND_STR_" ^ Int.toString m1 adamc@156: in adamc@156: box [string "datatype", adamc@156: space, adamc@156: string x, adamc@156: space, adamc@156: string "=", adamc@156: space, adamc@156: string "datatype", adamc@156: space, adamc@156: p_list_sep (string ".") string (m1x :: ms @ [x'])] adamc@156: end adamc@31: | SgiVal (x, n, c) => box [string "val", adamc@31: space, adamc@31: p_named x n, adamc@31: space, adamc@31: string ":", adamc@31: space, adamc@31: p_con env c] adamc@31: | SgiStr (x, n, sgn) => box [string "structure", adamc@31: space, adamc@31: p_named x n, adamc@31: space, adamc@31: string ":", adamc@31: space, adamc@31: p_sgn env sgn] adamc@59: | SgiSgn (x, n, sgn) => box [string "signature", adamc@59: space, adamc@59: p_named x n, adamc@59: space, adamc@59: string "=", adamc@59: space, adamc@59: p_sgn env sgn] adamc@88: | SgiConstraint (c1, c2) => box [string "constraint", adamc@88: space, adamc@88: p_con env c1, adamc@88: space, adamc@88: string "~", adamc@88: space, adamc@88: p_con env c2] adamc@563: | SgiClassAbs (x, n, k) => box [string "class", adamc@563: space, adamc@563: p_named x n, adamc@563: space, adamc@563: string "::", adamc@563: space, adamc@623: p_kind env k] adamc@563: | SgiClass (x, n, k, c) => box [string "class", adamc@563: space, adamc@563: p_named x n, adamc@563: space, adamc@563: string "::", adamc@563: space, adamc@623: p_kind env k, adamc@563: space, adamc@563: string "=", adamc@563: space, adamc@563: p_con env c] adamc@31: adamc@31: and p_sgn env (sgn, _) = adamc@31: case sgn of adamc@31: SgnConst sgis => box [string "sig", adamc@31: newline, adamc@32: let adamc@32: val (psgis, _) = ListUtil.foldlMap (fn (sgi, env) => adamc@32: (p_sgn_item env sgi, adamc@32: E.sgiBinds env sgi)) adamc@32: env sgis adamc@32: in adamc@32: p_list_sep newline (fn x => x) psgis adamc@32: end, adamc@31: newline, adamc@31: string "end"] adamc@88: | SgnVar n => ((string (#1 (E.lookupSgnNamed env n))) adamc@88: handle E.UnboundNamed _ => string ("UNBOUND_SGN_" ^ Int.toString n)) adamc@41: | SgnFun (x, n, sgn, sgn') => box [string "functor", adamc@41: space, adamc@41: string "(", adamc@41: string x, adamc@41: space, adamc@41: string ":", adamc@41: space, adamc@41: p_sgn env sgn, adamc@41: string ")", adamc@41: space, adamc@41: string ":", adamc@41: space, adamc@41: p_sgn (E.pushStrNamedAs env x n sgn) sgn'] adam@1864: | SgnWhere (sgn, ms, x, c) => box [p_sgn env sgn, adam@1864: space, adam@1864: string "where", adam@1864: space, adam@1864: string "con", adam@1864: space, adam@1864: p_list_sep (string ".") string (ms @ [x]), adam@1864: space, adam@1864: string "=", adam@1864: space, adam@1864: p_con env c] adamc@59: | SgnProj (m1, ms, x) => adamc@59: let adamc@88: val m1x = #1 (E.lookupStrNamed env m1) adamc@88: handle E.UnboundNamed _ => "UNBOUND_SGN_" ^ Int.toString m1 adamc@88: adamc@59: val m1s = if !debug then adamc@59: m1x ^ "__" ^ Int.toString m1 adamc@59: else adamc@59: m1x adamc@88: in adamc@59: p_list_sep (string ".") string (m1x :: ms @ [x]) adamc@59: end adamc@31: | SgnError => string "" adamc@31: adamc@123: fun p_vali env (x, n, t, e) = box [p_named x n, adamc@123: space, adamc@123: string ":", adamc@123: space, adamc@123: p_con env t, adamc@123: space, adamc@123: string "=", adamc@123: space, adamc@123: p_exp env e] adamc@123: adamc@447: adamc@447: adamc@123: fun p_decl env (dAll as (d, _) : decl) = adamc@3: case d of adamc@31: DCon (x, n, k, c) => box [string "con", adamc@31: space, adamc@31: p_named x n, adamc@31: space, adamc@31: string "::", adamc@31: space, adamc@623: p_kind env k, adamc@31: space, adamc@31: string "=", adamc@31: space, adamc@31: p_con env c] adamc@805: | DDatatype x => box [string "datatype", adamc@805: space, adamc@805: p_list_sep (box [space, string "and", space]) (p_datatype (E.declBinds env dAll)) x] adamc@191: | DDatatypeImp (x, _, m1, ms, x', _, _) => adamc@156: let adamc@156: val m1x = #1 (E.lookupStrNamed env m1) adamc@156: handle E.UnboundNamed _ => "UNBOUND_STR_" ^ Int.toString m1 adamc@156: in adamc@156: box [string "datatype", adamc@156: space, adamc@156: string x, adamc@156: space, adamc@156: string "=", adamc@156: space, adamc@156: string "datatype", adamc@156: space, adamc@156: p_list_sep (string ".") string (m1x :: ms @ [x'])] adamc@156: end adamc@123: | DVal vi => box [string "val", adamc@123: space, adamc@123: p_vali env vi] adamc@123: | DValRec vis => adamc@123: let adamc@123: val env = E.declBinds env dAll adamc@123: in adamc@123: box [string "val", adamc@123: space, adamc@123: string "rec", adamc@123: space, adamc@123: p_list_sep (box [newline, string "and", space]) (p_vali env) vis] adamc@123: end adamc@31: adamc@31: | DSgn (x, n, sgn) => box [string "signature", adamc@31: space, adamc@31: p_named x n, adamc@31: space, adamc@31: string "=", adamc@31: space, adamc@31: p_sgn env sgn] adamc@31: | DStr (x, n, sgn, str) => box [string "structure", adamc@31: space, adamc@31: p_named x n, adamc@31: space, adamc@31: string ":", adamc@31: space, adamc@31: p_sgn env sgn, adamc@31: space, adamc@31: string "=", adamc@31: space, adamc@31: p_str env str] adamc@48: | DFfiStr (x, n, sgn) => box [string "extern", adamc@48: space, adamc@48: string "structure", adamc@48: space, adamc@48: p_named x n, adamc@48: space, adamc@48: string ":", adamc@48: space, adamc@48: p_sgn env sgn] adamc@88: | DConstraint (c1, c2) => box [string "constraint", adamc@88: space, adamc@88: p_con env c1, adamc@88: space, adamc@88: string "~", adamc@88: space, adamc@88: p_con env c2] adamc@109: | DExport (_, sgn, str) => box [string "export", adamc@110: space, adamc@109: p_str env str, adamc@109: space, adamc@109: string ":", adamc@109: space, adamc@109: p_sgn env sgn] adamc@707: | DTable (_, x, n, c, pe, _, ce, _) => box [string "table", adamc@707: space, adamc@707: p_named x n, 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) => box [string "sequence", adamc@338: space, adamc@338: p_named x n] adamc@754: | DView (_, x, n, e, _) => box [string "view", adamc@754: space, adamc@754: p_named x n, adamc@754: space, adamc@754: string "as", adamc@754: space, adamc@754: p_exp env e] adamc@271: | DDatabase s => box [string "database", adamc@271: space, adamc@271: string s] adamc@459: | DCookie (_, x, n, c) => box [string "cookie", adamc@459: space, adamc@459: p_named x n, adamc@459: space, adamc@459: string ":", adamc@459: space, adamc@459: p_con env c] adamc@720: | DStyle (_, x, n) => box [string "style", adamc@720: space, adamc@720: p_named x n] adamc@1075: | DTask (e1, e2) => box [string "task", adamc@1073: space, adamc@1075: p_exp env e1, adamc@1075: space, adamc@1075: string "=", adamc@1075: space, adamc@1075: p_exp env e2] adamc@1199: | DPolicy e1 => box [string "policy", adamc@1199: space, adamc@1199: p_exp env e1] adam@1294: | DOnError _ => string "ONERROR" adam@2010: | DFfi _ => string "FFI" adamc@31: adamc@31: and p_str env (str, _) = adamc@31: case str of adamc@31: StrConst ds => box [string "struct", adamc@31: newline, adamc@32: p_file env ds, adamc@31: newline, adamc@31: string "end"] adamc@88: | StrVar n => ((string (#1 (E.lookupStrNamed env n))) adamc@88: handle E.UnboundNamed _ => string ("UNBOUND_STR_" ^ Int.toString n)) adamc@34: | StrProj (str, s) => box [p_str env str, adamc@34: string ".", adamc@34: string s] adamc@41: | StrFun (x, n, sgn, sgn', str) => adamc@41: let adamc@41: val env' = E.pushStrNamedAs env x n sgn adamc@41: in adamc@41: box [string "functor", adamc@41: space, adamc@41: string "(", adamc@41: string x, adamc@41: space, adamc@41: string ":", adamc@41: space, adamc@41: p_sgn env sgn, adamc@41: string ")", adamc@41: space, adamc@41: string ":", adamc@41: space, adamc@41: p_sgn env' sgn', adamc@41: space, adamc@41: string "=>", adamc@41: space, adamc@41: p_str env' str] adamc@41: end adamc@44: | StrApp (str1, str2) => box [p_str env str1, adamc@44: string "(", adamc@44: p_str env str2, adamc@44: string ")"] adamc@31: | StrError => string "" adamc@3: adamc@32: and p_file env file = adamc@3: let adamc@31: val (pds, _) = ListUtil.foldlMap (fn (d, env) => adamc@31: (p_decl env d, adamc@31: E.declBinds env d)) adamc@31: env file adamc@3: in adamc@3: p_list_sep newline (fn x => x) pds adamc@3: end adamc@3: adamc@3: end