lib/deriving_Typeable.ml

   1 (* Copyright Jeremy Yallop 2007.
   2    This file is free software, distributed under the MIT license.
   3    See the file COPYING for details.
   4 *)
   5
   6 (** A type is viewed as the application of type constructors to zero
   7     or more type arguments.  We provide equality and ordering
   8     operations on types.  The ordering is unspecified, but consistent
   9     within a process, i.e. sufficient for use in Map etc.
  10
  11     This might be considered to break abstraction, since it exposes
  12     the fact that two types are the same, even if that fact has been
  13     hidden by type abstraction (modules etc.).  This is considered a
  14     good thing, since it assists with the intended use, which is to
  15     maximise value sharing.
  16 *)
  17
  18 module TypeRep :
  19 sig
  20   type t
  21   type delayed = unit -> t
  22   val compare : t -> t -> int
  23   val eq : t -> t -> bool
  24   val mkFresh : string -> delayed list -> delayed
  25   val mkTuple : delayed list -> delayed
  26   val mkPolyv : (string * delayed option) list -> delayed list -> delayed
  27 end =
  28 struct
  29   module StringMap = Map.Make(Deriving_interned)
  30   module IntMap = Map.Make(struct type t = int let compare = Pervasives.compare end)
  31   module StringSet = Set.Make(Deriving_interned)
  32
  33   let counter = ref 0
  34   let fresh () =
  35     let c = !counter in
  36       incr counter;
  37       c
  38   type t =
  39       [`Variant of (delayed option StringMap.t)
  40       |`Gen of Deriving_interned.t * delayed list ] * int
  41
  42   and delayed = unit -> t
  43
  44   let make_fresh row : t =
  45     (* Just allocate a pointer for now.  Dereference the row later *)
  46     `Variant row, fresh ()
  47
  48   module EqualMap =
  49   struct
  50     type map = int list IntMap.t
  51     let equalp : map -> int -> int -> bool
  52       = fun map l r ->
  53         try List.mem r (IntMap.find l map)
  54         with Not_found -> false
  55
  56     let record_equality : map -> int -> int -> map =
  57       fun map l r ->
  58         let add map l r =
  59           try
  60             let vals = IntMap.find l map
  61             in IntMap.add l (r::vals) map
  62           with Not_found ->
  63             IntMap.add l [r] map
  64         in add (add map l r) r l
  65   end
  66
  67   let keys : 'a StringMap.t -> StringSet.t =
  68     fun m ->
  69       StringMap.fold (fun k _ set -> StringSet.add k set) m StringSet.empty
  70
  71   let rec equal : EqualMap.map -> t -> t -> bool
  72     = fun equalmap (l,lid) (r,rid) ->
  73       if lid = rid then true
  74       else if EqualMap.equalp equalmap lid rid then true
  75       else match l, r with
  76         | `Variant lrow, `Variant rrow ->
  77             (* distinct types.  assume they're equal for now; record
  78                that fact in the map, then look inside the types for
  79                evidence to the contrary *)
  80             equal_rows (EqualMap.record_equality equalmap lid rid) lrow rrow
  81         | `Gen (lname, ls), `Gen (rname, rs) when Deriving_interned.eq lname rname ->
  82             List.for_all2 (fun l r -> equal equalmap (l ()) (r ())) ls rs
  83         | _ -> false
  84   and equal_rows equalmap lfields rfields =
  85     equal_names lfields rfields
  86     && StringMap.fold
  87       (fun name t eq ->
  88          let t' = StringMap.find name rfields in
  89            match t, t' with
  90              | None, None -> eq
  91              | Some t, Some t' ->
  92                  equal equalmap (t ()) (t' ()) && eq
  93              | _ -> false)
  94       lfields
  95       true
  96   and equal_names lmap rmap =
  97     StringSet.equal (keys lmap) (keys rmap)
  98
  99   let mkFresh name args =
 100     let t : t = `Gen (Deriving_interned.intern name, args), fresh () in
 101       fun () -> t
 102
 103   let mkTuple args =
 104     mkFresh (string_of_int (List.length args)) args
 105
 106   let mkPolyv (args : (string * delayed option) list) (extends : delayed list) : delayed =
 107     (* assume all extensions have to be completely known types at this
 108        point *)
 109     let initial =
 110       List.fold_left
 111         (fun map extension ->
 112            match fst (extension ()) with
 113          | `Variant map' ->
 114              StringMap.fold StringMap.add map map'
 115          | `Gen _ -> assert false)
 116         StringMap.empty
 117         extends
 118     in
 119     let row =
 120       List.fold_left
 121         (fun map (name, t) ->
 122            StringMap.add (Deriving_interned.intern name) t map)
 123         initial
 124         args in
 125     let fresh = make_fresh row in
 126       fun () -> fresh
 127   let eq = equal IntMap.empty
 128
 129   let rec compare recargs (lrep,lid as l) (rrep,rid as r) =
 130     if eq l r then 0
 131     else if EqualMap.equalp recargs lid rid then 0
 132     else match lrep, rrep with
 133       | `Gen (lname, ls), `Gen (rname, rs) ->
 134           begin match Pervasives.compare lname rname with
 135             | 0 ->
 136                 begin match Pervasives.compare (List.length ls) (List.length rs) with
 137                   | 0 ->
 138                       List.fold_left2
 139                         (fun cmp l r ->
 140                            if cmp <> 0 then cmp
 141                            else compare recargs (l ()) (r ()))
 142                         0 ls rs
 143                   | n -> n
 144                 end
 145             | n -> n
 146           end
 147       | `Variant lrow, `Variant rrow ->
 148           compare_rows (EqualMap.record_equality recargs lid rid) lrow rrow
 149       | `Variant _, `Gen _ -> -1
 150       | `Gen _, `Variant _ -> 1
 151   and compare_rows recargs lrow rrow =
 152     match StringSet.compare (keys lrow) (keys rrow) with
 153       | 0 -> StringMap.compare
 154           (fun l r -> match l, r with
 155              | None, None -> 0
 156              | Some l, Some r -> compare recargs (l ()) (r ())
 157              | None, Some _ -> -1
 158              | Some _, None -> 1) lrow rrow
 159       | n -> n
 160
 161   let compare = compare IntMap.empty
 162 end
 163
 164 (* Dynamic types *)
 165 type dynamic = Obj.t * TypeRep.t
 166 let tagOf (_, tag) = tag
 167 let untag (obj, tag) target =
 168   if TypeRep.eq tag target
 169   then Some obj
 170   else None
 171
 172 (* Signature for type representations *)
 173 module type Typeable =
 174 sig
 175   type a
 176   val type_rep : unit -> TypeRep.t
 177   val has_type : dynamic -> bool
 178   val cast : dynamic -> a option
 179   val throwing_cast : dynamic -> a
 180   val make_dynamic : a -> dynamic
 181   val mk : a -> dynamic
 182 end
 183
 184 exception CastFailure of string
 185
 186 module Defaults (T : (sig
 187                         type a
 188                         val type_rep : unit -> TypeRep.t
 189                       end))
 190   : Typeable with type a = T.a =
 191 struct
 192   include T
 193   let has_type o = tagOf o = type_rep ()
 194   let cast d =
 195     match untag d (type_rep ()) with
 196       | Some c -> Some (Obj.obj c)
 197       | None -> None
 198   let make_dynamic o = (Obj.repr o, type_rep ())
 199   let mk = make_dynamic
 200   let throwing_cast d =
 201     match cast d with
 202       | None -> (*raise (CastFailure ("cast from type "^
 203                                       TypeRep.Show_t.show (tagOf d) ^" to type "^
 204                                       TypeRep.Show_t.show (T.type_rep ()) ^" failed"))*)
 205           raise (CastFailure "cast failed")
 206       | Some s -> s
 207 end
 208
 209 module Typeable_list (A:Typeable) : Typeable with type a = A.a list =
 210   Defaults(struct type a = A.a list
 211                   let type_rep = TypeRep.mkFresh "Primitive.list" [A.type_rep]
 212            end)
 213
 214 module Typeable_option (A:Typeable) : Typeable with type a = A.a option =
 215   Defaults(struct type a = A.a option
 216                   let type_rep = TypeRep.mkFresh "Primitive.option" [A.type_rep]
 217            end)
 218
 219 module Primitive_typeable (T : sig type t val magic : string end) : Typeable with type a = T.t =
 220   Defaults(struct type a = T.t
 221                   let type_rep = TypeRep.mkFresh T.magic []
 222            end)
 223 module Typeable_unit   = Primitive_typeable(struct type t = unit let magic = "Primitive.unit" end)
 224 module Typeable_int    = Primitive_typeable(struct type t = int let magic = "Primitive.int" end)
 225 module Typeable_num    = Primitive_typeable(struct type t = Num.num let magic = "Primitive.Num.num" end)
 226 module Typeable_float  = Primitive_typeable(struct type t = float let magic = "Primitive.float" end)
 227 module Typeable_bool   = Primitive_typeable(struct type t = bool let magic = "Primitive.bool" end)
 228 module Typeable_string = Primitive_typeable(struct type t = string let magic = "Primitive.string" end)
 229 module Typeable_char   = Primitive_typeable(struct type t = char let magic = "Primitive.char" end)
 230 module Typeable_int32  = Primitive_typeable(struct type t = int32 let magic = "Primitive.int32" end)
 231 module Typeable_int64  = Primitive_typeable(struct type t = int64 let magic = "Primitive.int64" end)
 232 module Typeable_nativeint = Primitive_typeable(struct type t = nativeint let magic = "Primitive.nativeint" end)
 233
 234 module Typeable_ref(A : Typeable) : Typeable with type a = A.a ref =
 235   Defaults(struct type a = A.a ref
 236                   let type_rep = TypeRep.mkFresh "Primitive.ref" [A.type_rep]
 237            end)
 238