src/printFn.sml

   1 (* HCoop Domtool (http://hcoop.sourceforge.net/)
   2  * Copyright (c) 2006, Adam Chlipala
   3  *
   4  * This program is free software; you can redistribute it and/or
   5  * modify it under the terms of the GNU General Public License
   6  * as published by the Free Software Foundation; either version 2
   7  * of the License, or (at your option) any later version.
   8  *
   9  * This program is distributed in the hope that it will be useful,
  10  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  11  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12  * GNU General Public License for more details.
  13  *
  14  * You should have received a copy of the GNU General Public License
  15  * along with this program; if not, write to the Free Software
  16  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
  17  *)
  18
  19 (* Pretty-printing Domtool configuration file ASTs *)
  20
  21 functor PrintFn (PF : PRINTFN_INPUT) :> PRINTFN_OUTPUT where type rendering = PF.rendering = struct
  22
  23 open Ast PF
  24 open PD
  25
  26 fun dBox ds = hovBox (PPS.Rel 1, ds)
  27 fun dvBox ds = vBox (PPS.Rel 0, ds)
  28 fun ivBox ds = vBox (PPS.Rel 1, ds)
  29
  30 fun modify file =
  31     let
  32         val file' = #file (OS.Path.splitDirFile file)
  33         val file' = #base (OS.Path.splitBaseExt file')
  34     in
  35         file'
  36     end
  37
  38 fun parenIf pn ds =
  39     if pn then
  40         dBox (punct "(" :: ds @ [punct ")"])
  41     else
  42         dBox ds
  43
  44 fun p_pred' pn (p, _) =
  45     case p of
  46         CRoot => keyword "Root"
  47       | CConst s => context s
  48       | CPrefix p => dBox [punct "^", p_pred' true p]
  49       | CNot p => dBox [punct "!", p_pred' true p]
  50       | CAnd (p1, p2) =>
  51         parenIf pn [p_pred' true p1, space 1, punct "&", space 1, p_pred' true p2]
  52
  53 val p_pred = p_pred' false
  54
  55 fun p_predBoxed p = dBox [punct "[", p_pred p, punct "]"]
  56
  57 fun p_typ' pn (t, _) =
  58     case t of
  59         TBase s => typ s
  60       | TList t => dBox [punct "[", p_typ' false t, punct "]"]
  61       | TArrow (t1, t2) =>
  62         parenIf pn [p_typ' true t1, space 1, punct "->", space 1, p_typ' false t2]
  63       | TAction (p, r1, r2) =>
  64         (case (StringMap.numItems r1, StringMap.numItems r2) of
  65              (0, 0) => parenIf pn [p_predBoxed p]
  66            | (_, 0) =>  parenIf pn [p_predBoxed p, space 1, p_record r1]
  67            | _ => parenIf pn [p_predBoxed p, space 1, p_record r1, space 1,
  68                               punct "=>", space 1, p_record r2])
  69       | TNested (p, t) =>
  70         parenIf pn [p_pred' false p, space 1, punct "=>", space 1, p_typ' false t]
  71
  72       | TError => keyword "<error>"
  73       | TUnif (_, ref (SOME t)) => p_typ' pn t
  74       | TUnif (name, ref NONE) => string ("<" ^ name ^ ">")
  75
  76 and p_record r =
  77     case StringMap.foldri (fn (name, t, d) =>
  78                               SOME (case d of
  79                                         NONE => dBox [field name, space 1,
  80                                                       punct ":", space 1, p_typ t]
  81                                       | SOME d => dBox [dBox [field name, space 1,
  82                                                               punct ":", space 1, p_typ t],
  83                                                         punct ",", space 1, d]))
  84                           NONE r of
  85         NONE => punct "{}"
  86       | SOME d => dBox [punct "{", d, punct "}"]
  87
  88 and p_typ t = p_typ' false t
  89
  90 fun p_exp' pn (e, _) =
  91     case e of
  92         EInt n => lit (Int.toString n)
  93       | EString s => lit (String.concat ["\"", String.toString s, "\""])
  94       | EList es =>
  95         (case foldr (fn (e, d) =>
  96                         SOME (case d of
  97                                   NONE => p_exp e
  98                                 | SOME d => dBox [p_exp e, punct ",", space 1, d]))
  99                     NONE es of
 100              NONE => punct "[]"
 101            | SOME d => dBox [punct "[", d, punct "]"])
 102
 103       | ELam (x, NONE, e) => dBox [punct "(\\", space 1, exp x, space 1,
 104                                 punct "->", space 1, p_exp e, punct ")"]
 105       | ELam (x, SOME t, e) => dBox [punct "(\\", space 1, exp x, space 1,
 106                                 punct ":", space 1,
 107                                 dBox [punct "(", p_typ t, punct ")"],
 108                                 space 1, punct "->", space 1, p_exp e, punct ")"]
 109       | EALam (x, p, e) => dBox [punct "(\\", space 1, exp x, space 1,
 110                                  punct ":", space 1, p_pred p,
 111                                  space 1, punct "->", space 1, p_exp e, punct ")"]
 112
 113       | EVar x => exp x
 114       | EApp (e1, e2) => parenIf pn [p_exp e1, break {nsp = 1, offset = 0}, p_exp' true e2]
 115
 116       | ESkip => keyword "_"
 117       | ESet (x, e) => parenIf pn [exp x, space 1, punct "=", space 1, p_exp e]
 118       | EGet (x1, NONE, x2, e) => parenIf pn [dBox [exp x1, space 1, punct "<-",
 119                                                     space 1, exp x2, punct ";", space 1],
 120                                               p_exp e]
 121       | EGet (x1, SOME t, x2, e) => parenIf pn [dBox [exp x1, space 1, punct ":", space 1, p_typ t,
 122                                                       space 1, punct "<-",
 123                                                       space 1, exp x2, punct ";", space 1],
 124                                                 p_exp e]
 125       | ESeq es => parenIf pn (valOf (foldr (fn (e, NONE) => SOME [p_exp e]
 126                                         | (e, SOME ds) => SOME (dBox [p_exp e, punct ";", newline] :: ds))
 127                                       NONE es))
 128       | ELocal (e1, e2) => dBox [keyword "let", space 1,
 129                                  p_exp e1, space 1,
 130                                  keyword "in", space 1,
 131                                  p_exp e2, space 1,
 132                                  keyword "end"]
 133       | EWith (e1, (ESkip, _)) => dBox [p_exp e1, space 1, keyword "with", space 1, keyword "end"]
 134       | EWith (e1, e2) => dBox [p_exp e1, space 1, keyword "with", p_exp e2, space 1, keyword "end"]
 135       | EIf (e1, e2, e3) => dBox [keyword "if", space 1, p_exp e1,
 136                                   space 1, keyword "then", space 1, p_exp e2,
 137                                   space 1, keyword "else", space 1, p_exp e3]
 138 and p_exp e = p_exp' false e
 139
 140 fun p_decl d =
 141     case d of
 142         DExternType name => anchor ("T_" ^ name,
 143                                     dBox [keyword "extern", space 1,
 144                                           keyword "type", space 1,
 145                                           ident name])
 146       | DExternVal (name, t) => anchor ("V_" ^ name,
 147                                         dBox [keyword "extern", space 1,
 148                                               keyword "val", space 1,
 149                                               ident name, space 1,
 150                                               string ":", space 1,
 151                                               p_typ t])
 152       | DVal (name, NONE, _) => string "Unannotated val declaration!"
 153       | DVal (name, SOME t, _) => anchor ("V_" ^ name,
 154                                           dBox [keyword "val", space 1,
 155                                                 ident name, space 1,
 156                                                 punct ":", space 1,
 157                                                 p_typ t])
 158       | DContext name => anchor ("C_" ^ name,
 159                                  dBox [keyword "context", space 1,
 160                                        ident name])
 161
 162 fun p_decl_fref d =
 163     case d of
 164         DExternType name => dBox [keyword "extern", space 1,
 165                                   keyword "type", space 1,
 166                                   link ("#T_" ^ name, ident name)]
 167       | DExternVal (name, t) => dBox [keyword "extern", space 1,
 168                                       keyword "val", space 1,
 169                                       link ("#V_" ^ name, ident name),
 170                                       space 1,
 171                                       string ":", space 1,
 172                                       p_typ t]
 173       | DVal (name, NONE, _) => string "Unannotated val declaration!"
 174       | DVal (name, SOME t, _) => dBox [keyword "val", space 1,
 175                                         link ("#V_" ^ name, ident name),
 176                                         space 1,
 177                                         punct ":", space 1,
 178                                         p_typ t]
 179       | DContext name => dBox [keyword "context", space 1,
 180                                link ("#C_" ^ name, ident name)]
 181
 182 fun output d =
 183     let
 184         val myStream = openStream ()
 185     in
 186         description (myStream, d);
 187         PPS.flushStream myStream;
 188         closeStream myStream
 189     end
 190
 191 fun preface (s, d) = output (PD.hovBox (PD.PPS.Rel 0,
 192                                         [PD.string s, PD.space 1, d]))
 193
 194 end