src/Pure/Isar/locale.ML
author wenzelm
Mon Nov 05 21:03:08 2001 +0100 (2001-11-05)
changeset 12058 cc182b43dd55
parent 12046 a404358fd965
child 12063 4c16bdee47d4
permissions -rw-r--r--
fixes: optional typ;
removed garbage;
wenzelm@12014
     1
(*  Title:      Pure/Isar/locale.ML
wenzelm@11896
     2
    ID:         $Id$
wenzelm@11896
     3
    Author:     Markus Wenzel, TU Muenchen
wenzelm@11896
     4
    License:    GPL (GNU GENERAL PUBLIC LICENSE)
wenzelm@11896
     5
wenzelm@12058
     6
Locales -- Isar proof contexts as meta-level predicates, with local
wenzelm@12058
     7
syntax and implicit structures.
wenzelm@11896
     8
wenzelm@11896
     9
TODO:
wenzelm@12014
    10
  - reset scope context on qed of legacy goal (!??);
wenzelm@12046
    11
  - implicit closure of ``loose'' free vars;
wenzelm@12046
    12
  - avoid dynamic scoping of facts/atts
wenzelm@12046
    13
    (use thms_closure for globals, even within att expressions);
wenzelm@12046
    14
  - scope of implicit fixed in elementents vs. locales (!??);
wenzelm@12058
    15
  - remove scope stuff;
wenzelm@11896
    16
*)
wenzelm@11896
    17
wenzelm@11896
    18
signature BASIC_LOCALE =
wenzelm@11896
    19
sig
wenzelm@11896
    20
  val print_locales: theory -> unit
wenzelm@11896
    21
end;
wenzelm@11896
    22
wenzelm@11896
    23
signature LOCALE =
wenzelm@11896
    24
sig
wenzelm@11896
    25
  include BASIC_LOCALE
wenzelm@12046
    26
  type context
wenzelm@12014
    27
  type expression
wenzelm@12046
    28
  datatype ('typ, 'term, 'fact, 'att) elem =
wenzelm@12058
    29
    Fixes of (string * 'typ option * mixfix option) list |
wenzelm@12046
    30
    Assumes of ((string * 'att list) * ('term * ('term list * 'term list)) list) list |
wenzelm@12046
    31
    Defines of ((string * 'att list) * ('term * 'term list)) list |
wenzelm@12046
    32
    Notes of ((string * 'att list) * ('fact * 'att list) list) list |
wenzelm@12046
    33
    Uses of expression
wenzelm@12046
    34
  type 'att element
wenzelm@12046
    35
  type 'att element_i
wenzelm@12046
    36
  type locale
wenzelm@12046
    37
  val intern: Sign.sg -> xstring -> string
wenzelm@12014
    38
  val cond_extern: Sign.sg -> string -> xstring
wenzelm@12046
    39
  val intern_att: ('att -> context attribute) ->
wenzelm@12046
    40
    ('typ, 'term, 'thm, 'att) elem -> ('typ, 'term, 'thm, context attribute) elem
wenzelm@12046
    41
  val activate_elements: context attribute element list -> context -> context
wenzelm@12046
    42
  val activate_elements_i: context attribute element_i list -> context -> context
wenzelm@12046
    43
  val activate_locale: xstring -> context -> context
wenzelm@12046
    44
  val activate_locale_i: string -> context -> context
wenzelm@12014
    45
(*
wenzelm@12014
    46
  val add_locale: bstring -> xstring option -> (string * string * mixfix) list ->
wenzelm@12046
    47
    ((string * context attribute list) * string) list ->
wenzelm@12046
    48
    ((string * context attribute list) * string) list -> theory -> theory
wenzelm@12014
    49
  val add_locale_i: bstring -> xstring option -> (string * typ * mixfix) list ->
wenzelm@12046
    50
    ((string * context attribute list) * term) list ->
wenzelm@12046
    51
    ((string * context attribute list) * term) list -> theory -> theory
wenzelm@12014
    52
  val read_prop_schematic: Sign.sg -> string -> cterm
wenzelm@12014
    53
*)
wenzelm@11896
    54
  val setup: (theory -> theory) list
wenzelm@11896
    55
end;
wenzelm@11896
    56
wenzelm@11896
    57
structure Locale: LOCALE =
wenzelm@11896
    58
struct
wenzelm@11896
    59
wenzelm@11896
    60
wenzelm@12014
    61
(** locale elements and locales **)
wenzelm@11896
    62
wenzelm@12014
    63
type context = ProofContext.context;
wenzelm@11896
    64
wenzelm@12014
    65
type expression = unit;  (* FIXME *)
wenzelm@11896
    66
wenzelm@12046
    67
datatype ('typ, 'term, 'fact, 'att) elem =
wenzelm@12058
    68
  Fixes of (string * 'typ option * mixfix option) list |
wenzelm@12046
    69
  Assumes of ((string * 'att list) * ('term * ('term list * 'term list)) list) list |
wenzelm@12046
    70
  Defines of ((string * 'att list) * ('term * 'term list)) list |
wenzelm@12046
    71
  Notes of ((string * 'att list) * ('fact * 'att list) list) list |
wenzelm@12014
    72
  Uses of expression;
wenzelm@11896
    73
wenzelm@12046
    74
type 'att element = (string, string, string, 'att) elem;
wenzelm@12046
    75
type 'att element_i = (typ, term, thm list, 'att) elem;
wenzelm@12046
    76
type locale = (thm -> string) * string list * context attribute element_i list;
wenzelm@12046
    77
wenzelm@12046
    78
wenzelm@12014
    79
fun fixes_of_elem (Fixes fixes) = map #1 fixes
wenzelm@12014
    80
  | fixes_of_elem _ = [];
wenzelm@11896
    81
wenzelm@12014
    82
fun frees_of_elem _ = [];  (* FIXME *)
wenzelm@11896
    83
wenzelm@11896
    84
wenzelm@11896
    85
wenzelm@11896
    86
(** theory data **)
wenzelm@11896
    87
wenzelm@11896
    88
(* data kind 'Pure/locales' *)
wenzelm@11896
    89
wenzelm@11896
    90
type locale_data =
wenzelm@11896
    91
  {space: NameSpace.T,
wenzelm@11896
    92
    locales: locale Symtab.table,
wenzelm@12046
    93
    scope: ((string * locale) list * context option) ref};
wenzelm@11896
    94
wenzelm@11896
    95
fun make_locale_data space locales scope =
wenzelm@11896
    96
  {space = space, locales = locales, scope = scope}: locale_data;
wenzelm@11896
    97
wenzelm@12014
    98
val empty_scope = ([], None);
wenzelm@12014
    99
wenzelm@11896
   100
structure LocalesArgs =
wenzelm@11896
   101
struct
wenzelm@12014
   102
  val name = "Isar/locales";
wenzelm@11896
   103
  type T = locale_data;
wenzelm@11896
   104
wenzelm@12014
   105
  val empty = make_locale_data NameSpace.empty Symtab.empty (ref empty_scope);
wenzelm@12014
   106
  fun copy {space, locales, scope = ref r} = make_locale_data space locales (ref r);
wenzelm@12014
   107
  fun prep_ext {space, locales, scope = _} = make_locale_data space locales (ref empty_scope);
wenzelm@11896
   108
  fun merge ({space = space1, locales = locales1, scope = _},
wenzelm@11896
   109
    {space = space2, locales = locales2, scope = _}) =
wenzelm@11896
   110
      make_locale_data (NameSpace.merge (space1, space2))
wenzelm@12014
   111
        (Symtab.merge (K true) (locales1, locales2)) (ref empty_scope);
wenzelm@11896
   112
wenzelm@12014
   113
  fun print _ {space, locales, scope = _} =
wenzelm@12014
   114
    Pretty.strs ("locales:" :: map (NameSpace.cond_extern space o #1) (Symtab.dest locales))
wenzelm@12014
   115
    |> Pretty.writeln;
wenzelm@11896
   116
end;
wenzelm@11896
   117
wenzelm@11896
   118
structure LocalesData = TheoryDataFun(LocalesArgs);
wenzelm@11896
   119
val print_locales = LocalesData.print;
wenzelm@11896
   120
wenzelm@12014
   121
val intern = NameSpace.intern o #space o LocalesData.get_sg;
wenzelm@12014
   122
val cond_extern = NameSpace.cond_extern o #space o LocalesData.get_sg;
wenzelm@12014
   123
wenzelm@11896
   124
wenzelm@11896
   125
(* access locales *)
wenzelm@11896
   126
wenzelm@11896
   127
fun get_locale_sg sg name = Symtab.lookup (#locales (LocalesData.get_sg sg), name);
wenzelm@11896
   128
val get_locale = get_locale_sg o Theory.sign_of;
wenzelm@11896
   129
wenzelm@12014
   130
fun put_locale (name, locale) = LocalesData.map (fn {space, locales, scope} =>
wenzelm@12014
   131
  make_locale_data (NameSpace.extend (space, [name]))
wenzelm@12014
   132
    (Symtab.update ((name, locale), locales)) scope);
wenzelm@11896
   133
wenzelm@12014
   134
fun the_locale thy name =
wenzelm@12014
   135
  (case get_locale thy name of
wenzelm@12014
   136
    Some loc => loc
wenzelm@12014
   137
  | None => error ("Unknown locale " ^ quote name));
wenzelm@11896
   138
wenzelm@11896
   139
wenzelm@11896
   140
(* access scope *)
wenzelm@11896
   141
wenzelm@11896
   142
fun get_scope_sg sg =
wenzelm@12014
   143
  if Sign.eq_sg (sg, Theory.sign_of ProtoPure.thy) then empty_scope
wenzelm@11896
   144
  else ! (#scope (LocalesData.get_sg sg));
wenzelm@11896
   145
wenzelm@11896
   146
val get_scope = get_scope_sg o Theory.sign_of;
wenzelm@12014
   147
val nonempty_scope_sg = not o null o #1 o get_scope_sg;
wenzelm@11896
   148
wenzelm@11896
   149
fun change_scope f thy =
wenzelm@11896
   150
  let val {scope, ...} = LocalesData.get thy
wenzelm@12014
   151
  in scope := f (! scope); thy end;
wenzelm@12014
   152
wenzelm@12014
   153
fun print_scope thy =
wenzelm@12014
   154
  Pretty.writeln (Pretty.strs ("current scope:" ::
wenzelm@12014
   155
    rev (map (cond_extern (Theory.sign_of thy) o #1) (#1 (get_scope thy)))));
wenzelm@12014
   156
wenzelm@12014
   157
wenzelm@12058
   158
(* print locales *)    (* FIXME activate local syntax *)
wenzelm@12014
   159
wenzelm@12014
   160
fun pretty_locale thy xname =
wenzelm@12014
   161
  let
wenzelm@12014
   162
    val sg = Theory.sign_of thy;
wenzelm@12014
   163
    val name = intern sg xname;
wenzelm@12046
   164
    val (_, ancestors, elements) = the_locale thy name;
wenzelm@12014
   165
wenzelm@12014
   166
    val prt_typ = Pretty.quote o Sign.pretty_typ sg;
wenzelm@12014
   167
    val prt_term = Pretty.quote o Sign.pretty_term sg;
wenzelm@12014
   168
wenzelm@12014
   169
    fun prt_syn syn =
wenzelm@12014
   170
      let val s = (case syn of None => "(structure)" | Some mx => Syntax.string_of_mixfix mx)
wenzelm@12014
   171
      in if s = "" then [] else [Pretty.brk 4, Pretty.str s] end;
wenzelm@12058
   172
    fun prt_fix (x, Some T, syn) = Pretty.block (Pretty.str (x ^ " ::") :: Pretty.brk 1 ::
wenzelm@12058
   173
          prt_typ T :: Pretty.brk 1 :: prt_syn syn)
wenzelm@12058
   174
      | prt_fix (x, None, syn) = Pretty.block (Pretty.str x :: Pretty.brk 1 :: prt_syn syn);
wenzelm@12014
   175
wenzelm@12014
   176
    fun prt_asm ((a, _), ts) = Pretty.block
wenzelm@12014
   177
      (Pretty.breaks (Pretty.str (a ^ ":") :: map (prt_term o fst) ts));
wenzelm@12014
   178
    fun prt_asms asms = Pretty.block
wenzelm@12014
   179
      (flat (separate [Pretty.fbrk, Pretty.str "and"] (map (single o prt_asm) asms)));
wenzelm@12014
   180
wenzelm@12014
   181
    fun prt_def ((a, _), (t, _)) = Pretty.block
wenzelm@12014
   182
      [Pretty.str (a ^ ":"), Pretty.brk 1, prt_term t];
wenzelm@12014
   183
wenzelm@12014
   184
    fun prt_fact ((a, _), ths) = Pretty.block
wenzelm@12014
   185
      (Pretty.breaks (Pretty.str (a ^ ":") :: map Display.pretty_thm (flat (map fst ths))));
wenzelm@12014
   186
wenzelm@12014
   187
    fun prt_elem (Fixes fixes) = Pretty.big_list "fixes" (map prt_fix fixes)
wenzelm@12014
   188
      | prt_elem (Assumes asms) = Pretty.big_list "assumes" (map prt_asm asms)
wenzelm@12014
   189
      | prt_elem (Defines defs) = Pretty.big_list "defines" (map prt_def defs)
wenzelm@12014
   190
      | prt_elem (Notes facts) = Pretty.big_list "notes" (map prt_fact facts)
wenzelm@12014
   191
      | prt_elem (Uses _) = Pretty.str "FIXME";
wenzelm@12014
   192
wenzelm@12014
   193
    val prt_header = Pretty.block (Pretty.str ("locale " ^ cond_extern sg name ^ " =") ::
wenzelm@12014
   194
       (if null ancestors then [] else
wenzelm@12014
   195
       (flat (separate [Pretty.str "+", Pretty.brk 1] (map (single o Pretty.str) ancestors)) @
wenzelm@12014
   196
         [Pretty.str "+"])));
wenzelm@12014
   197
  in Pretty.block (Pretty.fbreaks (prt_header :: map prt_elem elements)) end;
wenzelm@12014
   198
wenzelm@12014
   199
val print_locale = Pretty.writeln oo pretty_locale;
wenzelm@11896
   200
wenzelm@11896
   201
wenzelm@12046
   202
(** internalization of theorems and attributes **)
wenzelm@12046
   203
wenzelm@12046
   204
fun int_att attrib (x, srcs) = (x, map attrib srcs);
wenzelm@12046
   205
wenzelm@12046
   206
fun intern_att _ (Fixes fixes) = Fixes fixes
wenzelm@12046
   207
  | intern_att attrib (Assumes asms) = Assumes (map (apfst (int_att attrib)) asms)
wenzelm@12046
   208
  | intern_att attrib (Defines defs) = Defines (map (apfst (int_att attrib)) defs)
wenzelm@12046
   209
  | intern_att attrib (Notes facts) =
wenzelm@12046
   210
      Notes (map (apfst (int_att attrib) o apsnd (map (int_att attrib))) facts)
wenzelm@12046
   211
  | intern_att _ (Uses FIXME) = Uses FIXME;
wenzelm@12046
   212
wenzelm@12046
   213
wenzelm@11896
   214
wenzelm@12014
   215
(** activate locales **)
wenzelm@11896
   216
wenzelm@12058
   217
fun close_frees ctxt t =
wenzelm@12058
   218
  let val frees = rev (filter_out (ProofContext.is_fixed ctxt o #1) (Drule.add_frees ([], t)))
wenzelm@12058
   219
  in Term.list_all_free (frees, t) end;
wenzelm@11896
   220
wenzelm@12058
   221
fun read_elem ctxt =
wenzelm@12046
   222
 fn (Fixes fixes) =>
wenzelm@12046
   223
      let val vars =
wenzelm@12058
   224
        #2 (foldl_map ProofContext.read_vars (ctxt, map (fn (x, T, _) => ([x], T)) fixes))
wenzelm@12058
   225
      in Fixes (map2 (fn (([x'], T'), (_, _, mx)) => (x', T', mx)) (vars, fixes)) end
wenzelm@12046
   226
  | (Assumes asms) =>
wenzelm@12046
   227
      Assumes (map #1 asms ~~ #2 (ProofContext.read_propp (ctxt, map #2 asms)))
wenzelm@12046
   228
  | (Defines defs) =>
wenzelm@12046
   229
      let val propps =
wenzelm@12046
   230
        #2 (ProofContext.read_propp (ctxt, map (fn (_, (t, ps)) => [(t, (ps, []))]) defs))
wenzelm@12046
   231
      in Defines (map #1 defs ~~ map (fn [(t', (ps', []))] => (t', ps')) propps) end
wenzelm@12046
   232
  | (Notes facts) =>
wenzelm@12046
   233
      Notes (map (apsnd (map (apfst (ProofContext.get_thms ctxt)))) facts)
wenzelm@12046
   234
  | (Uses FIXME) => Uses FIXME;
wenzelm@11896
   235
wenzelm@12046
   236
wenzelm@12046
   237
fun activate (ctxt, Fixes fixes) =
wenzelm@12058
   238
      ProofContext.fix_direct (map (fn (x, T, FIXME) => ([x], T)) fixes) ctxt
wenzelm@12058
   239
  | activate (ctxt, Assumes asms) =
wenzelm@12058
   240
      ctxt |> ProofContext.fix_frees (flat (map (map #1 o #2) asms))
wenzelm@12058
   241
      |> ProofContext.assume_i ProofContext.export_assume asms |> #1
wenzelm@12046
   242
  | activate (ctxt, Defines defs) = #1 (ProofContext.assume_i ProofContext.export_def
wenzelm@12058
   243
      (map (fn (a, (t, ps)) => (a, [(ProofContext.cert_def ctxt t, (ps, []))])) defs) ctxt)
wenzelm@12046
   244
  | activate (ctxt, Notes facts) = #1 (ProofContext.have_thmss facts ctxt)
wenzelm@12046
   245
  | activate (ctxt, Uses FIXME) = ctxt;
wenzelm@11896
   246
wenzelm@12046
   247
fun read_activate (ctxt, elem) =
wenzelm@12058
   248
  let val elem' = read_elem ctxt elem
wenzelm@12046
   249
  in (activate (ctxt, elem'), elem') end;
wenzelm@11896
   250
wenzelm@12046
   251
fun activate_elements_i elems ctxt = foldl activate (ctxt, elems);
wenzelm@12046
   252
fun activate_elements elems ctxt = foldl (#1 o read_activate) (ctxt, elems);
wenzelm@12046
   253
wenzelm@12046
   254
fun with_locale f name ctxt =
wenzelm@12014
   255
  let
wenzelm@12014
   256
    val thy = ProofContext.theory_of ctxt;
wenzelm@12046
   257
    val locale = the_locale thy name;
wenzelm@12014
   258
  in
wenzelm@12046
   259
    f locale ctxt handle ProofContext.CONTEXT (msg, c) =>
wenzelm@12014
   260
      raise ProofContext.CONTEXT (msg ^ "\nThe error(s) above occurred in locale " ^
wenzelm@12014
   261
        quote (cond_extern (Theory.sign_of thy) name), c)
wenzelm@12014
   262
  end;
wenzelm@12014
   263
wenzelm@12046
   264
val activate_locale_elements = with_locale (activate_elements_i o #3);
wenzelm@12046
   265
wenzelm@12046
   266
fun activate_locale_ancestors name ctxt =
wenzelm@12046
   267
  foldl (fn (c, es) => activate_locale_elements es c)
wenzelm@12046
   268
    (ctxt, #2 (the_locale (ProofContext.theory_of ctxt) name));
wenzelm@12046
   269
wenzelm@12046
   270
fun activate_locale_i name ctxt =
wenzelm@12046
   271
  ctxt |> activate_locale_ancestors name |> activate_locale_elements name;
wenzelm@12046
   272
wenzelm@12046
   273
fun activate_locale xname ctxt =
wenzelm@12046
   274
  activate_locale_i (intern (ProofContext.sign_of ctxt) xname) ctxt;
wenzelm@11896
   275
wenzelm@11896
   276
wenzelm@11896
   277
wenzelm@12014
   278
(* FIXME
wenzelm@11896
   279
(** define locales **)
wenzelm@11896
   280
wenzelm@11896
   281
(* concrete syntax *)
wenzelm@11896
   282
wenzelm@11896
   283
fun mark_syn c = "\\<^locale>" ^ c;
wenzelm@11896
   284
wenzelm@11896
   285
fun mk_loc_tr c ts = list_comb (Free (c, dummyT), ts);
wenzelm@11896
   286
wenzelm@11896
   287
wenzelm@11896
   288
(* add_locale *)
wenzelm@11896
   289
wenzelm@12014
   290
fun gen_add_locale prep_typ prep_term bname bpar raw_fixes raw_assumes raw_defs thy =
wenzelm@11896
   291
  let val sign = Theory.sign_of thy;
wenzelm@11896
   292
wenzelm@11896
   293
    val name = Sign.full_name sign bname;
wenzelm@11896
   294
wenzelm@12014
   295
    val (envSb, old_loc_fixes, _) =
wenzelm@12014
   296
                    case bpar of
wenzelm@12014
   297
                       Some loc => (get_defaults thy loc)
wenzelm@11896
   298
                     | None      => ([],[],[]);
wenzelm@11896
   299
wenzelm@12014
   300
    val old_nosyn = case bpar of
wenzelm@12014
   301
                       Some loc => #nosyn(#2(the_locale thy loc))
wenzelm@11896
   302
                     | None      => [];
wenzelm@11896
   303
wenzelm@12014
   304
    (* Get the full name of the parent *)
wenzelm@12014
   305
    val parent = case bparent of
wenzelm@12014
   306
                       Some loc => Some(#1(the_locale thy loc))
wenzelm@11896
   307
                     | None      => None;
wenzelm@11896
   308
wenzelm@12014
   309
     (* prepare locale fixes *)
wenzelm@11896
   310
wenzelm@11896
   311
    fun prep_const (envS, (raw_c, raw_T, raw_mx)) =
wenzelm@11896
   312
      let
wenzelm@11896
   313
        val c = Syntax.const_name raw_c raw_mx;
wenzelm@11896
   314
        val c_syn = mark_syn c;
wenzelm@11896
   315
        val mx = Syntax.fix_mixfix raw_c raw_mx;
wenzelm@11896
   316
        val (envS', T) = prep_typ sign (envS, raw_T) handle ERROR =>
wenzelm@11896
   317
          error ("The error(s) above occured in locale constant " ^ quote c);
wenzelm@11896
   318
        val trfun = if mx = Syntax.NoSyn then None else Some (c_syn, mk_loc_tr c);
wenzelm@11896
   319
      in (envS', ((c, T), (c_syn, T, mx), trfun)) end;
wenzelm@11896
   320
wenzelm@12014
   321
    val (envS0, loc_fixes_syn) = foldl_map prep_const (envSb, raw_fixes);
wenzelm@12014
   322
    val loc_fixes = map #1 loc_fixes_syn;
wenzelm@12014
   323
    val loc_fixes = old_loc_fixes @ loc_fixes;
wenzelm@12014
   324
    val loc_syn = map #2 loc_fixes_syn;
wenzelm@12014
   325
    val nosyn = old_nosyn @ (map (#1 o #1) (filter (fn x => (#3(#2 x)) = NoSyn) loc_fixes_syn));
wenzelm@12014
   326
    val loc_trfuns = mapfilter #3 loc_fixes_syn;
wenzelm@11896
   327
wenzelm@11896
   328
wenzelm@11896
   329
    (* 1st stage: syntax_thy *)
wenzelm@11896
   330
wenzelm@11896
   331
    val syntax_thy =
wenzelm@11896
   332
      thy
wenzelm@11896
   333
      |> Theory.add_modesyntax_i ("", true) loc_syn
wenzelm@11896
   334
      |> Theory.add_trfuns ([], loc_trfuns, [], []);
wenzelm@11896
   335
wenzelm@11896
   336
    val syntax_sign = Theory.sign_of syntax_thy;
wenzelm@11896
   337
wenzelm@11896
   338
wenzelm@12014
   339
    (* prepare assumes and defs *)
wenzelm@11896
   340
wenzelm@11896
   341
    fun prep_axiom (env, (a, raw_t)) =
wenzelm@11896
   342
      let
wenzelm@11896
   343
        val (env', t) = prep_term syntax_sign (env, (a, raw_t)) handle ERROR =>
wenzelm@11896
   344
          error ("The error(s) above occured in locale rule / definition " ^ quote a);
wenzelm@11896
   345
      in (env', (a, t)) end;
wenzelm@11896
   346
wenzelm@12014
   347
    val ((envS1, envT1, used1), loc_assumes) =
wenzelm@12014
   348
      foldl_map prep_axiom ((envS0, loc_fixes, map fst envS0), raw_assumes);
wenzelm@12014
   349
    val (defaults, loc_defs) =
wenzelm@12014
   350
        foldl_map prep_axiom ((envS1, envT1, used1), raw_defs);
wenzelm@11896
   351
wenzelm@12014
   352
    val old_loc_fixes = collect_fixes syntax_sign;
wenzelm@12014
   353
    val new_loc_fixes = (map #1 loc_fixes);
wenzelm@12014
   354
    val all_loc_fixes = old_loc_fixes @ new_loc_fixes;
wenzelm@11896
   355
wenzelm@12014
   356
    val (defaults, loc_defs_terms) =
wenzelm@12014
   357
        foldl_map (abs_over_free all_loc_fixes) (defaults, loc_defs);
wenzelm@12014
   358
    val loc_defs_thms =
wenzelm@12014
   359
        map (apsnd (prep_hyps (map #1 loc_fixes) syntax_sign)) loc_defs_terms;
wenzelm@12014
   360
    val (defaults, loc_thms_terms) =
wenzelm@12014
   361
        foldl_map (abs_over_free all_loc_fixes) (defaults, loc_assumes);
wenzelm@12014
   362
    val loc_thms = map (apsnd (prep_hyps (map #1 loc_fixes) syntax_sign))
wenzelm@12014
   363
                       (loc_thms_terms)
wenzelm@11896
   364
                   @ loc_defs_thms;
wenzelm@11896
   365
wenzelm@11896
   366
wenzelm@12014
   367
    (* error messages *)
wenzelm@11896
   368
wenzelm@11896
   369
    fun locale_error msg = error (msg ^ "\nFor locale " ^ quote name);
wenzelm@11896
   370
wenzelm@11896
   371
    val err_dup_locale =
wenzelm@11896
   372
      if is_none (get_locale thy name) then []
wenzelm@11896
   373
      else ["Duplicate definition of locale " ^ quote name];
wenzelm@11896
   374
wenzelm@12014
   375
    (* check if definientes are locale constants
wenzelm@11896
   376
       (in the same locale, so no redefining!) *)
wenzelm@11896
   377
    val err_def_head =
wenzelm@12014
   378
      let fun peal_appl t =
wenzelm@12014
   379
            case t of
wenzelm@11896
   380
                 t1 $ t2 => peal_appl t1
wenzelm@11896
   381
               | Free(t) => t
wenzelm@11896
   382
               | _ => locale_error ("Bad form of LHS in locale definition");
wenzelm@12014
   383
          fun lhs (_, Const ("==" , _) $  d1 $ d2) = peal_appl d1
wenzelm@12014
   384
            | lhs _ = locale_error ("Definitions must use the == relation");
wenzelm@11896
   385
          val defs = map lhs loc_defs;
wenzelm@12014
   386
          val check = defs subset loc_fixes
wenzelm@12014
   387
      in if check then []
wenzelm@11896
   388
         else ["defined item not declared fixed in locale " ^ quote name]
wenzelm@12014
   389
      end;
wenzelm@11896
   390
wenzelm@11896
   391
    (* check that variables on rhs of definitions are either fixed or on lhs *)
wenzelm@12014
   392
    val err_var_rhs =
wenzelm@12014
   393
      let fun compare_var_sides (t, (_, Const ("==", _) $ d1 $ d2)) =
wenzelm@12014
   394
                let val varl1 = difflist d1 all_loc_fixes;
wenzelm@12014
   395
                    val varl2 = difflist d2 all_loc_fixes
wenzelm@12014
   396
                in t andalso (varl2 subset varl1)
wenzelm@12014
   397
                end
wenzelm@12014
   398
            | compare_var_sides (_,_) =
wenzelm@12014
   399
                locale_error ("Definitions must use the == relation")
wenzelm@11896
   400
          val check = foldl compare_var_sides (true, loc_defs)
wenzelm@11896
   401
      in if check then []
wenzelm@11896
   402
         else ["nonfixed variable on right hand side of a locale definition in locale " ^ quote name]
wenzelm@11896
   403
      end;
wenzelm@11896
   404
wenzelm@11896
   405
    val errs = err_dup_locale @ err_def_head @ err_var_rhs;
wenzelm@11896
   406
  in
wenzelm@11896
   407
    if null errs then ()
wenzelm@11896
   408
    else error (cat_lines errs);
wenzelm@11896
   409
wenzelm@11896
   410
    syntax_thy
wenzelm@12014
   411
    |> put_locale (name,
wenzelm@12014
   412
                   make_locale parent loc_fixes nosyn loc_thms_terms
wenzelm@11896
   413
                                        loc_defs_terms   loc_thms defaults)
wenzelm@11896
   414
  end;
wenzelm@11896
   415
wenzelm@11896
   416
wenzelm@11896
   417
val add_locale = gen_add_locale read_typ read_axm;
wenzelm@11896
   418
val add_locale_i = gen_add_locale cert_typ cert_axm;
wenzelm@11896
   419
wenzelm@12014
   420
wenzelm@12014
   421
wenzelm@12014
   422
(*
wenzelm@12014
   423
(** support for legacy proof scripts (cf. goals.ML) **)     (* FIXME move to goals.ML (!?) *)
wenzelm@12014
   424
wenzelm@12014
   425
(* hyps_in_scope *)
wenzelm@12014
   426
wenzelm@12014
   427
fun hyps_in_scope sg hyps =
wenzelm@12014
   428
  let val locs = map #2 (#1 (get_scope_sg sg))
wenzelm@12014
   429
  in gen_subset Term.aconv (hyps, map #2 (flat (map #assumes locs @ map #defines locs))) end;
wenzelm@12014
   430
wenzelm@11896
   431
wenzelm@12014
   432
(* get theorems *)
wenzelm@11896
   433
wenzelm@12014
   434
fun thmx get_local get_global name =
wenzelm@12014
   435
  let val thy = Context.the_context () in
wenzelm@12014
   436
    (case #2 (get_scope thy) of
wenzelm@12014
   437
      None => get_global thy name
wenzelm@12014
   438
    | Some ctxt => get_local ctxt name)
wenzelm@12014
   439
  end;
wenzelm@12014
   440
wenzelm@12014
   441
val thm = thmx ProofContext.get_thm PureThy.get_thm;
wenzelm@12014
   442
val thms = thmx ProofContext.get_thms PureThy.get_thms;
wenzelm@11896
   443
wenzelm@11896
   444
wenzelm@12014
   445
(** scope operations -- for old-style goals **)  (* FIXME move to goals.ML (!?) *)
wenzelm@12014
   446
wenzelm@12014
   447
(* open *)
wenzelm@12014
   448
wenzelm@12014
   449
local
wenzelm@12014
   450
wenzelm@12014
   451
fun is_open thy name = exists (equal name o #1) (#1 (get_scope thy));
wenzelm@12014
   452
wenzelm@12014
   453
fun open_loc thy name =
wenzelm@12014
   454
  let
wenzelm@12014
   455
    val (ancestors, elements) = the_locale thy name;
wenzelm@12014
   456
  in
wenzelm@12014
   457
    (case #parent locale of None => thy
wenzelm@12014
   458
    | Some par =>
wenzelm@12014
   459
        if is_open thy par then thy
wenzelm@12014
   460
        else (writeln ("Opening locale " ^ quote par ^ "(required by " ^ quote name ^ ")");
wenzelm@12014
   461
          open_loc name thy))
wenzelm@12014
   462
    |> change_scope (fn (locs, _) => ((name, locale) :: locs, None))
wenzelm@12014
   463
  end;
wenzelm@12014
   464
wenzelm@12014
   465
in
wenzelm@12014
   466
wenzelm@12014
   467
fun open_locale xname thy =
wenzelm@12014
   468
  let val name = intern (Theory.sign_of thy) xname in
wenzelm@12014
   469
    if is_open thy name then (warning ("Locale " ^ quote name ^ " already open"); thy)
wenzelm@12014
   470
    else open_loc name thy
wenzelm@12014
   471
  end;
wenzelm@12014
   472
wenzelm@12014
   473
end;
wenzelm@11896
   474
wenzelm@11896
   475
wenzelm@12014
   476
(* close *)
wenzelm@12014
   477
wenzelm@12014
   478
fun close_locale xname thy =
wenzelm@12014
   479
  let val name = intern_locale (Theory.sign_of thy) xname in
wenzelm@12014
   480
    thy |> change_scope (fn ([], _) => error "Currently no open locales"
wenzelm@12014
   481
    | ((name', _) :: locs, _) =>
wenzelm@12014
   482
        if name <> name' then error ("Locale " ^ quote name ^ " not at top of scope")
wenzelm@12014
   483
        else (locs, None))
wenzelm@12014
   484
  end;
wenzelm@12014
   485
wenzelm@12014
   486
wenzelm@12014
   487
(* implicit context versions *)
wenzelm@12014
   488
wenzelm@12014
   489
fun Open_locale xname = (open_locale xname (Context.the_context ()); ());
wenzelm@12014
   490
fun Close_locale xname = (close_locale xname (Context.the_context ()); ());
wenzelm@12014
   491
fun Print_scope () = (print_scope (Context.the_context ()); ());
wenzelm@12014
   492
*)
wenzelm@11896
   493
wenzelm@11896
   494
wenzelm@11896
   495
(** locale theory setup **)
wenzelm@12014
   496
*)
wenzelm@11896
   497
val setup =
wenzelm@11896
   498
 [LocalesData.init];
wenzelm@11896
   499
wenzelm@11896
   500
end;
wenzelm@11896
   501
wenzelm@11896
   502
structure BasicLocale: BASIC_LOCALE = Locale;
wenzelm@11896
   503
open BasicLocale;