Refactoring : change the functors' order of application.
This commit is contained in:
parent
93b6eed1e7
commit
25d300cfb1
|
@ -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%!"
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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,
|
||||
|
|
Loading…
Reference in New Issue