lib/deriving_Enum.ml

   1 (*pp deriving *)
   2
   3 (* Copyright Jeremy Yallop 2007.
   4    This file is free software, distributed under the MIT license.
   5    See the file COPYING for details.
   6 *)
   7
   8 open Bounded
   9
  10 let rec rassoc (rkey : 'b) : ('a * 'b) list -> 'a = function
  11   | []                     -> raise Not_found
  12   | (a,b)::_ when b = rkey -> a
  13   | _::xs                  -> rassoc rkey xs
  14
  15 let rec last : 'a list -> 'a = function
  16     | []    -> raise (Invalid_argument "last")
  17     | [x]   -> x
  18     | _::xs -> last xs
  19
  20 module Enum =
  21 struct
  22 (** Enum **)
  23 module type Enum = sig
  24   type a
  25   val succ : a -> a
  26   val pred : a -> a
  27   val to_enum : int -> a
  28   val from_enum : a -> int
  29   val enum_from : a -> a list
  30   val enum_from_then : a -> a -> a list
  31   val enum_from_to : a -> a -> a list
  32   val enum_from_then_to : a -> a -> a -> a list
  33 end
  34
  35 let startThenTo (start : int) (next : int) (until : int) : int list =
  36   let step = next - start in
  37     if step <= 0 then invalid_arg "startThenTo"
  38     else
  39       let rec upFrom current =
  40         if current > until then []
  41         else current :: upFrom (current+step)
  42       in
  43         upFrom start
  44
  45 let range : int -> int -> int list
  46   = fun f t -> startThenTo f (f+1) t
  47
  48 module Defaults
  49   (E : (sig
  50           type a
  51           val numbering : (a * int) list
  52         end)) : Enum with type a = E.a =
  53 struct
  54   let firstCon = fst (List.hd E.numbering)
  55   let lastCon = fst (last E.numbering)
  56
  57   type a = E.a
  58   let from_enum a = List.assoc a E.numbering
  59   let to_enum i = try rassoc i E.numbering with Not_found -> raise (Invalid_argument "to_enum")
  60   let succ s = try to_enum ((from_enum s) + 1) with Invalid_argument "to_enum" -> raise (Invalid_argument "succ")
  61   let pred s = try to_enum ((from_enum s) - 1) with Invalid_argument "to_enum" -> raise (Invalid_argument "pred")
  62   let enum_from_to x y = List.map to_enum (range (from_enum x) (from_enum y))
  63   let enum_from_then_to x y z = List.map to_enum (startThenTo (from_enum x) (from_enum y) (from_enum z))
  64   let enum_from_then x y = (enum_from_then_to x y
  65                             (if from_enum y >= from_enum x then lastCon
  66                              else firstCon))
  67   let enum_from x = enum_from_to x lastCon
  68 end
  69
  70
  71 module Defaults'
  72   (E : (sig
  73           type a
  74           val from_enum : a -> int
  75           val to_enum   : int -> a
  76         end))
  77   (B : Bounded with type a = E.a) : Enum with type a = E.a
  78                                          and  type a = B.a =
  79 struct
  80   include E
  81   let firstCon = B.min_bound
  82   let lastCon = B.max_bound
  83
  84   let succ s = try to_enum ((from_enum s) + 1) with Invalid_argument "to_enum" -> raise (Invalid_argument "succ")
  85   let pred s = try to_enum ((from_enum s) - 1) with Invalid_argument "to_enum" -> raise (Invalid_argument "pred")
  86   let enum_from_to x y = List.map to_enum (range (from_enum x) (from_enum y))
  87   let enum_from_then_to x y z = List.map to_enum (startThenTo (from_enum x) (from_enum y) (from_enum z))
  88   let enum_from_then x y = (enum_from_then_to x y
  89                             (if from_enum y >= from_enum x then lastCon
  90                              else firstCon))
  91   let enum_from x = enum_from_to x lastCon
  92 end
  93
  94 module Enum_bool = Defaults(struct
  95   type a = bool
  96   let numbering = [false, 0; true, 1]
  97 end)
  98
  99 module Enum_char = Defaults'(struct
 100   type a = char
 101   let from_enum = Char.code
 102   let to_enum = Char.chr
 103 end) (Bounded_char)
 104
 105 module Enum_int = Defaults' (struct
 106   type a = int
 107   let from_enum i = i
 108   let to_enum i = i
 109 end)(Bounded_int)
 110
 111 (* Can `instance Enum Float' be justified?
 112    For some floats `f' we have `succ f == f'.
 113    Furthermore, float is wider than int, so from_enum will necessarily
 114    give nonsense on many inputs. *)
 115
 116 module Enum_unit = Defaults' (struct
 117   type a = unit
 118   let from_enum () = 0
 119   let to_enum = function
 120     | 0 -> ()
 121     | _ -> raise (Invalid_argument "to_enum")
 122 end) (Bounded_unit)
 123 end
 124 include Enum
 125
 126 (*
 127 type open_flag = Pervasives.open_flag  =
 128                  | Open_rdonly
 129                  | Open_wronly
 130                  | Open_append
 131                  | Open_creat
 132                  | Open_trunc
 133                  | Open_excl
 134                  | Open_binary
 135                  | Open_text
 136                  | Open_nonblock
 137                      deriving (Enum)
 138
 139 type fpclass = Pervasives.fpclass =
 140                | FP_normal
 141                | FP_subnormal
 142                | FP_zero
 143                | FP_infinite
 144                | FP_nan
 145                    deriving (Enum)
 146 *)