adamc@1: (* Copyright (c) 2008, Adam Chlipala adamc@1: * All rights reserved. adamc@1: * adamc@1: * Redistribution and use in source and binary forms, with or without adamc@1: * modification, are permitted provided that the following conditions are met: adamc@1: * adamc@1: * - Redistributions of source code must retain the above copyright notice, adamc@1: * this list of conditions and the following disclaimer. adamc@1: * - Redistributions in binary form must reproduce the above copyright notice, adamc@1: * this list of conditions and the following disclaimer in the documentation adamc@1: * and/or other materials provided with the distribution. adamc@1: * - The names of contributors may not be used to endorse or promote products adamc@1: * derived from this software without specific prior written permission. adamc@1: * adamc@1: * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" adamc@1: * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE adamc@1: * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE adamc@1: * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE adamc@1: * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR adamc@1: * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF adamc@1: * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS adamc@1: * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN adamc@1: * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) adamc@1: * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE adamc@1: * POSSIBILITY OF SUCH DAMAGE. adamc@1: *) adamc@1: adamc@244: (* Pretty-printing Ur/Web *) adamc@1: adamc@4: structure SourcePrint :> SOURCE_PRINT = struct adamc@1: adamc@1: open Print.PD adamc@1: open Print adamc@1: adamc@4: open Source adamc@1: adamc@1: fun p_kind' par (k, _) = adamc@1: case k of adamc@1: KType => string "Type" adamc@1: | KArrow (k1, k2) => parenIf par (box [p_kind' true k1, adamc@1: space, adamc@1: string "->", adamc@1: space, adamc@1: p_kind k2]) adamc@1: | KName => string "Name" adamc@1: | KRecord k => box [string "{", p_kind k, string "}"] adamc@82: | KUnit => string "Unit" adamc@18: | KWild => string "_" adamc@207: | KTuple ks => box [string "(", adamc@207: p_list_sep (box [space, string "*", space]) p_kind ks, adamc@207: string ")"] adamc@1: adamc@623: | KVar x => string x adamc@623: | KFun (x, k) => box [string x, adamc@623: space, adamc@623: string "-->", adamc@623: space, adamc@623: p_kind k] adamc@623: adamc@1: and p_kind k = p_kind' false k adamc@1: adamc@1: fun p_explicitness e = adamc@1: case e of adamc@1: Explicit => string "::" adamc@1: | Implicit => string ":::" adamc@1: adamc@1: fun p_con' par (c, _) = adamc@1: case c of adamc@1: CAnnot (c, k) => box [string "(", adamc@1: p_con c, adamc@1: space, adamc@1: string "::", adamc@1: space, adamc@1: p_kind k, adamc@1: string ")"] adamc@1: adamc@1: | TFun (t1, t2) => parenIf par (box [p_con' true t1, adamc@1: space, adamc@1: string "->", adamc@1: space, adamc@1: p_con t2]) adamc@1: | TCFun (e, x, k, c) => parenIf par (box [string x, adamc@1: space, adamc@1: p_explicitness e, adamc@1: space, adamc@1: p_kind k, adamc@1: space, adamc@1: string "->", adamc@1: space, adamc@1: p_con c]) adamc@1: | TRecord (CRecord xcs, _) => box [string "{", adamc@1: p_list (fn (x, c) => adamc@20: box [p_name x, adamc@1: space, adamc@1: string ":", adamc@1: space, adamc@1: p_con c]) xcs, adamc@1: string "}"] adamc@1: | TRecord c => box [string "$", adamc@1: p_con' true c] adamc@628: | TDisjoint (c1, c2, c3) => parenIf par (box [string "[", adamc@628: p_con c1, adamc@628: space, adamc@628: string "~", adamc@628: space, adamc@628: p_con c2, adamc@628: string "]", adamc@628: space, adamc@628: string "=>", adamc@628: space, adamc@628: p_con c3]) adamc@1: adamc@34: | CVar (ss, s) => p_list_sep (string ".") string (ss @ [s]) adamc@1: | CApp (c1, c2) => parenIf par (box [p_con c1, adamc@1: space, adamc@1: p_con' true c2]) adamc@67: | CAbs (x, NONE, c) => parenIf par (box [string "fn", adamc@67: space, adamc@67: string x, adamc@67: space, adamc@67: string "=>", adamc@67: space, adamc@67: p_con c]) adamc@67: | CAbs (x, SOME k, c) => parenIf par (box [string "fn", adamc@67: space, adamc@67: string x, adamc@67: space, adamc@67: string "::", adamc@67: space, adamc@67: p_kind k, adamc@67: space, adamc@67: string "=>", adamc@67: space, adamc@67: p_con c]) adamc@628: adamc@1: adamc@1: | CName s => box [string "#", string s] adamc@1: adamc@1: | CRecord xcs => box [string "[", adamc@1: p_list (fn (x, c) => adamc@1: box [p_con x, adamc@1: space, adamc@1: string "=", adamc@1: space, adamc@1: p_con c]) xcs, adamc@1: string "]"] adamc@1: | CConcat (c1, c2) => parenIf par (box [p_con' true c1, adamc@1: space, adamc@1: string "++", adamc@1: space, adamc@1: p_con c2]) adamc@621: | CMap => string "map" adamc@82: adamc@82: | CUnit => string "()" adamc@82: adamc@18: | CWild k => box [string "(_", adamc@18: space, adamc@18: string "::", adamc@18: space, adamc@223: p_kind k, adamc@223: string ")"] adamc@207: adamc@207: | CTuple cs => box [string "(", adamc@207: p_list p_con cs, adamc@207: string ")"] adamc@207: | CProj (c, n) => box [p_con c, adamc@207: string ".", adamc@207: string (Int.toString n)] adamc@623: adamc@623: | CKAbs (x, c) => box [string x, adamc@623: space, adamc@623: string "==>", adamc@623: space, adamc@623: p_con c] adamc@623: | TKFun (x, c) => box [string x, adamc@623: space, adamc@623: string "-->", adamc@623: space, adamc@623: p_con c] adamc@1: adamc@1: and p_con c = p_con' false c adamc@1: adamc@20: and p_name (all as (c, _)) = adamc@20: case c of adamc@20: CName s => string s adamc@20: | _ => p_con all adamc@20: adamc@170: fun p_pat' par (p, _) = adamc@170: case p of adamc@170: PWild => string "_" adamc@170: | PVar s => string s adamc@173: | PPrim p => Prim.p_t p adamc@170: | PCon (ms, x, NONE) => p_list_sep (string ".") string (ms @ [x]) adamc@170: | PCon (ms, x, SOME p) => parenIf par (box [p_list_sep (string ".") string (ms @ [x]), adamc@170: space, adamc@170: p_pat' true p]) adamc@174: | PRecord (xps, flex) => adamc@174: let adamc@175: val pps = map (fn (x, p) => box [string x, space, string "=", space, p_pat p]) xps adamc@174: in adamc@174: box [string "{", adamc@174: p_list_sep (box [string ",", space]) (fn x => x) adamc@174: (if flex then adamc@175: pps @ [string "..."] adamc@174: else adamc@175: pps), adamc@174: string "}"] adamc@174: end adamc@170: adamc@822: | PAnnot (p, t) => box [p_pat p, adamc@822: space, adamc@822: string ":", adamc@822: space, adamc@822: p_con t] adamc@822: adamc@174: and p_pat x = p_pat' false x adamc@170: adamc@8: fun p_exp' par (e, _) = adamc@8: case e of adamc@8: EAnnot (e, t) => box [string "(", adamc@8: p_exp e, adamc@8: space, adamc@8: string ":", adamc@8: space, adamc@8: p_con t, adamc@8: string ")"] adamc@8: adamc@14: | EPrim p => Prim.p_t p adamc@403: | EVar (ss, s, _) => p_list_sep (string ".") string (ss @ [s]) adamc@8: | EApp (e1, e2) => parenIf par (box [p_exp e1, adamc@8: space, adamc@8: p_exp' true e2]) adamc@8: | EAbs (x, NONE, e) => parenIf par (box [string "fn", adamc@8: space, adamc@8: string x, adamc@8: space, adamc@8: string "=>", adamc@8: space, adamc@8: p_exp e]) adamc@8: | EAbs (x, SOME t, e) => parenIf par (box [string "fn", adamc@8: space, adamc@8: string x, adamc@8: space, adamc@8: string ":", adamc@8: space, adamc@8: p_con t, adamc@8: space, adamc@8: string "=>", adamc@8: space, adamc@8: p_exp e]) adamc@8: | ECApp (e, c) => parenIf par (box [p_exp e, adamc@8: space, adamc@8: string "[", adamc@8: p_con c, adamc@8: string "]"]) adamc@8: | ECAbs (exp, x, k, e) => parenIf par (box [string "fn", adamc@8: space, adamc@8: string x, adamc@8: space, adamc@8: p_explicitness exp, adamc@8: space, adamc@8: p_kind k, adamc@8: space, adamc@8: string "=>", adamc@8: space, adamc@8: p_exp e]) adamc@85: | EDisjoint (c1, c2, e) => parenIf par (box [p_con c1, adamc@85: space, adamc@85: string "~", adamc@85: space, adamc@85: p_con c2, adamc@85: space, adamc@85: string "=>", adamc@85: space, adamc@85: p_exp e]) adamc@629: | EDisjointApp e => parenIf par (box [p_exp e, adamc@629: space, adamc@629: string "!"]) adamc@8: adam@2009: | ERecord (xes, flex) => box [string "{", adam@2009: p_list (fn (x, e) => adam@2009: box [p_name x, adam@2009: space, adam@2009: string "=", adam@2009: space, adam@2009: p_exp e]) xes, adam@2009: if flex then adam@2009: box [string ",", adam@2009: space, adam@2009: string "..."] adam@2009: else adam@2009: box [], adam@2009: string "}"] adamc@12: | EField (e, c) => box [p_exp' true e, adamc@12: string ".", adamc@12: p_con' true c] adamc@445: | EConcat (e1, e2) => parenIf par (box [p_exp' true e1, adamc@445: space, adamc@445: string "++", adamc@445: space, adamc@445: p_exp' true e2]) adamc@149: | ECut (e, c) => parenIf par (box [p_exp' true e, adamc@149: space, adamc@149: string "--", adamc@149: space, adamc@149: p_con' true c]) adamc@493: | ECutMulti (e, c) => parenIf par (box [p_exp' true e, adamc@493: space, adamc@493: string "---", adamc@493: space, adamc@493: p_con' true c]) adamc@170: | ECase (e, pes) => parenIf par (box [string "case", adamc@170: space, adamc@171: p_exp e, adamc@170: space, adamc@170: string "of", adamc@170: space, adamc@170: p_list_sep (box [space, string "|", space]) adamc@170: (fn (p, e) => box [p_pat p, adamc@170: space, adamc@170: string "=>", adamc@170: space, adamc@170: p_exp e]) pes]) adamc@170: adamc@219: | EWild => string "_" adamc@210: adamc@446: | ELet (ds, e) => box [string "let", adamc@446: newline, adamc@446: box [p_list_sep newline p_edecl ds], adamc@446: newline, adamc@446: string "in", adamc@446: newline, adamc@446: box [p_exp e], adamc@446: newline, adamc@446: string "end"] adamc@446: adamc@623: | EKAbs (x, e) => box [string x, adamc@623: space, adamc@623: string "-->", adamc@623: space, adamc@623: p_exp e] adamc@623: adamc@8: and p_exp e = p_exp' false e adamc@8: adamc@446: and p_edecl (d, _) = adamc@446: case d of adamc@825: EDVal (p, e) => box [string "val", adamc@825: space, adamc@825: p_pat p, adamc@825: space, adamc@825: string "=", adamc@825: space, adamc@825: p_exp e] adamc@446: | EDValRec vis => box [string "val", adamc@446: space, adamc@446: string "rec", adamc@446: space, adamc@446: p_list_sep (box [newline, string "and", space]) p_vali vis] adamc@446: adamc@446: and p_vali (x, co, e) = adamc@446: case co of adamc@446: NONE => box [string x, adamc@446: space, adamc@446: string "=", adamc@446: space, adamc@446: p_exp e] adamc@446: | SOME t => box [string x, adamc@446: space, adamc@446: string ":", adamc@446: space, adamc@446: p_con t, adamc@446: space, adamc@446: string "=", adamc@446: space, adamc@446: p_exp e] adamc@446: adamc@446: adamc@191: fun p_datatype (x, xs, cons) = adamc@805: box [string x, adamc@191: p_list_sep (box []) (fn x => box [space, string x]) xs, adamc@156: space, adamc@156: string "=", adamc@156: space, adamc@156: p_list_sep (box [space, string "|", space]) adamc@156: (fn (x, NONE) => string x adamc@156: | (x, SOME t) => box [string x, space, string "of", space, p_con t]) adamc@156: cons] adamc@156: adamc@30: fun p_sgn_item (sgi, _) = adamc@30: case sgi of adamc@30: SgiConAbs (x, k) => box [string "con", adamc@30: space, adamc@30: string x, adamc@30: space, adamc@30: string "::", adamc@30: space, adamc@30: p_kind k] adamc@30: | SgiCon (x, NONE, c) => box [string "con", adamc@30: space, adamc@30: string x, adamc@30: space, adamc@30: string "=", adamc@30: space, adamc@30: p_con c] adamc@30: | SgiCon (x, SOME k, c) => box [string "con", adamc@30: space, adamc@30: string x, adamc@30: space, adamc@30: string "::", adamc@30: space, adamc@30: p_kind k, adamc@30: space, adamc@30: string "=", adamc@30: space, adamc@30: p_con c] adamc@805: | SgiDatatype x => box [string "datatype", adamc@805: space, adamc@805: p_list_sep (box [space, string "and", space]) p_datatype x] adamc@156: | SgiDatatypeImp (x, ms, x') => adamc@156: box [string "datatype", adamc@156: space, adamc@156: string x, adamc@156: space, adamc@156: string "=", adamc@156: space, adamc@156: string "datatype", adamc@156: space, adamc@156: p_list_sep (string ".") string (ms @ [x'])] adamc@30: | SgiVal (x, c) => box [string "val", adamc@30: space, adamc@30: string x, adamc@30: space, adamc@30: string ":", adamc@30: space, adamc@30: p_con c] adamc@707: | SgiTable (x, c, pe, ce) => box [string "table", adamc@707: space, adamc@707: string x, adamc@707: space, adamc@707: string ":", adamc@707: space, adamc@707: p_con c, adamc@707: space, adamc@707: string "keys", adamc@707: space, adamc@707: p_exp pe, adamc@707: space, adamc@707: string "constraints", adamc@707: space, adamc@707: p_exp ce] adamc@30: | SgiStr (x, sgn) => box [string "structure", adamc@30: space, adamc@30: string x, adamc@30: space, adamc@30: string ":", adamc@30: space, adamc@30: p_sgn sgn] adamc@59: | SgiSgn (x, sgn) => box [string "signature", adamc@59: space, adamc@59: string x, adamc@59: space, adamc@59: string "=", adamc@59: space, adamc@59: p_sgn sgn] adamc@58: | SgiInclude sgn => box [string "include", adamc@58: space, adamc@58: p_sgn sgn] adamc@88: | SgiConstraint (c1, c2) => box [string "constraint", adamc@88: space, adamc@88: p_con c1, adamc@88: space, adamc@88: string "~", adamc@88: space, adamc@88: p_con c2] adamc@563: | SgiClassAbs (x, k) => box [string "class", adamc@563: space, adamc@563: string x, adamc@563: space, adamc@563: string "::", adamc@563: space, adamc@563: p_kind k] adamc@563: | SgiClass (x, k, c) => box [string "class", adamc@563: space, adamc@563: string x, adamc@563: space, adamc@563: string "::", adamc@563: space, adamc@563: p_kind k, adamc@563: space, adamc@563: string "=", adamc@563: space, adamc@563: p_con c] adamc@563: adamc@30: and p_sgn (sgn, _) = adamc@30: case sgn of adamc@30: SgnConst sgis => box [string "sig", adamc@30: newline, adamc@30: p_list_sep newline p_sgn_item sgis, adamc@30: newline, adamc@30: string "end"] adamc@30: | SgnVar x => string x adamc@40: | SgnFun (x, sgn, sgn') => box [string "functor", adamc@40: space, adamc@40: string "(", adamc@40: string x, adamc@40: space, adamc@40: string ":", adamc@40: p_sgn sgn, adamc@40: string ")", adamc@40: space, adamc@40: string ":", adamc@40: space, adamc@40: p_sgn sgn'] adam@1864: | SgnWhere (sgn, ms, x, c) => box [p_sgn sgn, adam@1864: space, adam@1864: string "where", adam@1864: space, adam@1864: string "con", adam@1864: space, adam@1864: p_list_sep (string ".") adam@1864: string (ms @ [x]), adam@1864: string x, adam@1864: space, adam@1864: string "=", adam@1864: space, adam@1864: p_con c] adamc@59: | SgnProj (m, ms, x) => p_list_sep (string ".") string (m :: ms @ [x]) adamc@59: adamc@42: adamc@123: adamc@1: fun p_decl ((d, _) : decl) = adamc@1: case d of adamc@1: DCon (x, NONE, c) => box [string "con", adamc@1: space, adamc@1: string x, adamc@1: space, adamc@1: string "=", adamc@1: space, adamc@1: p_con c] adamc@1: | DCon (x, SOME k, c) => box [string "con", adamc@1: space, adamc@1: string x, adamc@1: space, adamc@1: string "::", adamc@1: space, adamc@1: p_kind k, adamc@1: space, adamc@1: string "=", adamc@1: space, adamc@1: p_con c] adamc@805: | DDatatype x => box [string "datatype", adamc@805: space, adamc@805: p_list_sep (box [space, string "and", space]) p_datatype x] adamc@156: | DDatatypeImp (x, ms, x') => adamc@156: box [string "datatype", adamc@156: space, adamc@156: string x, adamc@156: space, adamc@156: string "=", adamc@156: space, adamc@156: string "datatype", adamc@156: space, adamc@156: p_list_sep (string ".") string (ms @ [x'])] adamc@123: | DVal vi => box [string "val", adamc@123: space, adamc@123: p_vali vi] adamc@123: | DValRec vis => box [string "val", adamc@123: space, adamc@123: string "rec", adamc@123: space, adamc@123: p_list_sep (box [newline, string "and", space]) p_vali vis] adamc@1: adamc@30: | DSgn (x, sgn) => box [string "signature", adamc@30: space, adamc@30: string x, adamc@30: space, adamc@30: string "=", adamc@30: space, adamc@30: p_sgn sgn] adam@1868: | DStr (x, NONE, _, str, _) => box [string "structure", adam@1868: space, adam@1868: string x, adam@1868: space, adam@1868: string "=", adam@1868: space, adam@1868: p_str str] adam@1868: | DStr (x, SOME sgn, _, str, _) => box [string "structure", adam@1868: space, adam@1868: string x, adam@1868: space, adam@1868: string ":", adam@1868: space, adam@1868: p_sgn sgn, adam@1868: space, adam@1868: string "=", adam@1868: space, adam@1868: p_str str] adam@1732: | DFfiStr (x, sgn, _) => box [string "extern", adam@1732: space, adam@1732: string "structure", adamc@30: space, adamc@30: string x, adamc@30: space, adam@1732: string ":", adamc@30: space, adam@1732: p_sgn sgn] adamc@61: | DOpen (m, ms) => box [string "open", adamc@61: space, adamc@61: p_list_sep (string ".") string (m :: ms)] adamc@88: | DConstraint (c1, c2) => box [string "constraint", adamc@88: space, adamc@88: p_con c1, adamc@88: space, adamc@88: string "~", adamc@88: space, adamc@88: p_con c2] adamc@88: | DOpenConstraints (m, ms) => box [string "open", adamc@88: space, adamc@88: string "constraints", adamc@88: space, adamc@88: p_list_sep (string ".") string (m :: ms)] adamc@30: adamc@109: | DExport str => box [string "export", adamc@109: space, adamc@109: p_str str] adamc@707: | DTable (x, c, pe, ce) => box [string "table", adamc@707: space, adamc@707: string x, adamc@707: space, adamc@707: string ":", adamc@707: space, adamc@707: p_con c, adamc@707: space, adamc@707: string "keys", adamc@707: space, adamc@707: p_exp pe, adamc@707: space, adamc@707: string "constraints", adamc@707: space, adamc@707: p_exp ce] adamc@338: | DSequence x => box [string "sequence", adamc@338: space, adamc@338: string x] adamc@754: | DView (x, e) => box [string "view", adamc@754: space, adamc@754: string x, adamc@754: space, adamc@754: string "=", adamc@754: space, adamc@754: p_exp e] adamc@100: adamc@271: | DDatabase s => box [string "database", adamc@271: space, adamc@271: string s] adamc@271: adamc@459: | DCookie (x, c) => box [string "cookie", adamc@459: space, adamc@459: string x, adamc@459: space, adamc@459: string ":", adamc@459: space, adamc@459: p_con c] adamc@720: | DStyle x => box [string "style", adamc@720: space, adamc@720: string x] adamc@1075: | DTask (e1, e2) => box [string "task", adamc@1073: space, adamc@1075: p_exp e1, adamc@1075: space, adamc@1075: string "=", adamc@1075: space, adamc@1075: p_exp e2] adamc@1199: | DPolicy e1 => box [string "policy", adamc@1199: space, adamc@1199: p_exp e1] adam@1294: | DOnError _ => string "ONERROR" adam@2010: | DFfi _ => string "FFI" adamc@459: adamc@30: and p_str (str, _) = adamc@30: case str of adamc@30: StrConst ds => box [string "struct", adamc@30: newline, adamc@30: p_list_sep newline p_decl ds, adamc@30: newline, adamc@30: string "end"] adamc@30: | StrVar x => string x adamc@34: | StrProj (str, x) => box [p_str str, adamc@34: string ".", adamc@34: string x] adamc@40: | StrFun (x, sgn, NONE, str) => box [string "functor", adamc@40: space, adamc@40: string "(", adamc@40: string x, adamc@40: space, adamc@40: string ":", adamc@40: p_sgn sgn, adamc@40: string ")", adamc@40: space, adamc@40: string "=>", adamc@40: space, adamc@40: p_str str] adamc@40: | StrFun (x, sgn, SOME sgn', str) => box [string "functor", adamc@40: space, adamc@40: string "(", adamc@40: string x, adamc@40: space, adamc@40: string ":", adamc@40: p_sgn sgn, adamc@40: string ")", adamc@40: space, adamc@40: string ":", adamc@40: space, adamc@40: p_sgn sgn', adamc@40: space, adamc@40: string "=>", adamc@40: space, adamc@40: p_str str] adamc@44: | StrApp (str1, str2) => box [p_str str1, adamc@44: string "(", adamc@44: p_str str2, adamc@44: string ")"] adamc@30: adamc@1: val p_file = p_list_sep newline p_decl adamc@1: adamc@1: end