mlton/atoms/prim-tycons.fun

   1 (* Copyright (C) 2017 Matthew Fluet.
   2  * Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh
   3  *    Jagannathan, and Stephen Weeks.
   4  * Copyright (C) 1997-2000 NEC Research Institute.
   5  *
   6  * MLton is released under a BSD-style license.
   7  * See the file MLton-LICENSE for details.
   8  *)
   9
  10 functor PrimTycons (S: PRIM_TYCONS_STRUCTS): PRIM_TYCONS =
  11 struct
  12
  13 open S
  14
  15 datatype z = datatype RealSize.t
  16
  17 type tycon = t
  18
  19 local
  20    fun make s = (s, fromString s)
  21 in
  22    val array = make "array"
  23    val arrow = make "arrow"
  24    val bool = make "bool"
  25    val cpointer = make "cpointer"
  26    val exn = make "exn"
  27    val intInf = make "intInf"
  28    val list = make "list"
  29    val reff = make "ref"
  30    val thread = make "thread"
  31    val tuple = make "tuple"
  32    val vector = make "vector"
  33    val weak = make "weak"
  34 end
  35
  36 datatype z = datatype Kind.t
  37 datatype z = datatype AdmitsEquality.t
  38
  39 local
  40    fun 'a make (prefix: string,
  41                 all: 'a list,
  42                 bits: 'a -> Bits.t,
  43                 equalsA: 'a * 'a -> bool,
  44                 memo: ('a -> t) -> ('a -> t),
  45                 admitsEquality: AdmitsEquality.t) =
  46       let
  47          val all =
  48             Vector.fromListMap
  49             (all, fn s => let
  50                val name = concat [prefix, Bits.toString (bits s)]
  51             in
  52                {name = name,
  53                 size = s,
  54                 tycon = fromString name}
  55             end)
  56          val fromSize =
  57             memo
  58             (fn s =>
  59              case Vector.peek (all, fn {size = s', ...} => equalsA (s, s')) of
  60                 NONE => Error.bug "PrimTycons.make.fromSize"
  61               | SOME {tycon, ...} => tycon)
  62          fun is t = Vector.exists (all, fn {tycon = t', ...} => equals (t, t'))
  63          fun de t =
  64             case Vector.peek (all, fn {tycon = t', ...} => equals (t, t')) of
  65                NONE => Error.bug "PrimTycons.make.de"
  66              | SOME {size, ...} => size
  67          val prims =
  68             Vector.toListMap (all, fn {name, tycon, ...} =>
  69                               {admitsEquality = admitsEquality,
  70                                kind = Arity 0,
  71                                name = name,
  72                                tycon = tycon})
  73          val all = Vector.map (all, fn {tycon, size, ...} => (tycon, size))
  74       in
  75          (fromSize, all, is, de, prims)
  76       end
  77 in
  78    val (char, _, isCharX, deCharX, primChars) =
  79       let
  80          open CharSize
  81       in
  82          make ("char", all, bits, equals, memoize, Sometimes)
  83       end
  84    val (int, ints, isIntX, deIntX, primInts) =
  85       let
  86          open IntSize
  87       in
  88          make ("int", all, bits, equals, memoize, Sometimes)
  89       end
  90    val (real, reals, isRealX, deRealX, primReals) =
  91       let
  92          open RealSize
  93       in
  94          make ("real", all, bits, equals, memoize, Never)
  95       end
  96    val (word, words, isWordX, deWordX, primWords) =
  97       let
  98          open WordSize
  99       in
 100          make ("word", all, bits, equals, memoize, Sometimes)
 101       end
 102 end
 103
 104 val prims =
 105    List.map ([(array, Arity 1, Always),
 106               (arrow, Arity 2, Never),
 107               (bool, Arity 0, Sometimes),
 108               (cpointer, Arity 0, Always),
 109               (exn, Arity 0, Never),
 110               (intInf, Arity 0, Sometimes),
 111               (list, Arity 1, Sometimes),
 112               (reff, Arity 1, Always),
 113               (thread, Arity 0, Never),
 114               (tuple, Nary, Sometimes),
 115               (vector, Arity 1, Sometimes),
 116               (weak, Arity 1, Never)],
 117              fn ((name, tycon), kind, admitsEquality) =>
 118              {admitsEquality = admitsEquality,
 119               kind = kind,
 120               name = name,
 121               tycon = tycon})
 122    @ primChars @ primInts @ primReals @ primWords
 123
 124 val array = #2 array
 125 val arrow = #2 arrow
 126 val bool = #2 bool
 127 val cpointer = #2 cpointer
 128 val exn = #2 exn
 129 val intInf = #2 intInf
 130 val list = #2 list
 131 val reff = #2 reff
 132 val thread = #2 thread
 133 val tuple = #2 tuple
 134 val vector = #2 vector
 135 val weak = #2 weak
 136
 137 val defaultChar = fn () =>
 138    case !Control.defaultChar of
 139       "char8" => char CharSize.C8
 140     | _ => Error.bug "PrimTycons.defaultChar"
 141 val defaultInt = fn () =>
 142    case !Control.defaultInt of
 143       "int8" => int (IntSize.fromBits (Bits.fromInt 8))
 144     | "int16" => int (IntSize.fromBits (Bits.fromInt 16))
 145     | "int32" => int (IntSize.fromBits (Bits.fromInt 32))
 146     | "int64" => int (IntSize.fromBits (Bits.fromInt 64))
 147     | "intinf" => intInf
 148     | _ => Error.bug "PrimTycons.defaultInt"
 149 val defaultReal = fn () =>
 150    case !Control.defaultReal of
 151       "real32" => real RealSize.R32
 152     | "real64" => real RealSize.R64
 153     | _ => Error.bug "PrimTycons.defaultReal"
 154 val defaultWord = fn () =>
 155    case !Control.defaultWord of
 156       "word8" => word (WordSize.fromBits (Bits.fromInt 8))
 157     | "word16" => word (WordSize.fromBits (Bits.fromInt 16))
 158     | "word32" => word (WordSize.fromBits (Bits.fromInt 32))
 159     | "word64" => word (WordSize.fromBits (Bits.fromInt 64))
 160     | _ => Error.bug "PrimTycons.defaultWord"
 161
 162 val isBool = fn c => equals (c, bool)
 163 val isCPointer = fn c => equals (c, cpointer)
 164 val isIntX = fn c => equals (c, intInf) orelse isIntX c
 165 val deIntX = fn c => if equals (c, intInf) then NONE else SOME (deIntX c)
 166
 167 local
 168    local
 169       open Layout
 170    in
 171       val mayAlign = mayAlign
 172       val seq = seq
 173       val str = str
 174    end
 175    datatype z = datatype BindingStrength.t
 176    datatype binding_context =
 177       ArrowLhs
 178     | ArrowRhs
 179     | TupleElem
 180     | Tyseq1
 181     | TyseqN
 182    fun maybe bindingContext (l, ({isChar = _}, bindingStrength)) =
 183       case (bindingStrength, bindingContext) of
 184          (Unit, _) => l
 185        | (Tuple, ArrowLhs) => l
 186        | (Tuple, ArrowRhs) => l
 187        | (Tuple, TyseqN) => l
 188        | (Arrow, ArrowRhs) => l
 189        | (Arrow, TyseqN) =>  l
 190        | _ => Layout.paren l
 191    fun normal (c: Layout.t, args: LayoutPretty.t vector, {isChar}) =
 192       let
 193          val lay =
 194             case Vector.length args of
 195                0 => c
 196              | 1 => seq [maybe Tyseq1 (Vector.first args),
 197                          str " ", c]
 198              | _ => seq [Layout.tuple (Vector.toListMap (args, maybe TyseqN)),
 199                          str " ", c]
 200       in
 201          (lay, ({isChar = isChar}, Unit))
 202       end
 203
 204 in
 205    fun layoutAppPrettyNormal (c: Layout.t, args: LayoutPretty.t vector) =
 206       normal (c, args, {isChar = false})
 207    fun layoutAppPretty (c: t, args: LayoutPretty.t vector, {layoutPretty}) =
 208       if equals (c, arrow)
 209          then (mayAlign [maybe ArrowLhs (Vector.first args),
 210                          seq [str "-> ",
 211                               maybe ArrowRhs (Vector.sub (args, 1))]],
 212                ({isChar = false}, Arrow))
 213       else if equals (c, tuple)
 214          then if Vector.isEmpty args
 215                  then LayoutPretty.simple (str "unit")
 216               else (mayAlign (Layout.separateLeft
 217                               (Vector.toListMap (args, maybe TupleElem), "* ")),
 218                     ({isChar = false}, Tuple))
 219       else if equals (c, vector)
 220          then if #isChar (#1 (#2 (Vector.first args)))
 221                  then LayoutPretty.simple (str "string")
 222               else normal (layoutPretty c, args, {isChar = false})
 223       else normal (layoutPretty c, args, {isChar = equals (c, defaultChar ())})
 224 end
 225
 226 fun layoutApp (c: t, args: Layout.t vector) =
 227    let
 228       local
 229          open Layout
 230       in
 231          val empty = empty
 232          val seq = seq
 233          val str = str
 234       end
 235       val con =
 236          if equals (c, tuple) andalso Vector.isEmpty args
 237             then str "unit"
 238             else (case List.peekMap (prims, fn {name, tycon, ...} =>
 239                                      if equals (c, tycon) then SOME name else NONE) of
 240                      SOME name => str name
 241                    | _ => layout c)
 242       val args =
 243          if Vector.isEmpty args
 244             then empty
 245             else seq [Layout.tuple (Vector.toList args), str " "]
 246    in
 247       seq [args, con]
 248    end
 249
 250 end