mlton/atoms/type-ops.fun

   1 (* Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh
   2  *    Jagannathan, and Stephen Weeks.
   3  * Copyright (C) 1997-2000 NEC Research Institute.
   4  *
   5  * MLton is released under a BSD-style license.
   6  * See the file MLton-LICENSE for details.
   7  *)
   8
   9 functor TypeOps (S: TYPE_OPS_STRUCTS): TYPE_OPS =
  10 struct
  11
  12 open S
  13
  14 local
  15    open Tycon
  16 in
  17    structure RealSize = RealSize
  18    structure WordSize = WordSize
  19 end
  20 type realSize = RealSize.t
  21 type tycon = Tycon.t
  22 type wordSize = WordSize.t
  23
  24 local
  25    fun nullary tycon = con (tycon, Vector.new0 ())
  26 in
  27    val bool = nullary Tycon.bool
  28    val cpointer = nullary Tycon.cpointer
  29    val exn = nullary Tycon.exn
  30    val intInf = nullary Tycon.intInf
  31    val real = RealSize.memoize (fn s => nullary (Tycon.real s))
  32    val thread = nullary Tycon.thread
  33    val word = WordSize.memoize (fn s => nullary (Tycon.word s))
  34 end
  35
  36 local
  37    fun unary tycon t = con (tycon, Vector.new1 t)
  38 in
  39    val array = unary Tycon.array
  40    val list = unary Tycon.list
  41    val reff = unary Tycon.reff
  42    val vector = unary Tycon.vector
  43    val weak = unary Tycon.weak
  44 end
  45
  46 val word8 = word WordSize.word8
  47 val word8Vector = vector word8
  48 val word32 = word WordSize.word32
  49
  50 local
  51    fun binary tycon (t1, t2) = con (tycon, Vector.new2 (t1, t2))
  52 in
  53    val arrow = binary Tycon.arrow
  54 end
  55
  56 val arrow =
  57    Trace.trace ("TypeOps.arrow", Layout.tuple2 (layout, layout), layout) arrow
  58
  59 fun deUnaryOpt tycon t =
  60    case deConOpt t of
  61       SOME (c, ts) => if Tycon.equals (c, tycon)
  62                          then SOME (Vector.first ts)
  63                       else NONE
  64     | _ => NONE
  65
  66 fun deUnary tycon t =
  67    case deUnaryOpt tycon t of
  68       SOME t => t
  69     | NONE => Error.bug "TypeOps.deUnary"
  70
  71 val deArray = deUnary Tycon.array
  72 val deRef = deUnary Tycon.reff
  73 val deVector = deUnary Tycon.vector
  74 val deWeak = deUnary Tycon.weak
  75
  76 fun tuple ts =
  77    if 1 = Vector.length ts
  78       then Vector.first ts
  79    else con (Tycon.tuple, ts)
  80
  81 val unit = tuple (Vector.new0 ())
  82
  83 fun deTupleOpt t =
  84    case deConOpt t of
  85       SOME (c, ts) => if Tycon.equals (c, Tycon.tuple) then SOME ts else NONE
  86     | NONE => NONE
  87
  88 val isTuple = Option.isSome o deTupleOpt
  89
  90 fun deTuple t =
  91    case deTupleOpt t of
  92       SOME t => t
  93     | NONE => Error.bug "TypeOps.deTuple"
  94
  95 val unitRef = reff unit
  96
  97 fun deArrowOpt t =
  98    case deConOpt t of
  99       SOME (c, ts) => if Tycon.equals (c, Tycon.arrow)
 100                                then SOME (Vector.sub (ts, 0), Vector.sub (ts, 1))
 101                             else NONE
 102     | _ => NONE
 103
 104 fun deArrow t =
 105    case deArrowOpt t of
 106       SOME x => x
 107     | NONE => Error.bug "TypeOps.deArrow"
 108
 109 val deArrow =
 110    Trace.trace
 111    ("TypeOps.deArrow", layout, Layout.tuple2 (layout, layout))
 112    deArrow
 113
 114 end