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