src/Pure/context.ML
author wenzelm
Fri Dec 14 11:52:54 2001 +0100 (2001-12-14)
changeset 12498 3b0091bf06e8
parent 11819 9283b3c11234
child 14976 65f572245276
permissions -rw-r--r--
changed Thm.varifyT';
wenzelm@6185
     1
(*  Title:      Pure/context.ML
wenzelm@6185
     2
    ID:         $Id$
wenzelm@6185
     3
    Author:     Markus Wenzel, TU Muenchen
wenzelm@11819
     4
    License:    GPL (GNU GENERAL PUBLIC LICENSE)
wenzelm@6185
     5
wenzelm@6185
     6
Global theory context.
wenzelm@6185
     7
*)
wenzelm@6185
     8
wenzelm@6185
     9
signature BASIC_CONTEXT =
wenzelm@6185
    10
sig
wenzelm@6185
    11
  val context: theory -> unit
wenzelm@6185
    12
  val the_context: unit -> theory
wenzelm@6185
    13
end;
wenzelm@6185
    14
wenzelm@6185
    15
signature CONTEXT =
wenzelm@6185
    16
sig
wenzelm@6185
    17
  include BASIC_CONTEXT
wenzelm@6185
    18
  val get_context: unit -> theory option
wenzelm@6185
    19
  val set_context: theory option -> unit
wenzelm@6185
    20
  val reset_context: unit -> unit
wenzelm@6238
    21
  val setmp: theory option -> ('a -> 'b) -> 'a -> 'b
wenzelm@6310
    22
  val pass: theory option -> ('a -> 'b) -> 'a -> 'b * theory option
wenzelm@6310
    23
  val pass_theory: theory -> ('a -> 'b) -> 'a -> 'b * theory
wenzelm@6238
    24
  val save: ('a -> 'b) -> 'a -> 'b
wenzelm@6185
    25
  val >> : (theory -> theory) -> unit
wenzelm@10914
    26
  val ml_output: (string -> unit) * (string -> unit)
wenzelm@8348
    27
  val use_mltext: string -> bool -> theory option -> unit
wenzelm@8348
    28
  val use_mltext_theory: string -> bool -> theory -> theory
wenzelm@8348
    29
  val use_let: string -> string -> string -> theory -> theory
wenzelm@8348
    30
  val use_setup: string -> theory -> theory
wenzelm@6185
    31
end;
wenzelm@6185
    32
wenzelm@6185
    33
structure Context: CONTEXT =
wenzelm@6185
    34
struct
wenzelm@6185
    35
wenzelm@6185
    36
wenzelm@6185
    37
(* theory context *)
wenzelm@6185
    38
wenzelm@6185
    39
local
wenzelm@6185
    40
  val current_theory = ref (None: theory option);
wenzelm@6185
    41
in
wenzelm@6185
    42
  fun get_context () = ! current_theory;
wenzelm@6185
    43
  fun set_context opt_thy = current_theory := opt_thy;
wenzelm@6238
    44
  fun setmp opt_thy f x = Library.setmp current_theory opt_thy f x;
wenzelm@6185
    45
end;
wenzelm@6185
    46
wenzelm@6185
    47
fun the_context () =
wenzelm@6185
    48
  (case get_context () of
wenzelm@6185
    49
    Some thy => thy
wenzelm@6185
    50
  | _ => error "Unknown theory context");
wenzelm@6185
    51
wenzelm@6185
    52
fun context thy = set_context (Some thy);
wenzelm@6185
    53
fun reset_context () = set_context None;
wenzelm@6185
    54
wenzelm@6310
    55
fun pass opt_thy f x =
wenzelm@6261
    56
  setmp opt_thy (fn x => let val y = f x in (y, get_context ()) end) x;
wenzelm@6261
    57
wenzelm@6310
    58
fun pass_theory thy f x =
wenzelm@6310
    59
  (case pass (Some thy) f x of
wenzelm@6261
    60
    (y, Some thy') => (y, thy')
wenzelm@8801
    61
  | (_, None) => error "Lost theory context in ML");
wenzelm@6261
    62
wenzelm@6238
    63
fun save f x = setmp (get_context ()) f x;
wenzelm@6238
    64
wenzelm@6185
    65
wenzelm@6185
    66
(* map context *)
wenzelm@6185
    67
wenzelm@6185
    68
nonfix >>;
wenzelm@6185
    69
fun >> f = set_context (Some (f (the_context ())));
wenzelm@6185
    70
wenzelm@6185
    71
wenzelm@8348
    72
(* use ML text *)
wenzelm@8348
    73
wenzelm@10914
    74
val ml_output = (writeln, error_msg: string -> unit);
wenzelm@10924
    75
fun use_output verb txt = use_text ml_output verb (Symbol.plain_output 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;