adamc@25: (* Copyright (c) 2008, Adam Chlipala adamc@25: * All rights reserved. adamc@25: * adamc@25: * Redistribution and use in source and binary forms, with or without adamc@25: * modification, are permitted provided that the following conditions are met: adamc@25: * adamc@25: * - Redistributions of source code must retain the above copyright notice, adamc@25: * this list of conditions and the following disclaimer. adamc@25: * - Redistributions in binary form must reproduce the above copyright notice, adamc@25: * this list of conditions and the following disclaimer in the documentation adamc@25: * and/or other materials provided with the distribution. adamc@25: * - The names of contributors may not be used to endorse or promote products adamc@25: * derived from this software without specific prior written permission. adamc@25: * adamc@25: * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" adamc@25: * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE adamc@25: * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE adamc@25: * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE adamc@25: * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR adamc@25: * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF adamc@25: * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS adamc@25: * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN adamc@25: * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) adamc@25: * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE adamc@25: * POSSIBILITY OF SUCH DAMAGE. adamc@25: *) adamc@25: adamc@244: (* Pretty-printing monomorphic Ur/Web *) adamc@25: adamc@25: structure MonoPrint :> MONO_PRINT = struct adamc@25: adamc@25: open Print.PD adamc@25: open Print adamc@25: adamc@25: open Mono adamc@25: adamc@25: structure E = MonoEnv adamc@25: adamc@25: val debug = ref false adamc@25: adamc@252: val dummyt = (TRecord [], ErrorMsg.dummySpan) adamc@252: adamc@25: fun p_typ' par env (t, _) = adamc@25: case t of adamc@25: TFun (t1, t2) => parenIf par (box [p_typ' true env t1, adamc@25: space, adamc@25: string "->", adamc@25: space, adamc@25: p_typ env t2]) adamc@25: | TRecord xcs => box [string "{", adamc@25: p_list (fn (x, t) => adamc@25: box [string x, adamc@25: space, adamc@25: string ":", adamc@25: space, adamc@25: p_typ env t]) xcs, adamc@25: string "}"] adamc@196: | TDatatype (n, _) => adamc@178: ((if !debug then adamc@178: string (#1 (E.lookupDatatype env n) ^ "__" ^ Int.toString n) adamc@178: else adamc@178: string (#1 (E.lookupDatatype env n))) adamc@178: handle E.UnboundNamed _ => string ("UNBOUND_DATATYPE_" ^ Int.toString n)) adamc@51: | TFfi (m, x) => box [string "FFI(", string m, string ".", string x, string ")"] adamc@25: adamc@25: and p_typ env = p_typ' false env adamc@25: adamc@109: fun p_enamed env n = adamc@178: (if !debug then adamc@178: string (#1 (E.lookupENamed env n) ^ "__" ^ Int.toString n) adamc@178: else adamc@178: string (#1 (E.lookupENamed env n))) adamc@178: handle E.UnboundNamed _ => string ("UNBOUNDN_" ^ Int.toString n) adamc@178: adamc@178: fun p_con_named env n = adamc@178: (if !debug then adamc@178: string (#1 (E.lookupConstructor env n) ^ "__" ^ Int.toString n) adamc@178: else adamc@178: string (#1 (E.lookupConstructor env n))) adamc@178: handle E.UnboundNamed _ => string ("CONSTRUCTOR_" ^ Int.toString n) adamc@178: adamc@178: fun p_patCon env pc = adamc@178: case pc of adamc@178: 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@178: adamc@178: fun p_pat' par env (p, _) = adamc@178: case p of adamc@178: PWild => string "_" adamc@182: | PVar (s, _) => string s adamc@178: | PPrim p => Prim.p_t p adamc@188: | PCon (_, n, NONE) => p_patCon env n adamc@188: | PCon (_, n, SOME p) => parenIf par (box [p_patCon env n, adamc@178: space, adamc@178: p_pat' true env p]) adamc@178: | PRecord xps => adamc@178: box [string "{", adamc@182: p_list_sep (box [string ",", space]) (fn (x, p, _) => adamc@178: box [string x, adamc@178: space, adamc@178: string "=", adamc@178: space, adamc@178: p_pat env p]) xps, adamc@178: string "}"] adamc@178: adamc@178: and p_pat x = p_pat' false x adamc@109: adamc@25: fun p_exp' par env (e, _) = adamc@25: case e of adamc@25: EPrim p => Prim.p_t p adamc@25: | ERel n => adamc@178: ((if !debug then adamc@178: string (#1 (E.lookupERel env n) ^ "_" ^ Int.toString n) adamc@178: else adamc@178: string (#1 (E.lookupERel env n))) adamc@178: handle E.UnboundRel _ => string ("UNBOUND_" ^ Int.toString n)) adamc@109: | ENamed n => p_enamed env n adamc@188: | ECon (_, pc, NONE) => p_patCon env pc adamc@188: | ECon (_, pc, SOME e) => parenIf par (box [p_patCon env pc, adamc@188: space, adamc@188: p_exp' true env e]) adamc@109: adamc@51: | EFfi (m, x) => box [string "FFI(", string m, string ".", string x, string ")"] adamc@51: | EFfiApp (m, x, es) => box [string "FFI(", adamc@51: string m, adamc@51: string ".", adamc@51: string x, adamc@51: string "(", adamc@51: p_list (p_exp env) es, adamc@51: string "))"] adamc@25: | EApp (e1, e2) => parenIf par (box [p_exp env e1, adamc@25: space, adamc@25: p_exp' true env e2]) adamc@252: | EAbs (x, t, _, e) => parenIf true (box [string "fn", adamc@252: space, adamc@252: string x, adamc@252: space, adamc@252: string ":", adamc@252: space, adamc@252: p_typ env t, adamc@252: space, adamc@252: string "=>", adamc@252: space, adamc@252: p_exp (E.pushERel env x t NONE) e]) adamc@25: adamc@25: | ERecord xes => box [string "{", adamc@29: p_list (fn (x, e, _) => adamc@25: box [string x, adamc@25: space, adamc@25: string "=", adamc@25: space, adamc@25: p_exp env e]) xes, adamc@25: string "}"] adamc@25: | EField (e, x) => adamc@25: box [p_exp' true env e, adamc@25: string ".", adamc@25: string x] adamc@25: adamc@252: | ECase (e, pes, _) => parenIf true (box [string "case", adamc@252: space, adamc@252: p_exp env e, adamc@252: space, adamc@252: string "of", adamc@252: space, adamc@252: p_list_sep (box [space, string "|", space]) adamc@252: (fn (p, e) => box [p_pat env p, adamc@252: space, adamc@252: string "=>", adamc@252: space, adamc@252: p_exp (E.patBinds env p) e]) pes]) adamc@94: adamc@94: | EStrcat (e1, e2) => box [p_exp' true env e1, adamc@94: space, adamc@102: string "^", adamc@94: space, adamc@94: p_exp' true env e2] adamc@94: adamc@102: | EWrite e => box [string "write(", adamc@102: p_exp env e, adamc@102: string ")"] adamc@102: adamc@106: | ESeq (e1, e2) => box [p_exp env e1, adamc@106: string ";", adamc@106: space, adamc@106: p_exp env e2] adamc@252: | ELet (x, t, e1, e2) => box [string "(let", adamc@251: space, adamc@251: string x, adamc@251: space, adamc@251: string ":", adamc@251: space, adamc@251: p_typ env t, adamc@251: space, adamc@251: string "=", adamc@251: space, adamc@252: string "(", adamc@251: p_exp env e1, adamc@252: string ")", adamc@251: space, adamc@251: string "in", adamc@251: space, adamc@252: string "(", adamc@252: p_exp (E.pushERel env x t NONE) e2, adamc@252: string "))"] adamc@106: adamc@111: | EClosure (n, es) => box [string "CLOSURE(", adamc@111: p_enamed env n, adamc@111: p_list_sep (string "") (fn e => box [string ", ", adamc@111: p_exp env e]) es, adamc@111: string ")"] adamc@111: adamc@252: | EQuery {exps, tables, state, query, body, initial} => adamc@252: box [string "query[", adamc@252: p_list (fn (x, t) => box [string x, space, string ":", space, p_typ env t]) exps, adamc@252: string "] [", adamc@252: p_list (fn (x, xts) => box [string x, adamc@252: space, adamc@252: string ":", adamc@252: space, adamc@252: string "{", adamc@252: p_list (fn (x, t) => box [string x, space, string ":", space, p_typ env t]) xts, adamc@252: string "}"]) tables, adamc@252: string "] [", adamc@252: p_typ env state, adamc@252: string "]", adamc@252: space, adamc@252: p_exp env query, adamc@252: space, adamc@252: string "initial", adamc@252: space, adamc@252: p_exp env initial, adamc@252: space, adamc@252: string "in", adamc@252: space, adamc@252: p_exp (E.pushERel (E.pushERel env "r" dummyt NONE) "acc" dummyt NONE) body] adamc@252: adamc@25: and p_exp env = p_exp' false env adamc@25: adamc@126: fun p_vali env (x, n, t, e, s) = adamc@126: let adamc@126: val xp = if !debug then adamc@126: box [string x, adamc@126: string "__", adamc@126: string (Int.toString n)] adamc@126: else adamc@126: string x adamc@126: in adamc@126: box [xp, adamc@126: space, adamc@126: string "as", adamc@126: space, adamc@126: string s, adamc@126: space, adamc@126: string ":", adamc@126: space, adamc@126: p_typ env t, adamc@126: space, adamc@126: string "=", adamc@126: space, adamc@126: p_exp env e] adamc@126: end adamc@126: adamc@164: fun p_datatype env (x, n, cons) = adamc@164: let adamc@168: val env = E.pushDatatype env x n cons adamc@164: in adamc@164: box [string "datatype", adamc@164: space, adamc@164: string x, adamc@164: space, adamc@164: string "=", adamc@164: space, adamc@164: p_list_sep (box [space, string "|", space]) adamc@164: (fn (x, n, NONE) => if !debug then (string (x ^ "__" ^ Int.toString n)) adamc@164: else string x adamc@164: | (x, _, SOME t) => box [if !debug then (string (x ^ "__" ^ Int.toString n)) adamc@164: else string x, space, string "of", space, p_typ env t]) adamc@164: cons] adamc@164: end adamc@164: adamc@126: fun p_decl env (dAll as (d, _) : decl) = adamc@25: case d of adamc@164: DDatatype x => p_datatype env x adamc@164: | DVal vi => box [string "val", adamc@126: space, adamc@126: p_vali env vi] adamc@126: | DValRec vis => adamc@25: let adamc@126: val env = E.declBinds env dAll adamc@25: in adamc@25: box [string "val", adamc@25: space, adamc@126: string "rec", adamc@25: space, adamc@126: p_list_sep (box [newline, string "and", space]) (p_vali env) vis] adamc@25: end adamc@109: adamc@144: | DExport (ek, s, n, ts) => box [string "export", adamc@144: space, adamc@144: CorePrint.p_export_kind ek, adamc@144: space, adamc@144: p_enamed env n, adamc@144: space, adamc@144: string "as", adamc@144: space, adamc@144: string s, adamc@144: p_list_sep (string "") (fn t => box [space, adamc@144: string "(", adamc@144: p_typ env t, adamc@144: string ")"]) ts] adamc@271: adamc@271: | DDatabase s => box [string "database", adamc@271: space, adamc@271: string s] adamc@100: adamc@25: fun p_file env file = adamc@25: let adamc@31: val (pds, _) = ListUtil.foldlMap (fn (d, env) => adamc@31: (p_decl env d, adamc@31: E.declBinds env d)) adamc@25: env file adamc@25: in adamc@25: p_list_sep newline (fn x => x) pds adamc@25: end adamc@25: adamc@25: end