Fetching contributors…
Cannot retrieve contributors at this time
executable file 299 lines (263 sloc) 11.9 KB
Copyright © 2011 MLstate
This file is part of OPA.
OPA is free software: you can redistribute it and/or modify it under the
terms of the GNU Affero General Public License, version 3, as published by
the Free Software Foundation.
OPA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
more details.
You should have received a copy of the GNU Affero General Public License
along with OPA. If not, see <>.
Author: 2011, François Pessaux <>
Strongly mapped on of the old HMX typechecker.
This module implements comparison on QML types with the semantics that
old HMX typechecker had when it first transformed QML types into HMX types
then compared the HMX types.
The idea is to remove the bridge between QML and HMX primitives since HMX
is not used anymore. However, QML still used some parts of HMX functions
for various things. That's the reason why this module exists.
(* depends *)
module List = BaseList
(* shorthands *)
module Q = QmlAst
module TyPairSet : (BaseSetSig.S with type elt = QmlAst.ty * QmlAst.ty) =
BaseSet.Make (
type t = QmlAst.ty * QmlAst.ty
let compare =
sort the list of type variables [bvs] bounds in a TypeForall
according to the apparition order in the quantified type [t]
(* TODO : extend to row and column variables *)
let sort_bound_vars env bvs t =
let rec aux memo (sbvs, bvs) t =
match t with
| Q.TypeSumSugar _ ->
(* They should have all disappeared. *)
assert false
| Q.TypeConst _ -> (sbvs, bvs)
| Q.TypeVar v ->
if List.mem v bvs then ((v :: sbvs), (List.remove_first v bvs))
else (sbvs, bvs)
| Q.TypeArrow (lt, u) ->
aux memo (List.fold_left (aux memo) (sbvs, bvs) lt) u
| Q.TypeRecord (Q.TyRow (fields, _)) -> aux_fields memo (sbvs, bvs) fields
| Q.TypeSum (Q.TyCol (l_fields, _)) ->
List.fold_left (aux_fields memo) (sbvs, bvs) l_fields
| Q.TypeName (lt, tn) ->
let (tsc, _) =
QmlTypes.Env.TypeIdent.find ~visibility_applies: true tn env in
let acc =
if List.mem t memo then (sbvs, bvs)
let t' = QmlTypes.Scheme.specialize ~typeident: tn ~ty: lt tsc in
aux (t :: memo) (sbvs, bvs) t' in
(* explore phantom types, because they don't appear in the body *)
let (vars, _, _) = QmlGenericScheme.export_unsafe tsc in
let (typevars, _, _) = QmlTypeVars.FreeVars.export_as_lists vars in
let count_t_c_freevars t _c = QmlTypes.freevars_of_ty t in
let phantomvars =
QmlGenericScheme.phantomvars_with_cache count_t_c_freevars tsc in
let fold_fun acc v t =
if QmlTypeVars.FreeVars.mem_typevar v phantomvars then aux memo acc t
else acc in
List.fold_left2 fold_fun acc typevars lt
| Q.TypeAbstract -> (sbvs, bvs)
| Q.TypeForall (_, _, _, t) -> aux memo (sbvs, bvs) t
and aux_fields memo (sbvs, bvs) fields =
let lt = snd fields in
List.fold_left (aux memo) (sbvs, bvs) lt in
(* Note that it is legal to have variable not "seen", i.e. variable remaining
in [bvs] and not sent to [sbvs] after sorting because when a type name is
defined as an abstract type, since this latter doesn't have parameter,
parameters of the type name do not appear in the instantiation hence are
not "seen". As a result, they in effect are not removed from the list [bvs]
and not added in the list [sbvs]. *)
let (sbvs, _) = aux [] ([], bvs) t in
List.rev sbvs
let sort_row_fields fields =
List.sort (fun (n1, _) (n2, _) -> n1 n2) fields
let sort_col_cases (Q.TyCol (cases, ending)) =
(* First, for each case, sort the fields of the row forming the case. *)
let cases' = sort_row_fields cases in
(* Now, sort each case according to the fields it has. *)
let cases'' =
(fun case1 case2 ->
(fun (n1, _) (n2, _) -> n1 n2) case1 case2)
cases' in
QmlAst.TyCol (cases'', ending)
let rec test_tys_eq env ?(bound_vars=[]) memo t1 t2 =
let call_aux ?(bound_vars=bound_vars) = test_tys_eq env ~bound_vars memo in
let is_bound v = List.mem v bound_vars in
if t1 == t2 then true (* speedup *) else
match t1, t2 with
| ((Q.TypeConst c), (Q.TypeConst d)) -> c = d
| ((Q.TypeVar v1), (Q.TypeVar v2)) when is_bound v1 && not (is_bound v2) ->
| ((Q.TypeVar v1), (Q.TypeVar v2)) when not (is_bound v1) && is_bound v2 ->
| ((Q.TypeVar v1), (Q.TypeVar v2)) -> v1 = v2
| ((Q.TypeArrow (lt, t)), (Q.TypeArrow (lu, u))) ->
((List.length lt) = (List.length lu)) &&
(List.for_all2 (call_aux ~bound_vars) lt lu) &&
(call_aux ~bound_vars t u)
| ((Q.TypeSum ts), (Q.TypeSum us)) -> cmp_col env memo ts us
| ((Q.TypeRecord rx), (Q.TypeRecord ry)) -> cmp_row env memo rx ry
| (Q.TypeRecord (Q.TyRow (tfs, trv))), (Q.TypeSum (Q.TyCol (ufs, ucv))) -> (
match trv with
| Some _ -> false
| None ->
match ucv with
| Some _ -> false
| None ->
(* No row/column variables -> compare fields *)
(match ufs with
| [ one ] ->
(* To be "equal", the sum must have only 1 case. *)
sort_and_cmp_fields env memo tfs one
| _ -> false)
| ((Q.TypeSum _), (Q.TypeRecord _)) -> call_aux ~bound_vars t2 t1
| ((Q.TypeName (ts, tn)), (Q.TypeName (us, un))) ->
if TyPairSet.mem (t1, t2) memo then true (* already seen, assumed equal *)
else (
let memo = TyPairSet.add (t1, t2) (TyPairSet.add (t2, t1) memo) in
let (tn, (te, _)) =
QmlTypes.Env.TypeIdent.findi ~visibility_applies: true tn env in
let (un, (ue, _)) =
QmlTypes.Env.TypeIdent.findi ~visibility_applies: true un env in
(* First, perform a test ensuring that both types have the same names
and the same arguments (by induction, they hence will be the
same). *)
let are_equal_by_name =
(QmlAst.TypeIdent.equal tn un) &&
((List.length ts) = (List.length us)) &&
(List.for_all2 (call_aux ~bound_vars) ts us) in
(* Types are equal just by their name and inductively by their
argument, then we are done, test is true. *)
if are_equal_by_name then true
else (
(* Ok, we are in the case where the 2 types are not equal by names.
This means that they have different name and/or different
arguments. *)
let t = QmlTypes.Scheme.specialize ~typeident: tn ~ty: ts te in
let u = QmlTypes.Scheme.specialize ~typeident: un ~ty: us ue in
(* If these types are abstract, then they have no more internal
representation (i.e. they are not abbreviations that could point on
a same representation, and they don't have any own structure) and
hence they are *different*. *)
if (t = QmlAst.TypeAbstract) && (u = QmlAst.TypeAbstract) then false
else test_tys_eq env ~bound_vars memo t u
| ((Q.TypeForall _), _) | (_, (Q.TypeForall _)) ->
(* let env_vars = env.Hmx_env.freevars_of_idents in *)
let t = (* generalize_in_type env_vars *) t1 in
let u = (* generalize_in_type env_vars *) t2 in
let res = (
match (t, u) with
| Q.TypeForall (t_bvs, t_row_vars, t_col_vars, t),
Q.TypeForall (u_bvs, _, _, u) ->
(* TODO : comparison is not correct !!! *)
(* quantification over row and column variables is not handled *)
let t_bvs = sort_bound_vars env t_bvs t in
let u_bvs = sort_bound_vars env u_bvs u in
if (List.length t_bvs) <> (List.length u_bvs) then false
else (
(* At this point, we are sure that the lists of quantified vars
are the same length. So we can safely transform the type t
into a pseudo scheme, call QmlTypes.instantiate on it with
a fake type ident since lists of quantified vars being the
same length, we won't get an error, so the fake ident won't
re-spring. *)
let fake_ident =
QmlAst.TypeIdent.of_string "__icmpty_broken_if_seen " in
let fake_quantif =
(t_bvs, t_row_vars, t_col_vars) QmlTypeVars.FreeVars.empty in
let fake_sch = QmlGenericScheme.import fake_quantif t () in
let fake_ml_vars = (fun v -> QmlAst.TypeVar v) t_bvs in
let fake_row_vars = (fun v -> QmlAst.TyRow ([], (Some v))) t_row_vars in
(* Instantiate the pseudo scheme built from the body of t.
Instantiation is done by replacing its variables by those of
u. *)
let t =
~typeident: fake_ident ~ty: fake_ml_vars
~ty_row: fake_row_vars fake_sch in
call_aux ~bound_vars: (t_bvs @ bound_vars) t u
| ((Q.TypeForall _), _) | (_, (Q.TypeForall _)) -> false
| _ -> assert false (* at least one of them should be a TypeForall *)
) in
| ((Q.TypeName (ts, tn)), u) ->
(* beware of type 'a nil = {nil:unit}, then int nil = float nil *)
if TyPairSet.mem (t1, t2) memo then false
else (
let memo = TyPairSet.add (t1, t2) memo in
let (tn, (te, _)) =
QmlTypes.Env.TypeIdent.findi ~visibility_applies: true tn env in
let t = QmlTypes.Scheme.specialize ~typeident: tn ~ty: ts te in
if t = QmlAst.TypeAbstract then false
else test_tys_eq env memo t u
| (_, (Q.TypeName (_, _))) -> call_aux ~bound_vars t2 t1
| (Q.TypeAbstract, _) | (_, Q.TypeAbstract) -> false
| (_, _) ->
(* Different constructors or not matching extern abstract type:
fall back on Pervasives' comparison *)
t1 = t2
and sort_and_cmp_fields env memo tfs ufs =
let cmp_field (tfn, tft) (ufn, uft) =
(tfn = ufn) && (test_tys_eq env memo tft uft) in
(* First, compare lists lengths. *)
if (List.length tfs) <> (List.length ufs) then false
else (
(* Sort the fields by name. *)
let tfs' = sort_row_fields tfs in
let ufs' = sort_row_fields ufs in
List.for_all2 cmp_field tfs' ufs'
(* Fields will be sorted by name by calling [sort_and_cmp_fields]. No need
to sort them in this function. *)
and cmp_row env memo (Q.TyRow (tfs, tv)) (Q.TyRow (ufs, uv)) =
let row_var_eq =
(match (tv, uv) with
| (None, None) -> true
| (None, (Some _)) | ((Some _), None) -> false
| ((Some v1), (Some v2)) -> (QmlAst.RowVar.equal v1 v2)) in
row_var_eq && (sort_and_cmp_fields env memo tfs ufs)
(* Since to sort cases, we need to sort fields of each row forming a case,
to avoid sorting several times, we don't use [cmp_row] and
[sort_and_cmp_fields] and directly sort the whole column in one shot here. *)
and cmp_col env memo (Q.TyCol (_tfs, tv) as tcol) (Q.TyCol (_ufs, uv) as ucol) =
let col_var_eq =
(match (tv, uv) with
| (None, None) -> true
| (None, (Some _)) | ((Some _), None) -> false
| ((Some v1), (Some v2)) -> QmlAst.ColVar.equal v1 v2) in
if not col_var_eq then false
else (
(* Sort the cases. *)
let tcol = sort_col_cases tcol in
let ucol = sort_col_cases ucol in
let ts = Q.column_to_records tcol in
let us = Q.column_to_records ucol in
((List.length ts) = (List.length us)) &&
(List.for_all2 (test_tys_eq env memo) ts us)
let equal_ty env t u = test_tys_eq env TyPairSet.empty t u