Commit c8a04147 authored by POGODALLA Sylvain's avatar POGODALLA Sylvain

eta expansion added

parent 6ff347dc
...@@ -39,9 +39,11 @@ struct ...@@ -39,9 +39,11 @@ struct
| Constant of (Abstract_syntax.location * Lambda.term ) | Constant of (Abstract_syntax.location * Lambda.term )
let interpretation_to_string i sg = match i with let interpretation_to_string abstract_type_or_cst_id fun_type_from_id i sg = match i with
| Type (_,t) -> Printf.sprintf "\t%s" (Lambda.type_to_string t (Sg.id_to_string sg)) | Type (_,t) -> Printf.sprintf "\t%s" (Lambda.type_to_string t (Sg.id_to_string sg))
| Constant (_,c) -> Printf.sprintf "\t%s" (Lambda.term_to_string c (Sg.id_to_string sg)) | Constant (_,c) ->
let eta_long = Sg.eta_long_form c (fun_type_from_id abstract_type_or_cst_id) sg in
Printf.sprintf "\t%s [eta-long form: %s {%s}]" (Lambda.term_to_string c (Sg.id_to_string sg)) (Lambda.term_to_string eta_long (Sg.id_to_string sg) ) (Lambda.raw_to_string eta_long)
type t = {name:string*Abstract_syntax.location; type t = {name:string*Abstract_syntax.location;
dico:interpretation Dico.t; dico:interpretation Dico.t;
...@@ -103,7 +105,7 @@ struct ...@@ -103,7 +105,7 @@ struct
| Abstract_syntax.Type (id,loc,ty) -> {lex with dico=Dico.add id (Type (loc,Sg.convert_type ty lex.object_sig)) d} | Abstract_syntax.Type (id,loc,ty) -> {lex with dico=Dico.add id (Type (loc,Sg.convert_type ty lex.object_sig)) d}
| Abstract_syntax.Constant (id,loc,t) -> {lex with dico=Dico.add id (Constant (loc,Sg.typecheck t (interpret_type (Sg.type_of_constant id lex.abstract_sig) lex) lex.object_sig)) d} | Abstract_syntax.Constant (id,loc,t) -> {lex with dico=Dico.add id (Constant (loc,Sg.typecheck t (interpret_type (Sg.type_of_constant id lex.abstract_sig) lex) lex.object_sig)) d}
let to_string {name=n,_;dico=d;abstract_sig=abs_sg;object_sig=obj_sg} = let to_string ({name=n,_;dico=d;abstract_sig=abs_sg;object_sig=obj_sg} as lex) =
Printf.sprintf Printf.sprintf
"lexicon %s(%s): %s =\n%send" "lexicon %s(%s): %s =\n%send"
n n
...@@ -112,8 +114,8 @@ struct ...@@ -112,8 +114,8 @@ struct
(match (match
Dico.fold Dico.fold
(fun k i -> function (fun k i -> function
| None -> Some (Printf.sprintf "\t%s := %s;" k (interpretation_to_string i obj_sg)) | None -> Some (Printf.sprintf "\t%s := %s;" k (interpretation_to_string k (fun id -> interpret_type (Sg.type_of_constant id abs_sg) lex) i obj_sg))
| Some a -> Some (Printf.sprintf "%s\n\t%s := %s;" a k (interpretation_to_string i obj_sg))) | Some a -> Some (Printf.sprintf "%s\n\t%s := %s;" a k (interpretation_to_string k (fun id -> interpret_type (Sg.type_of_constant id abs_sg) lex) i obj_sg)))
d d
None with None with
| None -> "" | None -> ""
......
This diff is collapsed.
...@@ -50,6 +50,7 @@ sig ...@@ -50,6 +50,7 @@ sig
val fold : (entry -> 'a -> 'a) -> 'a -> t -> 'a val fold : (entry -> 'a -> 'a) -> 'a -> t -> 'a
val get_binder_argument_functional_type : string -> t -> Abstract_syntax.abstraction option val get_binder_argument_functional_type : string -> t -> Abstract_syntax.abstraction option
val is_declared : entry -> t -> string option val is_declared : entry -> t -> string option
val eta_long_form : term -> stype -> t -> term
end end
module type Lexicon_sig = module type Lexicon_sig =
......
...@@ -135,6 +135,10 @@ sig ...@@ -135,6 +135,10 @@ sig
[None] otherwise *) [None] otherwise *)
val is_declared : entry -> t -> string option val is_declared : entry -> t -> string option
(** [eta_long_form t ty sg] returns the eta-long form of [t] with
respect to the type [ty] and signature [sg]*)
val eta_long_form : term -> stype -> t -> term
end end
(** This module signature describes the interface for modules implementing lexicons *) (** This module signature describes the interface for modules implementing lexicons *)
......
...@@ -295,6 +295,8 @@ struct ...@@ -295,6 +295,8 @@ struct
let get_binder_argument_functional_type _ _ = Some Abstract_syntax.Linear let get_binder_argument_functional_type _ _ = Some Abstract_syntax.Linear
let is_declared _ _ = None let is_declared _ _ = None
let eta_long_form _ _ _ = failwith "Not implemented: useless"
let raw_to_string _ = failwith "TUTUTUT" let raw_to_string _ = failwith "TUTUTUT"
......
...@@ -82,13 +82,13 @@ module Lambda = ...@@ -82,13 +82,13 @@ module Lambda =
let rec unfold_labs acc level env = function let rec unfold_labs acc level env = function
| LAbs (x,t) -> | LAbs (x,t) ->
let x' = generate_var_name x env in let x' = generate_var_name x env in
unfold_labs ((level,x')::acc) (level+1) env t unfold_labs ((level,x')::acc) (level+1) ((level,x')::env) t
| t -> acc,level,t | t -> acc,level,t
let rec unfold_abs acc level env = function let rec unfold_abs acc level env = function
| Abs (x,t) -> | Abs (x,t) ->
let x' = generate_var_name x env in let x' = generate_var_name x env in
unfold_abs ((level,x')::acc) (level+1) env t unfold_abs ((level,x')::acc) (level+1) ((level,x')::env) t
| t -> acc,level,t | t -> acc,level,t
let rec unfold_app acc = function let rec unfold_app acc = function
...@@ -163,7 +163,7 @@ module Lambda = ...@@ -163,7 +163,7 @@ module Lambda =
| DConst i -> let _,x = id_to_sym i in x,true | DConst i -> let _,x = id_to_sym i in x,true
| Abs (x,t) -> | Abs (x,t) ->
let x' = generate_var_name x env in let x' = generate_var_name x env in
let vars,l,u=unfold_abs [level,x'] (level+1) env t in let vars,l,u=unfold_abs [level,x'] (level+1) ((level,x')::env) t in
Printf.sprintf Printf.sprintf
"Lambda %s. %s" "Lambda %s. %s"
(Utils.string_of_list " " (fun (_,x) -> x) (List.rev vars)) (Utils.string_of_list " " (fun (_,x) -> x) (List.rev vars))
...@@ -171,7 +171,7 @@ module Lambda = ...@@ -171,7 +171,7 @@ module Lambda =
false false
| LAbs (x,t) -> | LAbs (x,t) ->
let x' = generate_var_name x l_env in let x' = generate_var_name x l_env in
let vars,l,u=unfold_labs [l_level,x'] (l_level+1) l_env t in let vars,l,u=unfold_labs [l_level,x'] (l_level+1) ((l_level,x')::l_env) t in
Printf.sprintf Printf.sprintf
"lambda %s. %s" "lambda %s. %s"
(Utils.string_of_list " " (fun (_,x) -> x) (List.rev vars)) (Utils.string_of_list " " (fun (_,x) -> x) (List.rev vars))
...@@ -492,5 +492,83 @@ module Lambda = ...@@ -492,5 +492,83 @@ module Lambda =
in in
convert (type_normalize ty1) (type_normalize ty2) convert (type_normalize ty1) (type_normalize ty2)
let eta_expand t ty =
let wrap t abstraction l_level nl_level =
let f,l_length,nl_length,abs'=
List.fold_left
(fun (f,l_depth,nl_depth,acc) abs ->
match abs with
| LVar _ -> (fun x -> App(f x,LVar (l_level-l_depth))),l_depth+1,nl_depth,abs::acc
| Var _ -> (fun x -> App(f x,Var (nl_level-nl_depth))),l_depth,nl_depth+1,abs::acc
| _ -> failwith "eta_expand should not be called here")
((fun x -> x),1,1,[])
abstraction in
List.fold_left
(fun t abs ->
match abs with
| Var _ -> Abs("x",t)
| LVar _ -> LAbs("x",t)
| _ -> failwith "eta_expand should not be called here")
(f (lift (l_length-1) (nl_length-1) t))
abs' in
let rec eta_expand_rec ty l_level nl_level acc =
match ty with
| Atom _ -> wrap t acc l_level nl_level
| DAtom _ -> failwith "type definitions should have been unfolded"
| LFun (a,b) -> eta_expand_rec b (l_level+1) nl_level ((LVar 0)::acc)
| Fun (a,b) -> eta_expand_rec b l_level (nl_level+1) ((Var 0)::acc)
| _ -> failwith "Not yet implemented" in
let t' = eta_expand_rec ty 0 0 [] in
t'
(* We assume here that [term] is well typed and in beta-normal form
and that types and terms definitions have been unfolded*)
let eta_long_form term stype f_get_type_of_constant =
let rec eta_long_form_rec term stype linear_typing_env non_linear_typing_env =
match term,stype with
| LVar i , Some ty when ty = List.nth linear_typing_env i -> eta_expand term ty,ty
| LVar i , Some _ -> failwith "Term should be well typed"
| LVar i , None ->
let ty = List.nth linear_typing_env i in
eta_expand term ty,ty
| Var i , Some ty when ty = List.nth non_linear_typing_env i -> eta_expand term ty,ty
| Var i , Some _ -> failwith "Term should be well typed"
| Var i , None ->
let ty = List.nth non_linear_typing_env i in
eta_expand term ty,ty
| Const i , Some ty -> eta_expand term ty,ty
| Const i , None ->
let ty = f_get_type_of_constant i in
eta_expand term ty,ty
| DConst _ ,_ -> failwith "All the definitions should have been unfolded"
| Abs (x,t),Some (Fun(a,b) as ty) ->
let t',_ = eta_long_form_rec t (Some b) linear_typing_env (a::non_linear_typing_env) in
Abs(x,t'),ty
| Abs (x,t), None -> failwith "Should be in beta normal form"
| LAbs (x,t),Some (LFun(a,b) as ty) ->
let t',_ = eta_long_form_rec t (Some b) (a::linear_typing_env) non_linear_typing_env in
LAbs(x,t'),ty
| LAbs (x,t), None -> failwith "Should be in beta normal form"
| App (u,v) , None ->
let u',u_type = eta_long_form_rec u None linear_typing_env non_linear_typing_env in
(match u_type with
| (Fun (a,b)|LFun(a,b)) ->
let v',v_type =eta_long_form_rec v (Some a) linear_typing_env non_linear_typing_env in
eta_expand (normalize (App (u',v'))) b, b
| _ -> failwith "Should be well typed")
| App (u,v) , Some ty ->
let u',u_type = eta_long_form_rec u None linear_typing_env non_linear_typing_env in
(match u_type with
| (Fun (a,b)|LFun(a,b)) when ty=b ->
let v',v_type =eta_long_form_rec v (Some a) linear_typing_env non_linear_typing_env in
eta_expand (normalize (App (u',v'))) b, b
| _ -> failwith "Should be well typed")
| _ -> raise Not_yet_implemented in
let t',_ = eta_long_form_rec term (Some stype) [] [] in
normalize t'
end end
...@@ -70,5 +70,14 @@ sig ...@@ -70,5 +70,14 @@ sig
val term_to_string : term -> (int -> Abstract_syntax.syntactic_behavior * string) -> string val term_to_string : term -> (int -> Abstract_syntax.syntactic_behavior * string) -> string
val raw_to_string : term -> string val raw_to_string : term -> string
val normalize : ?id_to_term:(int -> term) -> term -> term val normalize : ?id_to_term:(int -> term) -> term -> term
(** [eta_long_form t ty type_of_cst] returns the eta-long form of
[t] with respect of type [ty]. [t] is supposed to be in
beta-normal form and all the definitions of [t] and [ty] should
have been unfolded. [type_of_cst i] is a function that returns
the type (with unfolded definitions) of the constant whose id is
[i]. [i] is supposed to be an actual id of a constant.*)
val eta_long_form : term -> stype -> (int -> stype) -> term
end end
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