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