src/Pure/Isar/constdefs.ML
author wenzelm
Sat Jan 21 23:02:14 2006 +0100 (2006-01-21)
changeset 18728 6790126ab5f6
parent 18668 4a15c09bd46a
child 18765 97911ffe9222
permissions -rw-r--r--
simplified type attribute;
wenzelm@14657
     1
(*  Title:      Pure/Isar/constdefs.ML
wenzelm@14657
     2
    ID:         $Id$
wenzelm@14657
     3
    Author:     Makarius, Hagia Maria Sion Abbey (Jerusalem)
wenzelm@14657
     4
wenzelm@14657
     5
Standard constant definitions, with type-inference and optional
wenzelm@14657
     6
structure context; specifications need to observe strictly sequential
wenzelm@14657
     7
dependencies; no support for overloading.
wenzelm@14657
     8
*)
wenzelm@14657
     9
wenzelm@14657
    10
signature CONSTDEFS =
wenzelm@14657
    11
sig
wenzelm@18668
    12
  val add_constdefs: (string * string option) list *
wenzelm@18668
    13
    ((bstring * string option * mixfix) option * ((bstring * Attrib.src list) * string)) list ->
wenzelm@18668
    14
    theory -> theory
wenzelm@18668
    15
  val add_constdefs_i: (string * typ option) list *
wenzelm@18728
    16
    ((bstring * typ option * mixfix) option * ((bstring * attribute list) * term)) list ->
wenzelm@18668
    17
    theory -> theory
wenzelm@14657
    18
end;
wenzelm@14657
    19
wenzelm@14657
    20
structure Constdefs: CONSTDEFS =
wenzelm@14657
    21
struct
wenzelm@14657
    22
wenzelm@14657
    23
(** add_constdefs(_i) **)
wenzelm@14657
    24
wenzelm@18668
    25
fun gen_constdef prep_vars prep_term prep_att
wenzelm@18668
    26
    structs (raw_decl, ((raw_name, raw_atts), raw_prop)) thy =
wenzelm@14657
    27
  let
wenzelm@14664
    28
    fun err msg ts =
wenzelm@17065
    29
      error (cat_lines (msg :: map (Sign.string_of_term thy) ts));
wenzelm@14664
    30
wenzelm@18668
    31
    val (_, ctxt) = thy |> ProofContext.init |> ProofContext.add_fixes_i structs;
wenzelm@18668
    32
    val ((d, mx), ctxt') =
wenzelm@18668
    33
      (case raw_decl of
wenzelm@18668
    34
        NONE => ((NONE, NoSyn), ctxt)
wenzelm@18668
    35
      | SOME raw_var =>
wenzelm@18668
    36
          ctxt |> prep_vars [raw_var] |-> (fn [(x, T, mx)] =>
wenzelm@18668
    37
            ProofContext.add_fixes_legacy [(x, T, mx)] #> snd #> pair (SOME x, mx)));
wenzelm@14657
    38
wenzelm@14657
    39
    val prop = prep_term ctxt' raw_prop;
wenzelm@14664
    40
    val concl = Logic.strip_imp_concl prop;
wenzelm@14664
    41
    val (lhs, _) = Logic.dest_equals concl handle TERM _ =>
wenzelm@14664
    42
      err "Not a meta-equality (==):" [concl];
wenzelm@14664
    43
    val head = Term.head_of lhs;
wenzelm@14664
    44
    val (c, T) = Term.dest_Free head handle TERM _ =>
wenzelm@14664
    45
      err "Locally fixed variable required as head of definition:" [head];
skalberg@15531
    46
    val _ = (case d of NONE => () | SOME c' =>
wenzelm@14719
    47
      if c <> c' then
wenzelm@14719
    48
        err ("Head of definition " ^ quote c ^ " differs from declaration " ^ quote c') []
wenzelm@14664
    49
      else ());
wenzelm@14657
    50
wenzelm@17065
    51
    val def = Term.subst_atomic [(Free (c, T), Const (Sign.full_name thy c, T))] prop;
wenzelm@14657
    52
    val name = if raw_name = "" then Thm.def_name c else raw_name;
wenzelm@14657
    53
    val atts = map (prep_att thy) raw_atts;
wenzelm@14664
    54
wenzelm@14664
    55
    val thy' =
wenzelm@14664
    56
      thy
wenzelm@14664
    57
      |> Theory.add_consts_i [(c, T, mx)]
wenzelm@18668
    58
      |> PureThy.add_defs_i false [((name, def), atts)] |> snd;
wenzelm@17853
    59
  in ((c, T), thy') end;
wenzelm@14657
    60
wenzelm@18668
    61
fun gen_constdefs prep_vars prep_term prep_att (raw_structs, specs) thy =
wenzelm@14664
    62
  let
wenzelm@18638
    63
    val ctxt = ProofContext.init thy;
wenzelm@18668
    64
    val (structs, _) = prep_vars (map (fn (x, T) => (x, T, Structure)) raw_structs) ctxt;
wenzelm@18668
    65
    val (decls, thy') = fold_map (gen_constdef prep_vars prep_term prep_att structs) specs thy;
wenzelm@18638
    66
  in Pretty.writeln (Specification.pretty_consts ctxt decls); thy' end;
wenzelm@14657
    67
wenzelm@18668
    68
val add_constdefs = gen_constdefs ProofContext.read_vars_legacy
wenzelm@18728
    69
  ProofContext.read_term_legacy Attrib.attribute;
wenzelm@18668
    70
val add_constdefs_i = gen_constdefs ProofContext.cert_vars_legacy ProofContext.cert_term (K I);
wenzelm@14657
    71
wenzelm@14657
    72
end;