mlton/atoms/admits-equality.fun

   1 (* Copyright (C) 2003-2006 Henry Cejtin, Matthew Fluet, Suresh
   2  *    Jagannathan, and Stephen Weeks.
   3  *
   4  * MLton is released under a BSD-style license.
   5  * See the file MLton-LICENSE for details.
   6  *)
   7
   8 functor AdmitsEquality (S: ADMITS_EQUALITY_STRUCTS): ADMITS_EQUALITY =
   9 struct
  10
  11 open S
  12
  13 datatype t = Always | Never | Sometimes
  14
  15 val toString =
  16    fn Always => "Always"
  17     | Never => "Never"
  18     | Sometimes => "Sometimes"
  19
  20 val layout = Layout.str o toString
  21
  22 val op <= =
  23    fn (Never, _) => true
  24     | (Sometimes, Never) => false
  25     | (Sometimes, _) => true
  26     | (Always, Always) => true
  27     | (Always, _) => false
  28
  29 val op <= =
  30    Trace.trace2 ("AdmitsEquality.<=", layout, layout, Bool.layout) (op <=)
  31
  32 val or =
  33    fn (Always, _) => Always
  34     | (_, Always) => Always
  35     | (Sometimes, _) => Sometimes
  36     | (_, Sometimes) => Sometimes
  37     | _ => Never
  38
  39 end