make field_kind and commutable abstract types

1 files changed, 81 insertions, 20 deletions

diff --git a/typing/types.ml b/typing/types.ml
index c70691dd9d..b43e656d13 100644
--- a/typing/types.ml
+++ b/typing/types.ml
@@ -64,14 +64,15 @@ and abbrev_memo =
   | Mlink of abbrev_memo ref
 
 and field_kind =
-    Fvar of field_kind option ref
-  | Fpresent
-  | Fabsent
+    FKvar of {mutable field_kind: field_kind}
+  | FKprivate (* was None as parameter to Fvar *)
+  | FKpublic (* was Fpresent *)
+  | FKabsent
 
 and commutable =
     Cok
   | Cunknown
-  | Clink of commutable ref
+  | Cvar of {mutable commu: commutable}
 
 module TransientTypeOps = struct
   type t = type_expr
@@ -487,8 +488,8 @@ type change =
   | Cname of
       (Path.t * type_expr list) option ref * (Path.t * type_expr list) option
   | Crow of row_field option ref * row_field option
-  | Ckind of field_kind option ref * field_kind option
-  | Ccommu of commutable ref * commutable
+  | Ckind of field_kind
+  | Ccommu of commutable
   | Cuniv of type_expr option ref * type_expr option
 
 type changes =
@@ -503,18 +504,47 @@ let log_change ch =
   !trail := Change (ch, r');
   trail := r'
 
-(**** Representative of a type ****)
+(* constructor and accessors for [field_kind] *)
+
+type field_kind_view =
+    Fprivate
+  | Fpublic
+  | Fabsent
+
+let rec field_kind_internal_repr = function
+  | FKvar {field_kind} when field_kind <> FKprivate ->
+      field_kind_internal_repr field_kind
+  | kind -> kind
+
+let field_kind_repr fk =
+  match field_kind_internal_repr fk with
+  | FKvar _ -> Fprivate
+  | FKpublic -> Fpublic
+  | FKabsent -> Fabsent
+  | FKprivate -> Misc.fatal_error "Types.field_kind_repr"
+
+let field_public = FKpublic
+let field_absent = FKabsent
+let field_private () = FKvar {field_kind=FKprivate}
+
+(* Constructor and accessors for [commutable] *)
 
-let rec field_kind_repr =
-  function
-    Fvar {contents = Some kind} -> field_kind_repr kind
-  | kind                        -> kind
+let rec is_commu_ok = function
+  | Cvar {commu} -> is_commu_ok commu
+  | Cunknown -> false
+  | Cok -> true
+
+let commu_ok = Cok
+let commu_var () = Cvar {commu=Cunknown}
+
+(**** Representative of a type ****)
 
 let rec repr_link (t : type_expr) d : type_expr -> type_expr =
  function
    {desc = Tlink t' as d'} ->
      repr_link t d' t'
- | {desc = Tfield (_, k, _, t') as d'} when field_kind_repr k = Fabsent ->
+ | {desc = Tfield (_, k, _, t') as d'}
+   when field_kind_internal_repr k = FKabsent ->
      repr_link t d' t'
  | t' ->
      log_change (Ccompress (t, t.desc, d));
@@ -524,7 +554,8 @@ let rec repr_link (t : type_expr) d : type_expr -> type_expr =
 let repr_link1 t = function
    {desc = Tlink t' as d'} ->
      repr_link t d' t'
- | {desc = Tfield (_, k, _, t') as d'} when field_kind_repr k = Fabsent ->
+ | {desc = Tfield (_, k, _, t') as d'}
+   when field_kind_internal_repr k = FKabsent ->
      repr_link t d' t'
  | t' -> t'
 
@@ -532,7 +563,7 @@ let repr t =
   match t.desc with
    Tlink t' ->
      repr_link1 t t'
- | Tfield (_, k, _, t') when field_kind_repr k = Fabsent ->
+ | Tfield (_, k, _, t') when field_kind_internal_repr k = FKabsent ->
      repr_link1 t t'
  | _ -> t
 
@@ -651,8 +682,10 @@ let undo_change = function
   | Cscope (ty, scope) -> Transient_expr.set_scope ty scope
   | Cname  (r, v) -> r := v
   | Crow   (r, v) -> r := v
-  | Ckind  (r, v) -> r := v
-  | Ccommu (r, v) -> r := v
+  | Ckind  (FKvar r) -> r.field_kind <- FKprivate
+  | Ckind _ -> assert false
+  | Ccommu (Cvar r) -> r.commu <- Cunknown
+  | Ccommu _ -> Misc.fatal_error "Types.undo_change"
   | Cuniv  (r, v) -> r := v
 
 type snapshot = changes ref * int
@@ -709,10 +742,38 @@ let set_name nm v =
   log_change (Cname (nm, !nm)); nm := v
 let set_row_field e v =
   log_change (Crow (e, !e)); e := Some v
-let set_kind rk k =
-  log_change (Ckind (rk, !rk)); rk := Some k
-let set_commu rc c =
-  log_change (Ccommu (rc, !rc)); rc := c
+
+let rec link_kind ~inside k =
+  match inside with
+  | FKvar ({field_kind = FKprivate} as rk) ->
+      (* prevent a loop by normalizing k and comparing it with inside *)
+      let k = field_kind_internal_repr k in
+      if k != inside then begin
+        log_change (Ckind inside);
+        rk.field_kind <- k
+      end
+  | FKvar {field_kind} ->
+      link_kind ~inside:field_kind k
+  | _ -> invalid_arg "Types.link_kind"
+
+let rec commu_repr = function
+    Cvar {commu} when commu != Cunknown -> commu_repr commu
+  | c -> c
+
+let rec link_commu ~inside c =
+  match inside with
+  | Cvar ({commu = Cunknown} as rc) ->
+      (* prevent a loop by normalizing c and comparing it with inside *)
+      let c = commu_repr c in
+      if c != inside then begin
+        log_change (Ccommu inside);
+        rc.commu <- c
+      end
+  | Cvar {commu} ->
+      link_commu ~inside:commu c
+  | _ -> invalid_arg "Types.link_commu"
+
+let set_commu_ok c = link_commu ~inside:c Cok
 
 let snapshot () =
   let old = !last_snapshot in