Theory FunctorClass

header {* Functor Class *}

theory FunctorClass
imports Coerce TypeApp
begin

subsection {* Class axioms *}

consts
  rep_fmap :: "(U => U) => U•'f => U•'f::tycon"

axclass functor < tycon
  rep_fmap_type:
    "[|!!x. x ::: A ==> f x ::: B; emb (xs::U•'f::tycon) ::: tc TYPE('f) A|]
      ==> emb (rep_fmap f xs) ::: tc TYPE('f) B"

  rep_fmap_cast:
    "rep_fmap (cast A) (xs::U•'f::tycon) =
      proj (cast (tc TYPE('f) A) (emb xs))"
 (* "emb (xs::U•'f::tycon) ::: tc TYPE('f) A ==> rep_fmap (cast A) xs = xs" *)

  rep_fmap_fmap:
    "rep_fmap f (rep_fmap g xs) = rep_fmap (λx. f (g x)) xs"

subsection {* @{term fmap} *}

constdefs
  fmap :: "('a => 'b) => 'a•'f => 'b•'f::functor"
  "fmap ≡ λf xs. coerce (rep_fmap (emb o f o proj) (coerce xs::U•'f))"

lemmas tc_rep_of = rep_of_App[symmetric]

lemmas rep_fmap_type2 =
  rep_fmap_type
    [of "rep_of TYPE('b)" _ "rep_of TYPE('c)",
       simplified tc_rep_of, standard]

theorem fmap_id [simp]: "fmap id xs = xs"
 apply (simp add: fmap_def o_def)
 apply (simp add: emb_proj)
 apply (subst rep_fmap_cast)
 apply (subst rep_of_App [symmetric])
 apply (simp add: coerce_def cast_rep_of)
done

lemmas fmap_ident [simp] = fmap_id [unfolded id_def]

theorem fmap_fmap:
  "fmap f (fmap g xs) = fmap (λx. f (g x)) xs"
 apply (simp add: fmap_def)
 apply (subst coerce_inverse)
  apply (rule rep_fmap_type2, simp)
  apply (rule coerce_type, simp)
 apply (simp add: rep_fmap_fmap o_def)
done

lemma fmap_comp: "fmap (f o g) = fmap f o fmap g"
by (simp add: o_def fmap_fmap)

lemma inj_fmap: "inj f ==> inj (fmap f)"
 apply (rule_tac g="fmap (inv f)" in inj_on_inverseI)
 apply (simp add: fmap_fmap)
done


subsection {* Proving that @{term "fmap coerce = coerce"} *}

lemma rep_fmap_eq_fmap: "rep_fmap = fmap"
by (simp add: fmap_def)

lemma in_rep_of_App_U:
  "xs ::: tc TYPE('f::tycon) A ==> xs ::: rep_of TYPE(U•'f)"
 apply (erule rev_subidemD)
 apply (simp add: rep_of_App)
 apply (rule monoD [OF mono_tc])
 apply (rule less_rep_of_U)
done

lemma rep_fmap_cast_rep_of:
  "rep_fmap (cast (rep_of TYPE('a))) =
    proj o cast (rep_of TYPE('a•'f::functor)) o (emb::U•'f => U)"
by (rule ext, simp add: rep_fmap_cast rep_of_App)

lemma rep_fmap_comp:
  "(rep_fmap (f o g) :: U•'f::functor => U•'f) = rep_fmap f o rep_fmap g"
by (simp add: rep_fmap_eq_fmap fmap_comp)

lemma coerce_coerce:
  "(emb o (coerce::'a => 'b) o proj :: U => U)
    = cast (rep_of TYPE('b)) o cast (rep_of TYPE('a))"
 apply (rule ext, simp)
 apply (simp only: coerce_def emb_proj)
done

lemma fmap_coerce: "fmap coerce = (coerce::'a•'f => 'b•'f::functor)"
 apply (rule ext)
 apply (simp add: fmap_def)
 apply (subst coerce_coerce)
 apply (subst rep_fmap_comp)
 apply (simp add: rep_fmap_cast_rep_of)
 apply (simp add: cast_rep_of)
 apply (simp add: coerce_def)
done


subsection {* Functor locale *}

text {*
  It is easy to prove instances of the functor class:
  All you need to do is define @{term tc} and @{term rep_fmap}
  in a standard way, and then prove that the functor laws
  hold at one specific type.
*}

constdefs
  functor_tc :: "((U => U) => 'l => 'l) => monotc"
  "functor_tc umap ≡ Abs_monotc (λA. Abs_idem (emb o umap (cast A) o proj))"

  rep_fmap_of :: "((U => U) => 'l => 'l) => ((U => U) => U•'f => U•'f::tycon)"
  "rep_fmap_of umap ≡ λf. coerce o umap f o coerce"

locale functor_locale =
  fixes umap :: "(U => U) => 'l => 'l"
assumes tc_umap:   "monotc TYPE('f::tycon) ≡ functor_tc umap"
    and rep_fmap:  "rep_fmap :: (U => U) => U•'f => U•'f::tycon
                      ≡ rep_fmap_of umap"
    and umap_id:   "!!xs. umap id xs = xs"
    and umap_umap: "!!f g xs. umap f (umap g xs) = umap (λx. f (g x)) xs"

lemma (in functor_locale) cast_tc:
  "cast (tc TYPE('f::tycon) A) = emb o umap (cast A) o proj"
 apply (unfold tc_def tc_umap functor_tc_def)
 apply (subst Abs_monotc_inverse)
  apply (simp)
  apply (rule monoI)
  apply (rule subidemI)
  apply (simp add: in_idem_def)
  apply (simp add: cast_Abs_idem idempotent_def umap_umap)
  apply (erule subst)
  apply (simp add: umap_umap)
  apply (subst cast_fixed)
   apply (erule subidemD)
   apply (rule cast_in_idem)
  apply (rule refl)
 apply (subst cast_Abs_idem)
  apply (simp add: idempotent_def umap_umap)
 apply (rule refl)
done

lemma (in functor_locale) rep_of_App_U_functor [simp]:
  "rep_of TYPE('l) = rep_of TYPE(U•'f::tycon)"
 apply (rule idempotent_equality, rule ext)
 apply (simp add: rep_of_App)
 apply (simp add: cast_tc cast_rep_of)
 apply (simp add: umap_id [unfolded id_def])
done

lemma (in functor_locale) in_tc_iff:
  "(x ::: tc TYPE('f::tycon) A) = (emb (umap (cast A) (proj x)) = x)"
by (simp add: in_idem_def cast_tc)

lemma (in functor_locale) emb_in_tc:
  "(emb (x::'l) ::: tc TYPE('f::tycon) A) = (umap (cast A) x = x)"
by (simp add: in_tc_iff coerce_def)

lemma (in functor_locale) emb_in_tc_2:
  "(emb (x::U•'f) ::: tc TYPE('f::tycon) A) =
    (umap (cast A) (coerce x) = coerce x)"
 apply (simp add: in_tc_iff coerce_def)
 apply safe
  apply (erule subst, rule emb_inverse[symmetric])
 apply simp
done

lemma (in functor_locale) umap_type:
  "emb (umap g xs) ::: rep_of TYPE(U•'f::tycon)"
by (simp add: rep_of_App in_tc_iff cast_rep_of_U umap_id)

theorem (in functor_locale) type:
fixes xs :: "U•'f::tycon"
assumes P: "!!x. x ::: A ==> f x ::: B"
shows "emb xs ::: tc TYPE('f) A ==> emb (rep_fmap f xs) ::: tc TYPE('f) B"
 apply (simp add: rep_fmap rep_fmap_of_def)
 apply (erule in_idemE)
 apply (rule in_idemI)
 apply (simp add: cast_tc)
 apply (simp add: coerce_def)
 apply (simp add: umap_umap)
 apply (rule_tac x="proj y" in fun_cong)
 apply (rule_tac f=umap in arg_cong)
 apply (rule ext)
 apply (rule cast_fixed)
 apply (rule P [OF cast_in_idem])
done


lemma (in functor_locale) cast:
fixes xs :: "U•'f::tycon"
shows "rep_fmap (cast A) xs = proj (cast (tc TYPE('f) A) (emb xs))"
by (simp add: rep_fmap cast_tc rep_fmap_of_def coerce_def)
(*
lemma (in functor_locale) cast:
fixes xs :: "U•'f::tycon"
shows "emb xs ::: tc TYPE('f) A ==> rep_fmap (cast A) xs = xs"
by (simp add: rep_fmap rep_fmap_of_def emb_in_tc_2)
*)
lemma (in functor_locale) comp:
fixes xs :: "U•'f::tycon"
shows "rep_fmap f (rep_fmap g xs) = rep_fmap (λx. f (g x)) xs"
by (simp add: rep_fmap rep_fmap_of_def umap_umap)

lemma (in functor_locale) functor_class:
  "OFCLASS('f::tycon, functor_class)"
 apply (intro_classes)
   apply (rule type, fast, assumption)
  apply (rule cast)
 apply (rule comp)
done

text {* Isomorphism at other type instances *}

lemma (in functor_locale) rep_of_App_functor:
  fixes map_aU :: "('a => U) => 'k => 'l"
  fixes map_Ua :: "(U => 'a) => 'l => 'k"
  assumes 1: "!!xs. emb xs = emb (map_aU emb xs)"
  assumes 2: "!!u. proj u = map_Ua proj (proj u)"
  assumes 3: "!!f g xs. map_aU f (map_Ua g xs) = umap (λx. f (g x)) xs"
  shows "rep_of TYPE('k) = rep_of TYPE('a•'f::tycon)"
 apply (rule idempotent_equality, rule ext)
 apply (simp add: rep_of_App)
 apply (simp add: cast_tc cast_rep_of)
 apply (simp add: prems)
done

lemma functor_locale_fmap_def:
  fixes map_Ua :: "(U => 'a) => 'l => 'k"
  fixes map_Ub :: "(U => 'b) => 'l => 'm"
  fixes map_ab :: "('a => 'b) => 'k => 'm"
  fixes map_bU :: "('b => U) => 'm => 'l"
  fixes map_UU :: "(U => U) => 'l => 'l"
  assumes fl: "functor_locale TYPE('f::functor) map_UU"
  assumes rews:
    "!!xs. emb xs = emb (map_bU emb xs)"
    "!!u. proj u = map_Ua proj (proj u)"
    "!!f g xs. map_ab f (map_Ua g xs) = map_Ub (λx. f (g x)) xs"
    "!!f g xs. map_bU f (map_Ub g xs) = map_UU (λx. f (g x)) xs"
  shows "fmap ≡ λf (xs::'a•'f::functor). coerce (map_ab f (coerce xs))"
 apply (rule eq_reflection, rule ext, rule ext)
 apply (unfold fmap_def)
 apply (simp add: fmap_coerce [symmetric])
 apply (simp add: fmap_def)
 apply (simp add: fl [THEN functor_locale.rep_fmap])
 apply (simp add: rep_fmap_of_def)
 apply (simp add: fl [THEN functor_locale.rep_of_App_U_functor])
 apply (simp add: fl [THEN functor_locale.umap_umap])
 apply (simp add: coerce_def rews)
done

end