src/Pure/primitive_defs.ML
author wenzelm
Sun, 22 Jul 2012 12:26:41 +0200
changeset 48423 0ccf143a2a69
parent 46218 ecf6375e2abb
child 56243 2e10a36b8d46
permissions -rw-r--r--
maintain set of source digests, including relevant parts of session entry;
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
24259
c9e05c49d02c Primitive definition forms.
wenzelm
parents:
diff changeset
     1
(*  Title:      Pure/primitive_defs.ML
c9e05c49d02c Primitive definition forms.
wenzelm
parents:
diff changeset
     2
    Author:     Makarius
c9e05c49d02c Primitive definition forms.
wenzelm
parents:
diff changeset
     3
c9e05c49d02c Primitive definition forms.
wenzelm
parents:
diff changeset
     4
Primitive definition forms.
c9e05c49d02c Primitive definition forms.
wenzelm
parents:
diff changeset
     5
*)
c9e05c49d02c Primitive definition forms.
wenzelm
parents:
diff changeset
     6
c9e05c49d02c Primitive definition forms.
wenzelm
parents:
diff changeset
     7
signature PRIMITIVE_DEFS =
c9e05c49d02c Primitive definition forms.
wenzelm
parents:
diff changeset
     8
sig
24981
4ec3f95190bf dest/cert_def: replaced Pretty.pp by explicit Proof.context;
wenzelm
parents: 24259
diff changeset
     9
  val dest_def: Proof.context -> (term -> bool) -> (string -> bool) -> (string -> bool) ->
24259
c9e05c49d02c Primitive definition forms.
wenzelm
parents:
diff changeset
    10
    term -> (term * term) * term
c9e05c49d02c Primitive definition forms.
wenzelm
parents:
diff changeset
    11
  val abs_def: term -> term * term
c9e05c49d02c Primitive definition forms.
wenzelm
parents:
diff changeset
    12
end;
c9e05c49d02c Primitive definition forms.
wenzelm
parents:
diff changeset
    13
33385
fb2358edcfb6 modernized structure Primitive_Defs;
wenzelm
parents: 30364
diff changeset
    14
structure Primitive_Defs: PRIMITIVE_DEFS =
24259
c9e05c49d02c Primitive definition forms.
wenzelm
parents:
diff changeset
    15
struct
c9e05c49d02c Primitive definition forms.
wenzelm
parents:
diff changeset
    16
c9e05c49d02c Primitive definition forms.
wenzelm
parents:
diff changeset
    17
fun term_kind (Const _) = "existing constant "
c9e05c49d02c Primitive definition forms.
wenzelm
parents:
diff changeset
    18
  | term_kind (Free _) = "free variable "
c9e05c49d02c Primitive definition forms.
wenzelm
parents:
diff changeset
    19
  | term_kind (Bound _) = "bound variable "
c9e05c49d02c Primitive definition forms.
wenzelm
parents:
diff changeset
    20
  | term_kind _ = "";
c9e05c49d02c Primitive definition forms.
wenzelm
parents:
diff changeset
    21
c9e05c49d02c Primitive definition forms.
wenzelm
parents:
diff changeset
    22
(*c x == t[x] to !!x. c x == t[x]*)
24981
4ec3f95190bf dest/cert_def: replaced Pretty.pp by explicit Proof.context;
wenzelm
parents: 24259
diff changeset
    23
fun dest_def ctxt check_head is_fixed is_fixedT eq =
24259
c9e05c49d02c Primitive definition forms.
wenzelm
parents:
diff changeset
    24
  let
c9e05c49d02c Primitive definition forms.
wenzelm
parents:
diff changeset
    25
    fun err msg = raise TERM (msg, [eq]);
c9e05c49d02c Primitive definition forms.
wenzelm
parents:
diff changeset
    26
    val eq_vars = Term.strip_all_vars eq;
c9e05c49d02c Primitive definition forms.
wenzelm
parents:
diff changeset
    27
    val eq_body = Term.strip_all_body eq;
c9e05c49d02c Primitive definition forms.
wenzelm
parents:
diff changeset
    28
c9e05c49d02c Primitive definition forms.
wenzelm
parents:
diff changeset
    29
    val display_terms =
42284
326f57825e1a explicit structure Syntax_Trans;
wenzelm
parents: 35989
diff changeset
    30
      commas_quote o map (Syntax.string_of_term ctxt o Syntax_Trans.bound_vars eq_vars);
24981
4ec3f95190bf dest/cert_def: replaced Pretty.pp by explicit Proof.context;
wenzelm
parents: 24259
diff changeset
    31
    val display_types = commas_quote o map (Syntax.string_of_typ ctxt);
24259
c9e05c49d02c Primitive definition forms.
wenzelm
parents:
diff changeset
    32
c9e05c49d02c Primitive definition forms.
wenzelm
parents:
diff changeset
    33
    val (raw_lhs, rhs) = Logic.dest_equals eq_body handle TERM _ => err "Not a meta-equality (==)";
c9e05c49d02c Primitive definition forms.
wenzelm
parents:
diff changeset
    34
    val lhs = Envir.beta_eta_contract raw_lhs;
c9e05c49d02c Primitive definition forms.
wenzelm
parents:
diff changeset
    35
    val (head, args) = Term.strip_comb lhs;
c9e05c49d02c Primitive definition forms.
wenzelm
parents:
diff changeset
    36
    val head_tfrees = Term.add_tfrees head [];
c9e05c49d02c Primitive definition forms.
wenzelm
parents:
diff changeset
    37
c9e05c49d02c Primitive definition forms.
wenzelm
parents:
diff changeset
    38
    fun check_arg (Bound _) = true
c9e05c49d02c Primitive definition forms.
wenzelm
parents:
diff changeset
    39
      | check_arg (Free (x, _)) = not (is_fixed x)
c9e05c49d02c Primitive definition forms.
wenzelm
parents:
diff changeset
    40
      | check_arg (Const ("TYPE", Type ("itself", [TFree _]))) = true
c9e05c49d02c Primitive definition forms.
wenzelm
parents:
diff changeset
    41
      | check_arg _ = false;
c9e05c49d02c Primitive definition forms.
wenzelm
parents:
diff changeset
    42
    fun close_arg (Bound _) t = t
46214
wenzelm
parents: 44241
diff changeset
    43
      | close_arg x t = Logic.all x t;
24259
c9e05c49d02c Primitive definition forms.
wenzelm
parents:
diff changeset
    44
c9e05c49d02c Primitive definition forms.
wenzelm
parents:
diff changeset
    45
    val lhs_bads = filter_out check_arg args;
c9e05c49d02c Primitive definition forms.
wenzelm
parents:
diff changeset
    46
    val lhs_dups = duplicates (op aconv) args;
c9e05c49d02c Primitive definition forms.
wenzelm
parents:
diff changeset
    47
    val rhs_extras = Term.fold_aterms (fn v as Free (x, _) =>
c9e05c49d02c Primitive definition forms.
wenzelm
parents:
diff changeset
    48
      if is_fixed x orelse member (op aconv) args v then I
c9e05c49d02c Primitive definition forms.
wenzelm
parents:
diff changeset
    49
      else insert (op aconv) v | _ => I) rhs [];
c9e05c49d02c Primitive definition forms.
wenzelm
parents:
diff changeset
    50
    val rhs_extrasT = Term.fold_aterms (Term.fold_types (fn v as TFree (a, S) =>
c9e05c49d02c Primitive definition forms.
wenzelm
parents:
diff changeset
    51
      if is_fixedT a orelse member (op =) head_tfrees (a, S) then I
c9e05c49d02c Primitive definition forms.
wenzelm
parents:
diff changeset
    52
      else insert (op =) v | _ => I)) rhs [];
c9e05c49d02c Primitive definition forms.
wenzelm
parents:
diff changeset
    53
  in
c9e05c49d02c Primitive definition forms.
wenzelm
parents:
diff changeset
    54
    if not (check_head head) then
c9e05c49d02c Primitive definition forms.
wenzelm
parents:
diff changeset
    55
      err ("Bad head of lhs: " ^ term_kind head ^ display_terms [head])
c9e05c49d02c Primitive definition forms.
wenzelm
parents:
diff changeset
    56
    else if not (null lhs_bads) then
c9e05c49d02c Primitive definition forms.
wenzelm
parents:
diff changeset
    57
      err ("Bad arguments on lhs: " ^ display_terms lhs_bads)
c9e05c49d02c Primitive definition forms.
wenzelm
parents:
diff changeset
    58
    else if not (null lhs_dups) then
c9e05c49d02c Primitive definition forms.
wenzelm
parents:
diff changeset
    59
      err ("Duplicate arguments on lhs: " ^ display_terms lhs_dups)
c9e05c49d02c Primitive definition forms.
wenzelm
parents:
diff changeset
    60
    else if not (null rhs_extras) then
c9e05c49d02c Primitive definition forms.
wenzelm
parents:
diff changeset
    61
      err ("Extra variables on rhs: " ^ display_terms rhs_extras)
c9e05c49d02c Primitive definition forms.
wenzelm
parents:
diff changeset
    62
    else if not (null rhs_extrasT) then
c9e05c49d02c Primitive definition forms.
wenzelm
parents:
diff changeset
    63
      err ("Extra type variables on rhs: " ^ display_types rhs_extrasT)
c9e05c49d02c Primitive definition forms.
wenzelm
parents:
diff changeset
    64
    else if exists_subterm (fn t => t aconv head) rhs then
c9e05c49d02c Primitive definition forms.
wenzelm
parents:
diff changeset
    65
      err "Entity to be defined occurs on rhs"
c9e05c49d02c Primitive definition forms.
wenzelm
parents:
diff changeset
    66
    else
46218
ecf6375e2abb renamed Term.list_all to Logic.list_all, in accordance to HOLogic.list_all;
wenzelm
parents: 46214
diff changeset
    67
      ((lhs, rhs), fold_rev close_arg args (Logic.list_all (eq_vars, (Logic.mk_equals (lhs, rhs)))))
24259
c9e05c49d02c Primitive definition forms.
wenzelm
parents:
diff changeset
    68
  end;
c9e05c49d02c Primitive definition forms.
wenzelm
parents:
diff changeset
    69
c9e05c49d02c Primitive definition forms.
wenzelm
parents:
diff changeset
    70
(*!!x. c x == t[x] to c == %x. t[x]*)
c9e05c49d02c Primitive definition forms.
wenzelm
parents:
diff changeset
    71
fun abs_def eq =
c9e05c49d02c Primitive definition forms.
wenzelm
parents:
diff changeset
    72
  let
c9e05c49d02c Primitive definition forms.
wenzelm
parents:
diff changeset
    73
    val body = Term.strip_all_body eq;
c9e05c49d02c Primitive definition forms.
wenzelm
parents:
diff changeset
    74
    val vars = map Free (Term.rename_wrt_term body (Term.strip_all_vars eq));
c9e05c49d02c Primitive definition forms.
wenzelm
parents:
diff changeset
    75
    val (lhs, rhs) = Logic.dest_equals (Term.subst_bounds (vars, body));
c9e05c49d02c Primitive definition forms.
wenzelm
parents:
diff changeset
    76
    val (lhs', args) = Term.strip_comb lhs;
44241
7943b69f0188 modernized signature of Term.absfree/absdummy;
wenzelm
parents: 42284
diff changeset
    77
    val rhs' = fold_rev (absfree o dest_Free) args rhs;
24259
c9e05c49d02c Primitive definition forms.
wenzelm
parents:
diff changeset
    78
  in (lhs', rhs') end;
c9e05c49d02c Primitive definition forms.
wenzelm
parents:
diff changeset
    79
c9e05c49d02c Primitive definition forms.
wenzelm
parents:
diff changeset
    80
end;