Refactoring : change the functors' order of application.

client/bin/midml.ml

@@ -5,6 +5,7 @@ let rectypes =
   ref false
 
 let test_ok filename =
+  ignore (Sys.command ("cat " ^ Filename.quote filename));
   match from_file filename with
   | exception (ParsingError range) ->
     Printf.eprintf "%!%sSyntax error.\n%!"

src/Generalization.ml

@@ -11,7 +11,7 @@
 
 open Signatures
 
-module Make (UserS : STRUCTURE_LEAF) = struct
+module Make (UserS : HSTRUCTURE) = struct
 
 (* -------------------------------------------------------------------------- *)
 
@@ -101,58 +101,8 @@ let fresh_mark : unit -> mark =
    Rigid variables have abstract strucutres.
  *)
 
-module S = struct
-  type 'a structure =
-    | Abstract of int
-    | User of 'a UserS.structure
-
-  exception InconsistentConjunction =
-    UserS.InconsistentConjunction
-
-  let conjunction f s1 s2 =
-    match s1, s2 with
-    | Abstract n1, Abstract n2 ->
-       if Int.equal n1 n2 then s1
-       else raise InconsistentConjunction
-    | User s1, User s2 ->
-       User (UserS.conjunction f s1 s2)
-    | Abstract n, User s
-    | User s, Abstract n ->
-       if UserS.is_leaf s then Abstract n
-       else
-         raise InconsistentConjunction
-
-  let iter f s =
-    match s with
-    | Abstract _ ->
-       ()
-    | User s ->
-       UserS.iter f s
-
-  let fold f s acc =
-    match s with
-    | Abstract _ ->
-       acc
-    | User s ->
-       UserS.fold f s acc
-
-  let map f s =
-    match s with
-    | Abstract n ->
-       Abstract n
-    | User s ->
-       User (UserS.map f s)
-
-  let leaf = User (UserS.leaf)
-
-  let is_leaf s =
-    match s with
-    | Abstract _ ->
-       false
-    | User s ->
-       UserS.is_leaf s
-
-end
+module AS = Structure.AbstractS(UserS)
+module S = Structure.OptionS(AS)
 
 (* -------------------------------------------------------------------------- *)
 
@@ -394,7 +344,7 @@ let fresh structure =
 let fresh_rigid =
   let fresh_abstract = Utils.gensym() in
   fun () ->
-  let structure = S.Abstract (fresh_abstract ()) in
+  let structure = Some (Structure.Abstract (fresh_abstract ())) in
   let rank = state.young in
   let scope = rank in
   let v = U.fresh (Data.make structure ~rank ~scope Active) in
@@ -824,7 +774,7 @@ let instantiate { generics; quantifiers; root } =
       let data = get v in
       assert (data.status = Generic);
       data.mark <- i;
-      fresh S.leaf
+      fresh None
     )
   in
 

src/Generalization.mli

@@ -22,7 +22,7 @@ open Signatures
    operations that allow constructing, inspecting, and instantiating
    schemes. *)
 module Make
-  (UserS : sig (** @inline *) include STRUCTURE_LEAF end)
+  (UserS : sig (** @inline *) include HSTRUCTURE end)
 : sig
 
   module S : sig

src/Solver.ml

@@ -255,8 +255,7 @@ open C
 
 (* TODO explain why we use [Structure.Option] *)
 
-module OS = Structure.Option(S)
-module G = Generalization.Make(OS)
+module G = Generalization.Make(S)
 module U = G.U
 
 (* -------------------------------------------------------------------------- *)
@@ -359,12 +358,20 @@ module D =
    A cyclic decoder is used even if [rectypes] is [false]. Indeed, recursive
    types can appear before the occurs check has been performed. *)
 
+let print_var v =
+  let data = G.U.get v in
+  Printf.printf "rank=%d | scope=%d | is_leaf=%b\n%!"
+    (G.Data.rank data) (G.Data.scope data)
+    (G.Data.is_leaf data)
+
 let unify range v1 v2 =
   try
     U.unify v1 v2
   with
   | U.Unify (v1, v2) ->
      let decode = D.new_cyclic_decoder() in
+     print_var v1;
+     print_var v2;
      raise (Unify (range, decode v1, decode v2))
   | G.VariableScopeEscape { rank=_ ; scope=_ } ->
      raise (VariableScopeEscape range)

src/Structure.ml

@@ -11,7 +11,53 @@
 
 open Signatures
 
-module Option (S : GSTRUCTURE) = struct
+type 'a or_abstract =
+  | Abstract of int
+  | User of 'a
+
+module AbstractS (UserS : HSTRUCTURE) = struct
+
+  type 'a structure = 'a UserS.structure or_abstract
+
+  exception InconsistentConjunction =
+    UserS.InconsistentConjunction
+
+  let conjunction f s1 s2 =
+    match s1, s2 with
+    | Abstract n1, Abstract n2 ->
+       if Int.equal n1 n2 then s1
+       else raise InconsistentConjunction
+    | User s1, User s2 ->
+       User (UserS.conjunction f s1 s2)
+    | Abstract _n, User _s
+    | User _s, Abstract _n -> (*
+       if UserS.is_leaf s then Abstract n
+       else *)
+         raise InconsistentConjunction
+
+  let iter f s =
+    match s with
+    | Abstract _ ->
+       ()
+    | User s ->
+       UserS.iter f s
+
+  let fold f s acc =
+    match s with
+    | Abstract _ ->
+       acc
+    | User s ->
+       UserS.fold f s acc
+
+  let map f s =
+    match s with
+    | Abstract n ->
+       Abstract n
+    | User s ->
+       User (UserS.map f s)
+end
+
+module OptionS (S : GSTRUCTURE) = struct
 
   type 'a structure =
     'a S.structure option

src/Structure.mli

@@ -11,6 +11,14 @@
 
 open Signatures
 
+type 'a or_abstract =
+  | Abstract of int
+  | User of 'a
+
+module AbstractS (S : sig (** @inline *) include HSTRUCTURE end) : sig
+  include GSTRUCTURE with type 'a structure = 'a S.structure or_abstract
+end
+
 (**This functor transforms a type ['a structure], equipped with [map],
    [iter] and [conjunction] operations, into the type ['a structure option],
    equipped with the same operations. The type ['a structure option] is
@@ -18,10 +26,11 @@ open Signatures
    indeed, the optional structure [None] indicates the absence of a
    constraint, while the optional structure [Some term] indicates the
    presence of an equality constraint. *)
-module Option (S : sig (** @inline *) include GSTRUCTURE end) : sig
+module OptionS (S : sig (** @inline *) include GSTRUCTURE end) : sig
 
   (** @inline *)
-  include STRUCTURE_LEAF with type 'a structure = 'a S.structure option
+  include STRUCTURE_LEAF
+          with type 'a structure = 'a S.structure option
 
   (**[project_nonleaf (Some s)] is [s], while [project_nonleaf None] is
      undefined. In other words, if [os] is a non-leaf optional structure,