src/Pure/Isar/overloading.ML
author wenzelm
Sat Apr 16 15:25:25 2011 +0200 (2011-04-16)
changeset 42359 6ca5407863ed
parent 40782 aa533c5e3f48
child 42360 da8817d01e7c
permissions -rw-r--r--
prefer local name spaces;
tuned signatures;
tuned;
haftmann@25519
     1
(*  Title:      Pure/Isar/overloading.ML
haftmann@25519
     2
    Author:     Florian Haftmann, TU Muenchen
haftmann@25519
     3
haftmann@25519
     4
Overloaded definitions without any discipline.
haftmann@25519
     5
*)
haftmann@25519
     6
haftmann@25519
     7
signature OVERLOADING =
haftmann@25519
     8
sig
haftmann@26238
     9
  type improvable_syntax
haftmann@39378
    10
  val activate_improvable_syntax: Proof.context -> Proof.context
haftmann@26238
    11
  val map_improvable_syntax: (improvable_syntax -> improvable_syntax)
haftmann@26238
    12
    -> Proof.context -> Proof.context
haftmann@26520
    13
  val set_primary_constraints: Proof.context -> Proof.context
haftmann@38342
    14
haftmann@38342
    15
  val overloading: (string * (string * typ) * bool) list -> theory -> local_theory
haftmann@38342
    16
  val overloading_cmd: (string * string * bool) list -> theory -> local_theory
haftmann@25519
    17
end;
haftmann@25519
    18
haftmann@25519
    19
structure Overloading: OVERLOADING =
haftmann@25519
    20
struct
haftmann@25519
    21
haftmann@26259
    22
(** generic check/uncheck combinators for improvable constants **)
haftmann@26238
    23
haftmann@26249
    24
type improvable_syntax = ((((string * typ) list * (string * typ) list) *
haftmann@26730
    25
  ((((string * typ -> (typ * typ) option) * (string * typ -> (typ * term) option)) * bool) *
haftmann@26249
    26
    (term * term) list)) * bool);
haftmann@25519
    27
wenzelm@33519
    28
structure ImprovableSyntax = Proof_Data
wenzelm@33519
    29
(
haftmann@26249
    30
  type T = {
haftmann@26520
    31
    primary_constraints: (string * typ) list,
haftmann@26520
    32
    secondary_constraints: (string * typ) list,
haftmann@26249
    33
    improve: string * typ -> (typ * typ) option,
haftmann@26249
    34
    subst: string * typ -> (typ * term) option,
haftmann@26730
    35
    consider_abbrevs: bool,
haftmann@26249
    36
    unchecks: (term * term) list,
haftmann@26249
    37
    passed: bool
haftmann@26249
    38
  };
haftmann@26238
    39
  fun init _ = {
haftmann@26520
    40
    primary_constraints = [],
haftmann@26520
    41
    secondary_constraints = [],
haftmann@26238
    42
    improve = K NONE,
haftmann@26238
    43
    subst = K NONE,
haftmann@26730
    44
    consider_abbrevs = false,
haftmann@26238
    45
    unchecks = [],
haftmann@26238
    46
    passed = true
haftmann@26238
    47
  };
haftmann@26238
    48
);
haftmann@25536
    49
haftmann@26520
    50
fun map_improvable_syntax f = ImprovableSyntax.map (fn { primary_constraints,
wenzelm@40782
    51
    secondary_constraints, improve, subst, consider_abbrevs, unchecks, passed } =>
wenzelm@40782
    52
  let
haftmann@26730
    53
    val (((primary_constraints', secondary_constraints'),
haftmann@26730
    54
      (((improve', subst'), consider_abbrevs'), unchecks')), passed')
haftmann@26730
    55
        = f (((primary_constraints, secondary_constraints),
haftmann@26730
    56
            (((improve, subst), consider_abbrevs), unchecks)), passed)
haftmann@26520
    57
  in { primary_constraints = primary_constraints', secondary_constraints = secondary_constraints',
haftmann@26730
    58
    improve = improve', subst = subst', consider_abbrevs = consider_abbrevs',
wenzelm@40782
    59
    unchecks = unchecks', passed = passed' }
wenzelm@40782
    60
  end);
haftmann@26238
    61
haftmann@26249
    62
val mark_passed = (map_improvable_syntax o apsnd) (K true);
haftmann@26238
    63
haftmann@26238
    64
fun improve_term_check ts ctxt =
haftmann@25519
    65
  let
wenzelm@36354
    66
    val { secondary_constraints, improve, subst, consider_abbrevs, passed, ... } =
wenzelm@36354
    67
      ImprovableSyntax.get ctxt;
haftmann@26238
    68
    val tsig = (Sign.tsig_of o ProofContext.theory_of) ctxt;
wenzelm@27285
    69
    val is_abbrev = consider_abbrevs andalso ProofContext.abbrev_mode ctxt;
haftmann@26730
    70
    val passed_or_abbrev = passed orelse is_abbrev;
haftmann@26238
    71
    fun accumulate_improvements (Const (c, ty)) = (case improve (c, ty)
haftmann@26597
    72
         of SOME ty_ty' => Type.typ_match tsig ty_ty'
haftmann@26238
    73
          | _ => I)
haftmann@26238
    74
      | accumulate_improvements _ = I;
haftmann@26238
    75
    val improvements = (fold o fold_aterms) accumulate_improvements ts Vartab.empty;
wenzelm@32035
    76
    val ts' = (map o map_types) (Envir.subst_type improvements) ts;
haftmann@26238
    77
    fun apply_subst t = Envir.expand_term (fn Const (c, ty) => (case subst (c, ty)
haftmann@26259
    78
         of SOME (ty', t') =>
haftmann@26238
    79
              if Type.typ_instance tsig (ty, ty')
haftmann@26238
    80
              then SOME (ty', apply_subst t') else NONE
haftmann@26238
    81
          | NONE => NONE)
haftmann@26259
    82
        | _ => NONE) t;
haftmann@26730
    83
    val ts'' = if is_abbrev then ts' else map apply_subst ts';
wenzelm@40782
    84
  in
wenzelm@40782
    85
    if eq_list (op aconv) (ts, ts'') andalso passed_or_abbrev then NONE else
haftmann@26730
    86
    if passed_or_abbrev then SOME (ts'', ctxt)
haftmann@26238
    87
    else SOME (ts'', ctxt
haftmann@26520
    88
      |> fold (ProofContext.add_const_constraint o apsnd SOME) secondary_constraints
haftmann@26238
    89
      |> mark_passed)
haftmann@26238
    90
  end;
haftmann@25519
    91
haftmann@31698
    92
fun rewrite_liberal thy unchecks t =
haftmann@31698
    93
  case try (Pattern.rewrite_term thy unchecks []) t
haftmann@31698
    94
   of NONE => NONE
haftmann@31698
    95
    | SOME t' => if t aconv t' then NONE else SOME t';
haftmann@31698
    96
haftmann@26238
    97
fun improve_term_uncheck ts ctxt =
haftmann@25519
    98
  let
haftmann@26238
    99
    val thy = ProofContext.theory_of ctxt;
haftmann@26238
   100
    val unchecks = (#unchecks o ImprovableSyntax.get) ctxt;
haftmann@31698
   101
    val ts' = map (rewrite_liberal thy unchecks) ts;
haftmann@31698
   102
  in if exists is_some ts' then SOME (map2 the_default ts ts', ctxt) else NONE end;
haftmann@26238
   103
haftmann@26520
   104
fun set_primary_constraints ctxt =
haftmann@26259
   105
  let
haftmann@26520
   106
    val { primary_constraints, ... } = ImprovableSyntax.get ctxt;
haftmann@26520
   107
  in fold (ProofContext.add_const_constraint o apsnd SOME) primary_constraints ctxt end;
haftmann@26259
   108
haftmann@39378
   109
val activate_improvable_syntax =
haftmann@26259
   110
  Context.proof_map
haftmann@26238
   111
    (Syntax.add_term_check 0 "improvement" improve_term_check
haftmann@26238
   112
    #> Syntax.add_term_uncheck 0 "improvement" improve_term_uncheck)
haftmann@26520
   113
  #> set_primary_constraints;
haftmann@26259
   114
haftmann@26259
   115
haftmann@26259
   116
(** overloading target **)
haftmann@26259
   117
haftmann@38382
   118
structure Data = Proof_Data
haftmann@26259
   119
(
haftmann@26259
   120
  type T = ((string * typ) * (string * bool)) list;
haftmann@26259
   121
  fun init _ = [];
haftmann@26259
   122
);
haftmann@26259
   123
haftmann@38382
   124
val get_overloading = Data.get o Local_Theory.target_of;
haftmann@38382
   125
val map_overloading = Local_Theory.target o Data.map;
haftmann@26259
   126
haftmann@30519
   127
fun operation lthy b = get_overloading lthy
haftmann@30519
   128
  |> get_first (fn ((c, _), (v, checked)) =>
haftmann@38382
   129
      if Binding.name_of b = v then SOME (c, (v, checked)) else NONE);
haftmann@26259
   130
haftmann@32343
   131
fun synchronize_syntax ctxt =
haftmann@32343
   132
  let
haftmann@38382
   133
    val overloading = Data.get ctxt;
haftmann@32343
   134
    fun subst (c, ty) = case AList.lookup (op =) overloading (c, ty)
haftmann@32343
   135
     of SOME (v, _) => SOME (ty, Free (v, ty))
haftmann@32343
   136
      | NONE => NONE;
haftmann@32343
   137
    val unchecks =
haftmann@32343
   138
      map (fn (c_ty as (_, ty), (v, _)) => (Free (v, ty), Const c_ty)) overloading;
haftmann@32343
   139
  in 
haftmann@32343
   140
    ctxt
haftmann@32343
   141
    |> map_improvable_syntax (K ((([], []), (((K NONE, subst), false), unchecks)), false))
haftmann@32343
   142
  end
haftmann@26259
   143
haftmann@38382
   144
fun define_overloaded (c, U) (v, checked) (b_def, rhs) =
wenzelm@38757
   145
  Local_Theory.background_theory_result
haftmann@38382
   146
    (Thm.add_def (not checked) true (b_def, Logic.mk_equals (Const (c, Term.fastype_of rhs), rhs)))
haftmann@38382
   147
  ##> map_overloading (filter_out (fn (_, (v', _)) => v' = v))
haftmann@38382
   148
  ##> Local_Theory.target synchronize_syntax
haftmann@38382
   149
  #-> (fn (_, def) => pair (Const (c, U), def))
haftmann@26259
   150
haftmann@38382
   151
fun foundation (((b, U), mx), (b_def, rhs)) (type_params, term_params) lthy =
haftmann@38382
   152
  case operation lthy b
haftmann@38382
   153
   of SOME (c, (v, checked)) => if mx <> NoSyn
haftmann@38382
   154
       then error ("Illegal mixfix syntax for overloaded constant " ^ quote c)
haftmann@38382
   155
        else lthy |> define_overloaded (c, U) (v, checked) (b_def, rhs)
haftmann@38382
   156
    | NONE => lthy |>
haftmann@38382
   157
        Generic_Target.theory_foundation (((b, U), mx), (b_def, rhs)) (type_params, term_params);
haftmann@25519
   158
haftmann@25606
   159
fun pretty lthy =
haftmann@25606
   160
  let
haftmann@25606
   161
    val overloading = get_overloading lthy;
haftmann@25606
   162
    fun pr_operation ((c, ty), (v, _)) =
wenzelm@42359
   163
      Pretty.block (Pretty.breaks
wenzelm@42359
   164
        [Pretty.str v, Pretty.str "==", Pretty.str (ProofContext.extern_const lthy c),
wenzelm@42359
   165
          Pretty.str "::", Syntax.pretty_typ lthy ty]);
haftmann@38382
   166
  in Pretty.str "overloading" :: map pr_operation overloading end;
haftmann@38342
   167
haftmann@38382
   168
fun conclude lthy =
haftmann@38382
   169
  let
haftmann@38382
   170
    val overloading = get_overloading lthy;
wenzelm@40782
   171
    val _ =
wenzelm@40782
   172
      if null overloading then ()
wenzelm@40782
   173
      else
wenzelm@40782
   174
        error ("Missing definition(s) for parameter(s) " ^ commas (map (quote
wenzelm@40782
   175
          o Syntax.string_of_term lthy o Const o fst) overloading));
haftmann@38382
   176
  in lthy end;
haftmann@38342
   177
haftmann@38382
   178
fun gen_overloading prep_const raw_overloading thy =
haftmann@38342
   179
  let
haftmann@38342
   180
    val ctxt = ProofContext.init_global thy;
haftmann@38382
   181
    val _ = if null raw_overloading then error "At least one parameter must be given" else ();
haftmann@38382
   182
    val overloading = raw_overloading |> map (fn (v, const, checked) =>
haftmann@38382
   183
      (Term.dest_Const (prep_const ctxt const), (v, checked)));
haftmann@38342
   184
  in
haftmann@38342
   185
    thy
haftmann@38382
   186
    |> Theory.checkpoint
haftmann@38382
   187
    |> ProofContext.init_global
haftmann@38382
   188
    |> Data.put overloading
haftmann@38382
   189
    |> fold (fn ((_, ty), (v, _)) => Variable.declare_names (Free (v, ty))) overloading
haftmann@39378
   190
    |> activate_improvable_syntax
haftmann@38382
   191
    |> synchronize_syntax
haftmann@38342
   192
    |> Local_Theory.init NONE ""
haftmann@38382
   193
       {define = Generic_Target.define foundation,
haftmann@38342
   194
        notes = Generic_Target.notes
haftmann@38342
   195
          (fn kind => fn global_facts => fn _ => Generic_Target.theory_notes kind global_facts),
haftmann@38342
   196
        abbrev = Generic_Target.abbrev
haftmann@38342
   197
          (fn prmode => fn (b, mx) => fn (t, _) => fn _ =>
haftmann@38342
   198
            Generic_Target.theory_abbrev prmode ((b, mx), t)),
haftmann@38342
   199
        declaration = K Generic_Target.theory_declaration,
haftmann@38342
   200
        syntax_declaration = K Generic_Target.theory_declaration,
haftmann@38382
   201
        pretty = pretty,
haftmann@38342
   202
        exit = Local_Theory.target_of o conclude}
haftmann@38342
   203
  end;
haftmann@38342
   204
haftmann@38342
   205
val overloading = gen_overloading (fn ctxt => Syntax.check_term ctxt o Const);
haftmann@38342
   206
val overloading_cmd = gen_overloading Syntax.read_term;
haftmann@38342
   207
haftmann@25519
   208
end;