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@16: (* Pretty-printing core Laconic/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@16: fun p_kind' par (k, _) = adamc@16: case k of adamc@16: KType => string "Type" adamc@16: | KArrow (k1, k2) => parenIf par (box [p_kind' true k1, adamc@16: space, adamc@16: string "->", adamc@16: space, adamc@16: p_kind k2]) adamc@16: | KName => string "Name" adamc@16: | KRecord k => box [string "{", p_kind k, string "}"] adamc@87: | KUnit => string "Unit" adamc@16: adamc@16: and p_kind k = p_kind' false k 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@16: p_kind 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@39: 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@16: p_kind 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@16: p_kind 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@69: | CFold _ => string "fold" adamc@87: | CUnit => string "()" 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@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@16: | ENamed n => adamc@39: ((if !debug then adamc@39: string (#1 (E.lookupENamed env n) ^ "__" ^ Int.toString n) adamc@39: else adamc@39: string (#1 (E.lookupENamed env n))) adamc@39: handle E.UnboundNamed _ => string ("UNBOUNDN_" ^ Int.toString n)) 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@16: | EApp (e1, e2) => parenIf par (box [p_exp 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@16: p_kind 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@73: | EFold _ => string "fold" adamc@16: adamc@16: and p_exp env = p_exp' false env adamc@16: adamc@16: fun p_decl env ((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@16: p_kind k, adamc@16: space, adamc@16: string "=", adamc@16: space, adamc@16: p_con env c] adamc@16: end adamc@16: | DVal (x, n, t, e) => 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 "val", adamc@16: space, adamc@16: xp, adamc@16: space, adamc@16: string ":", adamc@16: space, adamc@16: p_con env t, adamc@16: space, adamc@16: string "=", adamc@16: space, adamc@16: p_exp env e] adamc@16: end 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