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