486 lines
14 KiB
Plaintext
486 lines
14 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)
|
|
*)
|
|
|
|
(*
|
|
* Strengthen functions into simpler monads.
|
|
*
|
|
* Each block of lifting lemmas converts functions in the "L2" monadic
|
|
* framework (an exception framework) into its own framework.
|
|
*)
|
|
|
|
theory TypeStrengthen
|
|
imports
|
|
L2Defs
|
|
"Lib.OptionMonadND"
|
|
ExecConcrete
|
|
begin
|
|
|
|
(* Set up the database and ts_rule attribute. *)
|
|
ML_file "monad_types.ML"
|
|
setup \<open>
|
|
Attrib.setup (Binding.name "ts_rule") Monad_Types.ts_attrib
|
|
"AutoCorres type strengthening rule"
|
|
\<close>
|
|
|
|
(*
|
|
* Helpers for exception polymorphism lemmas (L2_call_Foo_polymorphic).
|
|
*
|
|
* They are used to rewrite a term like
|
|
*
|
|
* L2_call x = Foo y
|
|
*
|
|
* into an identical term with a different exception type.
|
|
*)
|
|
|
|
definition
|
|
unliftE
|
|
where
|
|
"unliftE (x :: ('a, 'u + 'b) nondet_monad) \<equiv> x <catch> (\<lambda>_. fail)"
|
|
|
|
lemma L2_call_liftE_unliftE:
|
|
"L2_call x = liftE (unliftE (L2_call x))"
|
|
apply (clarsimp simp: L2_call_def unliftE_def)
|
|
apply (rule ext)
|
|
apply (clarsimp simp: handleE'_def catch_def liftE_def bind_assoc)
|
|
apply (clarsimp cong: bind_apply_cong)
|
|
apply (clarsimp simp: bind_def split_def return_def split: sum.splits)
|
|
apply (force simp: return_def fail_def split: sum.splits)+
|
|
done
|
|
|
|
lemma unliftE_liftE [simp]:
|
|
"unliftE (liftE x) = x"
|
|
apply (clarsimp simp: unliftE_def catch_liftE)
|
|
done
|
|
|
|
|
|
|
|
(*
|
|
* Lifting into pure functional Isabelle.
|
|
*)
|
|
|
|
definition "TS_return x \<equiv> liftE (return x)"
|
|
|
|
lemma L2_call_TS_return: "L2_call (TS_return a) = L2_gets (\<lambda>_. a) [''ret'']"
|
|
apply (monad_eq simp: L2_call_def L2_gets_def TS_return_def)
|
|
done
|
|
|
|
lemma TS_return_L2_gets:
|
|
"L2_gets (\<lambda>_. P) n = TS_return P"
|
|
by (monad_eq simp: L2_defs TS_return_def)
|
|
|
|
lemma L2_call_L2_gets_polymorphic:
|
|
"(L2_call x :: ('s, 'a, 'e1) L2_monad) = L2_gets y n
|
|
\<Longrightarrow> (L2_call x :: ('s, 'a, 'e2) L2_monad) = L2_gets y n"
|
|
apply (monad_eq simp: L2_defs L2_call_def Ball_def split: sum.splits)
|
|
apply blast
|
|
done
|
|
|
|
setup \<open>
|
|
Monad_Types.new_monad_type
|
|
"pure"
|
|
"Pure function"
|
|
(Monad_Types.check_lifting_head [@{term "TS_return"}])
|
|
100
|
|
@{thms L2_call_TS_return TS_return_L2_gets}
|
|
@{term "(%a. L2_gets (%_. a) [''ret'']) :: 'a => ('s, 'a, unit) L2_monad"}
|
|
@{thm L2_call_L2_gets_polymorphic}
|
|
#2
|
|
(fn _ => error "monad_mono not applicable for pure monad")
|
|
|> Context.theory_map
|
|
\<close>
|
|
|
|
lemma TS_return_L2_seq:
|
|
"L2_seq (TS_return A) (\<lambda>a. TS_return (B a))
|
|
= TS_return (let a = A in B a)"
|
|
by (monad_eq simp: L2_defs TS_return_def)
|
|
|
|
lemma TS_return_L2_condition:
|
|
"L2_condition (\<lambda>_. c) (TS_return A) (TS_return B) = TS_return (if c then A else B)"
|
|
by (monad_eq simp: L2_defs TS_return_def)
|
|
|
|
lemmas [ts_rule pure] =
|
|
TS_return_L2_gets
|
|
TS_return_L2_seq
|
|
TS_return_L2_condition
|
|
split_distrib[where T = TS_return]
|
|
|
|
lemma L2_seq_TS_return:
|
|
"TS_return (let a = A in B a) = L2_seq (L2_gets (\<lambda>_. A) []) (\<lambda>a. L2_gets (\<lambda>_. B a) [])"
|
|
by (monad_eq simp: L2_defs TS_return_def)
|
|
|
|
lemma L2_condition_TS_return:
|
|
"TS_return (if c then A else B) = L2_condition (\<lambda>_. c) (L2_gets (\<lambda>_. A) []) (L2_gets (\<lambda>_. B) [])"
|
|
by (monad_eq simp: L2_defs TS_return_def)
|
|
|
|
lemmas [ts_rule pure unlift] =
|
|
TS_return_L2_gets [where n = "[]", symmetric]
|
|
TS_return_L2_seq [symmetric]
|
|
TS_return_L2_condition [symmetric]
|
|
L2_seq_TS_return
|
|
L2_condition_TS_return
|
|
split_distrib[where T = TS_return, symmetric]
|
|
|
|
|
|
|
|
(*
|
|
* Lifting into pure functional Isabelle with state.
|
|
*)
|
|
|
|
definition "TS_gets x \<equiv> liftE (gets x)"
|
|
|
|
lemma TS_gets_L2_gets:
|
|
"L2_gets X n = TS_gets X"
|
|
by (monad_eq simp: L2_defs TS_gets_def)
|
|
|
|
lemma L2_call_TS_gets: "L2_call (TS_gets a) = L2_gets a [''TS_internal_retval'']"
|
|
apply (monad_eq simp: L2_call_def L2_gets_def TS_gets_def)
|
|
done
|
|
|
|
setup \<open>
|
|
Monad_Types.new_monad_type
|
|
"gets"
|
|
"Read-only function"
|
|
(Monad_Types.check_lifting_head [@{term "TS_gets"}])
|
|
80
|
|
@{thms L2_call_TS_gets TS_gets_L2_gets}
|
|
@{term "(%x. L2_gets x [''ret'']) :: ('s => 'a) => ('s, 'a, unit) L2_monad"}
|
|
@{thm L2_call_L2_gets_polymorphic}
|
|
(fn (state, ret, ex) => state --> ret)
|
|
(fn _ => error "monad_mono not applicable for gets monad")
|
|
|> Context.theory_map
|
|
\<close>
|
|
|
|
lemma TS_gets_L2_seq:
|
|
"L2_seq (TS_gets A) (\<lambda>x. TS_gets (B x)) = (TS_gets (\<lambda>s. let x = A s in B x s))"
|
|
by (monad_eq simp: L2_defs TS_gets_def)
|
|
|
|
lemma TS_gets_L2_condition:
|
|
"L2_condition c (TS_gets A) (TS_gets B) = TS_gets (\<lambda>s. if c s then (A s) else (B s))"
|
|
by (monad_eq simp: L2_defs TS_gets_def)
|
|
|
|
lemmas [ts_rule gets] =
|
|
TS_gets_L2_gets
|
|
TS_gets_L2_seq
|
|
TS_gets_L2_condition
|
|
split_distrib[where T = TS_gets]
|
|
|
|
lemmas [ts_rule gets unlift] =
|
|
TS_gets_L2_gets [where n = "[]", symmetric]
|
|
TS_gets_L2_seq [symmetric]
|
|
TS_gets_L2_condition [symmetric]
|
|
split_distrib[where T = TS_gets, symmetric]
|
|
|
|
|
|
|
|
(*
|
|
* Lifting into option monad.
|
|
*)
|
|
|
|
definition "gets_theE \<equiv> \<lambda>x. (liftE (gets_the x))"
|
|
|
|
lemma L2_call_gets_theE [simp]: "L2_call (gets_theE x) = gets_theE x"
|
|
apply (monad_eq simp: L2_call_def L2_gets_def gets_theE_def)
|
|
done
|
|
|
|
lemma liftE_gets_theE: "gets_theE X = liftE (gets_the X)"
|
|
apply (clarsimp simp: gets_theE_def)
|
|
done
|
|
lemma L2_call_gets_theE_polymorphic:
|
|
"(L2_call x :: ('s, 'a, 'e1) L2_monad) = gets_theE y
|
|
\<Longrightarrow> (L2_call x :: ('s, 'a, 'e2) L2_monad) = gets_theE y"
|
|
apply (metis L2_call_liftE_unliftE liftE_gets_theE unliftE_liftE)
|
|
done
|
|
|
|
lemma in_gets_theE [monad_eq]:
|
|
"(rv, s') \<in> fst (gets_theE M s) = (\<exists>v'. rv = Inr v' \<and> s' = s \<and> M s = Some v')"
|
|
apply (monad_eq simp: gets_theE_def)
|
|
done
|
|
|
|
lemma snd_gets_theE [monad_eq]:
|
|
"snd (gets_theE M s) = (M s = None)"
|
|
apply (monad_eq simp: gets_theE_def gets_the_def Bex_def assert_opt_def split: option.splits)
|
|
done
|
|
|
|
lemma gets_theE_ofail [simp]:
|
|
"gets_theE ofail = fail"
|
|
by (monad_eq simp: L2_defs ofail_def split: option.splits)
|
|
|
|
(* unused *)
|
|
lemma monad_mono_transfer_option:
|
|
"\<lbrakk> \<And>m. (L2_call (f m) :: ('s, 'a, 'e) L2_monad) = gets_theE (f' m); monad_mono f \<rbrakk> \<Longrightarrow> option_monad_mono f'"
|
|
apply atomize
|
|
apply (clarsimp simp: monad_mono_def option_monad_mono_def)
|
|
apply (clarsimp split: option.splits)
|
|
apply (erule allE, erule allE, erule (1) impE)
|
|
apply (erule_tac x=s in allE)
|
|
apply (frule_tac x=x in spec)
|
|
apply (drule_tac x=y in spec)
|
|
apply rule
|
|
apply (monad_eq simp: L2_call_def split: sum.splits)
|
|
apply metis
|
|
apply (monad_eq simp: L2_call_def split: sum.splits)
|
|
apply (metis (full_types) sum.inject(2))
|
|
done
|
|
|
|
setup \<open>
|
|
Monad_Types.new_monad_type
|
|
"option"
|
|
"Option monad"
|
|
(Monad_Types.check_lifting_head [@{term "gets_theE"}])
|
|
60
|
|
@{thms L2_call_gets_theE gets_theE_ofail}
|
|
@{term "gets_theE :: ('s => 'a option) => ('s, 'a, unit) L2_monad"}
|
|
@{thm L2_call_gets_theE_polymorphic}
|
|
(fn (state, ret, ex) =>
|
|
state --> Term.map_atyps (fn t => if t = @{typ "'a"} then ret else t) @{typ "'a option"})
|
|
(fn def => fn mono_thm => @{thm monad_mono_transfer_option} OF [def, mono_thm])
|
|
|> Context.theory_map
|
|
\<close>
|
|
|
|
lemma gets_theE_L2_gets:
|
|
"L2_gets a n = gets_theE (ogets a)"
|
|
by (monad_eq simp: L2_defs ogets_def)
|
|
|
|
lemma gets_theE_L2_seq:
|
|
"L2_seq (gets_theE X) (\<lambda>x. gets_theE (Y x)) = gets_theE (X |>> Y)"
|
|
by (monad_eq simp: L2_defs ogets_def Bex_def obind_def split: option.splits)
|
|
|
|
lemma gets_theE_L2_guard:
|
|
"L2_guard G = gets_theE (oguard G)"
|
|
by (monad_eq simp: L2_defs oguard_def split: option.splits)
|
|
|
|
lemma gets_theE_L2_condition:
|
|
"L2_condition C (gets_theE L) (gets_theE R) = gets_theE (ocondition C L R)"
|
|
by (monad_eq simp: L2_defs ocondition_def split: option.splits)
|
|
|
|
lemma gets_theE_L2_fail:
|
|
"L2_fail = gets_theE (ofail)"
|
|
by (monad_eq simp: L2_defs ofail_def split: option.splits)
|
|
|
|
lemma gets_theE_L2_recguard:
|
|
"L2_recguard m (gets_theE x) = gets_theE (ocondition (\<lambda>_. m = 0) ofail x)"
|
|
by (monad_eq simp: L2_defs ocondition_def ofail_def split: option.splits)
|
|
|
|
lemma gets_theE_L2_while:
|
|
"L2_while C (\<lambda>x. gets_theE (B x)) i n = gets_theE (owhile C B i)"
|
|
unfolding L2_while_def gets_theE_def gets_the_whileLoop[symmetric]
|
|
by (rule whileLoopE_liftE)
|
|
|
|
|
|
lemmas [ts_rule option] =
|
|
gets_theE_L2_seq
|
|
gets_theE_L2_fail
|
|
gets_theE_L2_guard
|
|
gets_theE_L2_recguard
|
|
gets_theE_L2_gets
|
|
gets_theE_L2_condition
|
|
gets_theE_L2_while
|
|
split_distrib[where T = gets_theE]
|
|
|
|
lemmas [ts_rule option unlift] =
|
|
gets_theE_L2_seq [symmetric]
|
|
gets_theE_L2_fail [symmetric]
|
|
gets_theE_L2_guard [symmetric]
|
|
gets_theE_L2_recguard [symmetric]
|
|
gets_theE_L2_gets [where n = "[]", symmetric]
|
|
gets_theE_L2_condition [symmetric]
|
|
gets_theE_L2_while [symmetric]
|
|
split_distrib[where T = gets_theE, symmetric]
|
|
|
|
|
|
(*
|
|
* Lifting into the nondeterministic state monad.
|
|
* All L2 terms can be lifted into it.
|
|
*)
|
|
|
|
lemma L2_call_liftE_polymorphic:
|
|
"((L2_call x) :: ('s, 'a, 'e1) L2_monad) = liftE y
|
|
\<Longrightarrow> (L2_call x :: ('s, 'a, 'e2) L2_monad) = liftE y"
|
|
apply (metis L2_call_liftE_unliftE unliftE_liftE)
|
|
done
|
|
|
|
lemma monad_mono_transfer_nondet:
|
|
"\<lbrakk> \<And>m. (L2_call (f m) :: ('s, 'a, 'e) L2_monad) = liftE (f' m); monad_mono f \<rbrakk> \<Longrightarrow> monad_mono f'"
|
|
apply atomize
|
|
apply (clarsimp simp: monad_mono_def option_monad_mono_def)
|
|
apply (erule allE, erule allE, erule (1) impE)
|
|
apply (erule_tac x=s in allE)
|
|
apply (frule_tac x=x in spec)
|
|
apply (drule_tac x=y in spec)
|
|
apply rule
|
|
apply (monad_eq simp: L2_call_def split: sum.splits)
|
|
apply (metis set_rev_mp sum.inject(2))
|
|
apply (monad_eq simp: L2_call_def split: sum.splits)
|
|
apply (* not *) fast
|
|
done
|
|
|
|
setup \<open>
|
|
Monad_Types.new_monad_type
|
|
"nondet"
|
|
"Nondeterministic state monad (default)"
|
|
(Monad_Types.check_lifting_head [@{term "liftE"}])
|
|
0
|
|
@{thms L2_call_liftE}
|
|
@{term "liftE :: ('s, 'a) nondet_monad => ('s, 'a, unit) L2_monad"}
|
|
@{thm L2_call_liftE_polymorphic}
|
|
(fn (state, ret, ex) =>
|
|
Term.map_atyps (fn t => if t = @{typ "'a"} then ret
|
|
else if t = @{typ "'s"} then state else t)
|
|
@{typ "('s, 'a) nondet_monad"})
|
|
(fn def => fn mono_thm => @{thm monad_mono_transfer_nondet} OF [def, mono_thm])
|
|
|> Context.theory_map
|
|
\<close>
|
|
|
|
lemma liftE_L2_seq: "L2_seq (liftE A) (\<lambda>x. liftE (B x)) = (liftE (A >>= B))"
|
|
apply (clarsimp simp: L2_defs)
|
|
apply (clarsimp simp: liftE_def bindE_def bind_assoc)
|
|
done
|
|
|
|
lemma liftE_L2_condition: "L2_condition c (liftE A) (liftE B) = liftE (condition c A B)"
|
|
apply (clarsimp simp: L2_defs)
|
|
apply (rule ext)+
|
|
apply monad_eq
|
|
apply blast
|
|
done
|
|
|
|
lemma liftE_L2_modify: "L2_modify m = liftE (modify m)"
|
|
apply (clarsimp simp: L2_defs)
|
|
done
|
|
|
|
lemma liftE_L2_gets: "L2_gets a n = liftE (gets a)"
|
|
apply (clarsimp simp: L2_defs)
|
|
done
|
|
|
|
lemma liftE_L2_recguard:
|
|
"(L2_recguard x (liftE A)) = liftE (condition (\<lambda>s. x > 0) A fail)"
|
|
apply (case_tac "x = 0")
|
|
apply clarsimp
|
|
apply (clarsimp simp: L2_recguard_def)
|
|
done
|
|
|
|
lemma liftE_L2_while: "L2_while c (\<lambda>r. liftE (B r)) i n = liftE (whileLoop c B i)"
|
|
apply (clarsimp simp: L2_while_def)
|
|
apply (rule whileLoopE_liftE)
|
|
done
|
|
|
|
lemma liftE_L2_throw: "L2_throw X n = throwError X"
|
|
apply (monad_eq simp: L2_throw_def)
|
|
done
|
|
|
|
lemma liftE_L2_catch: "L2_catch (liftE A) B = liftE A"
|
|
apply (clarsimp simp: L2_defs)
|
|
done
|
|
|
|
lemma liftE_L2_catch': "L2_catch A (\<lambda>x. liftE (B x)) = liftE (A <catch> B)"
|
|
apply (clarsimp simp: L2_defs)
|
|
apply (clarsimp simp: handleE'_def liftE_def catch_def bind_assoc)
|
|
apply (rule arg_cong [where f="\<lambda>x. (A >>= x)"])
|
|
apply (rule ext)
|
|
apply (clarsimp split: sum.splits)
|
|
done
|
|
|
|
lemma liftE_L2_unknown: "L2_unknown name = liftE (select UNIV)"
|
|
apply (clarsimp simp: L2_defs)
|
|
done
|
|
|
|
lemma liftE_L2_spec: "L2_spec S = liftE (spec S >>= (\<lambda>_. select UNIV))"
|
|
apply (clarsimp simp: L2_defs)
|
|
done
|
|
|
|
lemma liftE_L2_guard: "L2_guard G = liftE (guard G)"
|
|
apply (clarsimp simp: L2_defs)
|
|
done
|
|
|
|
lemma liftE_L2_fail: "L2_fail = liftE (fail)"
|
|
apply (clarsimp simp: L2_defs liftE_def)
|
|
done
|
|
|
|
lemma liftE_exec_concrete:
|
|
"exec_concrete st (liftE x) = liftE (exec_concrete st x)"
|
|
apply (rule monad_eqI)
|
|
apply (clarsimp simp: in_liftE in_exec_concrete)
|
|
apply force
|
|
apply (clarsimp simp: in_liftE in_exec_concrete)
|
|
apply force
|
|
apply (clarsimp simp: snd_exec_concrete snd_liftE)
|
|
done
|
|
|
|
lemma liftE_exec_abstract:
|
|
"exec_abstract st (liftE x) = liftE (exec_abstract st x)"
|
|
apply (rule monad_eqI)
|
|
apply (clarsimp simp: in_liftE in_exec_abstract)
|
|
apply (clarsimp simp: in_liftE in_exec_abstract)
|
|
apply (clarsimp simp: snd_exec_abstract snd_liftE)
|
|
done
|
|
|
|
lemma liftE_measure_call:
|
|
"\<lbrakk> monad_mono A; \<And>m. L2_call (A m) = liftE (B m) \<rbrakk>
|
|
\<Longrightarrow> L2_call (measure_call A) = liftE (measure_call B)"
|
|
apply (monad_eq simp: measure_call_def L2_call_def L2_defs)
|
|
apply (fast dest: monad_mono_incl)
|
|
done
|
|
|
|
lemmas [ts_rule nondet] =
|
|
liftE_L2_seq
|
|
liftE_L2_condition
|
|
liftE_L2_modify
|
|
liftE_L2_gets
|
|
liftE_L2_while
|
|
liftE_L2_throw
|
|
liftE_L2_catch
|
|
liftE_L2_catch'
|
|
liftE_L2_spec
|
|
liftE_L2_guard
|
|
liftE_L2_unknown
|
|
liftE_L2_fail
|
|
liftE_L2_recguard
|
|
liftE_exec_concrete
|
|
liftE_exec_abstract
|
|
liftE_gets_theE
|
|
liftE_measure_call
|
|
split_distrib [where T=liftE]
|
|
|
|
definition
|
|
"AC_call_L1 arg_xf gs ret_xf l1body
|
|
= liftM (\<lambda>rv. case rv of Inr v \<Rightarrow> v)
|
|
(L2_call_L1 arg_xf gs ret_xf l1body)"
|
|
|
|
lemma liftE_L2_call_L1[ts_rule nondet]:
|
|
"L2_call_L1 arg_xf gs ret_xf l1body
|
|
= liftE (AC_call_L1 arg_xf gs ret_xf l1body)"
|
|
apply (simp add: AC_call_L1_def L2_call_L1_def
|
|
liftE_def liftM_def bind_assoc)
|
|
apply (rule ext)
|
|
apply (simp add: exec_gets exec_get)
|
|
apply (rule bind_apply_cong[OF refl])+
|
|
apply (clarsimp simp: bind_assoc returnOk_def in_monad split: sum.splits)
|
|
done
|
|
|
|
lemmas [ts_rule nondet unlift] =
|
|
liftE_L2_seq [symmetric]
|
|
liftE_L2_condition [symmetric]
|
|
liftE_L2_modify [symmetric]
|
|
liftE_L2_gets [symmetric]
|
|
liftE_L2_while [symmetric]
|
|
liftE_L2_throw [symmetric]
|
|
liftE_L2_catch [symmetric]
|
|
liftE_L2_catch' [symmetric]
|
|
liftE_L2_spec [symmetric]
|
|
liftE_L2_guard [symmetric]
|
|
liftE_L2_unknown [symmetric]
|
|
liftE_L2_fail [symmetric]
|
|
liftE_L2_recguard [symmetric]
|
|
liftE_exec_concrete [symmetric]
|
|
liftE_exec_abstract [symmetric]
|
|
liftE_gets_theE [symmetric]
|
|
split_distrib [where T=liftE, symmetric]
|
|
|
|
end
|