Attention une mise à jour du service Gitlab va être effectuée le mardi 18 janvier (et non lundi 17 comme annoncé précédemment) entre 18h00 et 18h30. Cette mise à jour va générer une interruption du service dont nous ne maîtrisons pas complètement la durée mais qui ne devrait pas excéder quelques minutes.

Commit d603556a authored by Simon Cruanes's avatar Simon Cruanes
Browse files

explicit_polymorphism transformation almost usable

parent c0538440
......@@ -29,12 +29,67 @@ open Term
open Decl
open Task
(** parenthesing operator *)
let ($) f x = f x
(** type representing types *)
let t = Ty.create_tysymbol (id_fresh "t") [] None
let t_decl = Decl.create_ty_decl [(t, Tabstract)]
(** {2 small functions} *)
module Utils = struct
(** parenthesing operator *)
let ($) f x = f x
(** type representing types *)
let t = Ty.create_tysymbol (id_fresh "t") [] None
let t_decl = Decl.create_ty_decl [(t, Tabstract)]
let has_type_t = ty_equal (ty_app t [])
let is_tyvar = function
| Tyvar _ -> true | _ -> false
and from_tyvar = function
| Tyvar x -> x | _ -> failwith "from_tyvar called on non-tyvar"
let fromSome = function
| Some x -> x | None -> failwith "fromSome called on None"
(** returns all type vars (free) in given fmla_node *)
let rec find_type_vars acc f = match f.f_node with
| Fapp (p, terms) ->
let new_acc = List.filter
(fun x -> is_tyvar x.ty_node) p.ls_args in
List.fold_left term_analyse (new_acc @ acc) terms
| _ -> f_fold term_analyse find_type_vars acc f
and term_analyse acc t = match t.t_node with
| Tvar x when is_tyvar (x.vs_ty.ty_node) -> x.vs_ty::acc
| _ -> t_fold term_analyse find_type_vars acc t
(** kind of composition of filter and map *)
let rec mapSome f = function
| e::es -> (match f e with
| Some x -> x :: mapSome f es
| None -> mapSome f es)
| [] -> []
let from_ty_node = function
| Tyvar _ -> assert false
| Tyapp (ty_symb, vars) -> (ty_symb, vars)
(** to get unique elements in list (inefficient) *)
let list_unique l =
let remember memory x = if List.mem x memory
then memory else x::memory in
List.fold_left remember [] l (* FIXME : make it efficient *)
let const x _ = x
let map_keys m = Mty.fold (fun key value acc -> key::acc) m []
let map_values m = Mty.fold (fun key value acc -> value::acc) m []
end
open Utils
(** {2 module to separate utilities from important functions} *)
......@@ -53,14 +108,17 @@ module Prelude = struct
(** creates a new logic symbol, with a different type if the
given symbol was polymorphic *)
let logic_to_logic lsymbol =
let replace ty = match ty.ty_node with
| Tyvar _ -> ty_app t []
| _ -> ty in
let new_ty = List.map replace lsymbol.ls_args in
let new_lsymbol =
Term.create_lsymbol (id_clone lsymbol.ls_name)
new_ty lsymbol.ls_value
in new_lsymbol
if ls_equal lsymbol ps_equ || ls_equal lsymbol ps_neq then lsymbol else
let new_ty = list_unique $
List.filter (fun x->is_tyvar x.ty_node) lsymbol.ls_args in
(* as many t as type vars *)
if new_ty = [] then lsymbol (* same type *) else
let new_ty = List.map (fun _ -> ty_app t []) new_ty in
let all_new_ty = new_ty @ lsymbol.ls_args in
let new_lsymbol =
Term.create_lsymbol (id_clone lsymbol.ls_name)
all_new_ty lsymbol.ls_value
in new_lsymbol
(** creates a lsymbol associated with the given type *)
let type_to_logic ty =
......@@ -70,24 +128,42 @@ module Prelude = struct
let new_lsymbol =
Term.create_lsymbol name args (Some my_t)
in new_lsymbol
(** [find_matching_vars tblT varM args_ty args_vars] matches [args_ty]
against [args_vars] to deduce a mapping from [args_vars] to lsymbols
through [tblT] and [varM] *)
let find_matching_vars tblT varM args_ty args_vars =
let tv_to_ty = Mtv.empty in
let mapping = List.fold_left2 ty_match tv_to_ty args_ty args_vars in
let tv_to_lsymbol = Mtv.empty in (* result mapping *)
Mtv.fold
(fun key value acc -> Mtv.add key (Mty.find value varM) acc)
mapping tv_to_lsymbol
(** different finders *)
let findL = find_generic logic_to_logic
let findT = find_generic type_to_logic
let findL tbl x = find_generic logic_to_logic tbl x
let findT tbl x = find_generic type_to_logic tbl x
(** substitutions in formulae and terms *)
let rec term_transform tblT tblL t = match t.t_node with
| Tconst x -> t
let rec term_transform tblT tblL varM t = match t.t_node with
| Tapp(f, terms) ->
let ty = match f.ls_value with
| Some ty -> ty
| None -> failwith "term function must have a type" in
Term.t_app (findL tblL f)
(List.map (term_transform tblT tblL) terms) ty
| _ -> t_map (term_transform tblT tblL) (fmla_transform tblT tblL) t
and fmla_transform tblT tblL f = match f.f_node with
| _ -> f_map (term_transform tblT tblL) (fmla_transform tblT tblL) f
let result_ty = fromSome f.ls_value in
let new_f = (findL tblL f) in
let args_ty = List.map (fun x-> x.t_ty) terms in
let matched_terms = find_matching_vars tblT varM args_ty new_f.ls_args in
let new_terms = List.filter (fun x->is_tyvar x.ty_node) f.ls_args in
let new_terms = List.map
(fun x-> match x.ty_node with
| Tyvar v -> t_var (Mtv.find v matched_terms)
| _ -> failwith "should find a mapping for this var") new_terms in
let transformed_terms = List.map (term_transform tblT tblL varM) terms in
t_app new_f (new_terms @ transformed_terms) result_ty
| _ -> (* default case : traverse *)
t_map (term_transform tblT tblL varM) (fmla_transform tblT tblL varM) t
and fmla_transform tblT tblL varM f = f_map
(term_transform tblT tblL varM) (fmla_transform tblT tblL varM) f
(** transforms a list of logic declarations into another
......@@ -96,9 +172,9 @@ module Prelude = struct
let helper = function
| (lsymbol, Some ldef) ->
let new_lsymbol = findL tbl lsymbol in (* new lsymbol *)
let polymorphic_vars = List.filter
let polymorphic_vars = list_unique $ List.filter
(fun ty -> match ty.ty_node with Tyvar _ -> true|_-> false)
lsymbol.ls_args in (* get polymorphic vars *)
lsymbol.ls_args in (* get unique type vars *)
let vars,expr = open_ls_defn ldef in
let new_vars = List.map
(fun _ -> Term.create_vsymbol (id_fresh "t") (ty_app t []))
......@@ -107,7 +183,6 @@ module Prelude = struct
(match expr with
| Term t -> Decl.make_fs_defn new_lsymbol vars t
| Fmla f -> Decl.make_ps_defn new_lsymbol vars (f_forall new_vars [] f))
(* FIXME : is it useful / meaningful ? *)
| (lsymbol, None) ->
let new_lsymbol = findL tbl lsymbol in
(new_lsymbol, None) in
......@@ -127,13 +202,20 @@ module Prelude = struct
(** transforms a proposition into another (mostly a substitution) *)
let prop_transform tblT tblL (prop_kind, prop_name, fmla) =
[Decl.create_prop_decl prop_kind prop_name
(fmla_transform tblT tblL fmla)]
let type_vars = list_unique $ find_type_vars [] fmla in
let varM = List.fold_left
(fun m x -> Mty.add x
(create_vsymbol (id_fresh "t") (ty_app t [])) m)
Mty.empty type_vars
in [Decl.create_prop_decl prop_kind prop_name
(f_forall (map_values varM) [] (*universal quantification over ty vars*)
(fmla_transform tblT tblL varM fmla))]
end
(** {2 main part} *)
(** utility to print a list of items *)
let rec print_list printer fmter = function
| [] -> ()
| e::es ->
......@@ -142,15 +224,15 @@ let rec print_list printer fmter = function
(** main function, takes hashtables (for memoization of types and logic
symbols) and a declaration, and returns the corresponding declaration in
explicit polymorphism logic. *)
let decl_transform tblT tblL d =
Format.printf "%a" Pretty.print_decl d;
let decl_transform tblT tblL d =
(* Format.eprintf "%a@ " Pretty.print_decl d; *)
let result = match d.d_node with
| Dind _inds ->
failwith "Dind : should not have inductives declarations at this point !"
| Dtype tys -> Prelude.type_transform tblT tys
| Dlogic decls -> Prelude.logic_transform tblL decls
| Dprop prop -> Prelude.prop_transform tblT tblL prop
in Format.printf " -> %a@." (print_list Pretty.print_decl) result;
in (* Format.eprintf " ===> %a@." (print_list Pretty.print_decl) result; *)
result
(** the transformation to be registered. *)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment