From 9b7ee2b22abce813120a633f5a4f5523a630a2ea Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 26 May 2007 17:14:42 +0000 Subject: [PATCH] Factor common printing functionality between text and HTML into a functor --- src/autodoc.sml | 2 +- src/describe.sig | 3 + src/describe.sml | 2 +- src/htmlPrint.sml | 311 +++++++++-------------------- src/print.sml | 187 +++++------------ src/printFn.sig | 58 ++++++ src/{htmlPrint.sml => printFn.sml} | 100 +++------- src/sources | 3 + src/tycheck.sml | 59 +----- 9 files changed, 240 insertions(+), 485 deletions(-) rewrite src/htmlPrint.sml (71%) rewrite src/print.sml (79%) create mode 100644 src/printFn.sig copy src/{htmlPrint.sml => printFn.sml} (67%) diff --git a/src/autodoc.sml b/src/autodoc.sml index 231a13e..86c8651 100644 --- a/src/autodoc.sml +++ b/src/autodoc.sml @@ -42,7 +42,7 @@ fun check' G fname = fun autodoc {outdir, infiles} = let val (prov, infiles) = Order.order NONE infiles - val _ = HtmlPrint.setProviders prov + val _ = HtmlPrintArg.setProviders prov val G = foldl (fn (fname, G) => check' G fname) Env.empty infiles diff --git a/src/describe.sig b/src/describe.sig index 43be39a..514c2a2 100644 --- a/src/describe.sig +++ b/src/describe.sig @@ -20,7 +20,10 @@ signature DESCRIBE = sig + exception UnequalDomains + val describe_unification_error : Ast.typ -> Ast.unification_error -> unit val describe_type_error : Ast.position -> Ast.type_error -> unit + end diff --git a/src/describe.sml b/src/describe.sml index a39faeb..1384d3b 100644 --- a/src/describe.sml +++ b/src/describe.sml @@ -100,7 +100,7 @@ fun describe_unification_error t ue = (print "Reason: Occurs check failed for "; print name; print " in:\n"; - printd (p_typ t)) + output (p_typ t)) fun describe_type_error loc te = case te of diff --git a/src/htmlPrint.sml b/src/htmlPrint.sml dissimilarity index 71% index c752c3f..f72c742 100644 --- a/src/htmlPrint.sml +++ b/src/htmlPrint.sml @@ -1,221 +1,90 @@ -(* HCoop Domtool (http://hcoop.sourceforge.net/) - * Copyright (c) 2006, Adam Chlipala - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. - *) - -(* Pretty-printing Domtool configuration file ASTs for HTML *) - -structure HtmlPrint :> HTML_PRINT = struct - -open Ast Order - -val prov : providers option ref = ref NONE -fun setProviders p = prov := SOME p - -structure TextToken = struct -type token = string -type style = HTMLDev.style -fun string t = t -fun style t = HTMLDev.styleTT -fun size t = String.size t -end - -structure SM = PPStreamFn(structure Token = TextToken - structure Device = HTMLDev) - -structure PD = PPDescFn(SM) -open PD - -fun dBox ds = hovBox (PPS.Rel 1, ds) -fun dvBox ds = vBox (PPS.Rel 0, ds) -fun ivBox ds = vBox (PPS.Rel 1, ds) - -fun keyword s = style (HTMLDev.styleB, [string s]) -val punct = string - -fun modify file = - let - val file' = #file (OS.Path.splitDirFile file) - val file' = #base (OS.Path.splitBaseExt file') - in - file' - end - -fun context s = - case providesContext (valOf (!prov), s) of - NONE => string s - | SOME m => style (HTMLDev.link (modify m ^ ".html#C_" ^ s), [string s]) -fun typ s = - case providesType (valOf (!prov), s) of - NONE => string s - | SOME m => style (HTMLDev.link (modify m ^ ".html#T_" ^ s), [string s]) -fun exp s = - case providesValue (valOf (!prov), s) of - NONE => string s - | SOME m => style (HTMLDev.link (modify m ^ ".html#V_" ^ s), [string s]) - -val field = string -val lit = string -val ident = string - -fun parenIf pn ds = - if pn then - dBox (punct "(" :: ds @ [punct ")"]) - else - dBox ds - -fun p_pred' pn (p, _) = - case p of - CRoot => keyword "Root" - | CConst s => context s - | CPrefix p => dBox [punct "^", p_pred' true p] - | CNot p => dBox [punct "!", p_pred' true p] - | CAnd (p1, p2) => - parenIf pn [p_pred' true p1, space 1, punct "&", space 1, p_pred' true p2] - -val p_pred = p_pred' false - -fun p_predBoxed p = dBox [punct "[", p_pred p, punct "]"] - -fun p_typ' pn (t, _) = - case t of - TBase s => typ s - | TList t => dBox [punct "[", p_typ' false t, punct "]"] - | TArrow (t1, t2) => - parenIf pn [p_typ' true t1, space 1, punct "->", space 1, p_typ' false t2] - | TAction (p, r1, r2) => - (case (StringMap.numItems r1, StringMap.numItems r2) of - (0, 0) => parenIf pn [p_predBoxed p] - | (_, 0) => parenIf pn [p_predBoxed p, space 1, p_record r1] - | _ => parenIf pn [p_predBoxed p, space 1, p_record r1, space 1, - punct "=>", space 1, p_record r2]) - | TNested (p, t) => - parenIf pn [p_pred' false p, space 1, punct "=>", space 1, p_typ' false t] - - | TError => keyword "" - | TUnif (_, ref (SOME t)) => p_typ' pn t - | TUnif (name, ref NONE) => string ("<" ^ name ^ ">") - -and p_record r = - case StringMap.foldri (fn (name, t, d) => - SOME (case d of - NONE => dBox [field name, space 1, - punct ":", space 1, p_typ t] - | SOME d => dBox [dBox [field name, space 1, - punct ":", space 1, p_typ t], - punct ",", space 1, d])) - NONE r of - NONE => punct "{}" - | SOME d => dBox [punct "{", d, punct "}"] - -and p_typ t = p_typ' false t - -fun p_exp (e, _) = - case e of - EInt n => lit (Int.toString n) - | EString s => lit (String.concat ["\"", String.toString s, "\""]) - | EList es => - (case foldr (fn (e, d) => - SOME (case d of - NONE => p_exp e - | SOME d => dBox [p_exp e, punct ",", space 1, d])) - NONE es of - NONE => punct "[]" - | SOME d => dBox [punct "[", d, punct "]"]) - - | ELam (x, NONE, e) => dBox [punct "(\\", space 1, exp x, space 1, - punct "->", space 1, p_exp e, punct ")"] - | ELam (x, SOME t, e) => dBox [punct "(\\", space 1, exp x, space 1, - punct ":", space 1, - dBox [punct "(", p_typ t, punct ")"], - space 1, punct "->", space 1, p_exp e, punct ")"] - | EALam (x, p, e) => dBox [punct "(\\", space 1, exp x, space 1, - punct ":", space 1, p_pred p, - space 1, punct "->", space 1, p_exp e, punct ")"] - - | EVar x => exp x - | EApp (e1, e2) => dBox [punct "(", p_exp e1, break {nsp = 1, offset = 0}, p_exp e2, punct ")"] - - | ESkip => keyword "_" - | ESet (x, e) => dBox [exp x, space 1, punct "=", space 1, p_exp e] - | EGet (x1, x2, e) => dBox [dBox [exp x1, space 1, punct "<-", - space 1, exp x2, punct ";", space 1], - p_exp e] - | ESeq es => dBox (valOf (foldr (fn (e, NONE) => SOME [p_exp e] - | (e, SOME ds) => SOME (dBox [p_exp e, punct ";", newline] :: ds)) - NONE es)) - | ELocal (e1, e2) => dBox [keyword "let", space 1, - p_exp e1, space 1, - keyword "in", space 1, - p_exp e2, space 1, - keyword "end"] - | EWith (e1, (ESkip, _)) => dBox [p_exp e1, space 1, keyword "with", space 1, keyword "end"] - | EWith (e1, e2) => dBox [p_exp e1, space 1, keyword "with", p_exp e2, space 1, keyword "end"] - -fun p_decl d = - case d of - DExternType name => style (HTMLDev.anchor ("T_" ^ name), - [dBox [keyword "extern", space 1, - keyword "type", space 1, - ident name]]) - | DExternVal (name, t) => style (HTMLDev.anchor ("V_" ^ name), - [dBox [keyword "extern", space 1, - keyword "val", space 1, - ident name, space 1, - string ":", space 1, - p_typ t]]) - | DVal (name, NONE, _) => string "Unannotated val declaration!" - | DVal (name, SOME t, _) => style (HTMLDev.anchor ("V_" ^ name), - [dBox [keyword "val", space 1, - ident name, space 1, - punct ":", space 1, - p_typ t]]) - | DContext name => style (HTMLDev.anchor ("C_" ^ name), - [dBox [keyword "context", space 1, - ident name]]) - -fun p_decl_fref d = - case d of - DExternType name => dBox [keyword "extern", space 1, - keyword "type", space 1, - style (HTMLDev.link ("#T_" ^ name), [ident name])] - | DExternVal (name, t) => dBox [keyword "extern", space 1, - keyword "val", space 1, - style (HTMLDev.link ("#V_" ^ name), [ident name]), - space 1, - string ":", space 1, - p_typ t] - | DVal (name, NONE, _) => string "Unannotated val declaration!" - | DVal (name, SOME t, _) => dBox [keyword "val", space 1, - style (HTMLDev.link ("#V_" ^ name), [ident name]), - space 1, - punct ":", space 1, - p_typ t] - | DContext name => dBox [keyword "context", space 1, - style (HTMLDev.link ("#C_" ^ name), [ident name])] - -fun output d = - let - val dev = HTMLDev.openDev {wid = 80, - textWid = NONE} - val myStream = SM.openStream dev - in - description (myStream, d); - SM.flushStream myStream; - HTMLDev.done dev - end - -end +(* HCoop Domtool (http://hcoop.sourceforge.net/) + * Copyright (c) 2006, Adam Chlipala + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + *) + +(* Pretty-printing Domtool configuration file ASTs for HTML *) + +signature HTML_PRINT_ARG = sig + include PRINTFN_INPUT where type rendering = HTML.text + + val setProviders : Order.providers -> unit +end + +structure HtmlPrintArg :> HTML_PRINT_ARG = struct + +open Ast Order + +structure TextToken = struct +type token = string +type style = HTMLDev.style +fun string t = t +fun style t = HTMLDev.styleTT +fun size t = String.size t +end + +structure SM = PPStreamFn(structure Token = TextToken + structure Device = HTMLDev) + +structure PD = PPDescFn(SM) +open PD + +fun keyword s = style (HTMLDev.styleB, [string s]) +val punct = string +val field = string +val lit = string +val ident = string + +val prov : providers option ref = ref NONE +fun setProviders p = prov := SOME p + +fun modify file = + let + val file' = #file (OS.Path.splitDirFile file) + val file' = #base (OS.Path.splitBaseExt file') + in + file' + end + +fun context s = + case providesContext (valOf (!prov), s) of + NONE => string s + | SOME m => style (HTMLDev.link (modify m ^ ".html#C_" ^ s), [string s]) +fun typ s = + case providesType (valOf (!prov), s) of + NONE => string s + | SOME m => style (HTMLDev.link (modify m ^ ".html#T_" ^ s), [string s]) +fun exp s = + case providesValue (valOf (!prov), s) of + NONE => string s + | SOME m => style (HTMLDev.link (modify m ^ ".html#V_" ^ s), [string s]) + +fun anchor (s, d) = style (HTMLDev.anchor s, [d]) +fun link (s, d) = style (HTMLDev.link s, [d]) + +type rendering = HTML.text +fun openStream () = + let + val dev = HTMLDev.openDev {wid = 80, + textWid = NONE} + in + SM.openStream dev + end +fun closeStream s = HTMLDev.done (SM.getDevice s) + +end + +structure HtmlPrint = PrintFn(HtmlPrintArg) diff --git a/src/print.sml b/src/print.sml dissimilarity index 79% index 7e38bb5..eb7421d 100644 --- a/src/print.sml +++ b/src/print.sml @@ -1,138 +1,49 @@ -(* HCoop Domtool (http://hcoop.sourceforge.net/) - * Copyright (c) 2006, Adam Chlipala - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. - *) - -(* Pretty-printing Domtool configuration file ASTs *) - -structure Print :> PRINT = struct - -open Ast - -structure SM = TextIOPP - -structure PD = PPDescFn(SM) -open PD - -fun dBox ds = hovBox (PPS.Rel 1, ds) -fun dvBox ds = vBox (PPS.Rel 0, ds) -fun ivBox ds = vBox (PPS.Rel 1, ds) - -fun parenIf pn ds = - if pn then - dBox (string "(" :: ds @ [string ")"]) - else - dBox ds - -fun p_pred' pn (p, _) = - case p of - CRoot => string "Root" - | CConst s => string s - | CPrefix p => dBox [string "^", p_pred' true p] - | CNot p => dBox [string "!", p_pred' true p] - | CAnd (p1, p2) => - parenIf pn [p_pred' true p1, space 1, string "&", space 1, p_pred' true p2] - -val p_pred = p_pred' false - -fun p_predBoxed p = dBox [string "[", p_pred p, string "]"] - -fun p_typ' pn (t, _) = - case t of - TBase s => string s - | TList t => dBox [string "[", p_typ' false t, string "]"] - | TArrow (t1, t2) => - parenIf pn [p_typ' true t1, space 1, string "->", space 1, p_typ' true t2] - | TAction (p, r1, r2) => - parenIf pn [p_predBoxed p, space 1, p_record r1, space 1, - string "=>", space 1, p_record r2] - | TNested (p, t) => - parenIf pn [p_pred' false p, space 1, string "=>", space 1, p_typ' false t] - - | TError => string "" - | TUnif (_, ref (SOME t)) => p_typ' pn t - | TUnif (name, ref NONE) => string ("<" ^ name ^ ">") - -and p_record r = - case StringMap.foldri (fn (name, t, d) => - SOME (case d of - NONE => dBox [string name, space 1, - string ":", space 1, p_typ t] - | SOME d => dBox [dBox [string name, space 1, - string ":", space 1, p_typ t], - string ",", space 1, d])) - NONE r of - NONE => string "{}" - | SOME d => dBox [string "{", d, string "}"] - -and p_typ t = p_typ' false t - -fun p_exp (e, _) = - case e of - EInt n => string (Int.toString n) - | EString s => string (String.concat ["\"", String.toString s, "\""]) - | EList es => - (case foldr (fn (e, d) => - SOME (case d of - NONE => p_exp e - | SOME d => dBox [p_exp e, string ",", space 1, d])) - NONE es of - NONE => string "[]" - | SOME d => dBox [string "[", d, string "]"]) - - | ELam (x, NONE, e) => dBox [string "(\\", space 1, string x, space 1, - string "->", space 1, p_exp e, string ")"] - | ELam (x, SOME t, e) => dBox [string "(\\", space 1, string x, space 1, - string ":", space 1, - dBox [string "(", p_typ t, string ")"], - space 1, string "->", space 1, p_exp e, string ")"] - | EALam (x, c, e) => dBox [string "(\\\\", space 1, string x, space 1, - string ":", space 1, p_pred c, - space 1, string "->", space 1, p_exp e, string ")"] - - | EVar x => string x - | EApp (e1, e2) => dBox [string "(", p_exp e1, break {nsp = 1, offset = 0}, p_exp e2, string ")"] - - | ESkip => string "_" - | ESet (x, e) => dBox [string x, space 1, string "=", space 1, p_exp e] - | EGet (x1, x2, e) => dBox [dBox [string x1, space 1, string "<-", - space 1, string x2, string ";", space 1], - p_exp e] - | ESeq es => dBox (valOf (foldr (fn (e, NONE) => SOME [p_exp e] - | (e, SOME ds) => SOME (dBox [p_exp e, string ";", newline] :: ds)) - NONE es)) - | ELocal (e1, e2) => dBox [string "let", space 1, - p_exp e1, space 1, - string "in", space 1, - p_exp e2, space 1, - string "end"] - | EWith (e1, (ESkip, _)) => dBox [p_exp e1, space 1, string "with", space 1, string "end"] - | EWith (e1, e2) => dBox [p_exp e1, space 1, string "with", p_exp e2, space 1, string "end"] - -fun printd d = - let - val myStream = SM.openOut {dst = TextIO.stdOut, - wid = 80} - in - description (myStream, d); - SM.newline myStream; - SM.closeStream myStream - end - -fun preface (s, d) = printd (PD.hovBox (PD.PPS.Rel 0, - [PD.string s, PD.space 1, d])) - -end +(* HCoop Domtool (http://hcoop.sourceforge.net/) + * Copyright (c) 2006, Adam Chlipala + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + *) + +(* Pretty-printing Domtool configuration file ASTs *) + +signature PRINT_ARG = PRINTFN_INPUT where type rendering = unit + +structure PrintArg :> PRINT_ARG = struct + +structure SM = TextIOPP + +structure PD = PPDescFn(SM) +open PD + +val keyword = string +val punct = string +val field = string +val lit = string +val ident = string + +val context = string +val typ = string +val exp = string + +fun anchor (_, d) = d +fun link (_, d) = d + +type rendering = unit +fun openStream () = SM.openOut {dst = TextIO.stdOut, wid = 80} +fun closeStream s = (SM.newline s; SM.closeStream s) + +end + +structure Print = PrintFn(PrintArg) diff --git a/src/printFn.sig b/src/printFn.sig new file mode 100644 index 0000000..b2afaf0 --- /dev/null +++ b/src/printFn.sig @@ -0,0 +1,58 @@ +(* HCoop Domtool (http://hcoop.sourceforge.net/) + * Copyright (c) 2006, Adam Chlipala + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + *) + +(* Pretty-printing Domtool configuration file ASTs *) + +signature PRINTFN_INPUT = sig + + structure PD : PP_DESC + + val keyword : string -> PD.pp_desc + val punct : string -> PD.pp_desc + val field : string -> PD.pp_desc + val lit : string -> PD.pp_desc + val ident : string -> PD.pp_desc + + val context : string -> PD.pp_desc + val typ : string -> PD.pp_desc + val exp : string -> PD.pp_desc + + val anchor : string * PD.pp_desc -> PD.pp_desc + val link : string * PD.pp_desc -> PD.pp_desc + + type rendering + val openStream : unit -> PD.PPS.stream + val closeStream : PD.PPS.stream -> rendering + +end + +signature PRINTFN_OUTPUT = sig + + structure PD : PP_DESC + type rendering + + val p_pred : Ast.pred -> PD.pp_desc + val p_typ : Ast.typ -> PD.pp_desc + val p_exp : Ast.exp -> PD.pp_desc + val p_decl : Ast.decl' -> PD.pp_desc + val p_decl_fref : Ast.decl' -> PD.pp_desc + + val output : PD.pp_desc -> rendering + val preface : string * PD.pp_desc -> rendering + +end diff --git a/src/htmlPrint.sml b/src/printFn.sml similarity index 67% copy from src/htmlPrint.sml copy to src/printFn.sml index c752c3f..871c1df 100644 --- a/src/htmlPrint.sml +++ b/src/printFn.sml @@ -16,36 +16,17 @@ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. *) -(* Pretty-printing Domtool configuration file ASTs for HTML *) +(* Pretty-printing Domtool configuration file ASTs *) -structure HtmlPrint :> HTML_PRINT = struct +functor PrintFn (PF : PRINTFN_INPUT) :> PRINTFN_OUTPUT where type rendering = PF.rendering = struct -open Ast Order - -val prov : providers option ref = ref NONE -fun setProviders p = prov := SOME p - -structure TextToken = struct -type token = string -type style = HTMLDev.style -fun string t = t -fun style t = HTMLDev.styleTT -fun size t = String.size t -end - -structure SM = PPStreamFn(structure Token = TextToken - structure Device = HTMLDev) - -structure PD = PPDescFn(SM) +open Ast PF open PD fun dBox ds = hovBox (PPS.Rel 1, ds) fun dvBox ds = vBox (PPS.Rel 0, ds) fun ivBox ds = vBox (PPS.Rel 1, ds) -fun keyword s = style (HTMLDev.styleB, [string s]) -val punct = string - fun modify file = let val file' = #file (OS.Path.splitDirFile file) @@ -54,23 +35,6 @@ fun modify file = file' end -fun context s = - case providesContext (valOf (!prov), s) of - NONE => string s - | SOME m => style (HTMLDev.link (modify m ^ ".html#C_" ^ s), [string s]) -fun typ s = - case providesType (valOf (!prov), s) of - NONE => string s - | SOME m => style (HTMLDev.link (modify m ^ ".html#T_" ^ s), [string s]) -fun exp s = - case providesValue (valOf (!prov), s) of - NONE => string s - | SOME m => style (HTMLDev.link (modify m ^ ".html#V_" ^ s), [string s]) - -val field = string -val lit = string -val ident = string - fun parenIf pn ds = if pn then dBox (punct "(" :: ds @ [punct ")"]) @@ -123,7 +87,7 @@ and p_record r = and p_typ t = p_typ' false t -fun p_exp (e, _) = +fun p_exp' pn (e, _) = case e of EInt n => lit (Int.toString n) | EString s => lit (String.concat ["\"", String.toString s, "\""]) @@ -147,14 +111,14 @@ fun p_exp (e, _) = space 1, punct "->", space 1, p_exp e, punct ")"] | EVar x => exp x - | EApp (e1, e2) => dBox [punct "(", p_exp e1, break {nsp = 1, offset = 0}, p_exp e2, punct ")"] + | EApp (e1, e2) => parenIf pn [p_exp e1, break {nsp = 1, offset = 0}, p_exp' true e2] | ESkip => keyword "_" - | ESet (x, e) => dBox [exp x, space 1, punct "=", space 1, p_exp e] - | EGet (x1, x2, e) => dBox [dBox [exp x1, space 1, punct "<-", - space 1, exp x2, punct ";", space 1], - p_exp e] - | ESeq es => dBox (valOf (foldr (fn (e, NONE) => SOME [p_exp e] + | ESet (x, e) => parenIf pn [exp x, space 1, punct "=", space 1, p_exp e] + | EGet (x1, x2, e) => parenIf pn [dBox [exp x1, space 1, punct "<-", + space 1, exp x2, punct ";", space 1], + p_exp e] + | ESeq es => parenIf pn (valOf (foldr (fn (e, NONE) => SOME [p_exp e] | (e, SOME ds) => SOME (dBox [p_exp e, punct ";", newline] :: ds)) NONE es)) | ELocal (e1, e2) => dBox [keyword "let", space 1, @@ -164,58 +128,60 @@ fun p_exp (e, _) = keyword "end"] | EWith (e1, (ESkip, _)) => dBox [p_exp e1, space 1, keyword "with", space 1, keyword "end"] | EWith (e1, e2) => dBox [p_exp e1, space 1, keyword "with", p_exp e2, space 1, keyword "end"] +and p_exp e = p_exp' false e fun p_decl d = case d of - DExternType name => style (HTMLDev.anchor ("T_" ^ name), - [dBox [keyword "extern", space 1, + DExternType name => anchor ("T_" ^ name, + dBox [keyword "extern", space 1, keyword "type", space 1, - ident name]]) - | DExternVal (name, t) => style (HTMLDev.anchor ("V_" ^ name), - [dBox [keyword "extern", space 1, + ident name]) + | DExternVal (name, t) => anchor ("V_" ^ name, + dBox [keyword "extern", space 1, keyword "val", space 1, ident name, space 1, string ":", space 1, - p_typ t]]) + p_typ t]) | DVal (name, NONE, _) => string "Unannotated val declaration!" - | DVal (name, SOME t, _) => style (HTMLDev.anchor ("V_" ^ name), - [dBox [keyword "val", space 1, + | DVal (name, SOME t, _) => anchor ("V_" ^ name, + dBox [keyword "val", space 1, ident name, space 1, punct ":", space 1, - p_typ t]]) - | DContext name => style (HTMLDev.anchor ("C_" ^ name), - [dBox [keyword "context", space 1, - ident name]]) + p_typ t]) + | DContext name => anchor ("C_" ^ name, + dBox [keyword "context", space 1, + ident name]) fun p_decl_fref d = case d of DExternType name => dBox [keyword "extern", space 1, keyword "type", space 1, - style (HTMLDev.link ("#T_" ^ name), [ident name])] + link ("#T_" ^ name, ident name)] | DExternVal (name, t) => dBox [keyword "extern", space 1, keyword "val", space 1, - style (HTMLDev.link ("#V_" ^ name), [ident name]), + link ("#V_" ^ name, ident name), space 1, string ":", space 1, p_typ t] | DVal (name, NONE, _) => string "Unannotated val declaration!" | DVal (name, SOME t, _) => dBox [keyword "val", space 1, - style (HTMLDev.link ("#V_" ^ name), [ident name]), + link ("#V_" ^ name, ident name), space 1, punct ":", space 1, p_typ t] | DContext name => dBox [keyword "context", space 1, - style (HTMLDev.link ("#C_" ^ name), [ident name])] + link ("#C_" ^ name, ident name)] fun output d = let - val dev = HTMLDev.openDev {wid = 80, - textWid = NONE} - val myStream = SM.openStream dev + val myStream = openStream () in description (myStream, d); - SM.flushStream myStream; - HTMLDev.done dev + PPS.flushStream myStream; + closeStream myStream end +fun preface (s, d) = output (PD.hovBox (PD.PPS.Rel 0, + [PD.string s, PD.space 1, d])) + end diff --git a/src/sources b/src/sources index 7809a93..3b129fd 100644 --- a/src/sources +++ b/src/sources @@ -18,6 +18,9 @@ domtool.lex parse.sig parse.sml +printFn.sig +printFn.sml + print.sig print.sml diff --git a/src/tycheck.sml b/src/tycheck.sml index 6f62a6c..d486603 100644 --- a/src/tycheck.sml +++ b/src/tycheck.sml @@ -47,61 +47,6 @@ fun newUnif () = end end -exception UnequalDomains - -fun eqRecord f (r1, r2) = - (SM.appi (fn (k, v1) => - case SM.find (r2, k) of - NONE => raise UnequalDomains - | SOME v2 => - if f (v1, v2) then - () - else - raise UnequalDomains) r1; - SM.appi (fn (k, v2) => - case SM.find (r1, k) of - NONE => raise UnequalDomains - | SOME v1 => - if f (v1, v2) then - () - else - raise UnequalDomains) r2; - true) - handle UnequalDomains => false - -fun eqPred ((p1, _), (p2, _)) = - case (p1, p2) of - (CRoot, CRoot) => true - | (CConst s1, CConst s2) => s1 = s2 - | (CPrefix p1, CPrefix p2) => eqPred (p1, p2) - | (CNot p1, CNot p2) => eqPred (p1, p2) - | (CAnd (p1, q1), CAnd (p2, q2)) => - eqPred (p1, p2) andalso eqPred (q1, q2) - - | _ => false - -fun eqTy (t1All as (t1, _), t2All as (t2, _)) = - case (t1, t2) of - (TBase s1, TBase s2) => s1 = s2 - | (TList t1, TList t2) => eqTy (t1, t2) - | (TArrow (d1, r1), TArrow (d2, r2)) => - eqTy (d1, d2) andalso eqTy (r1, r2) - - | (TAction (p1, d1, r1), TAction (p2, d2, r2)) => - eqPred (p1, p2) andalso eqRecord eqTy (d1, d2) - andalso eqRecord eqTy (r1, r2) - - | (TNested (p1, q1), TNested (p2, q2)) => - eqPred (p1, p2) andalso eqTy (q1, q2) - - | (TUnif (_, ref (SOME t1)), _) => eqTy (t1, t2All) - | (_, TUnif (_, ref (SOME t2))) => eqTy (t1All, t2) - - | (TUnif (_, r1), TUnif (_, r2)) => r1 = r2 - - | (TError, TError) => true - - | _ => false fun predImplies (p1All as (p1, _), p2All as (p2, _)) = case (p1, p2) of @@ -154,7 +99,7 @@ fun subPred (p1, p2) = fun subRecord f (r1, r2) = SM.appi (fn (k, v2) => case SM.find (r1, k) of - NONE => raise UnequalDomains + NONE => raise Describe.UnequalDomains | SOME v1 => f (v1, v2)) r2 fun occurs u (t, _) = @@ -646,7 +591,7 @@ fun checkUnit G (eAll as (_, loc)) = ununif t handle Ununif => (ErrorMsg.error (SOME loc) "Unification variables remain in type:"; - printd (p_typ t); + output (p_typ t); t) end -- 2.20.1