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@25: (* Pretty-printing monomorphic Laconic/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@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@25: | TNamed n => adamc@25: if !debug then adamc@25: string (#1 (E.lookupTNamed env n) ^ "__" ^ Int.toString n) adamc@25: else adamc@25: string (#1 (E.lookupTNamed env 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@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@25: if !debug then adamc@25: string (#1 (E.lookupERel env n) ^ "_" ^ Int.toString n) adamc@25: else adamc@25: string (#1 (E.lookupERel env n)) adamc@25: | ENamed n => adamc@25: if !debug then adamc@25: string (#1 (E.lookupENamed env n) ^ "__" ^ Int.toString n) adamc@25: else adamc@25: string (#1 (E.lookupENamed env n)) 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@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_typ env t, adamc@26: space, adamc@26: string "=>", adamc@26: space, adamc@26: p_exp (E.pushERel env x t) 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@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@106: adamc@25: and p_exp env = p_exp' false env adamc@25: adamc@25: fun p_decl env ((d, _) : decl) = adamc@25: case d of adamc@25: DVal (x, n, t, e) => adamc@25: let adamc@25: val xp = if !debug then adamc@25: box [string x, adamc@25: string "__", adamc@25: string (Int.toString n)] adamc@25: else adamc@25: string x adamc@25: in adamc@25: box [string "val", adamc@25: space, adamc@25: xp, adamc@25: space, adamc@25: string ":", adamc@25: space, adamc@25: p_typ env t, adamc@25: space, adamc@25: string "=", adamc@25: space, adamc@25: p_exp env e] adamc@25: end adamc@100: | DPage (xcs, e) => box [string "page", adamc@100: string "[", adamc@100: p_list (fn (x, t) => adamc@100: box [string x, adamc@100: space, adamc@100: string ":", adamc@100: space, adamc@100: p_typ env t]) xcs, adamc@100: string "]", adamc@100: space, adamc@100: string "=", adamc@100: space, adamc@100: p_exp env e] 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