Commit c0bd5a28 authored by Adrien KOUTSOS's avatar Adrien KOUTSOS

type checking and pretty printing is broken in this version

parent 8a9bd931
Pipeline #1657 failed with stage
in 1 minute and 15 seconds
......@@ -90,8 +90,8 @@ let hint_same_shape h1 h2 = match h1, h2 with
(* Pretty Printing *)
(*******************)
let print_axiom_hint : type a. Format.formatter -> a axiom_hint -> unit =
fun ppf hint -> match hint with
let print_axiom_hint : type a. env -> Format.formatter -> a axiom_hint -> unit =
fun env ppf hint -> match hint with
| No_cca_hint -> pf ppf "No hint"
| Guard_problem (enc_pairs,l_superfl,r_superfl) ->
......@@ -99,14 +99,14 @@ let print_axiom_hint : type a. Format.formatter -> a axiom_hint -> unit =
if s_list <> [] then
pf ppf "@;Superfluous on the %s:@[<v 1>%a@]"
(side_to_string side)
(list print_term) s_list
(list (print_term env)) s_list
else () in
pf ppf "@[<v 0>Missing guards:@;@[<hov>%a@]%a%a@]"
(list (fun ppf (a,b) ->
pf ppf "@[<hov>(@[%a@],@,@[%a@])@]"
print_term a
print_term b)) enc_pairs
(print_term env) a
(print_term env) b)) enc_pairs
(print_superfl Left) l_superfl
(print_superfl Right) r_superfl
......@@ -114,8 +114,8 @@ let print_axiom_hint : type a. Format.formatter -> a axiom_hint -> unit =
pf ppf "@[<v 1>Encryption randomness appearing twice on the %s:\
@;@[%a@]@;@[%a@]@]"
(side_to_string side)
print_term s
print_term t
(print_term env) s
(print_term env) t
| Bad_randomness (n,side) ->
pf ppf "Encryption randomness %s leaking on the %s"
......@@ -129,7 +129,7 @@ let print_axiom_hint : type a. Format.formatter -> a axiom_hint -> unit =
pf ppf "@[<v 1>Decryption appearing where it should not on the %s:\
@;@[%a@]@]"
(side_to_string side)
print_term t
(print_term env) t
| Bad_secret_key (n,side) ->
pf ppf "Secret key %s appearing outside a decryption position on the %s"
......@@ -146,8 +146,8 @@ let print_axiom_success : type a. Format.formatter -> a axiom_success -> unit =
| Decryption -> pf ppf "Dec"
let print_res_hint : type a. Format.formatter -> axiom_result -> unit =
fun ppf res ->
let print_res_hint : type a. env -> Format.formatter -> axiom_result -> unit =
fun env ppf res ->
let open Fmt in
let ident ppf s = pf ppf "%s" s in
......@@ -155,4 +155,4 @@ let print_res_hint : type a. Format.formatter -> axiom_result -> unit =
| Unset -> assert false
| Success ax_suc -> pf ppf "Success %a" print_axiom_success ax_suc
| Failure _ -> ident ppf "Failure"
| Failure_hint hint -> print_axiom_hint ppf hint
| Failure_hint hint -> print_axiom_hint env ppf hint
......@@ -47,7 +47,7 @@ exception Case_fail of cca axiom_hint
(*****************)
(* Prints the alpha-renaming constraints in stderr. *)
let print_alpha_constraints ppf alpha =
let print_alpha_constraints env ppf alpha =
let open Fmt in
let ident = fun ppf s -> pf ppf "%s" s in
......@@ -58,8 +58,8 @@ let print_alpha_constraints ppf alpha =
~sep:(fun ppf () -> pf ppf "@ ")
(fun ppf (l,r) ->
pf ppf "(%a, %a) "
print_term (t_name l Msg)
print_term (t_name r Msg)))
(print_term env) (t_name l Msg)
(print_term env) (t_name r Msg)))
alpha.msg_constraints
(styled `Bold ident) "Bool constraints : "
......@@ -68,11 +68,11 @@ let print_alpha_constraints ppf alpha =
~sep:(fun ppf () -> pf ppf "@ ")
(fun ppf (l,r) ->
pf ppf "(%a, %a) "
print_term (t_name l Msg)
print_term (t_name r Msg)))
(print_term env) (t_name l Msg)
(print_term env) (t_name r Msg)))
alpha.bool_constraints;;
let print_cca_constraints_aux long ppf constraints =
let print_cca_constraints_aux env long ppf constraints =
let open Fmt in
let ident = fun ppf s -> pf ppf "%s" s in
......@@ -81,11 +81,13 @@ let print_cca_constraints_aux long ppf constraints =
pf ppf "@;%a@;@[<v>%a@]@;%a@;@[<v>%a@]"
(styled `Bold ident) "Encryptions :"
(list (pair print_term print_term)) constraints.encryptions
(list (pair (print_term env) (print_term env)))
constraints.encryptions
(styled `Bold ident) "Decryptions :"
(list (pair print_term print_term)) constraints.decryptions
(list (pair (print_term env) (print_term env)))
constraints.decryptions
else
() in
......@@ -97,8 +99,8 @@ let print_cca_constraints_aux long ppf constraints =
~sep:(fun ppf () -> pf ppf "@ ")
(fun ppf (l,r) ->
pf ppf "(%a, %a)"
print_term (t_name l Msg)
print_term (t_name r Msg)))
(print_term env) (t_name l Msg)
(print_term env) (t_name r Msg)))
constraints.key_pairs
(styled `Bold ident) "Bool Encryption rands :"
......@@ -107,21 +109,21 @@ let print_cca_constraints_aux long ppf constraints =
~sep:(fun ppf () -> pf ppf "@ ")
(fun ppf (l,r) ->
pf ppf "(%a, %a) "
print_term (t_name l Msg)
print_term (t_name r Msg)))
(print_term env) (t_name l Msg)
(print_term env) (t_name r Msg)))
constraints.encryption_rands
print_alpha_constraints constraints.alpha
(print_alpha_constraints env) constraints.alpha
print_additional_terms ();;
(* Prints the cca2 constraints in stderr. *)
let print_cca_constraints ppf constraints =
print_cca_constraints_aux false ppf constraints
let print_cca_constraints env ppf constraints =
print_cca_constraints_aux env false ppf constraints
(* Prints the detailed cca2 constraints in stderr. *)
let print_cca_constraints_long ppf constraints =
print_cca_constraints_aux true ppf constraints
let print_cca_constraints_long env ppf constraints =
print_cca_constraints_aux env true ppf constraints
(****************************)
(* Alpha Renaming Functions *)
......@@ -172,7 +174,7 @@ let name_alpha_equal : type a.
if they are not alpha-equal, and new_constraints if they are alpha-equal
under new_constraints (which extend alpha_const). *)
let rec alpha_rename :
type a. environment -> alpha_const -> a term -> a term -> alpha_const =
type a. env -> alpha_const -> a term -> a term -> alpha_const =
fun env alpha_const t t' ->
match t.content, t'.content with
| True,True -> alpha_const
......@@ -278,7 +280,7 @@ let is_dec : type a. a term -> (a term * name_string) option =
keys except in dec(_,sk(.)) or pk(.), and that occurrences of the encryption
randomness appear with the corresponding message and encryption key. *)
let rec dec_pk_fresh :
type a. environment -> side -> cca_constraints -> a term -> unit =
type a. env -> side -> cca_constraints -> a term -> unit =
fun env side cca_constraints t -> match t.content with
| True -> ()
| False -> ()
......@@ -336,7 +338,7 @@ let rec dec_pk_fresh :
| _ -> false)
cca_constraints.encryptions in
if not (syntactic_equal env t encryption) then
if not (t_equal t encryption) then
raise (Case_fail (Bad_randomness_twice
( (t,encryption),
side )));
......@@ -367,7 +369,7 @@ let rec dec_pk_fresh :
(* enc_oracle_call_case env cca_constraints t t' : Check whether t \sim t'
is a valid encryption oracle call. Raise Case_fail (hint) if this fails. *)
let enc_oracle_call_case : type a. environment -> cca_constraints
let enc_oracle_call_case : type a. env -> cca_constraints
-> a term -> a term -> cca_constraints =
fun env cca_constraints t t' ->
match get_sort t, is_enc t, is_enc t' with
......@@ -400,7 +402,7 @@ let enc_oracle_call_case : type a. environment -> cca_constraints
constant term in environment env, under constraints cca_constraints. For
this, we need to check that there are no decryption using the cca keys, and
no encryptions. *)
let rec constant_term : type a. environment -> cca_constraints
let rec constant_term : type a. env -> cca_constraints
-> side -> a term -> unit =
fun env cca_constraints side d ->
match d.content with
......@@ -493,7 +495,7 @@ let symmetrical_part_case env cca_constraints t t' =
(* subterm_encryptions enc t n: Return the list of encryptions under key sk(n)
appearing in the term t, in the environment env. *)
let subterm_encryptions :
type a. environment -> a term -> name_string -> msg term list =
type a. env -> a term -> name_string -> msg term list =
fun env t n->
let rec aux : type a. msg term list -> a term -> msg term list =
......@@ -523,7 +525,7 @@ let rec check_guards_shape env t m = match t.content with
| If (b, _, t') ->
begin match b.content with
| EQ(u,v) ->
if (syntactic_equal env u m) || (syntactic_equal env v m) then
if (t_equal u m) || (t_equal v m) then
check_guards_shape env t' m
else
false
......@@ -540,9 +542,9 @@ let collect_guard_encryptions env t m =
| If (b, _, t') ->
begin match b.content with
| EQ(u,v) ->
if syntactic_equal env u m then
if t_equal u m then
v :: collect_aux t'
else if syntactic_equal env v m then
else if t_equal v m then
u :: collect_aux t'
else
raise Bad_shape
......@@ -559,7 +561,7 @@ let check_then_terms env t = match t.content with
let rec check_then_branch m = match m.content with
| If(a,x,y) ->
(syntactic_equal env x u) && (check_then_branch y)
(t_equal x u) && (check_then_branch y)
| Fun ("dec",_) ->
is_dec m <> None
......@@ -635,7 +637,7 @@ let get_missing_superfl_guards env cca_const side t =
let subterm_enc_calls =
List.filter
(fun x -> List.exists (syntactic_equal env x) side_encs)
(fun x -> List.exists (t_equal x) side_encs)
(subterm_encryptions env m sk)
(* We compute the list of encryptions appearing in guards. *)
......@@ -656,15 +658,15 @@ let get_missing_superfl_guards env cca_const side t =
let is_a_dec_call env constraints (t : msg term) (t' : msg term) =
List.exists (fun (x,y) ->
(syntactic_equal env x t)
&& (syntactic_equal env y t'))
(t_equal x t)
&& (t_equal y t'))
constraints.decryptions
let is_an_enc_call env constraints (t : msg term) (t' : msg term) =
List.exists (fun (x,y) ->
(syntactic_equal env x t)
&& (syntactic_equal env y t'))
(t_equal x t)
&& (t_equal y t'))
constraints.encryptions
exception Contexts_do_not_exist
......@@ -826,7 +828,7 @@ and shape_check env cca_constraints t t' =
(* dec_oracle_call_case env cca_constraints t t' : Check whether t \sim t'
is a valid decryption oracle call. *)
and dec_oracle_call_case
: type a. environment -> cca_constraints
: type a. env -> cca_constraints
-> a term -> a term -> cca_constraints =
fun env cca_constraints t t' -> match get_sort t, get_sort t' with
| Msg,Msg ->
......@@ -853,18 +855,18 @@ and dec_oracle_call_case
let enc_pairs_with_dup =
(List.map
(fun x -> List.find
(fun (a,b) -> syntactic_equal env a x)
(fun (a,b) -> t_equal a x)
cca_constraints''.encryptions)
left_missing)
@ (List.map
(fun x -> List.find
(fun (a,b) -> syntactic_equal env b x)
(fun (a,b) -> t_equal b x)
cca_constraints''.encryptions)
right_missing) in
let term_pair_compare (u,v) (s,t) =
match syntactic_equal env u s, syntactic_equal env v t with
match t_equal u s, t_equal v t with
| true,true -> 0
| _ -> Pervasives.compare (u,v) (s,t) in
......@@ -923,7 +925,7 @@ let equal_up_to_oracle_calls_strict env cca_constraints t t' =
Remark: ((c,c'),constraints) should be the result of a call to build_context
on terms s and s'. *)
let rec dec_pairs_from_terms
:type a. environment -> cca_constraints -> a term -> a term -> a term
:type a. env -> cca_constraints -> a term -> a term -> a term
-> a term -> (msg term * msg term) list -> (msg term * msg term) list
= fun env constraints c c' s s' acc ->
match c.content, c'.content, s.content, s'.content with
......@@ -976,19 +978,19 @@ let rec dec_pairs_from_terms
| _ ->
Fmt.pf Fmt.stderr "@[<v 1>@[%a@]@;@[%a@]@;@[%a@]@;@[%a@]@;@]%!"
print_term c print_term c'
print_term s print_term s';
(print_term env) c (print_term env) c'
(print_term env) s (print_term env) s';
failwith "dec_pairs_from_terms: bad call, contexts do not match"
and dec_pairs_from_terms_fun
:type a. environment -> cca_constraints -> a term -> a term -> a term
:type a. env -> cca_constraints -> a term -> a term -> a term
-> a term -> (msg term * msg term) list -> (msg term * msg term) list =
fun env constraints c c' s s' acc ->
let print_error () =
Fmt.pf Fmt.stderr "@[<v 1>@[%a@]@;@[%a@]@;@[%a@]@;@[%a@]@;@]%!"
print_term c print_term c'
print_term s print_term s';
(print_term env) c (print_term env) c'
(print_term env) s (print_term env) s';
failwith "dec_pairs_from_terms_fun: bad call, contexts do not match" in
match c.content, c'.content, s.content, s'.content with
......@@ -1037,8 +1039,8 @@ let extend_cca_dec_case env constraints t t' =
let synt_mem (x,y) l =
List.exists (fun (u,v) ->
(syntactic_equal env x u)
&& (syntactic_equal env y v)) l in
(t_equal x u)
&& (t_equal y v)) l in
(* We get the new enc. and dec. oracle calls *)
let diff_encs = List.filter
......@@ -1066,7 +1068,7 @@ let extend_cca_dec_case env constraints t t' =
(**************)
(* get_keys acc env t : Return the set of keys appearing in t @ acc. *)
let rec get_keys : type a. name_string list -> environment -> a term
let rec get_keys : type a. name_string list -> env -> a term
-> name_string list = fun acc env t ->
match t.content with
| False -> acc
......
......@@ -35,7 +35,7 @@ type cca_constraints =
(* Pretty Printing *)
(*******************)
val print_cca_constraints : Format.formatter -> cca_constraints -> unit
val print_cca_constraints : env -> Format.formatter -> cca_constraints -> unit
(*********************************)
......@@ -50,42 +50,42 @@ exception Alpha_conflict of
exception Shape_no_match
(* Raises Shape_no_match if the terms are not alpha-equal. *)
val alpha_rename : environment -> alpha_const -> 'a term -> 'a term
val alpha_rename : env -> alpha_const -> 'a term -> 'a term
-> alpha_const
(* subterm_encryptions enc t n: Return the list of encryptions under key sk(n)
appearing in the term t, in the environment env. *)
val subterm_encryptions :
environment -> 'a term -> name_string -> msg term list
env -> 'a term -> name_string -> msg term list
exception Case_fail of cca axiom_hint
(* Return the message and the key used in a decryption oracle call.
Return None if the shape of the term is wrong. *)
val get_m_dec_oracle : environment -> msg term
val get_m_dec_oracle : env -> msg term
-> (msg term * name_string) option
(* enc_oracle_call_case env cca_constraints t t' : Check whether t \sim t'
is a valid encryption oracle call. *)
val enc_oracle_call_case : environment -> cca_constraints
val enc_oracle_call_case : env -> cca_constraints
-> 'a term -> 'a term -> cca_constraints
exception Contexts_do_not_exist
(* equal_up_to_oracle_calls env cca_constraints t t' : Return true iff t and t'
are syntactically equal up-to encryption and decryption oracle calls. *)
val equal_up_to_oracle_calls : environment -> cca_constraints -> msg term
val equal_up_to_oracle_calls : env -> cca_constraints -> msg term
-> msg term -> bool
(* equal_up_to_oracle_calls_strict env cca_constraints t t' : Like the function
equal_up_to_oracle_calls, with the extra constraint that the context does not
contain secret key material. *)
val equal_up_to_oracle_calls_strict : environment -> cca_constraints -> msg term
val equal_up_to_oracle_calls_strict : env -> cca_constraints -> msg term
-> msg term -> bool
(* dec_oracle_call_case env cca_constraints t t' : Check whether t \sim t'
is a valid decryption oracle call. *)
val dec_oracle_call_case : environment -> cca_constraints
val dec_oracle_call_case : env -> cca_constraints
-> 'a term -> 'a term -> cca_constraints
......@@ -106,5 +106,5 @@ type extend_cca_result =
calls but should be guarded) when trying to show that t \sim t' is a valid
dec. oracle call. *)
val extend_cca_dec_case :
environment -> cca_constraints -> msg term -> msg term ->
env -> cca_constraints -> msg term -> msg term ->
extend_cca_result * cca_constraints
......@@ -15,7 +15,7 @@ type formula_element =
type formula =
{ formula_element_list : formula_element list;
env : environment }
env : env }
(*****************)
......@@ -187,12 +187,12 @@ let remove_duplicate formula =
List.exists (fun y ->
match x.term_pair,y.term_pair with
| B (a,a'), B (b,b') ->
(syntactic_equal formula.env a b)
&& (syntactic_equal formula.env a' b')
(t_equal a b)
&& (t_equal a' b')
| T (a,a'), T (b,b') ->
(syntactic_equal formula.env a b)
&& (syntactic_equal formula.env a' b')
(t_equal a b)
&& (t_equal a' b')
| _ -> false)
acc in
......@@ -327,7 +327,7 @@ let print_separator shell_mode =
(* Print the left or right formula, depending on the boolean lor_bool. *)
let rec print_lor_formula shell_mode lor_bool cpt f =
let rec print_lor_formula env shell_mode lor_bool cpt f =
let open Fmt in
let ident ppf s = pf ppf "%s" s in
......@@ -349,14 +349,14 @@ let rec print_lor_formula shell_mode lor_bool cpt f =
if not el.hidden_status then
pf stdout "%a@[%a@]@."
number_style (Printf.sprintf "%d:" cpt)
print_term (if lor_bool then b else b');
print_lor_formula shell_mode lor_bool (cpt + 1) tail;
(print_term env) (if lor_bool then b else b');
print_lor_formula env shell_mode lor_bool (cpt + 1) tail;
| T (t,t') ->
if not el.hidden_status then
pf stdout "%a@[%a@]@."
number_style (Printf.sprintf "%d:" cpt)
print_term (if lor_bool then t else t');
print_lor_formula shell_mode lor_bool (cpt + 1) tail
(print_term env) (if lor_bool then t else t');
print_lor_formula env shell_mode lor_bool (cpt + 1) tail
let hashtbl_to_list ht =
......@@ -378,12 +378,12 @@ let print_formula formula param =
Printf.printf "\n";
(* Print the left formula *)
print_lor_formula shell_mode true 0 formula.formula_element_list;
print_lor_formula formula.env shell_mode true 0 formula.formula_element_list;
print_separator shell_mode;
next_line shell_mode;
(* Print the right formula *)
print_lor_formula shell_mode false 0 formula.formula_element_list;
print_lor_formula formula.env shell_mode false 0 formula.formula_element_list;
(* Print the bindings *)
let print_bindings = bindings_to_print formula.env in
......
......@@ -12,7 +12,7 @@ type formula_element =
type formula =
{ formula_element_list : formula_element list;
env : environment }
env : env }
exception F_out_of_bound of int
exception F_bad_argument of int
......@@ -33,7 +33,7 @@ val update_unitary_result : formula_element -> axiom_result -> formula_element
(* new formula ~env:env l l': Create a new formula whose boolean elements are
the element of l and term elements are the elements of l'. A type checking
is perfomed before creating the formula *)
val new_formula : ?env:environment -> (boole term * boole term) list
val new_formula : ?env:env -> (boole term * boole term) list
-> (msg term * msg term) list -> formula
(* c_bind formula new_f: Return a new formula where the formula elements
......
......@@ -61,7 +61,7 @@ let unary_build proof r_and_index_list =
| Bad_rule (s,rule) ->
let err_fun = fun () ->
Fmt.pf Fmt.stderr "@[Bad rule:@;%a@;%s@]\n@?%!"
print_rule_long rule s in
(print_rule_long goal.env) rule s in
( goal,
err_fun :: l_fun_error,
......@@ -247,8 +247,8 @@ let apply_unitary_and_set_feedback :
(fun el res_el -> update_unitary_result el res_el)
goal.formula_element_list result_list in
let updated_goal = { formula_element_list = updated_element_list;
env = goal.env } in
let updated_goal =
{ goal with formula_element_list = updated_element_list } in
if print then
begin
......@@ -272,10 +272,10 @@ let apply_unitary_and_set_feedback :
(fun ppf res_el -> pf ppf "%a @[%a@]"
(number_style res_el)
(cpt:= !cpt + 1; Printf.sprintf "%d:" (!cpt))
print_res_hint
(print_res_hint goal.env)
res_el))
result_list
Cca.print_cca_constraints cca_constraints
(Cca.print_cca_constraints updated_goal.env) cca_constraints
end;
state.c_proof.goal <- updated_goal;
......@@ -347,8 +347,8 @@ let apply_ift_heuristic state constraints side t s =
let (included',strict') = is_included
(fun x y ->
if syntactic_equal env x y then 0
else Pervasives.compare x y)
if t_equal x y then 0
else t_compare x y)
s_encryptions t_encryptions in
(included && included', strict || strict'))
......@@ -933,7 +933,7 @@ let auto_guard state sk fk =
(* Return true if t is a decryption oracle call. *)
let not_in_g_dec decs t =
List.exists (syntactic_equal env t) decs in
List.exists (t_equal t) decs in
(* We compute all the decryptions appearing on the left and right that are
not subterm of a decryption oracle calls. *)
......@@ -953,12 +953,8 @@ let auto_guard state sk fk =
([],[]) goal.formula_element_list in
(* We remove duplicates *)
let my_compare t t' =
if syntactic_equal env t t' then 0 else Pervasives.compare t t' in
let l_decs = List.sort_uniq my_compare l_decs
and r_decs = List.sort_uniq my_compare r_decs in
let l_decs = List.sort_uniq t_compare l_decs
and r_decs = List.sort_uniq t_compare r_decs in
(* We compute the pairs of matching decryptions *)
let dec_pairs =
......@@ -993,7 +989,7 @@ let auto_guard state sk fk =
(list ~sep:(fun ppf () -> pf ppf "@;")
(fun ppf (a,b,r) -> pf ppf "@[<hv>%a @,%a@]@;%a@;"
print_term a print_term b print_res_hint r))
(print_term env) a (print_term env) b (print_res_hint env) r))
dec_pairs_with_res)
state in
......@@ -1020,7 +1016,7 @@ let auto_guard state sk fk =
pf stdout "@[<v>Guarded the following decryption pairs:@;%a%!@]"
(list ~sep:(fun ppf () -> pf ppf "@;")
(pair print_term print_term))
(pair (print_term new_goal.env) (print_term new_goal.env)))
(List.map (fun g_data ->
( g_data.left_guard.dec_term,
......
......@@ -18,19 +18,6 @@ let parse_problem input_channel =
try
let (decl_list,(p_left,p_right)) =
Term_parser.problem Term_lexer.token lexbuf in
let _ = debug (fun () ->
Printf.eprintf "Parsed process %d declarations:\n"
(List.length decl_list);
List.iter (fun process ->
print_process_decl Fmt.stderr process;
Fmt.pf Fmt.stderr "@.")
decl_list;
Printf.eprintf "Left process:\n";
print_concrete_process Fmt.stderr p_left;
Fmt.pf Fmt.stderr "@.";
Printf.eprintf "Right process:\n";
print_concrete_process Fmt.stderr p_right;
Fmt.pf Fmt.stderr "@.";) in
(decl_list,(p_left,p_right))
with
| Term_lexer.Lexer_Error i ->
......@@ -87,9 +74,25 @@ let main_interactive () =
failwith "YOu need to provide a .api file"
else
let input_channel = open_in !file_name in
let (declarations,(p_l,p_r)) = parse_problem input_channel in
add_declarations declarations;
let env = init_env () in
let _ = debug (fun () ->
let open Fmt in
pf stderr "Parsed process %d declarations:\n@.@[<v 0>%a@]\n"
(List.length declarations)
(list (fun ppf process ->
print_process_decl ppf process))
declarations;
pf stderr "Left process:@[%a@]\nRight process:@[%a@]\n@.%!"
(print_concrete_process env) p_l
(print_concrete_process env) p_r) in
List.map (fun (term_pair_list,env') ->
(new_formula ~env:env' [] term_pair_list))
(fold_protocol env p_l p_r) in
......@@ -135,7 +138,7 @@ let init_cca_constraints key_pairs =
encryptions = [];
decryptions = [] };;
let test_cca_case cca_fun_name cca_fun cca_constraints
let test_cca_case env cca_fun_name cca_fun cca_constraints
left_term right_term axiom_res =
let expect_success = match axiom_res with
| Success _ -> true
......@@ -146,11 +149,12 @@ let test_cca_case cca_fun_name cca_fun cca_constraints
Printf.eprintf "%s (should be Success)\n%!" s
else
Printf.eprintf "%s (should be Failure)\n%!" s) in
debug (fun () ->
Printf.eprintf "\nTesting %s call:\n" cca_fun_name;
Term.print_term_stderr left_term;
Term.print_term_stderr env left_term;
Printf.eprintf "\n ~ \n";
Term.print_term_stderr right_term;);
Term.print_term_stderr env right_term;);
match cca_fun env cca_constraints left_term right_term with
| exception (Case_fail hint) ->
......@@ -165,10 +169,10 @@ let test_cca_case cca_fun_name cca_fun cca_constraints
| const -> print_result "\nCCA2 Success"; assert (expect_success);;
let test_dec_oracle_call =
fun x -> test_cca_case "decryption oracle" Cca.dec_oracle_call_case x
fun x -> test_cca_case env "decryption oracle" Cca.dec_oracle_call_case x
let test_enc_oracle_call =
fun x -> test_cca_case "encryption oracle" Cca.enc_oracle_call_case x
fun x -> test_cca_case env "encryption oracle" Cca.enc_oracle_call_case x
let unit_test_decryption_oracle = fun () ->
(* 0: Simple decryptions (Success). *)
......
......@@ -100,11 +100,11 @@ let rec inject : abstract process -> concrete process = function
(* Process Pretty Printers *)
(***************************)
let print_term_par ppf t =
let print_term_par env ppf t =
let open Fmt in
match t.content with
| (Name (s,Msg)) -> print_term ppf t
| _ -> pf ppf "(%a)" print_term t
| (Name (s,Msg)) -> print_term env ppf t
| _ -> pf ppf "(%a)" (print_term env) t
let print_concrete ppf pn =
let open Fmt in
......@@ -132,7 +132,7 @@ let print_abstract_decl ppf rec_name =
(styled `Bold (styled `Blue ident)) ppf (rec_name ^ "{i}")
let rec print_process proc_call_printer ppf process =
let rec print_process env proc_call_printer ppf process =
let open Fmt in
let ident ppf s = pf ppf "%s" s in
let kw style = (styled style ident) in
......@@ -143,65 +143,66 @@ let rec print_process proc_call_printer ppf process =
| Apply (s,l) ->
pf ppf "@[<hov>%a@ %a@]"
proc_call_printer s
(Fmt.list ~sep:(fun ppf () -> pf ppf "@ ") print_term_par) l
(Fmt.list ~sep:(fun ppf () -> pf ppf "@ ") (print_term_par env)) l
| New (s,p) ->
pf ppf "@[<hov>%a %a.@,@[%a@]@]"
(kw `Red) "new"
(kw `Magenta) s
(print_process proc_call_printer) p
(print_process env proc_call_printer) p
| In (Public c, s, p) ->
pf ppf "@[<hov>%a(%a,@,%a).@,%a@]"
(kw `Bold) "in"
(kw `None) c
(styled `Magenta (styled `Bold ident)) s
(print_process proc_call_printer) p
(print_process env proc_call_printer) p
| Out (Public c, t, p) ->
pf ppf "@[<hov>%a(%a,@,%a).@,%a@]"
(kw `Bold) "out"
(kw `None) c
print_term t
(print_process proc_call_printer) p
(print_term env) t
(print_process env proc_call_printer) p
| Parallel (p1,p2) ->
pf ppf "@[<hv>@[(%a)@]@ | @[(%a)@]@]"
(print_process proc_call_printer) p1
(print_process proc_call_printer) p2
(print_process env proc_call_printer) p1
(print_process env proc_call_printer) p2
| IfThenElse (b,p1,p2) ->
if p2 = Nil then
pf ppf "@[<hov>%a %a %a@;<1 2>%a@]"
(styled `Red (styled `Underline ident)) "if"
print_term b
(print_term env) b
(styled `Red (styled `Underline ident)) "then"
(print_process proc_call_printer) p1
(print_process env proc_call_printer) p1
else