(*************************************************************************
 * Copyright (C) 
 *               2019      The University of Exeter 
 *               2018-2019 The University of Paris-Saclay
 *               2018      The University of Sheffield
 *
 * License:
 *   This program can be redistributed and/or modified under the terms
 *   of the 2-clause BSD-style license.
 *
 *   SPDX-License-Identifier: BSD-2-Clause
 *************************************************************************)

chapter\<open>Term Antiquotations\<close>

text\<open>Terms are represented by "Inner Syntax" parsed by an Earley parser in Isabelle.
For historical reasons, \<^emph>\<open>term antiquotations\<close> are called therefore somewhat misleadingly
"Inner Syntax Antiquotations". \<close>

theory 
  TermAntiquotations
imports 
  "Isabelle_DOF-Unit-Tests_document"
  "Isabelle_DOF-Ontologies.Conceptual"
keywords "definition*" :: thy_defn
and "theorem*" "lemma*" "corollary*" "proposition*" :: thy_goal_stmt
and "schematic_goal*" :: thy_goal_stmt

begin


record AA =
aa :: int
bb :: nat
record BB = AA +
cc :: int

typ "AA"
ML\<open>
val Type(s, t) = \<^typ>\<open>AA\<close>
\<close>
ML\<open>
val thy = \<^theory>
val ns = Sign.tsig_of thy |> Type.type_space
val Type(name, t) = \<^typ>\<open>AA\<close>
val {pos, ...} = Name_Space.the_entry ns name
\<close>
find_consts name:"AA"
find_theorems (50) name:"AA"
ML\<open>
val t = Record.get_info \<^theory> 
\<close>
print_record AA
ML\<open>
val t = Record.string_of_record \<^context> "AA" |> YXML.parse_body |> XML.content_of
\<close>
ML\<open>
val t = Syntax.read_typ \<^context> "AA" |> Record.pretty_recT \<^context>
\<close>
ML\<open>
val t = Record.get_recT_fields \<^theory> \<^typ>\<open>AA\<close>
\<close>
ML\<open>
val t = Record.get_recT_fields \<^theory> \<^typ>\<open>BB\<close>
\<close>
ML\<open>
val t = Record.dest_recTs \<^typ>\<open>BB\<close>
\<close>
ML\<open>
val Type(s, t) = \<^typ>\<open>AA\<close>
\<close>
ML\<open>
val t = Record.get_info \<^theory> "TermAntiquotations.BB"
\<close>
print_record "BB"


ML\<open>

(* definition *)

fun get_positions ctxt x =
  let
    fun get Cs (Const ("_type_constraint_", C) $ t) = get (C :: Cs) t
      | get Cs (Free (y, T)) =
          if x = y then
            map_filter Term_Position.decode_positionT
              (T :: map (Type.constraint_type ctxt) Cs)
          else []
      | get _ (t $ u) = get [] t @ get [] u
      | get _ (Abs (_, _, t)) = get [] t
      | get _ _ = [];
  in get [] end;

fun prep_decls prep_var raw_vars ctxt =
  let
    val (vars, ctxt') = fold_map prep_var raw_vars ctxt;
    val (xs, ctxt'') = ctxt'
      |> Context_Position.set_visible false
      |> Proof_Context.add_fixes vars
      ||> Context_Position.restore_visible ctxt';
    val _ =
      Context_Position.reports ctxt''
        (map (Binding.pos_of o #1) vars ~~
          map (Variable.markup_entity_def ctxt'' ##> Properties.remove Markup.kindN) xs);
  in ((vars, xs), ctxt'') end;

fun dummy_frees ctxt xs tss =
  let
    val names =
      Variable.names_of ((fold o fold) Variable.declare_term tss ctxt)
      |> fold Name.declare xs;
    val (tss', _) = (fold_map o fold_map) Term.free_dummy_patterns tss names;
  in tss' end;

fun prep_spec_open prep_var parse_prop raw_vars raw_params raw_prems raw_concl ctxt =
  let
    val ((vars, xs), vars_ctxt) = prep_decls prep_var raw_vars ctxt;
    val (ys, params_ctxt) = vars_ctxt |> fold_map prep_var raw_params |-> Proof_Context.add_fixes;

    val props =
      map (parse_prop params_ctxt) (raw_concl :: raw_prems)
      |> singleton (dummy_frees params_ctxt (xs @ ys));
    val concl :: prems = Syntax.check_props params_ctxt props;
    val spec = Logic.list_implies (prems, concl);
    val spec' = DOF_core.transduce_term_global {mk_elaboration=true}
                                               (spec , Position.none)
                                               (Proof_Context.theory_of ctxt)
    (*val spec_ctxt = Variable.declare_term spec params_ctxt;*)
    val spec_ctxt = Variable.declare_term spec' params_ctxt;

    fun get_pos x = maps (get_positions spec_ctxt x) props;
  (*in ((vars, xs, get_pos, spec), spec_ctxt) end;*)
    in ((vars, xs, get_pos, spec'), spec_ctxt) end;

val read_spec_open = prep_spec_open Proof_Context.read_var Syntax.parse_prop;

fun gen_def prep_spec prep_att raw_var raw_params raw_prems ((a, raw_atts), raw_spec) int lthy =
  let
    val atts = map (prep_att lthy) raw_atts;

    val ((vars, xs, get_pos, spec), _) = lthy
      |> prep_spec (the_list raw_var) raw_params raw_prems raw_spec;
    val (((x, T), rhs), prove) = Local_Defs.derived_def lthy get_pos {conditional = true} spec;
    val _ = Name.reject_internal (x, []);
    val (b, mx) =
      (case (vars, xs) of
        ([], []) => (Binding.make (x, (case get_pos x of [] => Position.none | p :: _ => p)), NoSyn)
      | ([(b, _, mx)], [y]) =>
          if x = y then (b, mx)
          else
            error ("Head of definition " ^ quote x ^ " differs from declaration " ^ quote y ^
              Position.here (Binding.pos_of b)));

    val name = Thm.def_binding_optional b a;
    val ((lhs, (_, raw_th)), lthy2) = lthy
      |> Local_Theory.define_internal ((b, mx), ((Binding.suffix_name "_raw" name, []), rhs));

    val th = prove lthy2 raw_th;
    val lthy3 = lthy2 |> Spec_Rules.add name Spec_Rules.equational [lhs] [th];

    val ([(def_name, [th'])], lthy4) = lthy3
      |> Local_Theory.notes [((name, atts), [([th], [])])];

    val lthy5 = lthy4
      |> Code.declare_default_eqns [(th', true)];

    val lhs' = Morphism.term (Local_Theory.target_morphism lthy5) lhs;

    val _ =
      Proof_Display.print_consts int (Position.thread_data ()) lthy5
        (Frees.defined (Frees.build (Frees.add_frees lhs'))) [(x, T)];
  in ((lhs, (def_name, th')), lthy5) end;

val definition_cmd = gen_def read_spec_open Attrib.check_src;

fun definition_cmd' meta_args_opt decl params prems spec bool ctxt =
  Local_Theory.background_theory (Value_Command.meta_args_exec meta_args_opt) ctxt
  |> definition_cmd decl params prems spec bool

val _ =
  Outer_Syntax.local_theory' \<^command_keyword>\<open>definition*\<close> "constant definition"
    (ODL_Meta_Args_Parser.opt_attributes --
      (Scan.option Parse_Spec.constdecl -- (Parse_Spec.opt_thm_name ":" -- Parse.prop) --
        Parse_Spec.if_assumes -- Parse.for_fixes)
     >> (fn (meta_args_opt, (((decl, spec), prems), params)) => 
                                    #2 oo definition_cmd' meta_args_opt decl params prems spec));

\<close>


ML\<open>
local

fun prep_statement prep_att prep_stmt raw_elems raw_stmt ctxt =
  let
    val (stmt, elems_ctxt) = prep_stmt raw_elems raw_stmt ctxt;
    val _ = writeln ("In prep_statement stmt: " ^ \<^make_string> stmt)
    val prems = Assumption.local_prems_of elems_ctxt ctxt;
    val stmt_ctxt = fold (fold (Proof_Context.augment o fst) o snd) stmt elems_ctxt;
  in
    (case raw_stmt of
      Element.Shows _ =>
        let val stmt' = Attrib.map_specs (map prep_att) stmt
            val _ = writeln ("In prep_statement case Element.Shows stmt': " ^ \<^make_string> stmt')
            val stmt'' = map (fn (b, ts) =>
                         (b, map (fn (t', t's) =>
                         (DOF_core.transduce_term_global {mk_elaboration=true}
                                                         (t' , Position.none)
                                                         (Proof_Context.theory_of ctxt),
                         map (fn t'' => 
                         DOF_core.transduce_term_global {mk_elaboration=true}
                                                        (t'' , Position.none)
                                                        (Proof_Context.theory_of ctxt))
                         t's)) ts)) stmt'
        (*in (([], prems, stmt', NONE), stmt_ctxt) end*)
        in (([], prems, stmt'', NONE), stmt_ctxt) end
    | Element.Obtains raw_obtains =>
        let
          val asms_ctxt = stmt_ctxt
            |> fold (fn ((name, _), asm) =>
                snd o Proof_Context.add_assms Assumption.assume_export
                  [((name, [Context_Rules.intro_query NONE]), asm)]) stmt;
          val that = Assumption.local_prems_of asms_ctxt stmt_ctxt;
          val ([(_, that')], that_ctxt) = asms_ctxt
            |> Proof_Context.set_stmt true
            |> Proof_Context.note_thmss "" [((Binding.name Auto_Bind.thatN, []), [(that, [])])]
            ||> Proof_Context.restore_stmt asms_ctxt;

          val stmt' = [(Binding.empty_atts, [(#2 (#1 (Obtain.obtain_thesis ctxt)), [])])];
          val stmt'' = map (fn (b, ts) =>
                         (b, map (fn (t', t's) =>
                         (DOF_core.transduce_term_global {mk_elaboration=true}
                                                         (t' , Position.none)
                                                         (Proof_Context.theory_of ctxt),
                         map (fn t'' => 
                         DOF_core.transduce_term_global {mk_elaboration=true}
                                                        (t'' , Position.none)
                                                        (Proof_Context.theory_of ctxt))
                         t's)) ts)) stmt'
          val _ = writeln ("In prep_statement case Element.Obtains stmt': " ^ \<^make_string> stmt')
        (*in ((Obtain.obtains_attribs raw_obtains, prems, stmt', SOME that'), that_ctxt) end)*)
        in ((Obtain.obtains_attribs raw_obtains, prems, stmt'', SOME that'), that_ctxt) end)
  end;

fun gen_theorem schematic bundle_includes prep_att prep_stmt
    long kind before_qed after_qed (name, raw_atts) raw_includes raw_elems raw_concl int lthy =
  let
    val _ = Local_Theory.assert lthy;

    val elems = raw_elems |> map (Element.map_ctxt_attrib (prep_att lthy));
    val ((more_atts, prems, stmt, facts), goal_ctxt) = lthy
      |> bundle_includes raw_includes
      |> prep_statement (prep_att lthy) prep_stmt elems raw_concl;
    val atts = more_atts @ map (prep_att lthy) raw_atts;

    val pos = Position.thread_data ();
    fun after_qed' results goal_ctxt' =
      let
        val results' =
          burrow (map (Goal.norm_result lthy) o Proof_Context.export goal_ctxt' lthy) results;
        val (res, lthy') =
          if forall (Binding.is_empty_atts o fst) stmt then (map (pair "") results', lthy)
          else
            Local_Theory.notes_kind kind
              (map2 (fn (b, _) => fn ths => (b, [(ths, [])])) stmt results') lthy;
        val lthy'' =
          if Binding.is_empty_atts (name, atts) then
            (Proof_Display.print_results int pos lthy' ((kind, ""), res); lthy')
          else
            let
              val ([(res_name, _)], lthy'') =
                Local_Theory.notes_kind kind [((name, atts), [(maps #2 res, [])])] lthy';
              val _ = Proof_Display.print_results int pos lthy' ((kind, res_name), res);
            in lthy'' end;
      in after_qed results' lthy'' end;

    val prems_name = if long then Auto_Bind.assmsN else Auto_Bind.thatN;
  in
    goal_ctxt
    |> not (null prems) ?
      (Proof_Context.note_thmss "" [((Binding.name prems_name, []), [(prems, [])])] #> snd)
    |> Proof.theorem before_qed after_qed' (map snd stmt)
    |> (case facts of NONE => I | SOME ths => Proof.refine_insert ths)
    |> tap (fn state => not schematic andalso Proof.schematic_goal state andalso
        error "Illegal schematic goal statement")
  end;

in

val theorem_cmd =
  gen_theorem false Bundle.includes_cmd Attrib.check_src Expression.read_statement;

fun theorem_cmd' meta_args_opt long kind before_qed after_qed (name, raw_atts) raw_includes raw_elems raw_concl int lthy =
  Local_Theory.background_theory (Value_Command.meta_args_exec meta_args_opt) lthy
  |> theorem_cmd long kind before_qed after_qed (name, raw_atts) raw_includes raw_elems raw_concl int;

val schematic_theorem_cmd =
  gen_theorem true Bundle.includes_cmd Attrib.check_src Expression.read_statement;

fun schematic_theorem_cmd' meta_args_opt long kind before_qed after_qed (name, raw_atts) raw_includes raw_elems raw_concl int lthy =
  Local_Theory.background_theory (Value_Command.meta_args_exec meta_args_opt) lthy
  |> schematic_theorem_cmd long kind before_qed after_qed (name, raw_atts) raw_includes raw_elems raw_concl int;

end;

local
val long_keyword =
  Parse_Spec.includes >> K "" ||
  Parse_Spec.long_statement_keyword;

val long_statement =
  ODL_Meta_Args_Parser.opt_attributes --
  Scan.optional (Parse_Spec.opt_thm_name ":" --| Scan.ahead long_keyword) Binding.empty_atts --
  Scan.optional Parse_Spec.includes [] -- Parse_Spec.long_statement
    >> (fn (((meta_args_opt, binding), includes), (elems, concl)) => (meta_args_opt, true, binding, includes, elems, concl));

val short_statement =
  ODL_Meta_Args_Parser.opt_attributes --
  Parse_Spec.statement -- Parse_Spec.if_statement -- Parse.for_fixes
    >> (fn (((meta_args_opt, shows), assumes), fixes) =>
      (meta_args_opt, false, Binding.empty_atts, [], [Element.Fixes fixes, Element.Assumes assumes],
        Element.Shows shows));

fun theorem spec schematic descr =
  Outer_Syntax.local_theory_to_proof' spec ("state " ^ descr)
    ((long_statement || short_statement) >> (fn (meta_args_opt, long, binding, includes, elems, concl) =>
      ((if schematic then schematic_theorem_cmd' else theorem_cmd')
        meta_args_opt long Thm.theoremK NONE (K I) binding includes elems concl)));

val _ = theorem \<^command_keyword>\<open>theorem*\<close> false "theorem";
val _ = theorem \<^command_keyword>\<open>lemma*\<close> false "lemma";
val _ = theorem \<^command_keyword>\<open>corollary*\<close> false "corollary";
val _ = theorem \<^command_keyword>\<open>proposition*\<close> false "proposition";
val _ = theorem \<^command_keyword>\<open>schematic_goal*\<close> true "schematic goal";
in end
\<close>

declare [[ML_print_depth=40]]
lemma* conj : "xx \<Longrightarrow> yy \<Longrightarrow> zz \<Longrightarrow> (xx \<and> yy) \<and> zz"
  apply (rule conjI)
  apply (rule conjI)
  apply assumption
  apply assumption
  apply assumption
  done

lemma* "xx \<Longrightarrow> yy \<Longrightarrow> zz \<Longrightarrow> (xx \<and> yy) \<and> zz"
  apply (rule conjI)
  apply (rule conjI)
  apply assumption
  apply assumption
  apply assumption
  done

text\<open>Since the syntax chosen for values of doc-class attributes is HOL-syntax --- requiring
a fast read on the ``What's in Main''-documentation, but not additional knowledge on, say, SML --- 
an own syntax for references to types, terms, theorems, etc. are necessary. These are the
``Inner Syntax Antiquotations'' since they make only sense \emph{inside} the Inner-Syntax
of Isabelle/Isar, so inside the \verb+" ... "+ parenthesis.

They are the key-mechanism to denote 
\<^item> Ontological Links, i.e. attributes refering to document classes defined by the ontology
\<^item> Ontological F-Links, i.e. attributes referring to formal entities inside Isabelle (such as thm's)

This file contains a number of examples resulting from the 
% @ {theory "Isabelle_DOF-Unit-Tests.Conceptual"} does not work here --- why ?
\<^theory_text>\<open>Conceptual\<close> - ontology; the emphasis of this presentation is to present the expressivity of 
ODL on a paradigmatical example.
\<close>


text\<open>Voila the content of the Isabelle/DOF environment so far:\<close>
ML\<open>
val x = DOF_core.get_instances \<^context>
val isa_transformer_tab = DOF_core.get_isa_transformers \<^context>
val docclass_tab = DOF_core.get_onto_classes \<^context>; 
Name_Space.dest_table isa_transformer_tab; 
\<close>

text\<open>Some sample lemma:\<close>
lemma murks : "Example=Example" by simp

text\<open>Example for a meta-attribute of ODL-type @{typ "file"} with an appropriate ISA for the
     file @{file "TermAntiquotations.thy"}\<close>
(* not working: 
text*[xcv::F, u="@{file ''InnerSyntaxAntiquotations.thy''}"]\<open>Lorem ipsum ...\<close>
*)

text*[xcv1::A, x=5]\<open>Lorem ipsum ...\<close>
text*[xcv3::A, x=7]\<open>Lorem ipsum ...\<close>


term\<open>
cpo
\<close>
text*[xcv10::A, x=5, level= "Some 1"]\<open>Lorem ipsum ...\<close>
ML\<open>
val t = Local_Theory.level \<^context>
\<close>
doc_class AAA = 
aaa :: "int list"
definition xxx where "xxx \<equiv> 2 + 3::int"
definition*[xcv11::A, x=5, level="Some 1"] xx' where "xx' \<equiv> A.x @{A \<open>xcv11\<close>}" if "A.x @{A \<open>xcv11\<close>} = 5"
definition* xx where "xx \<equiv> A.x @{A \<open>xcv10\<close>}"
(*definition* xx where "xx \<equiv> A.x @{A \<open>xcv10\<close>}" if "A.x @{A \<open>xcv10\<close>} = 5"*)
value*\<open>xxx\<close>
value*\<open>xx\<close>
find_theorems name:"xx'"
find_consts name:"xx'"
find_theorems name:"xx"
find_consts name:"xx"
find_theorems name:"some"

lemma* [xcv12::A, x=5, level="Some 1"] testtest : "xx + A.x @{A \<open>xcv12\<close>} = yy + A.x @{A \<open>xcv12\<close>} \<Longrightarrow> xx = yy"
  by auto

text\<open>Example for a meta-attribute of ODL-type @{typ "typ"} with an appropriate ISA for the
     theorem @{thm "refl"}\<close>
text*[xcv2::C, g="@{thm ''HOL.refl''}"]\<open>Lorem ipsum ...\<close>

text\<open>A warning about the usage of the \<open>docitem\<close> TA:
The \<open>docitem\<close> TA offers a way to check the reference of class instances
without checking the instances type.
So one will be able to reference \<open>docitem\<close>s (class instances) and have them checked,
without the burden of the type checking required otherwise.
But it may give rise to unwanted behaviors, due to its polymorphic type.
It must not be used for certification.
\<close>

text\<open>Major sample: test-item of doc-class \<open>F\<close> with a relational link between class instances, 
     and links to formal Isabelle items like \<open>typ\<close>, \<open>term\<close> and \<open>thm\<close>. \<close>
text*[xcv4::F, r="[@{thm ''HOL.refl''}, 
                   @{thm \<open>TermAntiquotations.murks\<close>}]", (* long names required *)
               b="{(@{docitem ''xcv1''},@{docitem \<open>xcv2\<close>})}",  (* notations \<open>...\<close> vs. ''...'' *)
               s="[@{typ \<open>int list\<close>}]",                        
               properties = "[@{term \<open>H \<longrightarrow> H\<close>}]"              (* notation \<open>...\<close> required for UTF8*)
]\<open>Lorem ipsum ...\<close>

text*[xcv5::G, g="@{thm \<open>HOL.sym\<close>}"]\<open>Lorem ipsum ...\<close>

text\<open>... and here we add a relation between @{docitem \<open>xcv3\<close>} and @{docitem \<open>xcv2\<close>} 
into the relation \verb+b+ of @{docitem \<open>xcv5\<close>}. Note that in the link-relation,
a @{typ "C"}-type is required, but a  @{typ "G"}-type is offered which is legal in
\verb+Isa_DOF+ because of the sub-class relation between those classes: \<close>
update_instance*[xcv4::F, b+="{(@{docitem ''xcv3''},@{docitem ''xcv5''})}"]

text\<open>And here is the results of some ML-term antiquotations:\<close>
ML\<open> @{docitem_attribute b::xcv4} \<close>
ML\<open> @{docitem xcv4}              \<close>
ML\<open> @{docitem_name xcv4}         \<close>
ML\<open> @{trace_attribute aaa}       \<close>

text\<open>Now we might need to reference a class instance in a term command and we would like
Isabelle to check that this instance is indeed an instance of this class.
Here, we want to reference the instance @{docitem_name "xcv4"} previously defined.
We can use the term* command which extends the classic term command
and does the appropriate checking.\<close>
term*\<open>@{F \<open>xcv4\<close>}\<close>

text\<open>We can also reference an attribute of the instance.
Here we reference the attribute r of the class F which has the type @{typ \<open>thm list\<close>}.\<close>
term*\<open>r @{F \<open>xcv4\<close>}\<close>

text\<open>We declare a new text element. Note that the class name contains an underscore "\_".\<close>
text*[te::text_element]\<open>Lorem ipsum...\<close>

text\<open>Unfortunately due to different lexical conventions for constant symbols and mixfix symbols
     this term antiquotation has to be denoted like this: @{term_ \<open>@{text-element \<open>te\<close>}\<close>}.
     We need to substitute an hyphen "-" for the underscore "\_".\<close>
term*\<open>@{text-element \<open>te\<close>}\<close>

text\<open>Terms containing term antiquotations can be checked and evaluated
using \<^theory_text>\<open>term_\<close> and \<^theory_text>\<open>value_\<close> text antiquotations respectively:
We can print the term @{term_ \<open>r @{F \<open>xcv4\<close>}\<close>} with \<open>@{term_ \<open>r @{F \<open>xcv4\<close>}\<close>}\<close>
or get the value of the \<^const>\<open>F.r\<close> attribute of @{docitem \<open>xcv4\<close>} with \<open>@{value_ \<open>r @{F \<open>xcv4\<close>}\<close>}\<close>
\<^theory_text>\<open>value_\<close> may have an optional argument between square brackets to specify the evaluator but this
argument must be specified after a default optional argument already defined
by the text antiquotation implementation.
So one must use the following syntax if he does not want to specify the first optional argument:
\<open>@{value_ [] [nbe] \<open>r @{F \<open>xcv4\<close>}\<close>}\<close>. Note the empty brackets.

\<close>

text\<open>There also are \<^theory_text>\<open>term_\<close> and \<^theory_text>\<open>value_\<close> ML antiquotations:
\<^ML>\<open>@{term_ \<open>r @{F \<open>xcv4\<close>}\<close>}\<close> will return the ML representation of the term \<^term_>\<open>r @{F \<open>xcv4\<close>}\<close>,
and \<^ML>\<open>@{value_ \<open>r @{F \<open>xcv4\<close>}\<close>}\<close> will return the ML representation
of the value of the \<^const>\<open>F.r\<close> attribute of @{docitem \<open>xcv4\<close>}.
\<^theory_text>\<open>value_\<close> may have an optional argument between square brackets to specify the evaluator:
\<close>

ML\<open>
val t = @{term_ \<open>r @{F \<open>xcv4\<close>}\<close>}
val tt = @{value_ [nbe] \<open>r @{F \<open>xcv4\<close>}\<close>}
\<close>

record BBB =
bbb ::int

record cc = BBB +
cc :: int

definition BB1 :: BBB where "BB1 \<equiv> \<lparr> bbb = 2\<rparr>"

find_consts name:"bb"

ML\<open>
val t = \<^Const>\<open>bb \<^typ>\<open>BB\<close>\<close> 
\<close>

ML\<open>
val (Const(s, _), _) = Consts.check_const (Context.Proof \<^context>)
                            (Sign.consts_of \<^theory>)
                            ("bb", [Position.none])
val ns = Consts.space_of (Sign.consts_of \<^theory>)
val {pos, ...} = Name_Space.the_entry ns s
\<close>
term*\<open>
A.x @{A \<open>xcv1\<close>} = 5

\<close>
end

