src/Pure/context.ML
changeset 22085 c138cfd500f7
parent 21962 279b129498b6
child 22095 07875394618e
equal deleted inserted replaced
22084:2fef69700f50 22085:c138cfd500f7
    10 signature BASIC_CONTEXT =
    10 signature BASIC_CONTEXT =
    11 sig
    11 sig
    12   type theory
    12   type theory
    13   type theory_ref
    13   type theory_ref
    14   exception THEORY of string * theory list
    14   exception THEORY of string * theory list
    15   val context: theory -> unit
       
    16   val the_context: unit -> theory
    15   val the_context: unit -> theory
    17 end;
    16 end;
    18 
    17 
    19 signature CONTEXT =
    18 signature CONTEXT =
    20 sig
    19 sig
    47   val checkpoint_thy: theory -> theory
    46   val checkpoint_thy: theory -> theory
    48   val finish_thy: theory -> theory
    47   val finish_thy: theory -> theory
    49   val theory_data_of: theory -> string list
    48   val theory_data_of: theory -> string list
    50   val pre_pure_thy: theory
    49   val pre_pure_thy: theory
    51   val begin_thy: (theory -> Pretty.pp) -> string -> theory list -> theory
    50   val begin_thy: (theory -> Pretty.pp) -> string -> theory list -> theory
    52   (*ML theory context*)
       
    53   val get_context: unit -> theory option
       
    54   val set_context: theory option -> unit
       
    55   val reset_context: unit -> unit
       
    56   val setmp: theory option -> ('a -> 'b) -> 'a -> 'b
       
    57   val pass: theory option -> ('a -> 'b) -> 'a -> 'b * theory option
       
    58   val pass_theory: theory -> ('a -> 'b) -> 'a -> 'b * theory
       
    59   val save: ('a -> 'b) -> 'a -> 'b
       
    60   val >> : (theory -> theory) -> unit
       
    61   val use_mltext: string -> bool -> theory option -> unit
       
    62   val use_mltext_theory: string -> bool -> theory -> theory
       
    63   val use_let: string -> string -> string -> theory -> theory
       
    64   val add_setup: (theory -> theory) -> unit
       
    65   val setup: unit -> theory -> theory
       
    66   (*proof context*)
    51   (*proof context*)
    67   type proof
    52   type proof
    68   val theory_of_proof: proof -> theory
    53   val theory_of_proof: proof -> theory
    69   val transfer_proof: theory -> proof -> proof
    54   val transfer_proof: theory -> proof -> proof
    70   val init_proof: theory -> proof
    55   val init_proof: theory -> proof
    80   val map_proof: (proof -> proof) -> generic -> generic
    65   val map_proof: (proof -> proof) -> generic -> generic
    81   val theory_map: (generic -> generic) -> theory -> theory
    66   val theory_map: (generic -> generic) -> theory -> theory
    82   val proof_map: (generic -> generic) -> proof -> proof
    67   val proof_map: (generic -> generic) -> proof -> proof
    83   val theory_of: generic -> theory   (*total*)
    68   val theory_of: generic -> theory   (*total*)
    84   val proof_of: generic -> proof     (*total*)
    69   val proof_of: generic -> proof     (*total*)
       
    70   (*ML context*)
       
    71   val get_context: unit -> generic option
       
    72   val set_context: generic option -> unit
       
    73   val setmp: generic option -> ('a -> 'b) -> 'a -> 'b
       
    74   val the_generic_context: unit -> generic
       
    75   val the_local_context: unit -> proof
       
    76   val pass: generic option -> ('a -> 'b) -> 'a -> 'b * generic option
       
    77   val pass_context: generic -> ('a -> 'b) -> 'a -> 'b * generic
       
    78   val save: ('a -> 'b) -> 'a -> 'b
       
    79   val >> : (theory -> theory) -> unit
       
    80   val use_mltext: string -> bool -> generic option -> unit
       
    81   val use_mltext_update: string -> bool -> generic -> generic
       
    82   val use_let: string -> string -> string -> generic -> generic
       
    83   val add_setup: (theory -> theory) -> unit
       
    84   val setup: unit -> theory -> theory
    85 end;
    85 end;
    86 
    86 
    87 signature PRIVATE_CONTEXT =
    87 signature PRIVATE_CONTEXT =
    88 sig
    88 sig
    89   include CONTEXT
    89   include CONTEXT
   445 
   445 
   446 end;
   446 end;
   447 
   447 
   448 
   448 
   449 
   449 
   450 (*** ML theory context ***)
       
   451 
       
   452 local
       
   453   val current_theory = ref (NONE: theory option);
       
   454 in
       
   455   fun get_context () = ! current_theory;
       
   456   fun set_context opt_thy = current_theory := opt_thy;
       
   457   fun setmp opt_thy f x = Library.setmp current_theory opt_thy f x;
       
   458 end;
       
   459 
       
   460 fun the_context () =
       
   461   (case get_context () of
       
   462     SOME thy => thy
       
   463   | _ => error "Unknown theory context");
       
   464 
       
   465 fun context thy = set_context (SOME thy);
       
   466 fun reset_context () = set_context NONE;
       
   467 
       
   468 fun pass opt_thy f x =
       
   469   setmp opt_thy (fn x => let val y = f x in (y, get_context ()) end) x;
       
   470 
       
   471 fun pass_theory thy f x =
       
   472   (case pass (SOME thy) f x of
       
   473     (y, SOME thy') => (y, thy')
       
   474   | (_, NONE) => error "Lost theory context in ML");
       
   475 
       
   476 fun save f x = setmp (get_context ()) f x;
       
   477 
       
   478 
       
   479 (* map context *)
       
   480 
       
   481 nonfix >>;
       
   482 fun >> f = set_context (SOME (f (the_context ())));
       
   483 
       
   484 
       
   485 (* use ML text *)
       
   486 
       
   487 fun use_output verbose txt =
       
   488   Output.ML_errors (use_text Output.ml_output verbose) (Symbol.escape txt);
       
   489 
       
   490 fun use_mltext txt verbose opt_thy = setmp opt_thy (fn () => use_output verbose txt) ();
       
   491 fun use_mltext_theory txt verbose thy = #2 (pass_theory thy (use_output verbose) txt);
       
   492 
       
   493 fun use_context txt = use_mltext_theory ("Context.>> (" ^ txt ^ ");") false;
       
   494 
       
   495 fun use_let bind body txt =
       
   496   use_context ("let " ^ bind ^ " = " ^ txt ^ " in\n" ^ body ^ " end");
       
   497 
       
   498 
       
   499 (* delayed theory setup *)
       
   500 
       
   501 local
       
   502   val setup_fn = ref (I: theory -> theory);
       
   503 in
       
   504   fun add_setup f = setup_fn := (! setup_fn #> f);
       
   505   fun setup () = let val f = ! setup_fn in setup_fn := I; f end;
       
   506 end;
       
   507 
       
   508 
       
   509 
       
   510 (*** proof context ***)
   450 (*** proof context ***)
   511 
   451 
   512 (* datatype proof *)
   452 (* datatype proof *)
   513 
   453 
   514 datatype proof = Proof of theory_ref * Object.T Datatab.table;
   454 datatype proof = Proof of theory_ref * Object.T Datatab.table;
   599 fun proof_map f = the_proof o f o Proof;
   539 fun proof_map f = the_proof o f o Proof;
   600 
   540 
   601 val theory_of = cases I theory_of_proof;
   541 val theory_of = cases I theory_of_proof;
   602 val proof_of = cases init_proof I;
   542 val proof_of = cases init_proof I;
   603 
   543 
       
   544 
       
   545 
       
   546 (*** ML context ***)
       
   547 
       
   548 local
       
   549   val current_context = ref (NONE: generic option);
       
   550 in
       
   551   fun get_context () = ! current_context;
       
   552   fun set_context opt_context = current_context := opt_context;
       
   553   fun setmp opt_context f x = Library.setmp current_context opt_context f x;
       
   554 end;
       
   555 
       
   556 fun the_generic_context () =
       
   557   (case get_context () of
       
   558     SOME context => context
       
   559   | _ => error "Unknown context");
       
   560 
       
   561 val the_context = theory_of o the_generic_context;
       
   562 val the_local_context = the_proof o the_generic_context;
       
   563 
       
   564 fun pass opt_context f x =
       
   565   setmp opt_context (fn x => let val y = f x in (y, get_context ()) end) x;
       
   566 
       
   567 fun pass_context context f x =
       
   568   (case pass (SOME context) f x of
       
   569     (y, SOME context') => (y, context')
       
   570   | (_, NONE) => error "Lost context in ML");
       
   571 
       
   572 fun save f x = setmp (get_context ()) f x;
       
   573 
       
   574 
       
   575 (* map context *)
       
   576 
       
   577 nonfix >>;
       
   578 fun >> f = set_context (SOME (map_theory f (the_generic_context ())));
       
   579 
       
   580 
       
   581 (* use ML text *)
       
   582 
       
   583 fun use_output verbose txt =
       
   584   Output.ML_errors (use_text Output.ml_output verbose) (Symbol.escape txt);
       
   585 
       
   586 fun use_mltext txt verbose opt_context = setmp opt_context (fn () => use_output verbose txt) ();
       
   587 fun use_mltext_update txt verbose context = #2 (pass_context context (use_output verbose) txt);
       
   588 
       
   589 fun use_context txt = use_mltext_update
       
   590     ("Context.set_context (SOME ((" ^ txt ^ ") (Context.the_generic_context ())));") false;
       
   591 
       
   592 fun use_let bind body txt =
       
   593   use_context ("let " ^ bind ^ " = " ^ txt ^ " in\n" ^ body ^ " end");
       
   594 
       
   595 
       
   596 (* delayed theory setup *)
       
   597 
       
   598 local
       
   599   val setup_fn = ref (I: theory -> theory);
       
   600 in
       
   601   fun add_setup f = setup_fn := (! setup_fn #> f);
       
   602   fun setup () = let val f = ! setup_fn in setup_fn := I; f end;
       
   603 end;
       
   604 
   604 end;
   605 end;
   605 
   606 
   606 structure BasicContext: BASIC_CONTEXT = Context;
   607 structure BasicContext: BASIC_CONTEXT = Context;
   607 open BasicContext;
   608 open BasicContext;
   608 
   609