section ‹Converting Arbitrary Values to Readable Strings›
text ‹
A type class similar to Haskell's \texttt{Show} class, allowing for constant-time concatenation of
strings using function composition.
›
theory Show
imports
Main
Deriving.Generator_Aux
Deriving.Derive_Manager
begin
type_synonym
"shows" = "string ⇒ string"
type_synonym
'a showsp = "nat ⇒ 'a ⇒ shows"
subsection ‹The Show-Law›
text ‹
The "show law", @{term "shows_prec p x (r @ s) = shows_prec p x r @ s"}, states that
show-functions do not temper with or depend on output produced so far.
›
named_theorems show_law_simps ‹simplification rules for proving the "show law"›
named_theorems show_law_intros ‹introduction rules for proving the "show law"›
definition show_law :: "'a showsp ⇒ 'a ⇒ bool"
where
"show_law s x ⟷ (∀p y z. s p x (y @ z) = s p x y @ z)"
lemma show_lawI:
"(⋀p y z. s p x (y @ z) = s p x y @ z) ⟹ show_law s x"
by (simp add: show_law_def)
lemma show_lawE:
"show_law s x ⟹ (s p x (y @ z) = s p x y @ z ⟹ P) ⟹ P"
by (auto simp: show_law_def)
lemma show_lawD:
"show_law s x ⟹ s p x (y @ z) = s p x y @ z"
by (blast elim: show_lawE)
class "show" =
fixes shows_prec :: "'a showsp"
and shows_list :: "'a list ⇒ shows"
assumes shows_prec_append [show_law_simps]: "shows_prec p x (r @ s) = shows_prec p x r @ s" and
shows_list_append [show_law_simps]: "shows_list xs (r @ s) = shows_list xs r @ s"
begin
abbreviation "shows x ≡ shows_prec 0 x"
abbreviation "show x ≡ shows x ''''"
end
text ‹Convert a string to a show-function that simply prepends the string unchanged.›
definition shows_string :: "string ⇒ shows"
where
"shows_string = (@)"
lemma shows_string_append [show_law_simps]:
"shows_string x (r @ s) = shows_string x r @ s"
by (simp add: shows_string_def)
fun shows_sep :: "('a ⇒ shows) ⇒ shows ⇒ 'a list ⇒ shows"
where
"shows_sep s sep [] = shows_string ''''" |
"shows_sep s sep [x] = s x" |
"shows_sep s sep (x#xs) = s x o sep o shows_sep s sep xs"
lemma shows_sep_append [show_law_simps]:
assumes "⋀r s. ∀x ∈ set xs. showsx x (r @ s) = showsx x r @ s"
and "⋀r s. sep (r @ s) = sep r @ s"
shows "shows_sep showsx sep xs (r @ s) = shows_sep showsx sep xs r @ s"
using assms
proof (induct xs)
case (Cons x xs) then show ?case by (cases xs) (simp_all)
qed (simp add: show_law_simps)
lemma shows_sep_map:
"shows_sep f sep (map g xs) = shows_sep (f o g) sep xs"
by (induct xs) (simp, case_tac xs, simp_all)
definition
shows_list_gen :: "('a ⇒ shows) ⇒ string ⇒ string ⇒ string ⇒ string ⇒ 'a list ⇒ shows"
where
"shows_list_gen showsx e l s r xs =
(if xs = [] then shows_string e
else shows_string l o shows_sep showsx (shows_string s) xs o shows_string r)"
lemma shows_list_gen_append [show_law_simps]:
assumes "⋀r s. ∀x∈set xs. showsx x (r @ s) = showsx x r @ s"
shows "shows_list_gen showsx e l sep r xs (s @ t) = shows_list_gen showsx e l sep r xs s @ t"
using assms by (cases xs) (simp_all add: shows_list_gen_def show_law_simps)
lemma shows_list_gen_map:
"shows_list_gen f e l sep r (map g xs) = shows_list_gen (f o g) e l sep r xs"
by (simp_all add: shows_list_gen_def shows_sep_map)
definition pshowsp_list :: "nat ⇒ shows list ⇒ shows"
where
"pshowsp_list p xs = shows_list_gen id ''[]'' ''['' '', '' '']'' xs"
definition showsp_list :: "'a showsp ⇒ nat ⇒ 'a list ⇒ shows"
where
[code del]: "showsp_list s p = pshowsp_list p o map (s 0)"
lemma showsp_list_code [code]:
"showsp_list s p xs = shows_list_gen (s 0) ''[]'' ''['' '', '' '']'' xs"
by (simp add: showsp_list_def pshowsp_list_def shows_list_gen_map)
lemma show_law_list [show_law_intros]:
"(⋀x. x ∈ set xs ⟹ show_law s x) ⟹ show_law (showsp_list s) xs"
by (simp add: show_law_def showsp_list_code show_law_simps)
lemma showsp_list_append [show_law_simps]:
"(⋀p y z. ∀x ∈ set xs. s p x (y @ z) = s p x y @ z) ⟹
showsp_list s p xs (y @ z) = showsp_list s p xs y @ z"
by (simp add: show_law_simps showsp_list_def pshowsp_list_def)
subsection ‹Show-Functions for Characters and Strings›
instantiation char :: "show"
begin
definition "shows_prec p (c::char) = (#) c"
definition "shows_list (cs::string) = shows_string cs"
instance
by standard (simp_all add: shows_prec_char_def shows_list_char_def show_law_simps)
end
definition "shows_nl = shows (CHR ''⏎'')"
definition "shows_space = shows (CHR '' '')"
definition "shows_paren s = shows (CHR ''('') o s o shows (CHR '')'')"
definition "shows_quote s = shows (CHR 0x27) o s o shows (CHR 0x27)"
abbreviation "apply_if b s ≡ (if b then s else id)"
text ‹Parenthesize only if precedence is greater than @{term "0::nat"}.›
definition "shows_pl (p::nat) = apply_if (p > 0) (shows (CHR ''(''))"
definition "shows_pr (p::nat) = apply_if (p > 0) (shows (CHR '')''))"
lemma
shows_nl_append [show_law_simps]: "shows_nl (x @ y) = shows_nl x @ y" and
shows_space_append [show_law_simps]: "shows_space (x @ y) = shows_space x @ y" and
shows_paren_append [show_law_simps]:
"(⋀x y. s (x @ y) = s x @ y) ⟹ shows_paren s (x @ y) = shows_paren s x @ y" and
shows_quote_append [show_law_simps]:
"(⋀x y. s (x @ y) = s x @ y) ⟹ shows_quote s (x @ y) = shows_quote s x @ y" and
shows_pl_append [show_law_simps]: "shows_pl p (x @ y) = shows_pl p x @ y" and
shows_pr_append [show_law_simps]: "shows_pr p (x @ y) = shows_pr p x @ y"
by (simp_all add: shows_nl_def shows_space_def shows_paren_def shows_quote_def shows_pl_def shows_pr_def show_law_simps)
lemma o_append:
"(⋀x y. f (x @ y) = f x @ y) ⟹ g (x @ y) = g x @ y ⟹ (f o g) (x @ y) = (f o g) x @ y"
by simp
ML_file ‹show_generator.ML›
local_setup ‹
Show_Generator.register_foreign_partial_and_full_showsp @{type_name "list"} 0
@{term "pshowsp_list"}
@{term "showsp_list"} (SOME @{thm showsp_list_def})
@{term "map"} (SOME @{thm list.map_comp}) [true] @{thm show_law_list}
›
instantiation list :: ("show") "show"
begin
definition "shows_prec (p :: nat) (xs :: 'a list) = shows_list xs"
definition "shows_list (xss :: 'a list list) = showsp_list shows_prec 0 xss"
instance
by standard (simp_all add: show_law_simps shows_prec_list_def shows_list_list_def)
end
definition shows_lines :: "'a::show list ⇒ shows"
where
"shows_lines = shows_sep shows shows_nl"
definition shows_many :: "'a::show list ⇒ shows"
where
"shows_many = shows_sep shows id"
definition shows_words :: "'a::show list ⇒ shows"
where
"shows_words = shows_sep shows shows_space"
lemma shows_lines_append [show_law_simps]:
"shows_lines xs (r @ s) = shows_lines xs r @ s"
by (simp add: shows_lines_def show_law_simps)
lemma shows_many_append [show_law_simps]:
"shows_many xs (r @ s) = shows_many xs r @ s"
by (simp add: shows_many_def show_law_simps)
lemma shows_words_append [show_law_simps]:
"shows_words xs (r @ s) = shows_words xs r @ s"
by (simp add: shows_words_def show_law_simps)
lemma shows_foldr_append [show_law_simps]:
assumes "⋀r s. ∀x ∈ set xs. showx x (r @ s) = showx x r @ s"
shows "foldr showx xs (r @ s) = foldr showx xs r @ s"
using assms by (induct xs) (simp_all)
lemma shows_sep_cong [fundef_cong]:
assumes "xs = ys" and "⋀x. x ∈ set ys ⟹ f x = g x"
shows "shows_sep f sep xs = shows_sep g sep ys"
using assms
proof (induct ys arbitrary: xs)
case (Cons y ys)
then show ?case by (cases ys) simp_all
qed simp
lemma shows_list_gen_cong [fundef_cong]:
assumes "xs = ys" and "⋀x. x ∈ set ys ⟹ f x = g x"
shows "shows_list_gen f e l sep r xs = shows_list_gen g e l sep r ys"
using shows_sep_cong [of xs ys f g] assms by (cases xs) (auto simp: shows_list_gen_def)
lemma showsp_list_cong [fundef_cong]:
"xs = ys ⟹ p = q ⟹
(⋀p x. x ∈ set ys ⟹ f p x = g p x) ⟹ showsp_list f p xs = showsp_list g q ys"
by (simp add: showsp_list_code cong: shows_list_gen_cong)
abbreviation (input) shows_cons :: "string ⇒ shows ⇒ shows" (infixr "+#+" 10)
where
"s +#+ p ≡ shows_string s ∘ p"
abbreviation (input) shows_append :: "shows ⇒ shows ⇒ shows" (infixr "+@+" 10)
where
"s +@+ p ≡ s ∘ p"
instantiation String.literal :: "show"
begin
definition shows_prec_literal :: "nat ⇒ String.literal ⇒ string ⇒ string"
where "shows_prec p s = shows_string (String.explode s)"
definition shows_list_literal :: "String.literal list ⇒ string ⇒ string"
where "shows_list ss = shows_string (concat (map String.explode ss))"
lemma shows_list_literal_code [code]:
"shows_list = foldr (λs. shows_string (String.explode s))"
proof
fix ss
show "shows_list ss = foldr (λs. shows_string (String.explode s)) ss"
by (induct ss) (simp_all add: shows_list_literal_def shows_string_def)
qed
instance by standard
(simp_all add: shows_prec_literal_def shows_list_literal_def shows_string_def)
end
text ‹
Don't use Haskell's existing "Show" class for code-generation, since it is not compatible to the
formalized class.
›
code_reserved Haskell "Show"
end