src/Pure/Isar/local_theory.ML
changeset 51735 f069c7d496ca
parent 50741 20e6e1a92e54
child 52118 2a976115c7c3
equal deleted inserted replaced
51734:d504e349e951 51735:f069c7d496ca
    12   type operations
    12   type operations
    13   val assert: local_theory -> local_theory
    13   val assert: local_theory -> local_theory
    14   val restore: local_theory -> local_theory
    14   val restore: local_theory -> local_theory
    15   val level: Proof.context -> int
    15   val level: Proof.context -> int
    16   val assert_bottom: bool -> local_theory -> local_theory
    16   val assert_bottom: bool -> local_theory -> local_theory
       
    17   val mark_brittle: local_theory -> local_theory
       
    18   val assert_nonbrittle: local_theory -> local_theory
    17   val open_target: Name_Space.naming -> operations -> (local_theory -> local_theory) ->
    19   val open_target: Name_Space.naming -> operations -> (local_theory -> local_theory) ->
    18     local_theory -> local_theory
    20     local_theory -> local_theory
    19   val close_target: local_theory -> local_theory
    21   val close_target: local_theory -> local_theory
    20   val map_contexts: (int -> Proof.context -> Proof.context) -> local_theory -> local_theory
    22   val map_contexts: (int -> Proof.context -> Proof.context) -> local_theory -> local_theory
    21   val naming_of: local_theory -> Name_Space.naming
    23   val naming_of: local_theory -> Name_Space.naming
    93 
    95 
    94 (* context data *)
    96 (* context data *)
    95 
    97 
    96 structure Data = Proof_Data
    98 structure Data = Proof_Data
    97 (
    99 (
    98   type T = lthy list;
   100   type T = lthy list * bool;
    99   fun init _ = [];
   101   fun init _ = ([], false);
   100 );
   102 );
   101 
   103 
   102 fun assert lthy =
   104 fun assert lthy =
   103   if null (Data.get lthy) then error "Missing local theory context" else lthy;
   105   if null (fst (Data.get lthy)) then error "Missing local theory context" else lthy;
   104 
   106 
   105 val get_last_lthy = List.last o Data.get o assert;
   107 val get_last_lthy = List.last o fst o Data.get o assert;
   106 val get_first_lthy = hd o Data.get o assert;
   108 val get_first_lthy = hd o fst o Data.get o assert;
   107 
   109 
   108 fun map_first_lthy f =
   110 fun map_first_lthy f =
   109   assert #>
   111   assert #>
   110   Data.map (fn {naming, operations, after_close, target} :: parents =>
   112   (Data.map o apfst) (fn {naming, operations, after_close, target} :: parents =>
   111     make_lthy (f (naming, operations, after_close, target)) :: parents);
   113     make_lthy (f (naming, operations, after_close, target)) :: parents);
   112 
   114 
   113 fun restore lthy = #target (get_first_lthy lthy) |> Data.put (Data.get lthy);
   115 fun restore lthy = #target (get_first_lthy lthy) |> Data.put (fst (Data.get lthy), false);
   114 
   116 
   115 
   117 
   116 (* nested structure *)
   118 (* nested structure *)
   117 
   119 
   118 val level = length o Data.get;  (*1: main target at bottom, >= 2: nested context*)
   120 val level = length o fst o Data.get;  (*1: main target at bottom, >= 2: nested context*)
   119 
   121 
   120 fun assert_bottom b lthy =
   122 fun assert_bottom b lthy =
   121   let
   123   let
   122     val _ = assert lthy;
   124     val _ = assert lthy;
   123     val b' = level lthy <= 1;
   125     val b' = level lthy <= 1;
   127     else lthy
   129     else lthy
   128   end;
   130   end;
   129 
   131 
   130 fun open_target naming operations after_close target =
   132 fun open_target naming operations after_close target =
   131   assert target
   133   assert target
   132   |> Data.map (cons (make_lthy (naming, operations, after_close, target)));
   134   |> (Data.map o apfst) (cons (make_lthy (naming, operations, after_close, target)));
   133 
   135 
   134 fun close_target lthy =
   136 fun close_target lthy =
   135   let
   137   let
   136     val _ = assert_bottom false lthy;
   138     val _ = assert_bottom false lthy;
   137     val {after_close, ...} :: rest = Data.get lthy;
   139     val ({after_close, ...} :: rest, tainted) = Data.get lthy;
   138   in lthy |> Data.put rest |> restore |> after_close end;
   140   in lthy |> Data.put (rest, tainted) |> restore |> after_close end;
   139 
   141 
   140 fun map_contexts f lthy =
   142 fun map_contexts f lthy =
   141   let val n = level lthy in
   143   let val n = level lthy in
   142     lthy |> (Data.map o map_index) (fn (i, {naming, operations, after_close, target}) =>
   144     lthy |> (Data.map o apfst o map_index) (fn (i, {naming, operations, after_close, target}) =>
   143       make_lthy (naming, operations, after_close,
   145       make_lthy (naming, operations, after_close,
   144         target
   146         target
   145         |> Context_Position.set_visible false
   147         |> Context_Position.set_visible false
   146         |> f (n - i - 1)
   148         |> f (n - i - 1)
   147         |> Context_Position.restore_visible target))
   149         |> Context_Position.restore_visible target))
   148     |> f n
   150     |> f n
   149   end;
   151   end;
       
   152 
       
   153 
       
   154 (* brittle context -- implicit for nested structures *)
       
   155 
       
   156 val mark_brittle = Data.map (fn ([data], _) => ([data], true) | x => x);
       
   157 
       
   158 fun assert_nonbrittle lthy =
       
   159   if snd (Data.get lthy) orelse level lthy > 1
       
   160   then error "Brittle local theory context"
       
   161   else lthy;
   150 
   162 
   151 
   163 
   152 (* naming *)
   164 (* naming *)
   153 
   165 
   154 val naming_of = #naming o get_first_lthy;
   166 val naming_of = #naming o get_first_lthy;
   288 (** init and exit **)
   300 (** init and exit **)
   289 
   301 
   290 (* init *)
   302 (* init *)
   291 
   303 
   292 fun init naming operations target =
   304 fun init naming operations target =
   293   target |> Data.map
   305   target |> (Data.map o apfst)
   294     (fn [] => [make_lthy (naming, operations, I, target)]
   306     (fn [] => [make_lthy (naming, operations, I, target)]
   295       | _ => error "Local theory already initialized")
   307       | _ => error "Local theory already initialized")
   296   |> checkpoint;
   308   |> checkpoint;
   297 
   309 
   298 
   310