[hcoop/debian/mlton.git] / mlton / atoms / admits-equality.fun

(* Copyright (C) 2003-2006 Henry Cejtin, Matthew Fluet, Suresh
 *    Jagannathan, and Stephen Weeks.
 *
 * MLton is released under a BSD-style license.
 * See the file MLton-LICENSE for details.
 *)

functor AdmitsEquality (S: ADMITS_EQUALITY_STRUCTS): ADMITS_EQUALITY = 
struct

open S

datatype t = Always | Never | Sometimes

val toString =
   fn Always => "Always"
    | Never => "Never"
    | Sometimes => "Sometimes"

val layout = Layout.str o toString

val op <= =
   fn (Never, _) => true
    | (Sometimes, Never) => false
    | (Sometimes, _) => true
    | (Always, Always) => true
    | (Always, _) => false

val op <= =
   Trace.trace2 ("AdmitsEquality.<=", layout, layout, Bool.layout) (op <=)

val or =
   fn (Always, _) => Always
    | (_, Always) => Always
    | (Sometimes, _) => Sometimes
    | (_, Sometimes) => Sometimes
    | _ => Never

end
Commit	Line	Data
7f918cf1 CE	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