mlton/control/pretty.sml

   1 (* Copyright (C) 2017 Matthew Fluet.
   2  * Copyright (C) 2003-2006 Henry Cejtin, Matthew Fluet, Suresh
   3  *    Jagannathan, and Stephen Weeks.
   4  *
   5  * MLton is released under a BSD-style license.
   6  * See the file MLton-LICENSE for details.
   7  *)
   8
   9 structure Pretty: PRETTY =
  10 struct
  11
  12 open Layout
  13
  14 fun casee {default, rules, test} =
  15    let
  16       val rules =
  17          case default of
  18             NONE => rules
  19           | SOME l => Vector.concat [rules, Vector.new1 (str "_", l)]
  20    in
  21       align [seq [str "case ", test, str " of"],
  22              indent (alignPrefix (Vector.toListMap
  23                                   (rules, fn (lhs, rhs) =>
  24                                    mayAlign [seq [lhs, str " =>"], rhs]),
  25                                   "| "),
  26                      2)]
  27    end
  28
  29 fun conApp {arg, con, targs} =
  30    seq [con,
  31         if !Control.showTypes
  32            then tuple (Vector.toList targs)
  33         else empty,
  34         case arg of
  35            NONE => empty
  36          | SOME x => seq [str " ", x]]
  37
  38 fun handlee {catch, handler, try} =
  39    align [try,
  40           seq [str "handle ", catch, str " => ", handler]]
  41
  42 fun nest (prefix, x, y) =
  43    align [seq [str prefix, x],
  44           str "in",
  45           indent (y, 3),
  46           str "end"]
  47
  48 fun lett (d, e) = nest ("let ", d, e)
  49
  50 fun locall (d, d') = nest ("local ", d, d')
  51
  52 fun primApp {args, prim, targs} =
  53    seq [prim,
  54         if !Control.showTypes
  55            andalso 0 < Vector.length targs
  56            then list (Vector.toList targs)
  57         else empty,
  58         str " ",
  59         tuple (Vector.toList args)]
  60
  61 fun raisee exn = seq [str "raise ", exn]
  62
  63 fun seq es = mayAlign (separateLeft (Vector.toList es, ";"))
  64
  65 end