Refactoring : change the functors' order of application.

This commit is contained in:
Olivier 2022-04-07 11:32:42 +02:00
parent 93b6eed1e7
commit 25d300cfb1
6 changed files with 74 additions and 61 deletions

View File

@ -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%!"

View File

@ -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

View File

@ -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

View File

@ -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)

View File

@ -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

View File

@ -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,