mlnlffigen/pp.sml

   1 (* pp.sml
   2  * 2005 Matthew Fluet (mfluet@acm.org)
   3  *  Adapted for MLton.
   4  *)
   5
   6 (*
   7  * pp.sml - Some simple pretty-printing infrastructure for the ml-ffigen
   8  *          program.
   9  *
  10  *  (C) 2001, Lucent Technologies, Bell Labs
  11  *
  12  * author: Matthias Blume (blume@research.bell-labs.com)
  13  *)
  14 structure PrettyPrint = struct
  15
  16     structure PP = PPStreamFn (structure Token = StringToken
  17                                structure Device = CPIFDev)
  18
  19     datatype mltype =
  20         ARROW of mltype * mltype
  21       | TUPLE of mltype list
  22       | CON of string * mltype list
  23       | RECORD of (string * mltype) list
  24
  25     val Unit = TUPLE []
  26     fun Type t = CON (t, [])
  27     fun St tag = Type (concat ["ST_", tag, ".tag"])
  28     fun Un tag = Type (concat ["UT_", tag, ".tag"])
  29     fun En tag = Type (concat ["ET_", tag, ".tag"])
  30
  31     datatype tcontext = C_STAR | C_ARROW | C_COMMA | C_CON
  32
  33     fun simplify (CON ("unit", [])) = Unit
  34       | simplify (TUPLE [t]) = simplify t
  35       | simplify (CON (k, tl)) =
  36         let
  37            fun doDefault () = CON (k, map simplify tl)
  38            fun doObj obj =
  39                case tl of
  40                   [CON (k, tl), c] =>
  41                      if List.exists (fn k' => k = k')
  42                         ["schar","uchar","sshort","ushort",
  43                          "sint","uint","slong","ulong",
  44                          "slonglong","ulonglong","float","double",
  45                          "voidptr"]
  46                         then CON (concat [k, "_", obj], [simplify c])
  47                      else if k = "fptr"
  48                         then case tl of
  49                                 [f] => CON ("fptr_" ^ obj, [simplify f, simplify c])
  50                               | _ => doDefault ()
  51                      else if k = "su"
  52                          then case tl of
  53                                 [su] => CON ("su_" ^ obj, [simplify su, simplify c])
  54                               | _ => doDefault ()
  55                      else doDefault ()
  56                 | _ => doDefault ()
  57            fun doDim d =
  58                if d = "dim"
  59                   then case tl of
  60                           [n, CON (k', [])] =>
  61                              if k' = "Dim.nonzero" orelse k' = "nonzero"
  62                                 then CON ("dim", [simplify n])
  63                                 else doDefault ()
  64                         | _ => doDefault ()
  65                else if d = "dec"
  66                   then case tl of
  67                           [] => CON ("dec", [])
  68                         | _ => doDefault ()
  69                else if List.exists (fn d' => d = d')
  70                        ["dg0","dg1","dg2","dg3","dg4",
  71                         "dg5","dg6","dg7","dg8","dg9"]
  72                   then case tl of
  73                           [n] => CON (d, [simplify n])
  74                         | _ => doDefault ()
  75                else doDefault ()
  76         in
  77            if k = "obj" orelse k = "obj'"
  78               then doObj k
  79            else if String.isPrefix "Dim." k
  80               then doDim (String.extract(k,4,NONE))
  81            else doDefault ()
  82         end
  83       | simplify (ARROW (t1, t2)) = ARROW (simplify t1, simplify t2)
  84       | simplify (TUPLE tl) = TUPLE (map simplify tl)
  85       | simplify (RECORD ml) = RECORD (map (fn (n, t) => (n, simplify t)) ml)
  86
  87     fun ppType0 s (t as ARROW _, c) =
  88         let fun loop (ARROW (x, y)) =
  89                 (ppType0 s (x, C_ARROW); PP.string s " ->"; PP.space s 1;
  90                  loop y)
  91               | loop t = ppType0 s (t, C_ARROW)
  92             val paren = not (c = C_COMMA)
  93             val indent = if paren then 5 else 4
  94         in
  95             PP.openHOVBox s (PP.Rel indent);
  96             if paren then PP.string s "(" else ();
  97             loop t;
  98             if paren then PP.string s ")" else ();
  99             PP.closeBox s
 100         end
 101       | ppType0 s (TUPLE [], _) = PP.string s "unit"
 102       | ppType0 s (TUPLE [t], c) = ppType0 s (t, c)
 103       | ppType0 s (TUPLE tl, c) = let
 104             fun loop [] = ()    (* cannot happen *)
 105               | loop [t] = ppType0 s (t, C_STAR)
 106               | loop (h :: tl) = (ppType0 s (h, C_STAR);
 107                                   PP.string s " *";
 108                                   PP.space s 1;
 109                                   loop tl)
 110             val paren =
 111                 case c of (C_STAR) => true
 112                         | (C_CON) => true
 113                         | (C_ARROW) => false
 114                         | (C_COMMA) => false
 115             val indent = if paren then 1 else 0
 116         in
 117             PP.openHVBox s (PP.Rel indent);
 118             if paren then PP.string s "(" else ();
 119             loop tl;
 120             if paren then PP.string s ")" else ();
 121             PP.closeBox s
 122         end
 123       | ppType0 s (RECORD [], _) = PP.string s "{}"
 124       | ppType0 s (RECORD tl, _) = let
 125             fun loop [] = ()            (* cannot happen *)
 126               | loop [(n, t)] = (PP.string s (n ^ " : ");
 127                                  ppType0 s (t, C_COMMA))
 128               | loop ((n, t) :: tl) = (PP.string s (n ^ " : ");
 129                                        ppType0 s (t, C_COMMA);
 130                                        PP.string s ",";
 131                                        PP.space s 1;
 132                                        loop tl)
 133         in
 134             PP.openHVBox s (PP.Rel 2);
 135             PP.string s "{ ";
 136             loop tl;
 137             PP.string s " }";
 138             PP.closeBox s
 139         end
 140       | ppType0 s (CON (k, []), _) = PP.string s k
 141       | ppType0 s (CON (k, [t]), _) =
 142         (PP.openHBox s;
 143          ppType0 s (t, C_CON);
 144          PP.space s 1;
 145          PP.string s k;
 146          PP.closeBox s)
 147       | ppType0 s (CON (k, tl), _) = let
 148             fun loop [] = ()    (* cannot happen *)
 149               | loop [t] = ppType0 s (t, C_COMMA)
 150               | loop (h :: tl) =
 151                 (ppType0 s (h, C_COMMA); PP.string s ","; PP.space s 1; loop tl)
 152         in
 153             PP.openHBox s;
 154             PP.openHVBox s (PP.Rel 1);
 155             PP.string s "(";
 156             loop tl;
 157             PP.string s ")";
 158             PP.closeBox s;
 159             PP.space s 1;
 160             PP.string s k;
 161             PP.closeBox s
 162         end
 163
 164     (* start with comma context *)
 165     fun ppType s t = ppType0 s (simplify t, C_COMMA)
 166     fun ppType' s (t, c) = ppType0 s (simplify t, c)
 167
 168     datatype mlexp =
 169         ETUPLE of mlexp list
 170       | ERECORD of (string * mlexp) list
 171       | EVAR of string
 172       | EAPP of mlexp * mlexp
 173       | ECONSTR of mlexp * mltype
 174       | ESEQ of mlexp * mlexp
 175       | EPRIM of string * mltype
 176       | ELET of (string * mlexp) list * mlexp
 177
 178     datatype econtext = EC_APP | EC_COMMA
 179
 180     fun ppExp0 s (ETUPLE [], _) = PP.string s "()"
 181       | ppExp0 s (ETUPLE [x], c) = ppExp0 s (x, c)
 182       | ppExp0 s (ETUPLE xl, _) = let
 183             fun loop [] = ()
 184               | loop [x] = ppExp0 s (x, EC_COMMA)
 185               | loop (x :: xl) =
 186                 (ppExp0 s (x, EC_COMMA); PP.string s ","; PP.space s 1;
 187                  loop xl)
 188         in
 189             PP.openHVBox s (PP.Rel 1);
 190             PP.string s "(";
 191             loop xl;
 192             PP.string s ")";
 193             PP.closeBox s
 194         end
 195       | ppExp0 s (ERECORD [], _) = PP.string s "{}"
 196       | ppExp0 s (ERECORD xl, _) = let
 197             fun loop [] = ()
 198               | loop [(n, x)] = (PP.string s (n ^ " =");
 199                                  PP.space s 1;
 200                                  ppExp0 s (x, EC_COMMA))
 201               | loop ((n, x) :: xl) = (PP.string s (n ^ " =");
 202                                        PP.space s 1;
 203                                        ppExp0 s (x, EC_COMMA);
 204                                        PP.string s ",";
 205                                        PP.space s 1;
 206                                        loop xl)
 207         in
 208             PP.openHVBox s (PP.Rel 2);
 209             PP.string s "{ ";
 210             loop xl;
 211             PP.string s " }";
 212             PP.closeBox s
 213         end
 214       | ppExp0 s (EVAR v, _) = PP.string s v
 215       | ppExp0 s (EAPP (x, y), c) = let
 216             fun loop (EAPP (x, y)) =
 217                 (loop x; ppExp0 s (y, EC_APP); PP.space s 1)
 218               | loop x = (ppExp0 s (x, EC_APP);
 219                           PP.space s 1;
 220                           PP.openHOVBox s (PP.Rel 0))
 221             val paren = c = EC_APP
 222         in
 223             PP.openHOVBox s (PP.Abs 4);
 224             if paren then PP.string s "(" else ();
 225             loop x;
 226             ppExp0 s (y, EC_APP);
 227             if paren then PP.string s ")" else ();
 228             PP.closeBox s;
 229             PP.closeBox s
 230         end
 231       | ppExp0 s (ECONSTR (x, t), c) = let
 232             val paren = c = EC_APP
 233             val indent = if paren then 5 else 4
 234             val tc = if paren then C_CON else C_COMMA
 235         in
 236             PP.openHOVBox s (PP.Rel indent);
 237             if paren then PP.string s "(" else ();
 238             ppExp0 s (x, c);
 239             PP.nbSpace s 1;
 240             PP.string s ":";
 241             PP.space s 1;
 242             ppType' s (t, tc);
 243             if paren then PP.string s ")" else  ();
 244             PP.closeBox s
 245         end
 246       | ppExp0 s (ESEQ (x, y), c) = let
 247         in
 248             PP.string s "(";
 249             PP.openHVBox s (PP.Rel 0);
 250             ppExp0 s (x, EC_COMMA);
 251             PP.string s ";";
 252             PP.space s 1;
 253             ppExp0 s (y, EC_COMMA);
 254             PP.string s ")";
 255             PP.closeBox s
 256         end
 257       | ppExp0 s (EPRIM (p, t), c) = let
 258             val paren = c = EC_APP
 259             val indent = if paren then 5 else 4
 260             val tc = if paren then C_CON else C_COMMA
 261         in
 262             PP.openHOVBox s (PP.Rel indent);
 263             if paren then PP.string s "(" else ();
 264             PP.string s p;
 265             PP.nbSpace s 1;
 266             PP.string s ":";
 267             PP.space s 1;
 268             ppType' s (t, tc);
 269             PP.string s ";";
 270             if paren then PP.string s ")" else  ();
 271             PP.closeBox s
 272         end
 273      | ppExp0 s (ELET ([], e), c) = ppExp0 s (e, c)
 274      | ppExp0 s (ELET (bnds, e), c) = let
 275            fun loop [] = ()
 276              | loop ((v, e) :: bnds) = (PP.newline s;
 277                                         PP.openHOVBox s (PP.Abs 4);
 278                                         PP.string s "val";
 279                                         PP.nbSpace s 1;
 280                                         PP.string s v;
 281                                         PP.nbSpace s 1;
 282                                         PP.string s "=";
 283                                         PP.space s 1;
 284                                         ppExp0 s (e, EC_COMMA);
 285                                         PP.closeBox s;
 286                                         loop bnds)
 287        in
 288            PP.string s "let";
 289            PP.openVBox s (PP.Abs 4);
 290            loop bnds;
 291            PP.closeBox s;
 292            PP.newline s;
 293            PP.string s "in";
 294            PP.openVBox s (PP.Abs 4);
 295            PP.newline s;
 296            ppExp0 s (e, EC_COMMA);
 297            PP.closeBox s;
 298            PP.newline s;
 299            PP.string s "end"
 300        end
 301
 302     fun ppExp s x = ppExp0 s (x, EC_COMMA)
 303     fun ppExp' s x = ppExp0 s (x, EC_APP)
 304
 305     fun ppFun s (name, args, body) =
 306         (PP.openHOVBox s (PP.Rel 4);
 307          PP.string s ("fun " ^ name);
 308          PP.nbSpace s 1;
 309          app (fn a => (ppExp' s a; PP.space s 1)) args;
 310          PP.string s "=";
 311          PP.nbSpace s 1;
 312          PP.openBox s (PP.Rel 0);
 313          ppExp s body;
 314          PP.closeBox s;
 315          PP.closeBox s)
 316 end