diff options
Diffstat (limited to 'src/flat_print.sml')
| -rw-r--r-- | src/flat_print.sml | 236 |
1 files changed, 0 insertions, 236 deletions
diff --git a/src/flat_print.sml b/src/flat_print.sml deleted file mode 100644 index f94614b4..00000000 --- a/src/flat_print.sml +++ /dev/null @@ -1,236 +0,0 @@ -(* Copyright (c) 2008, Adam Chlipala - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions are met: - * - * - Redistributions of source code must retain the above copyright notice, - * this list of conditions and the following disclaimer. - * - Redistributions in binary form must reproduce the above copyright notice, - * this list of conditions and the following disclaimer in the documentation - * and/or other materials provided with the distribution. - * - The names of contributors may not be used to endorse or promote products - * derived from this software without specific prior written permission. - * - * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" - * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE - * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE - * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR - * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF - * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS - * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN - * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) - * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE - * POSSIBILITY OF SUCH DAMAGE. - *) - -(* Pretty-printing flat-code Laconic/Web *) - -structure FlatPrint :> FLAT_PRINT = struct - -open Print.PD -open Print - -open Flat - -structure E = FlatEnv - -val debug = ref false - -val dummyTyp = (TNamed 0, ErrorMsg.dummySpan) - -fun p_typ' par env (t, _) = - case t of - TTop => string "?" - | TFun (t1, t2) => parenIf par (box [p_typ' true env t1, - space, - string "->", - space, - p_typ env t2]) - | TCode (t1, t2) => parenIf par (box [p_typ' true env t1, - space, - string "-->", - space, - p_typ env t2]) - | TRecord xcs => box [string "{", - p_list (fn (x, t) => - box [string x, - space, - string ":", - space, - p_typ env t]) xcs, - string "}"] - | TNamed n => - if !debug then - string (#1 (E.lookupTNamed env n) ^ "__" ^ Int.toString n) - else - string (#1 (E.lookupTNamed env n)) - | TFfi (m, x) => box [string "FFI(", string m, string ".", string x, string ")"] - -and p_typ env = p_typ' false env - -fun p_exp' par env (e, _) = - case e of - EPrim p => Prim.p_t p - | ERel n => - ((if !debug then - string (#1 (E.lookupERel env n) ^ "_" ^ Int.toString n) - else - string (#1 (E.lookupERel env n))) - handle E.UnboundRel _ => string ("UNBOUND" ^ Int.toString n)) - | ENamed n => - if !debug then - string (#1 (E.lookupENamed env n) ^ "__" ^ Int.toString n) - else - string (#1 (E.lookupENamed env n)) - | EFfi (m, x) => box [string "FFI(", string m, string ".", string x, string ")"] - | EFfiApp (m, x, es) => box [string "FFI(", - string m, - string ".", - string x, - string "(", - p_list (p_exp env) es, - string "))"] - | ECode n => string ("code$" ^ Int.toString n) - | EApp (e1, e2) => parenIf par (box [p_exp env e1, - space, - p_exp' true env e2]) - - | ERecord xes => box [string "{", - p_list (fn (x, e, _) => - box [string x, - space, - string "=", - space, - p_exp env e]) xes, - string "}"] - | EField (e, x) => - box [p_exp' true env e, - string ".", - string x] - - | ELet (xes, e) => - let - val (env, pps) = foldl (fn ((x, _, e), (env, pps)) => - (E.pushERel env x dummyTyp, - List.revAppend ([space, - string "val", - space, - string x, - space, - string "=", - space, - p_exp env e], - pps))) - (env, []) xes - in - box [string "let", - space, - box (rev pps), - space, - string "in", - space, - p_exp env e, - space, - string "end"] - end - - | EStrcat (e1, e2) => box [p_exp' true env e1, - space, - string "^", - space, - p_exp' true env e2] - - | EWrite e => box [string "write(", - p_exp env e, - string ")"] - - | ESeq (e1, e2) => box [p_exp env e1, - string ";", - space, - p_exp env e2] - -and p_exp env = p_exp' false env - -fun p_decl env ((d, _) : decl) = - case d of - DVal (x, n, t, e) => - let - val xp = if !debug then - box [string x, - string "__", - string (Int.toString n)] - else - string x - in - box [string "val", - space, - xp, - space, - string ":", - space, - p_typ env t, - space, - string "=", - space, - p_exp env e] - - end - | DFun (n, x, dom, ran, e) => - let - val xp = if !debug then - box [string x, - string "__", - string (Int.toString n)] - else - string x - in - box [string "fun", - space, - string "code$", - string (Int.toString n), - space, - string "(", - xp, - space, - string ":", - space, - p_typ env dom, - string ")", - space, - string ":", - space, - p_typ env ran, - space, - string "=", - space, - p_exp (E.pushERel env x dom) e] - - end - - | DPage (xcs, e) => box [string "page", - string "[", - p_list (fn (x, t) => - box [string x, - space, - string ":", - space, - p_typ env t]) xcs, - string "]", - space, - string "=", - space, - p_exp env e] - -fun p_file env file = - let - val (pds, _) = ListUtil.foldlMap (fn (d, env) => - (p_decl env d, - E.declBinds env d)) - env file - in - p_list_sep newline (fn x => x) pds - end - -end |