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