forked from ocaml/merlin
-
Notifications
You must be signed in to change notification settings - Fork 0
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
Add new module added in 4.13 + merlin patch from Ctype.Unification_tr…
…ace (moved in ocaml/ocaml#10170)
- Loading branch information
1 parent
f23cc9c
commit 24bed51
Showing
2 changed files
with
284 additions
and
0 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,165 @@ | ||
(**************************************************************************) | ||
(* *) | ||
(* OCaml *) | ||
(* *) | ||
(* Florian Angeletti, projet Cambium, Inria Paris *) | ||
(* Antal Spector-Zabusky, Jane Street, New York *) | ||
(* *) | ||
(* Copyright 2018 Institut National de Recherche en Informatique et *) | ||
(* en Automatique. *) | ||
(* Copyright 2021 Jane Street Group LLC *) | ||
(* *) | ||
(* All rights reserved. This file is distributed under the terms of *) | ||
(* the GNU Lesser General Public License version 2.1, with the *) | ||
(* special exception on linking described in the file LICENSE. *) | ||
(* *) | ||
(**************************************************************************) | ||
|
||
open Types | ||
open Format | ||
|
||
type position = First | Second | ||
|
||
let swap_position = function | ||
| First -> Second | ||
| Second -> First | ||
|
||
let print_pos ppf = function | ||
| First -> fprintf ppf "first" | ||
| Second -> fprintf ppf "second" | ||
|
||
type desc = { t: type_expr; expanded: type_expr option } | ||
type 'a diff = { got: 'a; expected: 'a} | ||
|
||
let short t = { t; expanded = None } | ||
let map_diff f r = | ||
(* ordering is often meaningful when dealing with type_expr *) | ||
let got = f r.got in | ||
let expected = f r.expected in | ||
{ got; expected} | ||
|
||
let flatten_desc f x = match x.expanded with | ||
| None -> f x.t x.t | ||
| Some expanded -> f x.t expanded | ||
|
||
let swap_diff x = { got = x.expected; expected = x.got } | ||
|
||
type 'a escape_kind = | ||
| Constructor of Path.t | ||
| Univ of type_expr | ||
(* The type_expr argument of [Univ] is always a [Tunivar _], | ||
we keep a [type_expr] to track renaming in {!Printtyp} *) | ||
| Self | ||
| Module_type of Path.t | ||
| Equation of 'a | ||
| Constraint | ||
|
||
type 'a escape = | ||
{ kind : 'a escape_kind; | ||
context : type_expr option } | ||
|
||
let explain trace f = | ||
let rec explain = function | ||
| [] -> None | ||
| [h] -> f ~prev:None h | ||
| h :: (prev :: _ as rem) -> | ||
match f ~prev:(Some prev) h with | ||
| Some _ as m -> m | ||
| None -> explain rem in | ||
explain (List.rev trace) | ||
|
||
(* Type indices *) | ||
type unification = private Unification | ||
type comparison = private Comparison | ||
|
||
type fixed_row_case = | ||
| Cannot_be_closed | ||
| Cannot_add_tags of string list | ||
|
||
type 'variety variant = | ||
(* Common *) | ||
| Incompatible_types_for : string -> _ variant | ||
| No_tags : position * (Asttypes.label * row_field) list -> _ variant | ||
(* Unification *) | ||
| No_intersection : unification variant | ||
| Fixed_row : | ||
position * fixed_row_case * fixed_explanation -> unification variant | ||
(* Equality & Moregen *) | ||
| Openness : position (* Always [Second] for Moregen *) -> comparison variant | ||
|
||
type 'variety obj = | ||
(* Common *) | ||
| Missing_field : position * string -> _ obj | ||
| Abstract_row : position -> _ obj | ||
(* Unification *) | ||
| Self_cannot_be_closed : unification obj | ||
|
||
type ('a, 'variety) elt = | ||
(* Common *) | ||
| Diff : 'a diff -> ('a, _) elt | ||
| Variant : 'variety variant -> ('a, 'variety) elt | ||
| Obj : 'variety obj -> ('a, 'variety) elt | ||
| Escape : 'a escape -> ('a, _) elt | ||
| Incompatible_fields : { name:string; diff: type_expr diff } -> ('a, _) elt | ||
(* Could move [Incompatible_fields] into [obj] *) | ||
(* Unification & Moregen; included in Equality for simplicity *) | ||
| Rec_occur : type_expr * type_expr -> ('a, _) elt | ||
|
||
type 'variety t = | ||
(desc, 'variety) elt list | ||
|
||
let diff got expected = Diff (map_diff short { got; expected }) | ||
|
||
let map_desc f { t; expanded } = | ||
let t = f t in | ||
let expanded = Std.Option.map ~f expanded in | ||
{ t; expanded } | ||
|
||
let map_elt (type variety) f : ('a, variety) elt -> ('b, variety) elt = function | ||
| Diff x -> Diff (map_diff f x) | ||
| Escape {kind = Equation x; context} -> | ||
Escape { kind = Equation (f x); context } | ||
| Escape {kind = (Univ _ | Self | Constructor _ | Module_type _ | Constraint); | ||
_} | ||
| Variant _ | Obj _ | Incompatible_fields _ | Rec_occur (_, _) as x -> x | ||
|
||
let map f t = List.map (map_elt f) t | ||
|
||
let map_types f = map (map_desc f) | ||
|
||
(* Convert desc to type_expr * type_expr *) | ||
let flatten f = map (flatten_desc f) | ||
|
||
let incompatible_fields name got expected = | ||
Incompatible_fields { name; diff={got; expected} } | ||
|
||
|
||
let swap_elt (type variety) : ('a, variety) elt -> ('a, variety) elt = function | ||
| Diff x -> Diff (swap_diff x) | ||
| Incompatible_fields { name; diff } -> | ||
Incompatible_fields { name; diff = swap_diff diff} | ||
| Obj (Missing_field(pos,s)) -> Obj (Missing_field(swap_position pos,s)) | ||
| Obj (Abstract_row pos) -> Obj (Abstract_row (swap_position pos)) | ||
| Variant (Fixed_row(pos,k,f)) -> | ||
Variant (Fixed_row(swap_position pos,k,f)) | ||
| Variant (No_tags(pos,f)) -> | ||
Variant (No_tags(swap_position pos,f)) | ||
| x -> x | ||
|
||
let swap_trace e = List.map swap_elt e | ||
|
||
module Subtype = struct | ||
type 'a elt = | ||
| Diff of 'a diff | ||
|
||
type t = desc elt list | ||
|
||
let diff got expected = Diff (map_diff short {got;expected}) | ||
|
||
let map_elt f = function | ||
| Diff x -> Diff (map_diff f x) | ||
|
||
let map f t = List.map (map_elt f) t | ||
|
||
let flatten f t = map (flatten_desc f) t | ||
end |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,119 @@ | ||
(**************************************************************************) | ||
(* *) | ||
(* OCaml *) | ||
(* *) | ||
(* Florian Angeletti, projet Cambium, Inria Paris *) | ||
(* Antal Spector-Zabusky, Jane Street, New York *) | ||
(* *) | ||
(* Copyright 2018 Institut National de Recherche en Informatique et *) | ||
(* en Automatique. *) | ||
(* Copyright 2021 Jane Street Group LLC *) | ||
(* *) | ||
(* All rights reserved. This file is distributed under the terms of *) | ||
(* the GNU Lesser General Public License version 2.1, with the *) | ||
(* special exception on linking described in the file LICENSE. *) | ||
(* *) | ||
(**************************************************************************) | ||
|
||
open Types | ||
|
||
type position = First | Second | ||
|
||
val swap_position : position -> position | ||
val print_pos : Format.formatter -> position -> unit | ||
|
||
type desc = { t: type_expr; expanded: type_expr option } | ||
type 'a diff = { got: 'a; expected: 'a} | ||
|
||
(** [map_diff f {expected;got}] is [{expected=f expected; got=f got}] *) | ||
val map_diff: ('a -> 'b) -> 'a diff -> 'b diff | ||
|
||
(** Scope escape related errors *) | ||
type 'a escape_kind = | ||
| Constructor of Path.t | ||
| Univ of type_expr | ||
(* The type_expr argument of [Univ] is always a [Tunivar _], | ||
we keep a [type_expr] to track renaming in {!Printtyp} *) | ||
| Self | ||
| Module_type of Path.t | ||
| Equation of 'a | ||
| Constraint | ||
|
||
type 'a escape = | ||
{ kind : 'a escape_kind; | ||
context : type_expr option } | ||
|
||
val short : type_expr -> desc | ||
|
||
val explain: 'a list -> | ||
(prev:'a option -> 'a -> 'b option) -> | ||
'b option | ||
|
||
(** merlin specific *) | ||
val map_types : (type_expr -> type_expr) -> t -> t | ||
|
||
(* Type indices *) | ||
type unification = private Unification | ||
type comparison = private Comparison | ||
|
||
type fixed_row_case = | ||
| Cannot_be_closed | ||
| Cannot_add_tags of string list | ||
|
||
type 'variety variant = | ||
(* Common *) | ||
| Incompatible_types_for : string -> _ variant | ||
| No_tags : position * (Asttypes.label * row_field) list -> _ variant | ||
(* Unification *) | ||
| No_intersection : unification variant | ||
| Fixed_row : | ||
position * fixed_row_case * fixed_explanation -> unification variant | ||
(* Equality & Moregen *) | ||
| Openness : position (* Always [Second] for Moregen *) -> comparison variant | ||
|
||
type 'variety obj = | ||
(* Common *) | ||
| Missing_field : position * string -> _ obj | ||
| Abstract_row : position -> _ obj | ||
(* Unification *) | ||
| Self_cannot_be_closed : unification obj | ||
|
||
type ('a, 'variety) elt = | ||
(* Common *) | ||
| Diff : 'a diff -> ('a, _) elt | ||
| Variant : 'variety variant -> ('a, 'variety) elt | ||
| Obj : 'variety obj -> ('a, 'variety) elt | ||
| Escape : 'a escape -> ('a, _) elt | ||
| Incompatible_fields : { name:string; diff: type_expr diff } -> ('a, _) elt | ||
(* Unification & Moregen; included in Equality for simplicity *) | ||
| Rec_occur : type_expr * type_expr -> ('a, _) elt | ||
|
||
type 'variety t = | ||
(desc, 'variety) elt list | ||
|
||
val diff : type_expr -> type_expr -> (desc, _) elt | ||
|
||
(** [flatten f trace] flattens all elements of type {!desc} in | ||
[trace] to either [f x.t expanded] if [x.expanded=Some expanded] | ||
or [f x.t x.t] otherwise *) | ||
val flatten : | ||
(type_expr -> type_expr -> 'a) -> 'variety t -> ('a, 'variety) elt list | ||
|
||
val map : ('a -> 'b) -> ('a, 'variety) elt list -> ('b, 'variety) elt list | ||
|
||
val incompatible_fields : string -> type_expr -> type_expr -> (desc, _) elt | ||
|
||
val swap_trace : 'variety t -> 'variety t | ||
|
||
module Subtype : sig | ||
type 'a elt = | ||
| Diff of 'a diff | ||
|
||
type t = desc elt list | ||
|
||
val diff: type_expr -> type_expr -> desc elt | ||
|
||
val flatten : (type_expr -> type_expr -> 'a) -> t -> 'a elt list | ||
|
||
val map : (desc -> desc) -> desc elt list -> desc elt list | ||
end |