src/Pure/Isar/named_target.ML
changeset 57196 d9a18e44b80d
parent 57195 ec0e10f11276
child 57483 950dc7446454
equal deleted inserted replaced
57195:ec0e10f11276 57196:d9a18e44b80d
    19 structure Named_Target: NAMED_TARGET =
    19 structure Named_Target: NAMED_TARGET =
    20 struct
    20 struct
    21 
    21 
    22 (* context data *)
    22 (* context data *)
    23 
    23 
    24 datatype target =
       
    25   Target of {target: string, is_locale: bool, is_class: bool};
       
    26 
       
    27 fun make_target target is_locale is_class =
       
    28   Target {target = target, is_locale = is_locale, is_class = is_class};
       
    29 
       
    30 fun named_target _ "" = make_target "" false false
       
    31   | named_target thy target =
       
    32       if Locale.defined thy target
       
    33       then make_target target true (Class.is_class thy target)
       
    34       else error ("No such locale: " ^ quote target);
       
    35 
       
    36 structure Data = Proof_Data
    24 structure Data = Proof_Data
    37 (
    25 (
    38   type T = target option;
    26   type T = (string * bool) option;
    39   fun init _ = NONE;
    27   fun init _ = NONE;
    40 );
    28 );
    41 
    29 
    42 val get_bottom_data = Option.map (fn Target ta => ta) o Data.get;
    30 val get_bottom_data = Data.get;
    43 
    31 
    44 fun get_data lthy =
    32 fun get_data lthy =
    45   if Local_Theory.level lthy = 1
    33   if Local_Theory.level lthy = 1
    46   then get_bottom_data lthy
    34   then get_bottom_data lthy
    47   else NONE;
    35   else NONE;
    48 
    36 
    49 fun is_theory lthy =
    37 fun is_theory lthy =
    50   case get_data lthy of
    38   case get_data lthy of
    51     SOME {target = "", ...} => true
    39     SOME ("", _) => true
    52   | _ => false;
    40   | _ => false;
    53 
    41 
    54 fun locale_of lthy =
    42 fun locale_name_of NONE = NONE
    55   case get_data lthy of
    43   | locale_name_of (SOME ("", _)) = NONE
    56     SOME {target = locale, is_locale = true, ...} => SOME locale
    44   | locale_name_of (SOME (locale, _)) = SOME locale;
    57   | _ => NONE;
       
    58 
    45 
    59 fun bottom_locale_of lthy =
    46 val locale_of = locale_name_of o get_data;
    60   case get_bottom_data lthy of
    47 
    61     SOME {target = locale, is_locale = true, ...} => SOME locale
    48 val bottom_locale_of = locale_name_of o get_bottom_data;
    62   | _ => NONE;
       
    63 
    49 
    64 fun class_of lthy =
    50 fun class_of lthy =
    65   case get_data lthy of
    51   case get_data lthy of
    66     SOME {target = class, is_class = true, ...} => SOME class
    52     SOME (class, true) => SOME class
    67   | _ => NONE;
    53   | _ => NONE;
    68 
    54 
    69 
    55 
    70 (* define *)
    56 (* define *)
    71 
    57 
    77 fun class_foundation class (((b, U), mx), (b_def, rhs)) params =
    63 fun class_foundation class (((b, U), mx), (b_def, rhs)) params =
    78   Generic_Target.background_foundation (((b, U), NoSyn), (b_def, rhs)) params
    64   Generic_Target.background_foundation (((b, U), NoSyn), (b_def, rhs)) params
    79   #-> (fn (lhs, def) => Class.const class ((b, mx), lhs) params
    65   #-> (fn (lhs, def) => Class.const class ((b, mx), lhs) params
    80     #> pair (lhs, def));
    66     #> pair (lhs, def));
    81 
    67 
    82 fun foundation (Target {target, is_locale, is_class, ...}) =
    68 fun foundation ("", _) = Generic_Target.theory_foundation
    83   if is_class then class_foundation target
    69   | foundation (locale, false) = locale_foundation locale
    84   else if is_locale then locale_foundation target
    70   | foundation (class, true) = class_foundation class;
    85   else Generic_Target.theory_foundation;
       
    86 
    71 
    87 
    72 
    88 (* notes *)
    73 (* notes *)
    89 
    74 
    90 fun notes (Target {target, is_locale, ...}) =
    75 fun notes ("", _) = Generic_Target.theory_notes
    91   if is_locale then Generic_Target.locale_notes target
    76   | notes (locale, _) = Generic_Target.locale_notes locale;
    92   else Generic_Target.theory_notes;
       
    93 
    77 
    94 
    78 
    95 (* abbrev *)
    79 (* abbrev *)
    96 
    80 
    97 fun locale_abbrev locale prmode (b, mx) global_rhs params =
    81 fun locale_abbrev locale prmode (b, mx) global_rhs params =
   100 
    84 
   101 fun class_abbrev class prmode (b, mx) global_rhs params =
    85 fun class_abbrev class prmode (b, mx) global_rhs params =
   102   Generic_Target.background_abbrev (b, global_rhs) (snd params)
    86   Generic_Target.background_abbrev (b, global_rhs) (snd params)
   103   #-> (fn (lhs, rhs) => Class.abbrev class prmode ((b, mx), lhs) rhs params);
    87   #-> (fn (lhs, rhs) => Class.abbrev class prmode ((b, mx), lhs) rhs params);
   104 
    88 
   105 fun abbrev (Target {target, is_locale, is_class, ...}) =
    89 fun abbrev ("", _) = Generic_Target.theory_abbrev
   106   if is_class then class_abbrev target
    90   | abbrev (locale, false) = locale_abbrev locale
   107   else if is_locale then locale_abbrev target
    91   | abbrev (class, true) = class_abbrev class;
   108   else Generic_Target.theory_abbrev;
       
   109 
    92 
   110 
    93 
   111 (* declaration *)
    94 (* declaration *)
   112 
    95 
   113 fun declaration (Target {target, is_locale, ...}) flags decl =
    96 fun declaration ("", _) flags decl = Generic_Target.theory_declaration decl
   114   if is_locale then Generic_Target.locale_declaration target flags decl
    97   | declaration (locale, _) flags decl = Generic_Target.locale_declaration locale flags decl;
   115   else Generic_Target.theory_declaration decl;
       
   116 
    98 
   117 
    99 
   118 (* subscription *)
   100 (* subscription *)
   119 
   101 
   120 fun subscription (Target {target, is_locale, ...}) =
   102 fun subscription ("", _) = Generic_Target.theory_registration
   121   if is_locale then Generic_Target.locale_dependency target
   103   | subscription (locale, _) = Generic_Target.locale_dependency locale;
   122   else Generic_Target.theory_registration;
       
   123 
   104 
   124 
   105 
   125 (* pretty *)
   106 (* pretty *)
   126 
   107 
   127 fun pretty (Target {target, is_locale, is_class, ...}) ctxt =
   108 fun pretty (target, is_class) ctxt =
   128   let
   109   let
   129     val target_name =
   110     val target_name =
   130       [Pretty.keyword1 (if is_class then "class" else "locale"), Pretty.brk 1,
   111       [Pretty.keyword1 (if is_class then "class" else "locale"), Pretty.brk 1,
   131         Locale.pretty_name ctxt target];
   112         Locale.pretty_name ctxt target];
   132     val fixes =
   113     val fixes =
   137         (Assumption.all_assms_of ctxt);
   118         (Assumption.all_assms_of ctxt);
   138     val elems =
   119     val elems =
   139       (if null fixes then [] else [Element.Fixes fixes]) @
   120       (if null fixes then [] else [Element.Fixes fixes]) @
   140       (if null assumes then [] else [Element.Assumes assumes]);
   121       (if null assumes then [] else [Element.Assumes assumes]);
   141     val body_elems =
   122     val body_elems =
   142       if not is_locale then []
   123       if target = "" then []
   143       else if null elems then [Pretty.block target_name]
   124       else if null elems then [Pretty.block target_name]
   144       else [Pretty.block (Pretty.fbreaks (Pretty.block (target_name @ [Pretty.str " ="]) ::
   125       else [Pretty.block (Pretty.fbreaks (Pretty.block (target_name @ [Pretty.str " ="]) ::
   145         map (Pretty.chunks o Element.pretty_ctxt ctxt) elems))];
   126         map (Pretty.chunks o Element.pretty_ctxt ctxt) elems))];
   146   in
   127   in
   147     Pretty.block [Pretty.keyword1 "theory", Pretty.brk 1,
   128     Pretty.block [Pretty.keyword1 "theory", Pretty.brk 1,
   149   end;
   130   end;
   150 
   131 
   151 
   132 
   152 (* init *)
   133 (* init *)
   153 
   134 
   154 fun init_context (Target {target, is_locale, is_class, ...}) =
   135 fun make_name_data _ "" = ("", false)
   155   if not is_locale then Proof_Context.init_global
   136   | make_name_data thy target =
   156   else if not is_class then Locale.init target
   137       if Locale.defined thy target
   157   else Class.init target;
   138       then (target, Class.is_class thy target)
       
   139       else error ("No such locale: " ^ quote target);
       
   140 
       
   141 fun init_context ("", _) = Proof_Context.init_global
       
   142   | init_context (locale, false) = Locale.init locale
       
   143   | init_context (class, true) = Class.init class;
   158 
   144 
   159 fun init target thy =
   145 fun init target thy =
   160   let
   146   let
   161     val ta = named_target thy target;
   147     val name_data = make_name_data thy target;
   162     val naming = Sign.naming_of thy
   148     val naming = Sign.naming_of thy
   163       |> Name_Space.mandatory_path (Long_Name.base_name target);
   149       |> Name_Space.mandatory_path (Long_Name.base_name target);
   164   in
   150   in
   165     thy
   151     thy
   166     |> Sign.change_begin
   152     |> Sign.change_begin
   167     |> init_context ta
   153     |> init_context name_data
   168     |> Data.put (SOME ta)
   154     |> Data.put (SOME name_data)
   169     |> Local_Theory.init naming
   155     |> Local_Theory.init naming
   170        {define = Generic_Target.define (foundation ta),
   156        {define = Generic_Target.define (foundation name_data),
   171         notes = Generic_Target.notes (notes ta),
   157         notes = Generic_Target.notes (notes name_data),
   172         abbrev = Generic_Target.abbrev (abbrev ta),
   158         abbrev = Generic_Target.abbrev (abbrev name_data),
   173         declaration = declaration ta,
   159         declaration = declaration name_data,
   174         subscription = subscription ta,
   160         subscription = subscription name_data,
   175         pretty = pretty ta,
   161         pretty = pretty name_data,
   176         exit = Local_Theory.target_of #> Sign.change_end_local}
   162         exit = Local_Theory.target_of #> Sign.change_end_local}
   177   end;
   163   end;
   178 
   164 
   179 val theory_init = init "";
   165 val theory_init = init "";
   180 
   166