From 63920aa5296a85edd9d734a65be22d9911358df2 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Mon, 24 Jul 2006 17:05:29 +0000 Subject: [PATCH 1/1] Pretty-printing --- src/ast.sml | 24 +++++----- src/domtool.cm | 4 ++ src/domtool.grm | 26 ++++------- src/domtool.lex | 1 + src/print.sig | 31 +++++++++++++ src/print.sml | 120 ++++++++++++++++++++++++++++++++++++++++++++++++ tests/test.dtl | 4 +- 7 files changed, 180 insertions(+), 30 deletions(-) create mode 100644 src/print.sig create mode 100644 src/print.sml diff --git a/src/ast.sml b/src/ast.sml index 6ee4b7b..91bca42 100644 --- a/src/ast.sml +++ b/src/ast.sml @@ -23,18 +23,18 @@ structure Ast = struct open DataStructures (* A description of a predicate on configuration block stacks *) -datatype context' = +datatype pred' = CRoot (* The stack is empty. *) | CConst of string - (* The given context name is on top of the stack. *) - | CPrefix of context - (* Some prefix of the stack matches the context. *) - | CNot of context - (* The context does not match. *) - | CAnd of context * context - (* Both contexts match. *) -withtype context = context' * position + (* The given pred name is on top of the stack. *) + | CPrefix of pred + (* Some prefix of the stack matches the pred. *) + | CNot of pred + (* The pred does not match. *) + | CAnd of pred * pred + (* Both preds match. *) +withtype pred = pred' * position datatype typ' = TBase of string @@ -43,9 +43,9 @@ datatype typ' = (* SML 'a list *) | TArrow of typ * typ (* SML -> *) - | TAction of context * record * record + | TAction of pred * record * record (* An action that: - * - Is valid in the given context + * - Is valid in the given pred * - Expects an environment compatible with the first record * - Modifies it according to the second record *) withtype typ = typ' * position @@ -68,7 +68,7 @@ datatype exp' = | ESet of string * exp (* Set an environment variable *) - | EEnv of string + | EGet of string * string * exp (* Get an environment variable *) | ESeq of exp list (* Monad sequencer; execute a number of commands in order *) diff --git a/src/domtool.cm b/src/domtool.cm index acf15a7..3d866f9 100644 --- a/src/domtool.cm +++ b/src/domtool.cm @@ -3,6 +3,7 @@ Group is $/basis.cm $/smlnj-lib.cm $/ml-yacc-lib.cm +$/pp-lib.cm errormsg.sig errormsg.sml @@ -16,3 +17,6 @@ domtool.grm parse.sig parse.sml + +print.sig +print.sml diff --git a/src/domtool.grm b/src/domtool.grm index 3384492..102349e 100644 --- a/src/domtool.grm +++ b/src/domtool.grm @@ -17,6 +17,7 @@ *) (* Parser for Domtool configuration files *) + open Ast %% @@ -27,7 +28,8 @@ open Ast | SYMBOL of string | CSYMBOL of string | STRING of string | INT of int - | ARROW | DARROW | COLON | CARET | BANG | AND + | ARROW | DARROW | LARROW + | COLON | CARET | BANG | AND | LPAREN | RPAREN | LBRACK | RBRACK | LBRACE | RBRACE | EQ | COMMA | BSLASH | SEMI | LET | IN | END | ROOT @@ -41,7 +43,7 @@ open Ast | elistNe of exp list | clist of exp list | typ of typ - | ctxt of context + | ctxt of pred | recd of record | recdNe of record @@ -77,6 +79,7 @@ exp : apps (apps) in (ESeq ls, (exp1left, exp2right)) end) + | SYMBOL LARROW CSYMBOL SEMI exp (EGet (SYMBOL, CSYMBOL, exp), (SYMBOLleft, expright)) apps : term (term) | apps term (EApp (apps, term), (appsleft, termright)) @@ -85,18 +88,9 @@ term : LPAREN exp RPAREN (exp) | INT (EInt INT, (INTleft, INTright)) | STRING (EString STRING, (STRINGleft, STRINGright)) | LBRACK elist RBRACK (EList elist, (LBRACKleft, RBRACKright)) - | LET exp IN exp END (let - val ls = case (#1 exp1, #1 exp2) of - (ESeq ls1, ESeq ls2) => ls1 @ ls2 - | (ESeq ls, _) => ls @ [exp2] - | (_, ESeq ls) => exp1 :: ls - | _ => [exp1, exp2] - in - (ELocal (ESeq ls, (exp1left, exp2right)), - (exp1left, exp2right)) - end) + | LET exp IN exp END (ELocal (ESeq [exp1, exp2], (LETleft, ENDright)), + (LETleft, ENDright)) | SYMBOL (EVar SYMBOL, (SYMBOLleft, SYMBOLright)) - | CSYMBOL (EEnv CSYMBOL, (CSYMBOLleft, CSYMBOLright)) elist : ([]) | elistNe (elistNe) @@ -107,11 +101,11 @@ elistNe: exp ([exp]) typ : SYMBOL (TBase SYMBOL, (SYMBOLleft, SYMBOLright)) | LBRACK typ RBRACK (TList typ, (LBRACKleft, RBRACKright)) | typ ARROW typ (TArrow (typ1, typ2), (typleft, typright)) - | LBRACK ctxt RBRACK recd DARROW recd (TAction (ctxt, recd1, recd2), (ctxtleft, recd2right)) + | LBRACK ctxt RBRACK recd DARROW recd (TAction (ctxt, recd1, recd2), (LBRACKleft, recd2right)) | LBRACK ctxt RBRACK recd (TAction (ctxt, recd, StringMap.empty), - (ctxtleft, recdright)) + (LBRACKleft, recdright)) | LBRACK ctxt RBRACK (TAction (ctxt, StringMap.empty, StringMap.empty), - (ctxtleft, ctxtright)) + (LBRACKleft, ctxtright)) | LPAREN typ RPAREN (typ) recd : LBRACE RBRACE (StringMap.empty) diff --git a/src/domtool.lex b/src/domtool.lex index 765a6ab..5130ad9 100644 --- a/src/domtool.lex +++ b/src/domtool.lex @@ -103,6 +103,7 @@ lineComment = #[^\n]*\n; "->" => (Tokens.ARROW (yypos, yypos + size yytext)); "=>" => (Tokens.DARROW (yypos, yypos + size yytext)); + "<-" => (Tokens.LARROW (yypos, yypos + size yytext)); "=" => (Tokens.EQ (yypos, yypos + size yytext)); "," => (Tokens.COMMA (yypos, yypos + size yytext)); diff --git a/src/print.sig b/src/print.sig new file mode 100644 index 0000000..92493fb --- /dev/null +++ b/src/print.sig @@ -0,0 +1,31 @@ +(* 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 = sig + +structure PD : PP_DESC + +val print : PD.pp_desc -> unit + +val p_pred : Ast.pred -> PD.pp_desc +val p_typ : Ast.typ -> PD.pp_desc +val p_exp : Ast.exp -> PD.pp_desc + +end diff --git a/src/print.sml b/src/print.sml new file mode 100644 index 0000000..7f182b9 --- /dev/null +++ b/src/print.sml @@ -0,0 +1,120 @@ +(* 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] +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, 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 ")"] + | EVar x => string x + | EApp (e1, e2) => dBox [string "(", p_exp e1, break {nsp = 1, offset = 0}, p_exp e2, 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 ";", space 1] :: ds)) + NONE es)) + | ELocal (ESeq [e1, e2], _) => dBox [string "let", space 1, + p_exp e1, space 1, + string "in", space 1, + p_exp e2, space 1, + string "end"] + | ELocal _ => raise Fail "Unexpected ELocal form" + +fun print d = + let + val myStream = SM.openOut {dst = TextIO.stdOut, + wid = 80} + in + description (myStream, d); + SM.newline myStream; + SM.closeStream myStream + end + +end diff --git a/tests/test.dtl b/tests/test.dtl index c026ea2..8a6ae2c 100644 --- a/tests/test.dtl +++ b/tests/test.dtl @@ -1,6 +1,6 @@ -\x : ([int] -> [Root]) -> x X; +\x : ([int] -> [Root]) -> x; let Day = "Tuesday" in - Kill monkeys + kill monkeys end -- 2.20.1