src/Pure/context.ML
author wenzelm
Mon Aug 14 14:49:49 2000 +0200 (2000-08-14)
changeset 9586 f6669dead969
parent 8801 9d01c9a26134
child 10893 408906dd1e1b
permissions -rw-r--r--
use_let: exclude 'val';
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@8348
    25
  val use_mltext: string -> bool -> theory option -> unit
wenzelm@8348
    26
  val use_mltext_theory: string -> bool -> theory -> theory
wenzelm@8348
    27
  val use_let: string -> string -> string -> theory -> theory
wenzelm@8348
    28
  val use_setup: string -> theory -> theory
wenzelm@6185
    29
end;
wenzelm@6185
    30
wenzelm@6185
    31
structure Context: CONTEXT =
wenzelm@6185
    32
struct
wenzelm@6185
    33
wenzelm@6185
    34
wenzelm@6185
    35
(* theory context *)
wenzelm@6185
    36
wenzelm@6185
    37
local
wenzelm@6185
    38
  val current_theory = ref (None: theory option);
wenzelm@6185
    39
in
wenzelm@6185
    40
  fun get_context () = ! current_theory;
wenzelm@6185
    41
  fun set_context opt_thy = current_theory := opt_thy;
wenzelm@6238
    42
  fun setmp opt_thy f x = Library.setmp current_theory opt_thy f x;
wenzelm@6185
    43
end;
wenzelm@6185
    44
wenzelm@6185
    45
fun the_context () =
wenzelm@6185
    46
  (case get_context () of
wenzelm@6185
    47
    Some thy => thy
wenzelm@6185
    48
  | _ => error "Unknown theory context");
wenzelm@6185
    49
wenzelm@6185
    50
fun context thy = set_context (Some thy);
wenzelm@6185
    51
fun reset_context () = set_context None;
wenzelm@6185
    52
wenzelm@6310
    53
fun pass opt_thy f x =
wenzelm@6261
    54
  setmp opt_thy (fn x => let val y = f x in (y, get_context ()) end) x;
wenzelm@6261
    55
wenzelm@6310
    56
fun pass_theory thy f x =
wenzelm@6310
    57
  (case pass (Some thy) f x of
wenzelm@6261
    58
    (y, Some thy') => (y, thy')
wenzelm@8801
    59
  | (_, None) => error "Lost theory context in ML");
wenzelm@6261
    60
wenzelm@6238
    61
fun save f x = setmp (get_context ()) f x;
wenzelm@6238
    62
wenzelm@6185
    63
wenzelm@6185
    64
(* map context *)
wenzelm@6185
    65
wenzelm@6185
    66
nonfix >>;
wenzelm@6185
    67
fun >> f = set_context (Some (f (the_context ())));
wenzelm@6185
    68
wenzelm@6185
    69
wenzelm@8348
    70
(* use ML text *)
wenzelm@8348
    71
wenzelm@9586
    72
fun use_mltext txt verb opt_thy = setmp opt_thy (fn () => use_text writeln verb txt) ();
wenzelm@8348
    73
fun use_mltext_theory txt verb thy = #2 (pass_theory thy (use_text writeln verb) txt);
wenzelm@8348
    74
wenzelm@8348
    75
fun use_context txt = use_mltext_theory ("Context.>> (" ^ txt ^ ");") false;
wenzelm@8348
    76
wenzelm@9586
    77
fun use_let bind body txt =
wenzelm@9586
    78
  use_context ("let " ^ bind ^ " = " ^ txt ^ " in\n" ^ body ^ " end");
wenzelm@8348
    79
wenzelm@8348
    80
val use_setup =
wenzelm@9586
    81
  use_let "val setup: (theory -> theory) list" "Library.apply setup";
wenzelm@8348
    82
wenzelm@8348
    83
wenzelm@6185
    84
end;
wenzelm@6185
    85
wenzelm@6185
    86
structure BasicContext: BASIC_CONTEXT = Context;
wenzelm@6185
    87
open BasicContext;