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@841: | TDatatype (n, ref (dk, _)) => adamc@178: ((if !debug then adamc@841: string (#1 (E.lookupDatatype env n) ^ "__" ^ Int.toString n ^ "[" adamc@841: ^ (case dk of adamc@841: Option => "Option" adamc@841: | Enum => "Enum" adamc@841: | Default => "Default") adamc@841: ^ "]") 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@292: | TOption t => box [string "option(", adamc@292: p_typ env t, adamc@292: string ")"] adamc@757: | TList t => box [string "list(", adamc@757: p_typ env t, adamc@757: string ")"] adamc@577: | TSource => string "source" adamc@568: | TSignal t => box [string "signal(", adamc@568: p_typ env t, adamc@568: 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@288: space, adamc@288: 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@288: | PNone _ => string "None" adamc@757: | PSome (t, p) => adamc@757: if !debug then adamc@757: box [string "Some[", adamc@757: p_typ env t, adamc@757: string "]", adamc@757: space, adamc@757: p_pat' true env p] adamc@757: else adamc@757: box [string "Some", adamc@757: space, adamc@757: p_pat' true env p] adamc@178: adamc@178: and p_pat x = p_pat' false x adamc@109: adamc@591: fun p_mode env m = adamc@591: case m of adamc@591: Attribute => string "Attribute" adamc@591: | Script => string "Script" adamc@591: | Source t => box [string "Source", space, p_typ env t] adamc@591: 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@297: | ENone _ => string "None" adamc@290: | ESome (_, e) => parenIf par (box [string "Some", adamc@290: space, adamc@290: 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@387: | EUnop (s, e) => parenIf true (box [string s, adamc@387: space, adamc@387: p_exp' true env e]) adamc@387: | EBinop (s, e1, e2) => parenIf true (box [p_exp' true env e1, adamc@387: space, adamc@387: string s, adamc@387: space, adamc@387: p_exp' true env e2]) adamc@387: 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@1107: | ECase (e, pes, {result, ...}) => parenIf true (box [string "case", adamc@1107: space, adamc@1107: p_exp env e, adamc@1107: space, adamc@1107: if !debug then adamc@1107: box [string "return", adamc@1107: space, adamc@1107: p_typ env result, adamc@1107: space] adamc@1107: else adamc@1107: box [], adamc@1107: string "of", adamc@1107: space, adamc@1107: p_list_sep (box [space, string "|", space]) adamc@1107: (fn (p, e) => box [p_pat env p, adamc@1107: space, adamc@1107: string "=>", adamc@1107: space, adamc@1107: p_exp (E.patBinds env p) e]) adamc@1107: pes]) adamc@94: adamc@283: | EError (e, t) => box [string "(error", adamc@283: space, adamc@283: p_exp env e, adamc@283: space, adamc@283: string ":", adamc@283: space, adamc@283: p_typ env t, adamc@283: string ")"] adamc@741: | EReturnBlob {blob, mimeType, t} => box [string "(blob", adamc@741: space, adamc@741: p_exp env blob, adamc@741: space, adamc@741: string "in", adamc@741: space, adamc@741: p_exp env mimeType, adamc@741: space, adamc@741: string ":", adamc@741: space, adamc@741: p_typ env t, adamc@741: string ")"] adamc@1065: | ERedirect (e, t) => box [string "(redirect", adamc@1065: space, adamc@1065: p_exp env e, adamc@1065: space, adamc@1065: string ":", adamc@1065: space, adamc@1065: p_typ env t, adamc@1065: string ")"] adamc@283: adamc@331: | EStrcat (e1, e2) => parenIf par (box [p_exp' true env e1, adamc@331: space, adamc@331: string "^", adamc@331: space, adamc@331: p_exp env e2]) adamc@94: adamc@102: | EWrite e => box [string "write(", adamc@102: p_exp env e, adamc@102: string ")"] adamc@102: adamc@578: | ESeq (e1, e2) => box [string "(", adamc@578: p_exp env e1, adamc@106: string ";", adamc@106: space, adamc@578: p_exp env e2, adamc@578: string ")"] 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@307: | EDml e => box [string "dml(", adamc@307: p_exp env e, adamc@307: string ")"] adamc@338: | ENextval e => box [string "nextval(", adamc@338: p_exp env e, adamc@338: string ")"] adamc@1073: | ESetval (e1, e2) => box [string "setval(", adamc@1073: p_exp env e1, adamc@1073: string ",", adamc@1073: space, adamc@1073: p_exp env e2, adamc@1073: string ")"] adamc@1112: | EUnurlify (e, _, _) => box [string "unurlify(", adamc@1112: p_exp env e, adamc@1112: string ")"] adamc@815: | EJavaScript (m, e) => box [string "JavaScript(", adamc@815: p_mode env m, adamc@815: string ",", adamc@815: space, adamc@815: p_exp env e, adamc@815: string ")"] adamc@568: adamc@568: | ESignalReturn e => box [string "Return(", adamc@568: p_exp env e, adamc@568: string ")"] adamc@574: | ESignalBind (e1, e2) => box [string "Bind(", adamc@572: p_exp env e1, adamc@572: string ",", adamc@572: space, adamc@572: p_exp env e2, adamc@572: string ")"] adamc@574: | ESignalSource e => box [string "Source(", adamc@574: p_exp env e, adamc@574: string ")"] adamc@252: adamc@1020: | EServerCall (n, _, _) => box [string "Server(", adamc@1020: p_exp env n, adamc@1020: string ")"] adamc@1021: | ERecv (n, _) => box [string "Recv(", adamc@1021: p_exp env n, adamc@1021: string ")"] adamc@1021: | ESleep n => box [string "Sleep(", adamc@1021: p_exp env n, adamc@1021: string ")"] adamc@1021: | ESpawn n => box [string "Spawn(", adamc@1021: p_exp env n, adamc@1021: string ")"] adamc@608: 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@808: box [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@1199: fun p_policy env pol = adamc@1199: case pol of adamc@1214: PolClient e => box [string "sendClient", adamc@1214: space, adamc@1214: p_exp env e] adamc@1220: | PolInsert e => box [string "mayInsert", adamc@1220: space, adamc@1220: p_exp env e] adamc@1199: adamc@126: fun p_decl env (dAll as (d, _) : decl) = adamc@25: case d of adamc@808: DDatatype x => box [string "datatype", adamc@808: space, adamc@808: p_list_sep (box [space, string "and", space]) (p_datatype (E.declBinds env dAll)) 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@1104: | DExport (ek, s, n, ts, t, _) => box [string "export", adamc@1104: space, adamc@1104: Export.p_export_kind ek, adamc@1104: space, adamc@1104: p_enamed env n, adamc@1104: space, adamc@1104: string "as", adamc@1104: space, adamc@1104: string s, adamc@1104: p_list_sep (string "") (fn t => box [space, adamc@1104: string "(", adamc@1104: p_typ env t, adamc@1104: string ")"]) ts, adamc@1104: space, adamc@1104: string "->", adamc@1104: space, adamc@1104: p_typ env t] adamc@271: adamc@707: | DTable (s, xts, pe, ce) => box [string "(* SQL table ", adamc@707: string s, adamc@707: space, adamc@707: string ":", adamc@707: space, adamc@707: p_list (fn (x, t) => box [string x, adamc@707: space, adamc@707: string ":", adamc@707: space, adamc@707: p_typ env t]) xts, adamc@707: space, adamc@707: string "keys", adamc@707: space, adamc@707: p_exp env pe, adamc@707: space, adamc@707: string "constraints", adamc@707: space, adamc@707: p_exp env ce, adamc@707: space, adamc@707: string "*)"] adamc@338: | DSequence s => box [string "(* SQL sequence ", adamc@338: string s, adamc@338: string "*)"] adamc@754: | DView (s, _, e) => box [string "(* SQL view ", adamc@754: string s, adamc@754: space, adamc@754: string "as", adamc@754: space, adamc@754: p_exp env e, adamc@754: string "*)"] adamc@687: | DDatabase {name, expunge, initialize} => box [string "database", adamc@687: space, adamc@687: string name, adamc@687: space, adamc@687: string "(", adamc@687: p_enamed env expunge, adamc@687: string ",", adamc@687: space, adamc@687: p_enamed env initialize, adamc@687: string ")"] adamc@569: | DJavaScript s => box [string "JavaScript(", adamc@569: string s, adamc@569: string ")"] adamc@569: adamc@725: | DCookie s => box [string "cookie", adamc@725: space, adamc@725: string s] adamc@720: | DStyle s => box [string "style", adamc@720: space, adamc@720: string s] adamc@1075: | DTask (e1, e2) => box [string "task", adamc@1073: space, adamc@1075: p_exp env e1, adamc@1075: space, adamc@1075: string "=", adamc@1075: space, adamc@1075: p_exp env e2] adamc@1199: | DPolicy p => box [string "policy", adamc@1199: space, adamc@1199: p_policy env p] adamc@718: 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