src/Pure/context.ML
author berghofe
Thu Apr 21 19:12:03 2005 +0200 (2005-04-21)
changeset 15797 a63605582573
parent 15531 08c8dad8e399
child 15801 d2f5ca3c048d
permissions -rw-r--r--
- Eliminated nodup_vars check.
- Unification and matching functions now check types of term variables / sorts
of type variables when applying a substitution.
- Thm.instantiate now takes (ctyp * ctyp) list instead of (indexname * ctyp) list
as argument, to allow for proper instantiation of theorems containing
type variables with same name but different sorts.
wenzelm@6185
     1
(*  Title:      Pure/context.ML
wenzelm@6185
     2
    ID:         $Id$
wenzelm@6185
     3
    Author:     Markus Wenzel, TU Muenchen
wenzelm@6185
     4
wenzelm@6185
     5
Global theory context.
wenzelm@6185
     6
*)
wenzelm@6185
     7
wenzelm@6185
     8
signature BASIC_CONTEXT =
wenzelm@6185
     9
sig
wenzelm@6185
    10
  val context: theory -> unit
wenzelm@6185
    11
  val the_context: unit -> theory
wenzelm@6185
    12
end;
wenzelm@6185
    13
wenzelm@6185
    14
signature CONTEXT =
wenzelm@6185
    15
sig
wenzelm@6185
    16
  include BASIC_CONTEXT
wenzelm@6185
    17
  val get_context: unit -> theory option
wenzelm@6185
    18
  val set_context: theory option -> unit
wenzelm@6185
    19
  val reset_context: unit -> unit
wenzelm@6238
    20
  val setmp: theory option -> ('a -> 'b) -> 'a -> 'b
wenzelm@6310
    21
  val pass: theory option -> ('a -> 'b) -> 'a -> 'b * theory option
wenzelm@6310
    22
  val pass_theory: theory -> ('a -> 'b) -> 'a -> 'b * theory
wenzelm@6238
    23
  val save: ('a -> 'b) -> 'a -> 'b
wenzelm@6185
    24
  val >> : (theory -> theory) -> unit
wenzelm@10914
    25
  val ml_output: (string -> unit) * (string -> unit)
wenzelm@8348
    26
  val use_mltext: string -> bool -> theory option -> unit
wenzelm@8348
    27
  val use_mltext_theory: string -> bool -> theory -> theory
wenzelm@8348
    28
  val use_let: string -> string -> string -> theory -> theory
wenzelm@8348
    29
  val use_setup: string -> theory -> theory
wenzelm@6185
    30
end;
wenzelm@6185
    31
wenzelm@6185
    32
structure Context: CONTEXT =
wenzelm@6185
    33
struct
wenzelm@6185
    34
wenzelm@6185
    35
wenzelm@6185
    36
(* theory context *)
wenzelm@6185
    37
wenzelm@6185
    38
local
skalberg@15531
    39
  val current_theory = ref (NONE: theory option);
wenzelm@6185
    40
in
wenzelm@6185
    41
  fun get_context () = ! current_theory;
wenzelm@6185
    42
  fun set_context opt_thy = current_theory := opt_thy;
wenzelm@6238
    43
  fun setmp opt_thy f x = Library.setmp current_theory opt_thy f x;
wenzelm@6185
    44
end;
wenzelm@6185
    45
wenzelm@6185
    46
fun the_context () =
wenzelm@6185
    47
  (case get_context () of
skalberg@15531
    48
    SOME thy => thy
wenzelm@6185
    49
  | _ => error "Unknown theory context");
wenzelm@6185
    50
skalberg@15531
    51
fun context thy = set_context (SOME thy);
skalberg@15531
    52
fun reset_context () = set_context NONE;
wenzelm@6185
    53
wenzelm@6310
    54
fun pass opt_thy f x =
wenzelm@6261
    55
  setmp opt_thy (fn x => let val y = f x in (y, get_context ()) end) x;
wenzelm@6261
    56
wenzelm@6310
    57
fun pass_theory thy f x =
skalberg@15531
    58
  (case pass (SOME thy) f x of
skalberg@15531
    59
    (y, SOME thy') => (y, thy')
skalberg@15531
    60
  | (_, NONE) => error "Lost theory context in ML");
wenzelm@6261
    61
wenzelm@6238
    62
fun save f x = setmp (get_context ()) f x;
wenzelm@6238
    63
wenzelm@6185
    64
wenzelm@6185
    65
(* map context *)
wenzelm@6185
    66
wenzelm@6185
    67
nonfix >>;
skalberg@15531
    68
fun >> f = set_context (SOME (f (the_context ())));
wenzelm@6185
    69
wenzelm@6185
    70
wenzelm@8348
    71
(* use ML text *)
wenzelm@8348
    72
wenzelm@10914
    73
val ml_output = (writeln, error_msg: string -> unit);
wenzelm@14976
    74
wenzelm@14976
    75
fun use_output verb txt = use_text ml_output verb (Symbol.escape txt);
wenzelm@10914
    76
wenzelm@10924
    77
fun use_mltext txt verb opt_thy = setmp opt_thy (fn () => use_output verb txt) ();
wenzelm@10924
    78
fun use_mltext_theory txt verb thy = #2 (pass_theory thy (use_output verb) txt);
wenzelm@8348
    79
wenzelm@8348
    80
fun use_context txt = use_mltext_theory ("Context.>> (" ^ txt ^ ");") false;
wenzelm@8348
    81
wenzelm@9586
    82
fun use_let bind body txt =
wenzelm@9586
    83
  use_context ("let " ^ bind ^ " = " ^ txt ^ " in\n" ^ body ^ " end");
wenzelm@8348
    84
wenzelm@8348
    85
val use_setup =
wenzelm@9586
    86
  use_let "val setup: (theory -> theory) list" "Library.apply setup";
wenzelm@8348
    87
wenzelm@8348
    88
wenzelm@6185
    89
end;
wenzelm@6185
    90
wenzelm@6185
    91
structure BasicContext: BASIC_CONTEXT = Context;
wenzelm@6185
    92
open BasicContext;