156 lines
5.5 KiB
Plaintext
156 lines
5.5 KiB
Plaintext
(*
|
|
* Copyright 2014, NICTA
|
|
*
|
|
* This software may be distributed and modified according to the terms of
|
|
* the BSD 2-Clause license. Note that NO WARRANTY is provided.
|
|
* See "LICENSE_BSD2.txt" for details.
|
|
*
|
|
* @TAG(NICTA_BSD)
|
|
*)
|
|
|
|
theory Crunch_Instances_NonDet
|
|
imports
|
|
Crunch
|
|
"Monad_WP/wp/WPEx"
|
|
"Monad_WP/NonDetMonadVCG"
|
|
begin
|
|
|
|
lemmas [crunch_param_rules] = Let_def return_bind returnOk_bindE
|
|
K_bind_def split_def bind_assoc bindE_assoc
|
|
trans[OF liftE_bindE return_bind]
|
|
|
|
ML \<open>
|
|
fun get_nondet_monad_state_type
|
|
(Type ("Product_Type.prod",
|
|
[Type ("Set.set", [Type ("Product_Type.prod", [_,v])]),
|
|
Type ("HOL.bool",[])]))
|
|
= SOME v
|
|
| get_nondet_monad_state_type _ = NONE
|
|
|
|
structure CrunchValidInstance : CrunchInstance =
|
|
struct
|
|
val name = "valid";
|
|
type extra = term;
|
|
val eq_extra = ae_conv;
|
|
fun parse_extra ctxt extra
|
|
= case extra of
|
|
"" => error "A post condition is required"
|
|
| extra => let val pre = Syntax.parse_term ctxt extra
|
|
in (pre, Abs ("_", dummyT, pre)) end;
|
|
val has_preconds = true;
|
|
fun mk_term pre body post =
|
|
(Syntax.parse_term @{context} "valid") $ pre $ body $ post;
|
|
fun dest_term ((Const (@{const_name "valid"}, _)) $ pre $ body $ post)
|
|
= SOME (pre, body, post)
|
|
| dest_term _ = NONE;
|
|
fun put_precond pre ((v as Const (@{const_name "valid"}, _)) $ _ $ body $ post)
|
|
= v $ pre $ body $ post
|
|
| put_precond _ _ = error "put_precond: not a hoare triple";
|
|
val pre_thms = @{thms "hoare_pre"};
|
|
val wpc_tactic = wp_cases_tactic_weak;
|
|
val wps_tactic = wps_tac;
|
|
val magic = Syntax.parse_term @{context}
|
|
"\<lambda>mapp_lambda_ignore. valid P_free_ignore mapp_lambda_ignore Q_free_ignore";
|
|
val get_monad_state_type = get_nondet_monad_state_type;
|
|
end;
|
|
|
|
structure CrunchValid : CRUNCH = Crunch(CrunchValidInstance);
|
|
|
|
structure CrunchNoFailInstance : CrunchInstance =
|
|
struct
|
|
val name = "no_fail";
|
|
type extra = unit;
|
|
val eq_extra = op =;
|
|
fun parse_extra ctxt extra
|
|
= case extra of
|
|
"" => (Syntax.parse_term ctxt "%_. True", ())
|
|
| _ => (Syntax.parse_term ctxt extra, ());
|
|
val has_preconds = true;
|
|
fun mk_term pre body _ =
|
|
(Syntax.parse_term @{context} "no_fail") $ pre $ body;
|
|
fun dest_term ((Const (@{const_name "no_fail"}, _)) $ pre $ body)
|
|
= SOME (pre, body, ())
|
|
| dest_term _ = NONE;
|
|
fun put_precond pre ((v as Const (@{const_name "no_fail"}, _)) $ _ $ body)
|
|
= v $ pre $ body
|
|
| put_precond _ _ = error "put_precond: not a no_fail term";
|
|
val pre_thms = @{thms "no_fail_pre"};
|
|
val wpc_tactic = wp_cases_tactic_weak;
|
|
fun wps_tactic _ _ _ = no_tac;
|
|
val magic = Syntax.parse_term @{context}
|
|
"\<lambda>mapp_lambda_ignore. no_fail P_free_ignore mapp_lambda_ignore";
|
|
val get_monad_state_type = get_nondet_monad_state_type;
|
|
end;
|
|
|
|
structure CrunchNoFail : CRUNCH = Crunch(CrunchNoFailInstance);
|
|
|
|
structure CrunchEmptyFailInstance : CrunchInstance =
|
|
struct
|
|
val name = "empty_fail";
|
|
type extra = unit;
|
|
val eq_extra = op =;
|
|
fun parse_extra ctxt extra
|
|
= case extra of
|
|
"" => (Syntax.parse_term ctxt "%_. True", ())
|
|
| _ => error "empty_fail does not need a precondition";
|
|
val has_preconds = false;
|
|
fun mk_term _ body _ =
|
|
(Syntax.parse_term @{context} "empty_fail") $ body;
|
|
fun dest_term (Const (@{const_name empty_fail}, _) $ b)
|
|
= SOME (Term.dummy, b, ())
|
|
| dest_term _ = NONE;
|
|
fun put_precond _ _ = error "crunch empty_fail should not be calling put_precond";
|
|
val pre_thms = [];
|
|
val wpc_tactic = wp_cases_tactic_weak;
|
|
fun wps_tactic _ _ _ = no_tac;
|
|
val magic = Syntax.parse_term @{context}
|
|
"\<lambda>mapp_lambda_ignore. empty_fail mapp_lambda_ignore";
|
|
val get_monad_state_type = get_nondet_monad_state_type;
|
|
end;
|
|
|
|
structure CrunchEmptyFail : CRUNCH = Crunch(CrunchEmptyFailInstance);
|
|
|
|
structure CrunchValidEInstance : CrunchInstance =
|
|
struct
|
|
val name = "valid_E";
|
|
type extra = term * term;
|
|
fun eq_extra ((a, b), (c, d)) = (ae_conv (a, c) andalso ae_conv (b, d));
|
|
fun parse_extra ctxt extra
|
|
= case extra of
|
|
"" => error "A post condition is required"
|
|
| extra => let val pre = Syntax.parse_term ctxt extra
|
|
in (pre, (Abs ("_", dummyT, pre), Abs ("_", dummyT, pre))) end;
|
|
val has_preconds = true;
|
|
fun mk_term pre body extra =
|
|
(Syntax.parse_term @{context} "validE") $ pre $ body $ fst extra $ snd extra;
|
|
fun dest_term (Const (@{const_name "validE"}, _) $ pre $ body $ p1 $ p2)
|
|
= SOME (pre, body, (p1, p2))
|
|
| dest_term _ = NONE;
|
|
fun put_precond pre ((v as Const (@{const_name "validE"}, _)) $ _ $ body $ post $ post')
|
|
= v $ pre $ body $ post $ post'
|
|
| put_precond _ _ = error "put_precond: not a validE term";
|
|
val pre_thms = @{thms "hoare_pre"};
|
|
val wpc_tactic = wp_cases_tactic_weak;
|
|
val wps_tactic = wps_tac;
|
|
val magic = Syntax.parse_term @{context}
|
|
"\<lambda>mapp_lambda_ignore. validE P_free_ignore mapp_lambda_ignore Q_free_ignore Q_free_ignore";
|
|
val get_monad_state_type = get_nondet_monad_state_type;
|
|
end;
|
|
|
|
structure CrunchValidE : CRUNCH = Crunch(CrunchValidEInstance);
|
|
\<close>
|
|
|
|
setup \<open>
|
|
add_crunch_instance "" (CrunchValid.crunch_x, CrunchValid.crunch_ignore_add_del)
|
|
\<close>
|
|
setup \<open>
|
|
add_crunch_instance "valid" (CrunchValid.crunch_x, CrunchValid.crunch_ignore_add_del)
|
|
\<close>
|
|
setup \<open>
|
|
add_crunch_instance "no_fail" (CrunchNoFail.crunch_x, CrunchNoFail.crunch_ignore_add_del)
|
|
\<close>
|
|
setup \<open>
|
|
add_crunch_instance "empty_fail" (CrunchEmptyFail.crunch_x, CrunchEmptyFail.crunch_ignore_add_del)
|
|
\<close>
|
|
|
|
end |