locale -> old_locale, new_locale -> locale
authorhaftmann
Mon Jan 05 15:55:04 2009 +0100 (2009-01-05)
changeset 29360a5be60c3674e
parent 29359 f831192b9366
child 29361 764d51ab0198
locale -> old_locale, new_locale -> locale
src/HOL/Statespace/state_space.ML
src/Pure/IsaMakefile
src/Pure/Isar/ROOT.ML
src/Pure/Isar/class.ML
src/Pure/Isar/class_target.ML
src/Pure/Isar/expression.ML
src/Pure/Isar/isar_cmd.ML
src/Pure/Isar/isar_syn.ML
src/Pure/Isar/locale.ML
src/Pure/Isar/new_locale.ML
src/Pure/Isar/old_locale.ML
src/Pure/Isar/spec_parse.ML
src/Pure/Isar/theory_target.ML
src/Pure/Tools/invoke.ML
     1.1 --- a/src/HOL/Statespace/state_space.ML	Mon Jan 05 15:37:49 2009 +0100
     1.2 +++ b/src/HOL/Statespace/state_space.ML	Mon Jan 05 15:55:04 2009 +0100
     1.3 @@ -265,7 +265,7 @@
     1.4        in EVERY [rtac rule i] st
     1.5        end
     1.6  
     1.7 -    fun tac ctxt = EVERY [NewLocale.intro_locales_tac true ctxt [],
     1.8 +    fun tac ctxt = EVERY [Locale.intro_locales_tac true ctxt [],
     1.9                            ALLGOALS (SUBGOAL (solve_tac ctxt))]
    1.10  
    1.11    in thy
    1.12 @@ -429,7 +429,7 @@
    1.13        let
    1.14          val expr = ([(pname, (("",false), Expression.Positional rs))],[])
    1.15        in prove_interpretation_in
    1.16 -           (fn ctxt => NewLocale.intro_locales_tac false ctxt [])
    1.17 +           (fn ctxt => Locale.intro_locales_tac false ctxt [])
    1.18             (full_name, expr) end;
    1.19  
    1.20      fun declare_declinfo updates lthy phi ctxt =
     2.1 --- a/src/Pure/IsaMakefile	Mon Jan 05 15:37:49 2009 +0100
     2.2 +++ b/src/Pure/IsaMakefile	Mon Jan 05 15:55:04 2009 +0100
     2.3 @@ -41,7 +41,7 @@
     2.4    Isar/element.ML Isar/expression.ML Isar/find_theorems.ML		\
     2.5    Isar/isar.ML Isar/isar_cmd.ML Isar/isar_syn.ML	\
     2.6    Isar/local_defs.ML Isar/local_syntax.ML Isar/local_theory.ML		\
     2.7 -  Isar/locale.ML Isar/method.ML Isar/net_rules.ML Isar/new_locale.ML	\
     2.8 +  Isar/locale.ML Isar/method.ML Isar/net_rules.ML Isar/old_locale.ML	\
     2.9    Isar/object_logic.ML Isar/obtain.ML Isar/outer_keyword.ML		\
    2.10    Isar/outer_lex.ML Isar/outer_parse.ML Isar/outer_syntax.ML		\
    2.11    Isar/overloading.ML Isar/proof.ML Isar/proof_context.ML		\
     3.1 --- a/src/Pure/Isar/ROOT.ML	Mon Jan 05 15:37:49 2009 +0100
     3.2 +++ b/src/Pure/Isar/ROOT.ML	Mon Jan 05 15:55:04 2009 +0100
     3.3 @@ -53,8 +53,8 @@
     3.4  (*local theories and targets*)
     3.5  use "local_theory.ML";
     3.6  use "overloading.ML";
     3.7 +use "old_locale.ML";
     3.8  use "locale.ML";
     3.9 -use "new_locale.ML";
    3.10  use "class_target.ML";
    3.11  use "theory_target.ML";
    3.12  use "expression.ML";
     4.1 --- a/src/Pure/Isar/class.ML	Mon Jan 05 15:37:49 2009 +0100
     4.2 +++ b/src/Pure/Isar/class.ML	Mon Jan 05 15:55:04 2009 +0100
     4.3 @@ -27,7 +27,7 @@
     4.4  (** rule calculation **)
     4.5  
     4.6  fun calculate_axiom thy sups base_sort assm_axiom param_map class =
     4.7 -  case Locale.intros thy class
     4.8 +  case Old_Locale.intros thy class
     4.9     of (_, []) => assm_axiom
    4.10      | (_, [intro]) =>
    4.11        let
    4.12 @@ -52,7 +52,7 @@
    4.13          (Var ((v, 0), map_atyps (fn _ => TVar ((Name.aT, 0), sort)) ty),
    4.14            Const (c, map_atyps (fn _ => TVar ((Name.aT, 0), sort)) ty))) param_map);
    4.15      val defs = these_defs thy sups;
    4.16 -    val assm_intro = Locale.intros thy class
    4.17 +    val assm_intro = Old_Locale.intros thy class
    4.18        |> fst
    4.19        |> map (instantiate thy base_sort)
    4.20        |> map (MetaSimplifier.rewrite_rule defs)
    4.21 @@ -64,7 +64,7 @@
    4.22      val of_class_sups = if null sups
    4.23        then map (fixate o Thm.class_triv thy) base_sort
    4.24        else map (fixate o snd o rules thy) sups;
    4.25 -    val locale_dests = map Drule.standard' (Locale.dests thy class);
    4.26 +    val locale_dests = map Drule.standard' (Old_Locale.dests thy class);
    4.27      val num_trivs = case length locale_dests
    4.28       of 0 => if is_none axiom then 0 else 1
    4.29        | n => n;
    4.30 @@ -105,10 +105,10 @@
    4.31      val base_sort = if null sups then supsort else
    4.32        foldr1 (Sorts.inter_sort (Sign.classes_of thy))
    4.33          (map (base_sort thy) sups);
    4.34 -    val suplocales = map Locale.Locale sups;
    4.35 -    val supexpr = Locale.Merge suplocales;
    4.36 -    val supparams = (map fst o Locale.parameters_of_expr thy) supexpr;
    4.37 -    val mergeexpr = Locale.Merge suplocales;
    4.38 +    val suplocales = map Old_Locale.Locale sups;
    4.39 +    val supexpr = Old_Locale.Merge suplocales;
    4.40 +    val supparams = (map fst o Old_Locale.parameters_of_expr thy) supexpr;
    4.41 +    val mergeexpr = Old_Locale.Merge suplocales;
    4.42      val constrain = Element.Constrains ((map o apsnd o map_atyps)
    4.43        (K (TFree (Name.aT, base_sort))) supparams);
    4.44      fun fork_syn (Element.Fixes xs) =
    4.45 @@ -121,23 +121,23 @@
    4.46        in (constrain :: elems', global_syntax) end;
    4.47      val (elems, global_syntax) =
    4.48        ProofContext.init thy
    4.49 -      |> Locale.cert_expr supexpr [constrain]
    4.50 +      |> Old_Locale.cert_expr supexpr [constrain]
    4.51        |> snd
    4.52        |> begin sups base_sort
    4.53 -      |> process_expr Locale.empty raw_elems
    4.54 +      |> process_expr Old_Locale.empty raw_elems
    4.55        |> fst
    4.56        |> fork_syntax
    4.57    in (((sups, supparams), (supsort, base_sort, mergeexpr)), (elems, global_syntax)) end;
    4.58  
    4.59 -val read_class_spec = gen_class_spec Sign.intern_class Locale.read_expr;
    4.60 -val check_class_spec = gen_class_spec (K I) Locale.cert_expr;
    4.61 +val read_class_spec = gen_class_spec Sign.intern_class Old_Locale.read_expr;
    4.62 +val check_class_spec = gen_class_spec (K I) Old_Locale.cert_expr;
    4.63  
    4.64  fun add_consts bname class base_sort sups supparams global_syntax thy =
    4.65    let
    4.66      val supconsts = map fst supparams
    4.67        |> AList.make (snd o the o AList.lookup (op =) (these_params thy sups))
    4.68        |> (map o apsnd o apsnd o map_atyps o K o TFree) (Name.aT, [class]);
    4.69 -    val all_params = map fst (Locale.parameters_of thy class);
    4.70 +    val all_params = map fst (Old_Locale.parameters_of thy class);
    4.71      val raw_params = (snd o chop (length supparams)) all_params;
    4.72      fun add_const (v, raw_ty) thy =
    4.73        let
    4.74 @@ -165,7 +165,7 @@
    4.75      fun globalize param_map = map_aterms
    4.76        (fn Free (v, ty) => Const ((fst o the o AList.lookup (op =) param_map) v, ty)
    4.77          | t => t);
    4.78 -    val raw_pred = Locale.intros thy class
    4.79 +    val raw_pred = Old_Locale.intros thy class
    4.80        |> fst
    4.81        |> map (Logic.unvarify o Logic.strip_imp_concl o Thm.prop_of);
    4.82      fun get_axiom thy = case (#axioms o AxClass.get_info thy) class
    4.83 @@ -191,7 +191,7 @@
    4.84      val supconsts = map (apsnd fst o snd) (these_params thy sups);
    4.85    in
    4.86      thy
    4.87 -    |> Locale.add_locale "" bname mergeexpr elems
    4.88 +    |> Old_Locale.add_locale "" bname mergeexpr elems
    4.89      |> snd
    4.90      |> ProofContext.theory_of
    4.91      |> adjungate_axclass bname class base_sort sups supsort supparams global_syntax
    4.92 @@ -242,7 +242,7 @@
    4.93        error ("Class " ^ Syntax.string_of_sort lthy [sub] ^ " lacks parameter(s) " ^
    4.94          commas_quote err_params ^ " of " ^ Syntax.string_of_sort lthy [sup]);
    4.95      val sublocale_prop =
    4.96 -      Locale.global_asms_of thy sup
    4.97 +      Old_Locale.global_asms_of thy sup
    4.98        |> maps snd
    4.99        |> try the_single
   4.100        |> Option.map (ObjectLogic.ensure_propT thy);
     5.1 --- a/src/Pure/Isar/class_target.ML	Mon Jan 05 15:37:49 2009 +0100
     5.2 +++ b/src/Pure/Isar/class_target.ML	Mon Jan 05 15:55:04 2009 +0100
     5.3 @@ -72,23 +72,23 @@
     5.4  structure Old_Locale =
     5.5  struct
     5.6  
     5.7 -val intro_locales_tac = Locale.intro_locales_tac; (*already forked!*)
     5.8 +val intro_locales_tac = Old_Locale.intro_locales_tac; (*already forked!*)
     5.9  
    5.10 -val interpretation = Locale.interpretation;
    5.11 -val interpretation_in_locale = Locale.interpretation_in_locale;
    5.12 -val get_interpret_morph = Locale.get_interpret_morph;
    5.13 -val Locale = Locale.Locale;
    5.14 -val extern = Locale.extern;
    5.15 -val intros = Locale.intros;
    5.16 -val dests = Locale.dests;
    5.17 -val init = Locale.init;
    5.18 -val Merge = Locale.Merge;
    5.19 -val parameters_of_expr = Locale.parameters_of_expr;
    5.20 -val empty = Locale.empty;
    5.21 -val cert_expr = Locale.cert_expr;
    5.22 -val read_expr = Locale.read_expr;
    5.23 -val parameters_of = Locale.parameters_of;
    5.24 -val add_locale = Locale.add_locale;
    5.25 +val interpretation = Old_Locale.interpretation;
    5.26 +val interpretation_in_locale = Old_Locale.interpretation_in_locale;
    5.27 +val get_interpret_morph = Old_Locale.get_interpret_morph;
    5.28 +val Locale = Old_Locale.Locale;
    5.29 +val extern = Old_Locale.extern;
    5.30 +val intros = Old_Locale.intros;
    5.31 +val dests = Old_Locale.dests;
    5.32 +val init = Old_Locale.init;
    5.33 +val Merge = Old_Locale.Merge;
    5.34 +val parameters_of_expr = Old_Locale.parameters_of_expr;
    5.35 +val empty = Old_Locale.empty;
    5.36 +val cert_expr = Old_Locale.cert_expr;
    5.37 +val read_expr = Old_Locale.read_expr;
    5.38 +val parameters_of = Old_Locale.parameters_of;
    5.39 +val add_locale = Old_Locale.add_locale;
    5.40  
    5.41  end;
    5.42  
    5.43 @@ -401,7 +401,7 @@
    5.44    end;
    5.45  
    5.46  fun default_intro_tac ctxt [] =
    5.47 -      intro_classes_tac [] ORELSE NewLocale.intro_locales_tac true ctxt [] ORELSE
    5.48 +      intro_classes_tac [] ORELSE Locale.intro_locales_tac true ctxt [] ORELSE
    5.49        Locale.intro_locales_tac true ctxt []
    5.50    | default_intro_tac _ _ = no_tac;
    5.51  
     6.1 --- a/src/Pure/Isar/expression.ML	Mon Jan 05 15:37:49 2009 +0100
     6.2 +++ b/src/Pure/Isar/expression.ML	Mon Jan 05 15:55:04 2009 +0100
     6.3 @@ -1,7 +1,7 @@
     6.4  (*  Title:      Pure/Isar/expression.ML
     6.5      Author:     Clemens Ballarin, TU Muenchen
     6.6  
     6.7 -New locale development --- experimental.
     6.8 +Locale expressions.
     6.9  *)
    6.10  
    6.11  signature EXPRESSION =
    6.12 @@ -55,7 +55,7 @@
    6.13  
    6.14  (** Internalise locale names in expr **)
    6.15  
    6.16 -fun intern thy instances =  map (apfst (NewLocale.intern thy)) instances;
    6.17 +fun intern thy instances =  map (apfst (Locale.intern thy)) instances;
    6.18  
    6.19  
    6.20  (** Parameters of expression.
    6.21 @@ -85,14 +85,14 @@
    6.22        (* FIXME: cannot compare bindings for equality. *)
    6.23  
    6.24      fun params_loc loc =
    6.25 -          (NewLocale.params_of thy loc |> map (fn (p, _, mx) => (p, mx)), loc);
    6.26 +          (Locale.params_of thy loc |> map (fn (p, _, mx) => (p, mx)), loc);
    6.27      fun params_inst (expr as (loc, (prfx, Positional insts))) =
    6.28            let
    6.29              val (ps, loc') = params_loc loc;
    6.30              val d = length ps - length insts;
    6.31              val insts' =
    6.32                if d < 0 then error ("More arguments than parameters in instantiation of locale " ^
    6.33 -                quote (NewLocale.extern thy loc))
    6.34 +                quote (Locale.extern thy loc))
    6.35                else insts @ replicate d NONE;
    6.36              val ps' = (ps ~~ insts') |>
    6.37                map_filter (fn (p, NONE) => SOME p | (_, SOME _) => NONE);
    6.38 @@ -309,7 +309,7 @@
    6.39  fun finish_inst ctxt parms do_close (loc, (prfx, inst)) =
    6.40    let
    6.41      val thy = ProofContext.theory_of ctxt;
    6.42 -    val (parm_names, parm_types) = NewLocale.params_of thy loc |>
    6.43 +    val (parm_names, parm_types) = Locale.params_of thy loc |>
    6.44        map (fn (b, SOME T, _) => (Binding.base_name b, T)) |> split_list;
    6.45      val (morph, _) = inst_morph (parm_names, parm_types) (prfx, inst) ctxt;
    6.46    in (loc, morph) end;
    6.47 @@ -341,7 +341,7 @@
    6.48  
    6.49      fun prep_inst (loc, (prfx, inst)) (i, insts, ctxt) =
    6.50        let
    6.51 -        val (parm_names, parm_types) = NewLocale.params_of thy loc |>
    6.52 +        val (parm_names, parm_types) = Locale.params_of thy loc |>
    6.53            map (fn (b, SOME T, _) => (Binding.base_name b, T)) |> split_list;
    6.54          val inst' = parse_inst parm_names inst ctxt;
    6.55          val parm_types' = map (TypeInfer.paramify_vars o
    6.56 @@ -351,7 +351,7 @@
    6.57          val (insts'', _, _, ctxt' (* FIXME not used *) ) = check_autofix insts' [] [] ctxt;
    6.58          val inst''' = insts'' |> List.last |> snd |> snd;
    6.59          val (morph, _) = inst_morph (parm_names, parm_types) (prfx, inst''') ctxt;
    6.60 -        val ctxt'' = NewLocale.activate_declarations thy (loc, morph) ctxt;
    6.61 +        val ctxt'' = Locale.activate_declarations thy (loc, morph) ctxt;
    6.62        in (i+1, insts', ctxt'') end;
    6.63    
    6.64      fun prep_elem raw_elem (insts, elems, ctxt) =
    6.65 @@ -425,7 +425,7 @@
    6.66      (* Declare parameters and imported facts *)
    6.67      val context' = context |>
    6.68        ProofContext.add_fixes_i fixed |> snd |>
    6.69 -      fold NewLocale.activate_local_facts deps;
    6.70 +      fold Locale.activate_local_facts deps;
    6.71      val (elems', _) = activate elems (ProofContext.set_stmt true context');
    6.72    in ((fixed, deps, elems'), (parms, ctxt')) end;
    6.73  
    6.74 @@ -443,7 +443,7 @@
    6.75  
    6.76  fun props_of thy (name, morph) =
    6.77    let
    6.78 -    val (asm, defs) = NewLocale.specification_of thy name;
    6.79 +    val (asm, defs) = Locale.specification_of thy name;
    6.80    in
    6.81      (case asm of NONE => defs | SOME asm => asm :: defs) |> map (Morphism.term morph)
    6.82    end;
    6.83 @@ -530,7 +530,7 @@
    6.84  fun eval_inst ctxt (loc, morph) text =
    6.85    let
    6.86      val thy = ProofContext.theory_of ctxt;
    6.87 -    val (asm, defs) = NewLocale.specification_of thy loc;
    6.88 +    val (asm, defs) = Locale.specification_of thy loc;
    6.89      val asm' = Option.map (Morphism.term morph) asm;
    6.90      val defs' = map (Morphism.term morph) defs;
    6.91      val text' = text |>
    6.92 @@ -540,7 +540,7 @@
    6.93        (if not (null defs)
    6.94          then eval_text ctxt false (Defines (map (fn def => (Attrib.empty_binding, (def, []))) defs'))
    6.95          else I)
    6.96 -(* FIXME clone from new_locale.ML *)
    6.97 +(* FIXME clone from locale.ML *)
    6.98    in text' end;
    6.99  
   6.100  fun eval_elem ctxt elem text =
   6.101 @@ -657,7 +657,7 @@
   6.102              |> Sign.add_path aname
   6.103              |> Sign.no_base_names
   6.104              |> PureThy.note_thmss Thm.internalK
   6.105 -              [((Binding.name introN, []), [([intro], [NewLocale.unfold_attrib])])]
   6.106 +              [((Binding.name introN, []), [([intro], [Locale.unfold_attrib])])]
   6.107              ||> Sign.restore_naming thy';
   6.108            in (SOME statement, SOME intro, axioms, thy'') end;
   6.109      val (b_pred, b_intro, b_axioms, thy'''') =
   6.110 @@ -672,7 +672,7 @@
   6.111              |> Sign.add_path pname
   6.112              |> Sign.no_base_names
   6.113              |> PureThy.note_thmss Thm.internalK
   6.114 -                 [((Binding.name introN, []), [([intro], [NewLocale.intro_attrib])]),
   6.115 +                 [((Binding.name introN, []), [([intro], [Locale.intro_attrib])]),
   6.116                    ((Binding.name axiomsN, []),
   6.117                      [(map (Drule.standard o Element.conclude_witness) axioms, [])])]
   6.118              ||> Sign.restore_naming thy''';
   6.119 @@ -694,14 +694,14 @@
   6.120  fun defines_to_notes thy (Defines defs) =
   6.121        Notes (Thm.definitionK, map (fn (a, (def, _)) =>
   6.122          (a, [([Assumption.assume (cterm_of thy def)],
   6.123 -          [(Attrib.internal o K) NewLocale.witness_attrib])])) defs)
   6.124 +          [(Attrib.internal o K) Locale.witness_attrib])])) defs)
   6.125    | defines_to_notes _ e = e;
   6.126  
   6.127  fun gen_add_locale prep_decl
   6.128      bname predicate_name raw_imprt raw_body thy =
   6.129    let
   6.130      val name = Sign.full_bname thy bname;
   6.131 -    val _ = NewLocale.test_locale thy name andalso
   6.132 +    val _ = Locale.test_locale thy name andalso
   6.133        error ("Duplicate definition of locale " ^ quote name);
   6.134  
   6.135      val ((fixed, deps, body_elems), (parms, ctxt')) =
   6.136 @@ -726,7 +726,7 @@
   6.137          if is_some asm
   6.138          then [(Thm.internalK, [((Binding.name (bname ^ "_" ^ axiomsN), []),
   6.139            [([Assumption.assume (cterm_of thy' (the asm))],
   6.140 -            [(Attrib.internal o K) NewLocale.witness_attrib])])])]
   6.141 +            [(Attrib.internal o K) Locale.witness_attrib])])])]
   6.142          else [];
   6.143  
   6.144      val notes' = body_elems |>
   6.145 @@ -740,7 +740,7 @@
   6.146      val deps' = map (fn (l, morph) => (l, morph $> b_satisfy)) deps;
   6.147  
   6.148      val loc_ctxt = thy'
   6.149 -      |> NewLocale.register_locale bname (extraTs, params)
   6.150 +      |> Locale.register_locale bname (extraTs, params)
   6.151            (asm, rev defs) ([], [])
   6.152            (map (fn n => (n, stamp ())) notes |> rev) (map (fn d => (d, stamp ())) deps' |> rev)
   6.153        |> TheoryTarget.init (SOME name)
   6.154 @@ -774,20 +774,20 @@
   6.155      raw_target expression thy =
   6.156    let
   6.157      val target = intern thy raw_target;
   6.158 -    val target_ctxt = NewLocale.init target thy;
   6.159 +    val target_ctxt = Locale.init target thy;
   6.160  
   6.161      val ((propss, deps, export), goal_ctxt) = prep_expr expression target_ctxt;
   6.162      
   6.163      fun store_dep ((name, morph), thms) =
   6.164 -      NewLocale.add_dependency target (name, morph $> Element.satisfy_morphism thms $> export);
   6.165 +      Locale.add_dependency target (name, morph $> Element.satisfy_morphism thms $> export);
   6.166  
   6.167      fun after_qed results =
   6.168        ProofContext.theory (
   6.169          (* store dependencies *)
   6.170          fold store_dep (deps ~~ prep_result propss results) #>
   6.171          (* propagate registrations *)
   6.172 -        (fn thy => fold_rev (fn reg => NewLocale.activate_global_facts reg)
   6.173 -          (NewLocale.get_global_registrations thy) thy));
   6.174 +        (fn thy => fold_rev (fn reg => Locale.activate_global_facts reg)
   6.175 +          (Locale.get_global_registrations thy) thy));
   6.176    in
   6.177      goal_ctxt |>
   6.178        Proof.theorem_i NONE after_qed (prep_propp propss) |>
   6.179 @@ -796,7 +796,7 @@
   6.180  
   6.181  in
   6.182  
   6.183 -fun sublocale_cmd x = gen_sublocale read_goal_expression NewLocale.intern x;
   6.184 +fun sublocale_cmd x = gen_sublocale read_goal_expression Locale.intern x;
   6.185  fun sublocale x = gen_sublocale cert_goal_expression (K I) x;
   6.186  
   6.187  end;
   6.188 @@ -824,11 +824,11 @@
   6.189          let
   6.190            val thms' = map (Element.morph_witness export') thms;
   6.191            val morph' = morph $> Element.satisfy_morphism thms';
   6.192 -          val add = NewLocale.add_global_registration (name, (morph', export));
   6.193 +          val add = Locale.add_global_registration (name, (morph', export));
   6.194          in ((name, morph') :: regs, add thy) end
   6.195        | store (Eqns [], []) (regs, thy) =
   6.196          let val add = fold_rev (fn (name, morph) =>
   6.197 -              NewLocale.activate_global_facts (name, morph $> export)) regs;
   6.198 +              Locale.activate_global_facts (name, morph $> export)) regs;
   6.199          in (regs, add thy) end
   6.200        | store (Eqns attns, thms) (regs, thy) =
   6.201          let
   6.202 @@ -842,8 +842,8 @@
   6.203            val attns' = map ((apsnd o map) (Attrib.attribute_i thy)) attns;
   6.204            val add =
   6.205              fold_rev (fn (name, morph) =>
   6.206 -              NewLocale.amend_global_registration eq_morph (name, morph) #>
   6.207 -              NewLocale.activate_global_facts (name, morph $> eq_morph $> export)) regs #>
   6.208 +              Locale.amend_global_registration eq_morph (name, morph) #>
   6.209 +              Locale.activate_global_facts (name, morph $> eq_morph $> export)) regs #>
   6.210              PureThy.note_thmss Thm.lemmaK (attns' ~~ map (fn th => [([th], [])]) thms') #>
   6.211              snd
   6.212          in (regs, add thy) end;
   6.213 @@ -883,7 +883,7 @@
   6.214        let
   6.215          val morph' = morph $> Element.satisfy_morphism thms $> export;
   6.216        in
   6.217 -        NewLocale.activate_local_facts (name, morph')
   6.218 +        Locale.activate_local_facts (name, morph')
   6.219        end;
   6.220  
   6.221      fun after_qed results =
     7.1 --- a/src/Pure/Isar/isar_cmd.ML	Mon Jan 05 15:37:49 2009 +0100
     7.2 +++ b/src/Pure/Isar/isar_cmd.ML	Mon Jan 05 15:55:04 2009 +0100
     7.3 @@ -354,17 +354,17 @@
     7.4  val print_theorems = Toplevel.unknown_context o print_theorems_theory o print_theorems_proof;
     7.5  
     7.6  val print_locales = Toplevel.unknown_theory o
     7.7 -  Toplevel.keep (NewLocale.print_locales o Toplevel.theory_of);
     7.8 +  Toplevel.keep (Locale.print_locales o Toplevel.theory_of);
     7.9  
    7.10  fun print_locale (show_facts, name) = Toplevel.unknown_theory o
    7.11    Toplevel.keep (fn state =>
    7.12 -    NewLocale.print_locale (Toplevel.theory_of state) show_facts name);
    7.13 +    Locale.print_locale (Toplevel.theory_of state) show_facts name);
    7.14  
    7.15  fun print_registrations show_wits name = Toplevel.unknown_context o
    7.16    Toplevel.keep (Toplevel.node_case
    7.17 -      (Context.cases (Locale.print_registrations show_wits name o ProofContext.init)
    7.18 -        (Locale.print_registrations show_wits name))
    7.19 -    (Locale.print_registrations show_wits name o Proof.context_of));
    7.20 +      (Context.cases (Old_Locale.print_registrations show_wits name o ProofContext.init)
    7.21 +        (Old_Locale.print_registrations show_wits name))
    7.22 +    (Old_Locale.print_registrations show_wits name o Proof.context_of));
    7.23  
    7.24  val print_attributes = Toplevel.unknown_theory o
    7.25    Toplevel.keep (Attrib.print_attributes o Toplevel.theory_of);
     8.1 --- a/src/Pure/Isar/isar_syn.ML	Mon Jan 05 15:37:49 2009 +0100
     8.2 +++ b/src/Pure/Isar/isar_syn.ML	Mon Jan 05 15:55:04 2009 +0100
     8.3 @@ -427,24 +427,24 @@
     8.4  val locale_val =
     8.5    SpecParse.locale_expr --
     8.6      Scan.optional (P.$$$ "+" |-- P.!!! (Scan.repeat1 SpecParse.context_element)) [] ||
     8.7 -  Scan.repeat1 SpecParse.context_element >> pair Locale.empty;
     8.8 +  Scan.repeat1 SpecParse.context_element >> pair Old_Locale.empty;
     8.9  
    8.10  val _ =
    8.11    OuterSyntax.command "class_locale" "define named proof context based on classes" K.thy_decl
    8.12 -    (P.name -- Scan.optional (P.$$$ "=" |-- P.!!! locale_val) (Locale.empty, []) -- P.opt_begin
    8.13 +    (P.name -- Scan.optional (P.$$$ "=" |-- P.!!! locale_val) (Old_Locale.empty, []) -- P.opt_begin
    8.14        >> (fn ((name, (expr, elems)), begin) =>
    8.15            (begin ? Toplevel.print) o Toplevel.begin_local_theory begin
    8.16 -            (Locale.add_locale_cmd name expr elems #-> TheoryTarget.begin)));
    8.17 +            (Old_Locale.add_locale_cmd name expr elems #-> TheoryTarget.begin)));
    8.18  
    8.19  val _ =
    8.20    OuterSyntax.command "class_interpretation"
    8.21      "prove and register interpretation of locale expression in theory or locale" K.thy_goal
    8.22      (P.xname --| (P.$$$ "\\<subseteq>" || P.$$$ "<") -- P.!!! SpecParse.locale_expr
    8.23 -      >> (Toplevel.print oo (Toplevel.theory_to_proof o Locale.interpretation_in_locale I)) ||
    8.24 +      >> (Toplevel.print oo (Toplevel.theory_to_proof o Old_Locale.interpretation_in_locale I)) ||
    8.25        opt_prefix  -- SpecParse.locale_expr -- SpecParse.locale_insts
    8.26          >> (fn ((name, expr), insts) => Toplevel.print o
    8.27              Toplevel.theory_to_proof
    8.28 -              (Locale.interpretation_cmd (Binding.base_name name) expr insts)));
    8.29 +              (Old_Locale.interpretation_cmd (Binding.base_name name) expr insts)));
    8.30  
    8.31  val _ =
    8.32    OuterSyntax.command "class_interpret"
    8.33 @@ -453,7 +453,7 @@
    8.34      (opt_prefix -- SpecParse.locale_expr -- SpecParse.locale_insts
    8.35        >> (fn ((name, expr), insts) => Toplevel.print o
    8.36            Toplevel.proof'
    8.37 -            (fn int => Locale.interpret_cmd (Binding.base_name name) expr insts int)));
    8.38 +            (fn int => Old_Locale.interpret_cmd (Binding.base_name name) expr insts int)));
    8.39  
    8.40  end;
    8.41  
     9.1 --- a/src/Pure/Isar/locale.ML	Mon Jan 05 15:37:49 2009 +0100
     9.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     9.3 @@ -1,2485 +0,0 @@
     9.4 -(*  Title:      Pure/Isar/locale.ML
     9.5 -    Author:     Clemens Ballarin, TU Muenchen
     9.6 -    Author:     Markus Wenzel, LMU/TU Muenchen
     9.7 -
     9.8 -Locales -- Isar proof contexts as meta-level predicates, with local
     9.9 -syntax and implicit structures.
    9.10 -
    9.11 -Draws basic ideas from Florian Kammueller's original version of
    9.12 -locales, but uses the richer infrastructure of Isar instead of the raw
    9.13 -meta-logic.  Furthermore, structured import of contexts (with merge
    9.14 -and rename operations) are provided, as well as type-inference of the
    9.15 -signature parts, and predicate definitions of the specification text.
    9.16 -
    9.17 -Interpretation enables the reuse of theorems of locales in other
    9.18 -contexts, namely those defined by theories, structured proofs and
    9.19 -locales themselves.
    9.20 -
    9.21 -See also:
    9.22 -
    9.23 -[1] Clemens Ballarin. Locales and Locale Expressions in Isabelle/Isar.
    9.24 -    In Stefano Berardi et al., Types for Proofs and Programs: International
    9.25 -    Workshop, TYPES 2003, Torino, Italy, LNCS 3085, pages 34-50, 2004.
    9.26 -[2] Clemens Ballarin. Interpretation of Locales in Isabelle: Managing
    9.27 -    Dependencies between Locales. Technical Report TUM-I0607, Technische
    9.28 -    Universitaet Muenchen, 2006.
    9.29 -[3] Clemens Ballarin. Interpretation of Locales in Isabelle: Theories and
    9.30 -    Proof Contexts. In J.M. Borwein and W.M. Farmer, MKM 2006, LNAI 4108,
    9.31 -    pages 31-43, 2006.
    9.32 -*)
    9.33 -
    9.34 -(* TODO:
    9.35 -- beta-eta normalisation of interpretation parameters
    9.36 -- dangling type frees in locales
    9.37 -- test subsumption of interpretations when merging theories
    9.38 -*)
    9.39 -
    9.40 -signature LOCALE =
    9.41 -sig
    9.42 -  datatype expr =
    9.43 -    Locale of string |
    9.44 -    Rename of expr * (string * mixfix option) option list |
    9.45 -    Merge of expr list
    9.46 -  val empty: expr
    9.47 -
    9.48 -  val intern: theory -> xstring -> string
    9.49 -  val intern_expr: theory -> expr -> expr
    9.50 -  val extern: theory -> string -> xstring
    9.51 -  val init: string -> theory -> Proof.context
    9.52 -
    9.53 -  (* The specification of a locale *)
    9.54 -  val parameters_of: theory -> string -> ((string * typ) * mixfix) list
    9.55 -  val parameters_of_expr: theory -> expr -> ((string * typ) * mixfix) list
    9.56 -  val local_asms_of: theory -> string -> (Attrib.binding * term list) list
    9.57 -  val global_asms_of: theory -> string -> (Attrib.binding * term list) list
    9.58 -
    9.59 -  (* Theorems *)
    9.60 -  val intros: theory -> string -> thm list * thm list
    9.61 -  val dests: theory -> string -> thm list
    9.62 -  (* Not part of the official interface.  DO NOT USE *)
    9.63 -  val facts_of: theory -> string -> (Attrib.binding * (thm list * Attrib.src list) list) list list
    9.64 -
    9.65 -  (* Not part of the official interface.  DO NOT USE *)
    9.66 -  val declarations_of: theory -> string -> declaration list * declaration list;
    9.67 -
    9.68 -  (* Processing of locale statements *)
    9.69 -  val read_context_statement: string option -> Element.context list ->
    9.70 -    (string * string list) list list -> Proof.context ->
    9.71 -    string option * Proof.context * Proof.context * (term * term list) list list
    9.72 -  val read_context_statement_cmd: xstring option -> Element.context list ->
    9.73 -    (string * string list) list list -> Proof.context ->
    9.74 -    string option * Proof.context * Proof.context * (term * term list) list list
    9.75 -  val cert_context_statement: string option -> Element.context_i list ->
    9.76 -    (term * term list) list list -> Proof.context ->
    9.77 -    string option * Proof.context * Proof.context * (term * term list) list list
    9.78 -  val read_expr: expr -> Element.context list -> Proof.context ->
    9.79 -    Element.context_i list * Proof.context
    9.80 -  val cert_expr: expr -> Element.context_i list -> Proof.context ->
    9.81 -    Element.context_i list * Proof.context
    9.82 -
    9.83 -  (* Diagnostic functions *)
    9.84 -  val print_locales: theory -> unit
    9.85 -  val print_locale: theory -> bool -> expr -> Element.context list -> unit
    9.86 -  val print_registrations: bool -> string -> Proof.context -> unit
    9.87 -
    9.88 -  val add_locale: string -> bstring -> expr -> Element.context_i list -> theory
    9.89 -    -> string * Proof.context
    9.90 -  val add_locale_cmd: bstring -> expr -> Element.context list -> theory
    9.91 -    -> string * Proof.context
    9.92 -
    9.93 -  (* Tactics *)
    9.94 -  val intro_locales_tac: bool -> Proof.context -> thm list -> tactic
    9.95 -
    9.96 -  (* Storing results *)
    9.97 -  val global_note_qualified: string ->
    9.98 -    ((Binding.T * attribute list) * (thm list * attribute list) list) list ->
    9.99 -    theory -> (string * thm list) list * theory
   9.100 -  val local_note_qualified: string ->
   9.101 -    ((Binding.T * attribute list) * (thm list * attribute list) list) list ->
   9.102 -    Proof.context -> (string * thm list) list * Proof.context
   9.103 -  val add_thmss: string -> string -> (Attrib.binding * (thm list * Attrib.src list) list) list ->
   9.104 -    Proof.context -> Proof.context
   9.105 -  val add_type_syntax: string -> declaration -> Proof.context -> Proof.context
   9.106 -  val add_term_syntax: string -> declaration -> Proof.context -> Proof.context
   9.107 -  val add_declaration: string -> declaration -> Proof.context -> Proof.context
   9.108 -
   9.109 -  (* Interpretation *)
   9.110 -  val get_interpret_morph: theory -> (Binding.T -> Binding.T) -> string * string ->
   9.111 -    (Morphism.morphism * ((typ Vartab.table * typ list) * (term Vartab.table * term list))) ->
   9.112 -    string -> term list -> Morphism.morphism
   9.113 -  val interpretation: (Proof.context -> Proof.context) ->
   9.114 -    (Binding.T -> Binding.T) -> expr ->
   9.115 -    term option list * (Attrib.binding * term) list ->
   9.116 -    theory ->
   9.117 -    (Morphism.morphism * ((typ Vartab.table * typ list) * (term Vartab.table * term list))) * Proof.state
   9.118 -  val interpretation_cmd: string -> expr -> string option list * (Attrib.binding * string) list ->
   9.119 -    theory -> Proof.state
   9.120 -  val interpretation_in_locale: (Proof.context -> Proof.context) ->
   9.121 -    xstring * expr -> theory -> Proof.state
   9.122 -  val interpret: (Proof.state -> Proof.state Seq.seq) ->
   9.123 -    (Binding.T -> Binding.T) -> expr ->
   9.124 -    term option list * (Attrib.binding * term) list ->
   9.125 -    bool -> Proof.state ->
   9.126 -    (Morphism.morphism * ((typ Vartab.table * typ list) * (term Vartab.table * term list))) * Proof.state
   9.127 -  val interpret_cmd: string -> expr -> string option list * (Attrib.binding * string) list ->
   9.128 -    bool -> Proof.state -> Proof.state
   9.129 -end;
   9.130 -
   9.131 -structure Locale: LOCALE =
   9.132 -struct
   9.133 -
   9.134 -(* legacy operations *)
   9.135 -
   9.136 -fun merge_lists _ xs [] = xs
   9.137 -  | merge_lists _ [] ys = ys
   9.138 -  | merge_lists eq xs ys = xs @ filter_out (member eq xs) ys;
   9.139 -
   9.140 -fun merge_alists eq xs = merge_lists (eq_fst eq) xs;
   9.141 -
   9.142 -
   9.143 -(* auxiliary: noting name bindings with qualified base names *)
   9.144 -
   9.145 -fun global_note_qualified kind facts thy =
   9.146 -  thy
   9.147 -  |> Sign.qualified_names
   9.148 -  |> PureThy.note_thmss kind facts
   9.149 -  ||> Sign.restore_naming thy;
   9.150 -
   9.151 -fun local_note_qualified kind facts ctxt =
   9.152 -  ctxt
   9.153 -  |> ProofContext.qualified_names
   9.154 -  |> ProofContext.note_thmss_i kind facts
   9.155 -  ||> ProofContext.restore_naming ctxt;
   9.156 -
   9.157 -
   9.158 -(** locale elements and expressions **)
   9.159 -
   9.160 -datatype ctxt = datatype Element.ctxt;
   9.161 -
   9.162 -datatype expr =
   9.163 -  Locale of string |
   9.164 -  Rename of expr * (string * mixfix option) option list |
   9.165 -  Merge of expr list;
   9.166 -
   9.167 -val empty = Merge [];
   9.168 -
   9.169 -datatype 'a element =
   9.170 -  Elem of 'a | Expr of expr;
   9.171 -
   9.172 -fun map_elem f (Elem e) = Elem (f e)
   9.173 -  | map_elem _ (Expr e) = Expr e;
   9.174 -
   9.175 -type decl = declaration * stamp;
   9.176 -
   9.177 -type locale =
   9.178 - {axiom: Element.witness list,
   9.179 -    (* For locales that define predicates this is [A [A]], where A is the locale
   9.180 -       specification.  Otherwise [].
   9.181 -       Only required to generate the right witnesses for locales with predicates. *)
   9.182 -  elems: (Element.context_i * stamp) list,
   9.183 -    (* Static content, neither Fixes nor Constrains elements *)
   9.184 -  params: ((string * typ) * mixfix) list,                        (*all term params*)
   9.185 -  decls: decl list * decl list,                    (*type/term_syntax declarations*)
   9.186 -  regs: ((string * string list) * Element.witness list) list,
   9.187 -    (* Registrations: indentifiers and witnesses of locales interpreted in the locale. *)
   9.188 -  intros: thm list * thm list,
   9.189 -    (* Introduction rules: of delta predicate and locale predicate. *)
   9.190 -  dests: thm list}
   9.191 -    (* Destruction rules: projections from locale predicate to predicates of fragments. *)
   9.192 -
   9.193 -(* CB: an internal (Int) locale element was either imported or included,
   9.194 -   an external (Ext) element appears directly in the locale text. *)
   9.195 -
   9.196 -datatype ('a, 'b) int_ext = Int of 'a | Ext of 'b;
   9.197 -
   9.198 -
   9.199 -
   9.200 -(** substitutions on Vars -- clone from element.ML **)
   9.201 -
   9.202 -(* instantiate types *)
   9.203 -
   9.204 -fun var_instT_type env =
   9.205 -  if Vartab.is_empty env then I
   9.206 -  else Term.map_type_tvar (fn (x, S) => the_default (TVar (x, S)) (Vartab.lookup env x));
   9.207 -
   9.208 -fun var_instT_term env =
   9.209 -  if Vartab.is_empty env then I
   9.210 -  else Term.map_types (var_instT_type env);
   9.211 -
   9.212 -fun var_inst_term (envT, env) =
   9.213 -  if Vartab.is_empty env then var_instT_term envT
   9.214 -  else
   9.215 -    let
   9.216 -      val instT = var_instT_type envT;
   9.217 -      fun inst (Const (x, T)) = Const (x, instT T)
   9.218 -        | inst (Free (x, T)) = Free(x, instT T)
   9.219 -        | inst (Var (xi, T)) =
   9.220 -            (case Vartab.lookup env xi of
   9.221 -              NONE => Var (xi, instT T)
   9.222 -            | SOME t => t)
   9.223 -        | inst (b as Bound _) = b
   9.224 -        | inst (Abs (x, T, t)) = Abs (x, instT T, inst t)
   9.225 -        | inst (t $ u) = inst t $ inst u;
   9.226 -    in Envir.beta_norm o inst end;
   9.227 -
   9.228 -
   9.229 -(** management of registrations in theories and proof contexts **)
   9.230 -
   9.231 -type registration =
   9.232 -  {prfx: (Binding.T -> Binding.T) * (string * string),
   9.233 -      (* first component: interpretation name morphism;
   9.234 -         second component: parameter prefix *)
   9.235 -    exp: Morphism.morphism,
   9.236 -      (* maps content to its originating context *)
   9.237 -    imp: (typ Vartab.table * typ list) * (term Vartab.table * term list),
   9.238 -      (* inverse of exp *)
   9.239 -    wits: Element.witness list,
   9.240 -      (* witnesses of the registration *)
   9.241 -    eqns: thm Termtab.table,
   9.242 -      (* theorems (equations) interpreting derived concepts and indexed by lhs *)
   9.243 -    morph: unit
   9.244 -      (* interpreting morphism *)
   9.245 -  }
   9.246 -
   9.247 -structure Registrations :
   9.248 -  sig
   9.249 -    type T
   9.250 -    val empty: T
   9.251 -    val join: T * T -> T
   9.252 -    val dest: theory -> T ->
   9.253 -      (term list *
   9.254 -        (((Binding.T -> Binding.T) * (string * string)) *
   9.255 -         (Morphism.morphism * ((typ Vartab.table * typ list) * (term Vartab.table * term list))) *
   9.256 -         Element.witness list *
   9.257 -         thm Termtab.table)) list
   9.258 -    val test: theory -> T * term list -> bool
   9.259 -    val lookup: theory ->
   9.260 -      T * (term list * ((typ Vartab.table * typ list) * (term Vartab.table * term list))) ->
   9.261 -      (((Binding.T -> Binding.T) * (string * string)) * Element.witness list * thm Termtab.table) option
   9.262 -    val insert: theory -> term list -> ((Binding.T -> Binding.T) * (string * string)) ->
   9.263 -      (Morphism.morphism * ((typ Vartab.table * typ list) * (term Vartab.table * term list))) ->
   9.264 -      T ->
   9.265 -      T * (term list * (((Binding.T -> Binding.T) * (string * string)) * Element.witness list)) list
   9.266 -    val add_witness: term list -> Element.witness -> T -> T
   9.267 -    val add_equation: term list -> thm -> T -> T
   9.268 -(*
   9.269 -    val update_morph: term list -> Morphism.morphism -> T -> T
   9.270 -    val get_morph: theory -> T ->
   9.271 -      term list * ((typ Vartab.table * typ list) * (term Vartab.table * term list)) ->
   9.272 -      Morphism.morphism
   9.273 -*)
   9.274 -  end =
   9.275 -struct
   9.276 -  (* A registration is indexed by parameter instantiation.
   9.277 -     NB: index is exported whereas content is internalised. *)
   9.278 -  type T = registration Termtab.table;
   9.279 -
   9.280 -  fun mk_reg prfx exp imp wits eqns morph =
   9.281 -    {prfx = prfx, exp = exp, imp = imp, wits = wits, eqns = eqns, morph = morph};
   9.282 -
   9.283 -  fun map_reg f reg =
   9.284 -    let
   9.285 -      val {prfx, exp, imp, wits, eqns, morph} = reg;
   9.286 -      val (prfx', exp', imp', wits', eqns', morph') = f (prfx, exp, imp, wits, eqns, morph);
   9.287 -    in mk_reg prfx' exp' imp' wits' eqns' morph' end;
   9.288 -
   9.289 -  val empty = Termtab.empty;
   9.290 -
   9.291 -  (* term list represented as single term, for simultaneous matching *)
   9.292 -  fun termify ts =
   9.293 -    Term.list_comb (Const ("", map fastype_of ts ---> propT), ts);
   9.294 -  fun untermify t =
   9.295 -    let fun ut (Const _) ts = ts
   9.296 -          | ut (s $ t) ts = ut s (t::ts)
   9.297 -    in ut t [] end;
   9.298 -
   9.299 -  (* joining of registrations:
   9.300 -     - prefix and morphisms of right theory;
   9.301 -     - witnesses are equal, no attempt to subsumption testing;
   9.302 -     - union of equalities, if conflicting (i.e. two eqns with equal lhs)
   9.303 -       eqn of right theory takes precedence *)
   9.304 -  fun join (r1, r2) = Termtab.join (fn _ => fn ({eqns = e1, ...}, {prfx = n, exp, imp, wits = w, eqns = e2, morph = m}) =>
   9.305 -      mk_reg n exp imp w (Termtab.join (fn _ => fn (_, e) => e) (e1, e2)) m) (r1, r2);
   9.306 -
   9.307 -  fun dest_transfer thy regs =
   9.308 -    Termtab.dest regs |> map (apsnd (map_reg (fn (n, e, i, ws, es, m) =>
   9.309 -      (n, e, i, map (Element.transfer_witness thy) ws, Termtab.map (transfer thy) es, m))));
   9.310 -
   9.311 -  fun dest thy regs = dest_transfer thy regs |> map (apfst untermify) |>
   9.312 -    map (apsnd (fn {prfx, exp, imp, wits, eqns, ...} => (prfx, (exp, imp), wits, eqns)));
   9.313 -
   9.314 -  (* registrations that subsume t *)
   9.315 -  fun subsumers thy t regs =
   9.316 -    filter (fn (t', _) => Pattern.matches thy (t', t)) (dest_transfer thy regs);
   9.317 -
   9.318 -  (* test if registration that subsumes the query is present *)
   9.319 -  fun test thy (regs, ts) =
   9.320 -    not (null (subsumers thy (termify ts) regs));
   9.321 -      
   9.322 -  (* look up registration, pick one that subsumes the query *)
   9.323 -  fun lookup thy (regs, (ts, ((impT, _), (imp, _)))) =
   9.324 -    let
   9.325 -      val t = termify ts;
   9.326 -      val subs = subsumers thy t regs;
   9.327 -    in
   9.328 -      (case subs of
   9.329 -        [] => NONE
   9.330 -        | ((t', {prfx, exp = exp', imp = ((impT', domT'), (imp', dom')), wits, eqns, morph}) :: _) =>
   9.331 -          let
   9.332 -            val (tinst, inst) = Pattern.match thy (t', t) (Vartab.empty, Vartab.empty);
   9.333 -            val tinst' = domT' |> map (fn (T as TFree (x, _)) =>
   9.334 -                (x, T |> Morphism.typ exp' |> Envir.typ_subst_TVars tinst
   9.335 -                      |> var_instT_type impT)) |> Symtab.make;
   9.336 -            val inst' = dom' |> map (fn (t as Free (x, _)) =>
   9.337 -                (x, t |> Morphism.term exp' |> Envir.subst_vars (tinst, inst)
   9.338 -                      |> var_inst_term (impT, imp))) |> Symtab.make;
   9.339 -            val inst'_morph = Element.inst_morphism thy (tinst', inst');
   9.340 -          in SOME (prfx,
   9.341 -            map (Element.morph_witness inst'_morph) wits,
   9.342 -            Termtab.map (Morphism.thm inst'_morph) eqns)
   9.343 -          end)
   9.344 -    end;
   9.345 -
   9.346 -  (* add registration if not subsumed by ones already present,
   9.347 -     additionally returns registrations that are strictly subsumed *)
   9.348 -  fun insert thy ts prfx (exp, imp) regs =
   9.349 -    let
   9.350 -      val t = termify ts;
   9.351 -      val subs = subsumers thy t regs ;
   9.352 -    in (case subs of
   9.353 -        [] => let
   9.354 -                val sups =
   9.355 -                  filter (fn (t', _) => Pattern.matches thy (t, t')) (dest_transfer thy regs);
   9.356 -                val sups' = map (apfst untermify) sups |> map (fn (ts, {prfx, wits, ...}) => (ts, (prfx, wits)))
   9.357 -              in (Termtab.update (t, mk_reg prfx exp imp [] Termtab.empty ()) regs, sups') end
   9.358 -      | _ => (regs, []))
   9.359 -    end;
   9.360 -
   9.361 -  fun gen_add f ts regs =
   9.362 -    let
   9.363 -      val t = termify ts;
   9.364 -    in
   9.365 -      Termtab.update (t, map_reg f (the (Termtab.lookup regs t))) regs
   9.366 -    end;
   9.367 -
   9.368 -  (* add witness theorem to registration,
   9.369 -     only if instantiation is exact, otherwise exception Option raised *)
   9.370 -  fun add_witness ts wit regs =
   9.371 -    gen_add (fn (x, e, i, wits, eqns, m) => (x, e, i, Element.close_witness wit :: wits, eqns, m))
   9.372 -      ts regs;
   9.373 -
   9.374 -  (* add equation to registration, replaces previous equation with same lhs;
   9.375 -     only if instantiation is exact, otherwise exception Option raised;
   9.376 -     exception TERM raised if not a meta equality *)
   9.377 -  fun add_equation ts thm regs =
   9.378 -    gen_add (fn (x, e, i, thms, eqns, m) =>
   9.379 -      (x, e, i, thms, Termtab.update (thm |> prop_of |> Logic.dest_equals |> fst, Thm.close_derivation thm) eqns, m))
   9.380 -      ts regs;
   9.381 -
   9.382 -end;
   9.383 -
   9.384 -
   9.385 -(** theory data : locales **)
   9.386 -
   9.387 -structure LocalesData = TheoryDataFun
   9.388 -(
   9.389 -  type T = NameSpace.T * locale Symtab.table;
   9.390 -    (* 1st entry: locale namespace,
   9.391 -       2nd entry: locales of the theory *)
   9.392 -
   9.393 -  val empty = NameSpace.empty_table;
   9.394 -  val copy = I;
   9.395 -  val extend = I;
   9.396 -
   9.397 -  fun join_locales _
   9.398 -    ({axiom, elems, params, decls = (decls1, decls2), regs, intros, dests}: locale,
   9.399 -      {elems = elems', decls = (decls1', decls2'), regs = regs', ...}: locale) =
   9.400 -     {axiom = axiom,
   9.401 -      elems = merge_lists (eq_snd (op =)) elems elems',
   9.402 -      params = params,
   9.403 -      decls =
   9.404 -       (Library.merge (eq_snd (op =)) (decls1, decls1'),
   9.405 -        Library.merge (eq_snd (op =)) (decls2, decls2')),
   9.406 -      regs = merge_alists (op =) regs regs',
   9.407 -      intros = intros,
   9.408 -      dests = dests};
   9.409 -  fun merge _ = NameSpace.join_tables join_locales;
   9.410 -);
   9.411 -
   9.412 -
   9.413 -
   9.414 -(** context data : registrations **)
   9.415 -
   9.416 -structure RegistrationsData = GenericDataFun
   9.417 -(
   9.418 -  type T = Registrations.T Symtab.table;  (*registrations, indexed by locale name*)
   9.419 -  val empty = Symtab.empty;
   9.420 -  val extend = I;
   9.421 -  fun merge _ = Symtab.join (K Registrations.join);
   9.422 -);
   9.423 -
   9.424 -
   9.425 -(** access locales **)
   9.426 -
   9.427 -val intern = NameSpace.intern o #1 o LocalesData.get;
   9.428 -val extern = NameSpace.extern o #1 o LocalesData.get;
   9.429 -
   9.430 -fun get_locale thy name = Symtab.lookup (#2 (LocalesData.get thy)) name;
   9.431 -
   9.432 -fun the_locale thy name = case get_locale thy name
   9.433 - of SOME loc => loc
   9.434 -  | NONE => error ("Unknown locale " ^ quote name);
   9.435 -
   9.436 -fun register_locale bname loc thy =
   9.437 -  thy |> LocalesData.map (NameSpace.bind (Sign.naming_of thy)
   9.438 -    (Binding.name bname, loc) #> snd);
   9.439 -
   9.440 -fun change_locale name f thy =
   9.441 -  let
   9.442 -    val {axiom, elems, params, decls, regs, intros, dests} =
   9.443 -        the_locale thy name;
   9.444 -    val (axiom', elems', params', decls', regs', intros', dests') =
   9.445 -      f (axiom, elems, params, decls, regs, intros, dests);
   9.446 -  in
   9.447 -    thy
   9.448 -    |> (LocalesData.map o apsnd) (Symtab.update (name, {axiom = axiom',
   9.449 -          elems = elems', params = params',
   9.450 -          decls = decls', regs = regs', intros = intros', dests = dests'}))
   9.451 -  end;
   9.452 -
   9.453 -fun print_locales thy =
   9.454 -  let val (space, locs) = LocalesData.get thy in
   9.455 -    Pretty.strs ("locales:" :: map #1 (NameSpace.extern_table (space, locs)))
   9.456 -    |> Pretty.writeln
   9.457 -  end;
   9.458 -
   9.459 -
   9.460 -(* access registrations *)
   9.461 -
   9.462 -(* retrieve registration from theory or context *)
   9.463 -
   9.464 -fun get_registrations ctxt name =
   9.465 -  case Symtab.lookup (RegistrationsData.get ctxt) name of
   9.466 -      NONE => []
   9.467 -    | SOME reg => Registrations.dest (Context.theory_of ctxt) reg;
   9.468 -
   9.469 -fun get_global_registrations thy = get_registrations (Context.Theory thy);
   9.470 -fun get_local_registrations ctxt = get_registrations (Context.Proof ctxt);
   9.471 -
   9.472 -
   9.473 -fun get_registration ctxt imprt (name, ps) =
   9.474 -  case Symtab.lookup (RegistrationsData.get ctxt) name of
   9.475 -      NONE => NONE
   9.476 -    | SOME reg => Registrations.lookup (Context.theory_of ctxt) (reg, (ps, imprt));
   9.477 -
   9.478 -fun get_global_registration thy = get_registration (Context.Theory thy);
   9.479 -fun get_local_registration ctxt = get_registration (Context.Proof ctxt);
   9.480 -
   9.481 -
   9.482 -fun test_registration ctxt (name, ps) =
   9.483 -  case Symtab.lookup (RegistrationsData.get ctxt) name of
   9.484 -      NONE => false
   9.485 -    | SOME reg => Registrations.test (Context.theory_of ctxt) (reg, ps);
   9.486 -
   9.487 -fun test_global_registration thy = test_registration (Context.Theory thy);
   9.488 -fun test_local_registration ctxt = test_registration (Context.Proof ctxt);
   9.489 -
   9.490 -
   9.491 -(* add registration to theory or context, ignored if subsumed *)
   9.492 -
   9.493 -fun put_registration (name, ps) prfx morphs ctxt =
   9.494 -  RegistrationsData.map (fn regs =>
   9.495 -    let
   9.496 -      val thy = Context.theory_of ctxt;
   9.497 -      val reg = the_default Registrations.empty (Symtab.lookup regs name);
   9.498 -      val (reg', sups) = Registrations.insert thy ps prfx morphs reg;
   9.499 -      val _ = if not (null sups) then warning
   9.500 -                ("Subsumed interpretation(s) of locale " ^
   9.501 -                 quote (extern thy name) ^
   9.502 -                 "\nwith the following prefix(es):" ^
   9.503 -                  commas_quote (map (fn (_, ((_, (_, s)), _)) => s) sups))
   9.504 -              else ();
   9.505 -    in Symtab.update (name, reg') regs end) ctxt;
   9.506 -
   9.507 -fun put_global_registration id prfx morphs =
   9.508 -  Context.theory_map (put_registration id prfx morphs);
   9.509 -fun put_local_registration id prfx morphs =
   9.510 -  Context.proof_map (put_registration id prfx morphs);
   9.511 -
   9.512 -fun put_registration_in_locale name id =
   9.513 -  change_locale name (fn (axiom, elems, params, decls, regs, intros, dests) =>
   9.514 -    (axiom, elems, params, decls, regs @ [(id, [])], intros, dests));
   9.515 -
   9.516 -
   9.517 -(* add witness theorem to registration, ignored if registration not present *)
   9.518 -
   9.519 -fun add_witness (name, ps) thm =
   9.520 -  RegistrationsData.map (Symtab.map_entry name (Registrations.add_witness ps thm));
   9.521 -
   9.522 -fun add_global_witness id thm = Context.theory_map (add_witness id thm);
   9.523 -fun add_local_witness id thm = Context.proof_map (add_witness id thm);
   9.524 -
   9.525 -
   9.526 -fun add_witness_in_locale name id thm =
   9.527 -  change_locale name (fn (axiom, elems, params, decls, regs, intros, dests) =>
   9.528 -    let
   9.529 -      fun add (id', thms) =
   9.530 -        if id = id' then (id', thm :: thms) else (id', thms);
   9.531 -    in (axiom, elems, params, decls, map add regs, intros, dests) end);
   9.532 -
   9.533 -
   9.534 -(* add equation to registration, ignored if registration not present *)
   9.535 -
   9.536 -fun add_equation (name, ps) thm =
   9.537 -  RegistrationsData.map (Symtab.map_entry name (Registrations.add_equation ps thm));
   9.538 -
   9.539 -fun add_global_equation id thm = Context.theory_map (add_equation id thm);
   9.540 -fun add_local_equation id thm = Context.proof_map (add_equation id thm);
   9.541 -
   9.542 -(*
   9.543 -(* update morphism of registration, ignored if registration not present *)
   9.544 -
   9.545 -fun update_morph (name, ps) morph =
   9.546 -  RegistrationsData.map (Symtab.map_entry name (Registrations.update_morph ps morph));
   9.547 -
   9.548 -fun update_global_morph id morph = Context.theory_map (update_morph id morph);
   9.549 -fun update_local_morph id morph = Context.proof_map (update_morph id morph);
   9.550 -*)
   9.551 -
   9.552 -
   9.553 -(* printing of registrations *)
   9.554 -
   9.555 -fun print_registrations show_wits loc ctxt =
   9.556 -  let
   9.557 -    val thy = ProofContext.theory_of ctxt;
   9.558 -    val prt_term = Pretty.quote o Syntax.pretty_term ctxt;
   9.559 -    fun prt_term' t = if !show_types
   9.560 -          then Pretty.block [prt_term t, Pretty.brk 1, Pretty.str "::",
   9.561 -            Pretty.brk 1, (Pretty.quote o Syntax.pretty_typ ctxt) (type_of t)]
   9.562 -          else prt_term t;
   9.563 -    val prt_thm = prt_term o prop_of;
   9.564 -    fun prt_inst ts =
   9.565 -        Pretty.enclose "(" ")" (Pretty.breaks (map prt_term' ts));
   9.566 -    fun prt_prfx ((false, prfx), param_prfx) = [Pretty.str prfx, Pretty.brk 1, Pretty.str "(optional)", Pretty.brk 1, Pretty.str param_prfx]
   9.567 -      | prt_prfx ((true, prfx), param_prfx) = [Pretty.str prfx, Pretty.brk 1, Pretty.str param_prfx];
   9.568 -    fun prt_eqns [] = Pretty.str "no equations."
   9.569 -      | prt_eqns eqns = Pretty.block (Pretty.str "equations:" :: Pretty.brk 1 ::
   9.570 -          Pretty.breaks (map prt_thm eqns));
   9.571 -    fun prt_core ts eqns =
   9.572 -          [prt_inst ts, Pretty.fbrk, prt_eqns (Termtab.dest eqns |> map snd)];
   9.573 -    fun prt_witns [] = Pretty.str "no witnesses."
   9.574 -      | prt_witns witns = Pretty.block (Pretty.str "witnesses:" :: Pretty.brk 1 ::
   9.575 -          Pretty.breaks (map (Element.pretty_witness ctxt) witns))
   9.576 -    fun prt_reg (ts, (_, _, witns, eqns)) =
   9.577 -        if show_wits
   9.578 -          then Pretty.block (prt_core ts eqns @ [Pretty.fbrk, prt_witns witns])
   9.579 -          else Pretty.block (prt_core ts eqns)
   9.580 -
   9.581 -    val loc_int = intern thy loc;
   9.582 -    val regs = RegistrationsData.get (Context.Proof ctxt);
   9.583 -    val loc_regs = Symtab.lookup regs loc_int;
   9.584 -  in
   9.585 -    (case loc_regs of
   9.586 -        NONE => Pretty.str ("no interpretations")
   9.587 -      | SOME r => let
   9.588 -            val r' = Registrations.dest thy r;
   9.589 -            val r'' = Library.sort_wrt (fn (_, ((_, (_, prfx)), _, _, _)) => prfx) r';
   9.590 -          in Pretty.big_list ("interpretations:") (map prt_reg r'') end)
   9.591 -    |> Pretty.writeln
   9.592 -  end;
   9.593 -
   9.594 -
   9.595 -(* diagnostics *)
   9.596 -
   9.597 -fun err_in_locale ctxt msg ids =
   9.598 -  let
   9.599 -    val thy = ProofContext.theory_of ctxt;
   9.600 -    fun prt_id (name, parms) =
   9.601 -      [Pretty.block (Pretty.breaks (map Pretty.str (extern thy name :: parms)))];
   9.602 -    val prt_ids = flat (separate [Pretty.str " +", Pretty.brk 1] (map prt_id ids));
   9.603 -    val err_msg =
   9.604 -      if forall (fn (s, _) => s = "") ids then msg
   9.605 -      else msg ^ "\n" ^ Pretty.string_of (Pretty.block
   9.606 -        (Pretty.str "The error(s) above occurred in locale:" :: Pretty.brk 1 :: prt_ids));
   9.607 -  in error err_msg end;
   9.608 -
   9.609 -fun err_in_locale' ctxt msg ids' = err_in_locale ctxt msg (map fst ids');
   9.610 -
   9.611 -
   9.612 -fun pretty_ren NONE = Pretty.str "_"
   9.613 -  | pretty_ren (SOME (x, NONE)) = Pretty.str x
   9.614 -  | pretty_ren (SOME (x, SOME syn)) =
   9.615 -      Pretty.block [Pretty.str x, Pretty.brk 1, Syntax.pretty_mixfix syn];
   9.616 -
   9.617 -fun pretty_expr thy (Locale name) = Pretty.str (extern thy name)
   9.618 -  | pretty_expr thy (Rename (expr, xs)) =
   9.619 -      Pretty.block [pretty_expr thy expr, Pretty.brk 1, Pretty.block (map pretty_ren xs |> Pretty.breaks)]
   9.620 -  | pretty_expr thy (Merge es) =
   9.621 -      Pretty.separate "+" (map (pretty_expr thy) es) |> Pretty.block;
   9.622 -
   9.623 -fun err_in_expr _ msg (Merge []) = error msg
   9.624 -  | err_in_expr ctxt msg expr =
   9.625 -    error (msg ^ "\n" ^ Pretty.string_of (Pretty.block
   9.626 -      [Pretty.str "The error(s) above occured in locale expression:", Pretty.brk 1,
   9.627 -       pretty_expr (ProofContext.theory_of ctxt) expr]));
   9.628 -
   9.629 -
   9.630 -(** structured contexts: rename + merge + implicit type instantiation **)
   9.631 -
   9.632 -(* parameter types *)
   9.633 -
   9.634 -fun frozen_tvars ctxt Ts =
   9.635 -  #1 (Variable.importT_inst (map Logic.mk_type Ts) ctxt)
   9.636 -  |> map (fn ((xi, S), T) => (xi, (S, T)));
   9.637 -
   9.638 -fun unify_frozen ctxt maxidx Ts Us =
   9.639 -  let
   9.640 -    fun paramify NONE i = (NONE, i)
   9.641 -      | paramify (SOME T) i = apfst SOME (TypeInfer.paramify_dummies T i);
   9.642 -
   9.643 -    val (Ts', maxidx') = fold_map paramify Ts maxidx;
   9.644 -    val (Us', maxidx'') = fold_map paramify Us maxidx';
   9.645 -    val thy = ProofContext.theory_of ctxt;
   9.646 -
   9.647 -    fun unify (SOME T, SOME U) env = (Sign.typ_unify thy (U, T) env
   9.648 -          handle Type.TUNIFY => raise TYPE ("unify_frozen: failed to unify types", [U, T], []))
   9.649 -      | unify _ env = env;
   9.650 -    val (unifier, _) = fold unify (Ts' ~~ Us') (Vartab.empty, maxidx'');
   9.651 -    val Vs = map (Option.map (Envir.norm_type unifier)) Us';
   9.652 -    val unifier' = fold Vartab.update_new (frozen_tvars ctxt (map_filter I Vs)) unifier;
   9.653 -  in map (Option.map (Envir.norm_type unifier')) Vs end;
   9.654 -
   9.655 -fun params_of elemss =
   9.656 -  distinct (eq_fst (op = : string * string -> bool)) (maps (snd o fst) elemss);
   9.657 -
   9.658 -fun params_of' elemss =
   9.659 -  distinct (eq_fst (op = : string * string -> bool)) (maps (snd o fst o fst) elemss);
   9.660 -
   9.661 -fun param_prefix locale_name params = (NameSpace.base locale_name ^ "_locale", space_implode "_" params);
   9.662 -
   9.663 -
   9.664 -(* CB: param_types has the following type:
   9.665 -  ('a * 'b option) list -> ('a * 'b) list *)
   9.666 -fun param_types ps = map_filter (fn (_, NONE) => NONE | (x, SOME T) => SOME (x, T)) ps;
   9.667 -
   9.668 -
   9.669 -fun merge_syntax ctxt ids ss = Symtab.merge (op = : mixfix * mixfix -> bool) ss
   9.670 -  handle Symtab.DUP x => err_in_locale ctxt
   9.671 -    ("Conflicting syntax for parameter: " ^ quote x) (map fst ids);
   9.672 -
   9.673 -
   9.674 -(* Distinction of assumed vs. derived identifiers.
   9.675 -   The former may have axioms relating assumptions of the context to
   9.676 -   assumptions of the specification fragment (for locales with
   9.677 -   predicates).  The latter have witnesses relating assumptions of the
   9.678 -   specification fragment to assumptions of other (assumed) specification
   9.679 -   fragments. *)
   9.680 -
   9.681 -datatype 'a mode = Assumed of 'a | Derived of 'a;
   9.682 -
   9.683 -fun map_mode f (Assumed x) = Assumed (f x)
   9.684 -  | map_mode f (Derived x) = Derived (f x);
   9.685 -
   9.686 -
   9.687 -(* flatten expressions *)
   9.688 -
   9.689 -local
   9.690 -
   9.691 -fun unify_parms ctxt fixed_parms raw_parmss =
   9.692 -  let
   9.693 -    val thy = ProofContext.theory_of ctxt;
   9.694 -    val maxidx = length raw_parmss;
   9.695 -    val idx_parmss = (0 upto maxidx - 1) ~~ raw_parmss;
   9.696 -
   9.697 -    fun varify i = Term.map_type_tfree (fn (a, S) => TVar ((a, i), S));
   9.698 -    fun varify_parms (i, ps) = map (apsnd (varify i)) (param_types ps);
   9.699 -    val parms = fixed_parms @ maps varify_parms idx_parmss;
   9.700 -
   9.701 -    fun unify T U envir = Sign.typ_unify thy (U, T) envir
   9.702 -      handle Type.TUNIFY =>
   9.703 -        let
   9.704 -          val T' = Envir.norm_type (fst envir) T;
   9.705 -          val U' = Envir.norm_type (fst envir) U;
   9.706 -          val prt = Syntax.string_of_typ ctxt;
   9.707 -        in
   9.708 -          raise TYPE ("unify_parms: failed to unify types " ^
   9.709 -            prt U' ^ " and " ^ prt T', [U', T'], [])
   9.710 -        end;
   9.711 -    fun unify_list (T :: Us) = fold (unify T) Us
   9.712 -      | unify_list [] = I;
   9.713 -    val (unifier, _) = fold unify_list (map #2 (Symtab.dest (Symtab.make_list parms)))
   9.714 -      (Vartab.empty, maxidx);
   9.715 -
   9.716 -    val parms' = map (apsnd (Envir.norm_type unifier)) (distinct (eq_fst (op =)) parms);
   9.717 -    val unifier' = fold Vartab.update_new (frozen_tvars ctxt (map #2 parms')) unifier;
   9.718 -
   9.719 -    fun inst_parms (i, ps) =
   9.720 -      List.foldr OldTerm.add_typ_tfrees [] (map_filter snd ps)
   9.721 -      |> map_filter (fn (a, S) =>
   9.722 -          let val T = Envir.norm_type unifier' (TVar ((a, i), S))
   9.723 -          in if T = TFree (a, S) then NONE else SOME (a, T) end)
   9.724 -      |> Symtab.make;
   9.725 -  in map inst_parms idx_parmss end;
   9.726 -
   9.727 -in
   9.728 -
   9.729 -fun unify_elemss _ _ [] = []
   9.730 -  | unify_elemss _ [] [elems] = [elems]
   9.731 -  | unify_elemss ctxt fixed_parms elemss =
   9.732 -      let
   9.733 -        val thy = ProofContext.theory_of ctxt;
   9.734 -        val phis = unify_parms ctxt fixed_parms (map (snd o fst o fst) elemss)
   9.735 -          |> map (Element.instT_morphism thy);
   9.736 -        fun inst ((((name, ps), mode), elems), phi) =
   9.737 -          (((name, map (apsnd (Option.map (Morphism.typ phi))) ps),
   9.738 -              map_mode (map (Element.morph_witness phi)) mode),
   9.739 -            map (Element.morph_ctxt phi) elems);
   9.740 -      in map inst (elemss ~~ phis) end;
   9.741 -
   9.742 -
   9.743 -fun renaming xs parms = zip_options parms xs
   9.744 -  handle Library.UnequalLengths =>
   9.745 -    error ("Too many arguments in renaming: " ^
   9.746 -      commas (map (fn NONE => "_" | SOME x => quote (fst x)) xs));
   9.747 -
   9.748 -
   9.749 -(* params_of_expr:
   9.750 -   Compute parameters (with types and syntax) of locale expression.
   9.751 -*)
   9.752 -
   9.753 -fun params_of_expr ctxt fixed_params expr (prev_parms, prev_types, prev_syn) =
   9.754 -  let
   9.755 -    val thy = ProofContext.theory_of ctxt;
   9.756 -
   9.757 -    fun merge_tenvs fixed tenv1 tenv2 =
   9.758 -        let
   9.759 -          val [env1, env2] = unify_parms ctxt fixed
   9.760 -                [tenv1 |> Symtab.dest |> map (apsnd SOME),
   9.761 -                 tenv2 |> Symtab.dest |> map (apsnd SOME)]
   9.762 -        in
   9.763 -          Symtab.merge (op =) (Symtab.map (Element.instT_type env1) tenv1,
   9.764 -            Symtab.map (Element.instT_type env2) tenv2)
   9.765 -        end;
   9.766 -
   9.767 -    fun merge_syn expr syn1 syn2 =
   9.768 -        Symtab.merge (op = : mixfix * mixfix -> bool) (syn1, syn2)
   9.769 -        handle Symtab.DUP x => err_in_expr ctxt
   9.770 -          ("Conflicting syntax for parameter: " ^ quote x) expr;
   9.771 -
   9.772 -    fun params_of (expr as Locale name) =
   9.773 -          let
   9.774 -            val {params, ...} = the_locale thy name;
   9.775 -          in (map (fst o fst) params, params |> map fst |> Symtab.make,
   9.776 -               params |> map (apfst fst) |> Symtab.make) end
   9.777 -      | params_of (expr as Rename (e, xs)) =
   9.778 -          let
   9.779 -            val (parms', types', syn') = params_of e;
   9.780 -            val ren = renaming xs parms';
   9.781 -            (* renaming may reduce number of parameters *)
   9.782 -            val new_parms = map (Element.rename ren) parms' |> distinct (op =);
   9.783 -            val ren_syn = syn' |> Symtab.dest |> map (Element.rename_var_name ren);
   9.784 -            val new_syn = fold (Symtab.insert (op =)) ren_syn Symtab.empty
   9.785 -                handle Symtab.DUP x =>
   9.786 -                  err_in_expr ctxt ("Conflicting syntax for parameter: " ^ quote x) expr;
   9.787 -            val syn_types = map (apsnd (fn mx =>
   9.788 -                SOME (Type.freeze_type (#1 (TypeInfer.paramify_dummies (Syntax.mixfixT mx) 0)))))
   9.789 -              (Symtab.dest new_syn);
   9.790 -            val ren_types = types' |> Symtab.dest |> map (apfst (Element.rename ren));
   9.791 -            val (env :: _) = unify_parms ctxt []
   9.792 -                ((ren_types |> map (apsnd SOME)) :: map single syn_types);
   9.793 -            val new_types = fold (Symtab.insert (op =))
   9.794 -                (map (apsnd (Element.instT_type env)) ren_types) Symtab.empty;
   9.795 -          in (new_parms, new_types, new_syn) end
   9.796 -      | params_of (Merge es) =
   9.797 -          fold (fn e => fn (parms, types, syn) =>
   9.798 -                   let
   9.799 -                     val (parms', types', syn') = params_of e
   9.800 -                   in
   9.801 -                     (merge_lists (op =) parms parms', merge_tenvs [] types types',
   9.802 -                      merge_syn e syn syn')
   9.803 -                   end)
   9.804 -            es ([], Symtab.empty, Symtab.empty)
   9.805 -
   9.806 -      val (parms, types, syn) = params_of expr;
   9.807 -    in
   9.808 -      (merge_lists (op =) prev_parms parms, merge_tenvs fixed_params prev_types types,
   9.809 -       merge_syn expr prev_syn syn)
   9.810 -    end;
   9.811 -
   9.812 -fun make_params_ids params = [(("", params), ([], Assumed []))];
   9.813 -fun make_raw_params_elemss (params, tenv, syn) =
   9.814 -    [((("", map (fn p => (p, Symtab.lookup tenv p)) params), Assumed []),
   9.815 -      Int [Fixes (map (fn p =>
   9.816 -        (Binding.name p, Symtab.lookup tenv p, Symtab.lookup syn p |> the)) params)])];
   9.817 -
   9.818 -
   9.819 -(* flatten_expr:
   9.820 -   Extend list of identifiers by those new in locale expression expr.
   9.821 -   Compute corresponding list of lists of locale elements (one entry per
   9.822 -   identifier).
   9.823 -
   9.824 -   Identifiers represent locale fragments and are in an extended form:
   9.825 -     ((name, ps), (ax_ps, axs))
   9.826 -   (name, ps) is the locale name with all its parameters.
   9.827 -   (ax_ps, axs) is the locale axioms with its parameters;
   9.828 -     axs are always taken from the top level of the locale hierarchy,
   9.829 -     hence axioms may contain additional parameters from later fragments:
   9.830 -     ps subset of ax_ps.  axs is either singleton or empty.
   9.831 -
   9.832 -   Elements are enriched by identifier-like information:
   9.833 -     (((name, ax_ps), axs), elems)
   9.834 -   The parameters in ax_ps are the axiom parameters, but enriched by type
   9.835 -   info: now each entry is a pair of string and typ option.  Axioms are
   9.836 -   type-instantiated.
   9.837 -
   9.838 -*)
   9.839 -
   9.840 -fun flatten_expr ctxt ((prev_idents, prev_syntax), expr) =
   9.841 -  let
   9.842 -    val thy = ProofContext.theory_of ctxt;
   9.843 -
   9.844 -    fun rename_parms top ren ((name, ps), (parms, mode)) =
   9.845 -        ((name, map (Element.rename ren) ps),
   9.846 -         if top
   9.847 -         then (map (Element.rename ren) parms,
   9.848 -               map_mode (map (Element.morph_witness (Element.rename_morphism ren))) mode)
   9.849 -         else (parms, mode));
   9.850 -
   9.851 -    (* add (name, pTs) and its registrations, recursively; adjust hyps of witnesses *)
   9.852 -
   9.853 -    fun add_with_regs ((name, pTs), mode) (wits, ids, visited) =
   9.854 -        if member (fn (a, (b, _)) => a = b) visited (name, map #1 pTs)
   9.855 -        then (wits, ids, visited)
   9.856 -        else
   9.857 -          let
   9.858 -            val {params, regs, ...} = the_locale thy name;
   9.859 -            val pTs' = map #1 params;
   9.860 -            val ren = map #1 pTs' ~~ map (fn (x, _) => (x, NONE)) pTs;
   9.861 -              (* dummy syntax, since required by rename *)
   9.862 -            val pTs'' = map (fn ((p, _), (_, T)) => (p, T)) (pTs ~~ pTs');
   9.863 -            val [env] = unify_parms ctxt pTs [map (apsnd SOME) pTs''];
   9.864 -              (* propagate parameter types, to keep them consistent *)
   9.865 -            val regs' = map (fn ((name, ps), wits) =>
   9.866 -                ((name, map (Element.rename ren) ps),
   9.867 -                 map (Element.transfer_witness thy) wits)) regs;
   9.868 -            val new_regs = regs';
   9.869 -            val new_ids = map fst new_regs;
   9.870 -            val new_idTs =
   9.871 -              map (apsnd (map (fn p => (p, (the o AList.lookup (op =) pTs) p)))) new_ids;
   9.872 -
   9.873 -            val new_wits = new_regs |> map (#2 #> map
   9.874 -              (Element.morph_witness
   9.875 -                (Element.instT_morphism thy env $>
   9.876 -                  Element.rename_morphism ren $>
   9.877 -                  Element.satisfy_morphism wits)
   9.878 -                #> Element.close_witness));
   9.879 -            val new_ids' = map (fn (id, wits) =>
   9.880 -                (id, ([], Derived wits))) (new_ids ~~ new_wits);
   9.881 -            val new_idTs' = map (fn ((n, pTs), (_, ([], mode))) =>
   9.882 -                ((n, pTs), mode)) (new_idTs ~~ new_ids');
   9.883 -            val new_id = ((name, map #1 pTs), ([], mode));
   9.884 -            val (wits', ids', visited') = fold add_with_regs new_idTs'
   9.885 -              (wits @ flat new_wits, ids, visited @ [new_id]);
   9.886 -          in
   9.887 -            (wits', ids' @ [new_id], visited')
   9.888 -          end;
   9.889 -
   9.890 -    (* distribute top-level axioms over assumed ids *)
   9.891 -
   9.892 -    fun axiomify all_ps ((name, parms), (_, Assumed _)) axioms =
   9.893 -        let
   9.894 -          val {elems, ...} = the_locale thy name;
   9.895 -          val ts = maps
   9.896 -            (fn (Assumes asms, _) => maps (map #1 o #2) asms
   9.897 -              | _ => [])
   9.898 -            elems;
   9.899 -          val (axs1, axs2) = chop (length ts) axioms;
   9.900 -        in (((name, parms), (all_ps, Assumed axs1)), axs2) end
   9.901 -      | axiomify all_ps (id, (_, Derived ths)) axioms =
   9.902 -          ((id, (all_ps, Derived ths)), axioms);
   9.903 -
   9.904 -    (* identifiers of an expression *)
   9.905 -
   9.906 -    fun identify top (Locale name) =
   9.907 -    (* CB: ids_ax is a list of tuples of the form ((name, ps), axs),
   9.908 -       where name is a locale name, ps a list of parameter names and axs
   9.909 -       a list of axioms relating to the identifier, axs is empty unless
   9.910 -       identify at top level (top = true);
   9.911 -       parms is accumulated list of parameters *)
   9.912 -          let
   9.913 -            val {axiom, params, ...} = the_locale thy name;
   9.914 -            val ps = map (#1 o #1) params;
   9.915 -            val (_, ids'', _) = add_with_regs ((name, map #1 params), Assumed []) ([], [], []);
   9.916 -            val ids_ax = if top then fst (fold_map (axiomify ps) ids'' axiom) else ids'';
   9.917 -            in (ids_ax, ps) end
   9.918 -      | identify top (Rename (e, xs)) =
   9.919 -          let
   9.920 -            val (ids', parms') = identify top e;
   9.921 -            val ren = renaming xs parms'
   9.922 -              handle ERROR msg => err_in_locale' ctxt msg ids';
   9.923 -
   9.924 -            val ids'' = distinct (eq_fst (op =)) (map (rename_parms top ren) ids');
   9.925 -            val parms'' = distinct (op =) (maps (#2 o #1) ids'');
   9.926 -          in (ids'', parms'') end
   9.927 -      | identify top (Merge es) =
   9.928 -          fold (fn e => fn (ids, parms) =>
   9.929 -                   let
   9.930 -                     val (ids', parms') = identify top e
   9.931 -                   in
   9.932 -                     (merge_alists (op =) ids ids', merge_lists (op =) parms parms')
   9.933 -                   end)
   9.934 -            es ([], []);
   9.935 -
   9.936 -    fun inst_wit all_params (t, th) = let
   9.937 -         val {hyps, prop, ...} = Thm.rep_thm th;
   9.938 -         val ps = map (apsnd SOME) (fold Term.add_frees (prop :: hyps) []);
   9.939 -         val [env] = unify_parms ctxt all_params [ps];
   9.940 -         val t' = Element.instT_term env t;
   9.941 -         val th' = Element.instT_thm thy env th;
   9.942 -       in (t', th') end;
   9.943 -
   9.944 -    fun eval all_params tenv syn ((name, params), (locale_params, mode)) =
   9.945 -      let
   9.946 -        val {params = ps_mx, elems = elems_stamped, ...} = the_locale thy name;
   9.947 -        val elems = map fst elems_stamped;
   9.948 -        val ps = map fst ps_mx;
   9.949 -        fun lookup_syn x = (case Symtab.lookup syn x of SOME Structure => NONE | opt => opt);
   9.950 -        val locale_params' = map (fn p => (p, Symtab.lookup tenv p |> the)) locale_params;
   9.951 -        val mode' = map_mode (map (Element.map_witness (inst_wit all_params))) mode;
   9.952 -        val ren = map fst ps ~~ map (fn p => (p, lookup_syn p)) params;
   9.953 -        val [env] = unify_parms ctxt all_params [map (apfst (Element.rename ren) o apsnd SOME) ps];
   9.954 -        val (lprfx, pprfx) = param_prefix name params;
   9.955 -        val add_prefices = pprfx <> "" ? Binding.add_prefix false pprfx
   9.956 -          #> Binding.add_prefix false lprfx;
   9.957 -        val elem_morphism =
   9.958 -          Element.rename_morphism ren $>
   9.959 -          Morphism.binding_morphism add_prefices $>
   9.960 -          Element.instT_morphism thy env;
   9.961 -        val elems' = map (Element.morph_ctxt elem_morphism) elems;
   9.962 -      in (((name, map (apsnd SOME) locale_params'), mode'), elems') end;
   9.963 -
   9.964 -    (* parameters, their types and syntax *)
   9.965 -    val (all_params', tenv, syn) = params_of_expr ctxt [] expr ([], Symtab.empty, Symtab.empty);
   9.966 -    val all_params = map (fn p => (p, Symtab.lookup tenv p |> the)) all_params';
   9.967 -    (* compute identifiers and syntax, merge with previous ones *)
   9.968 -    val (ids, _) = identify true expr;
   9.969 -    val idents = subtract (eq_fst (op =)) prev_idents ids;
   9.970 -    val syntax = merge_syntax ctxt ids (syn, prev_syntax);
   9.971 -    (* type-instantiate elements *)
   9.972 -    val final_elemss = map (eval all_params tenv syntax) idents;
   9.973 -  in ((prev_idents @ idents, syntax), final_elemss) end;
   9.974 -
   9.975 -end;
   9.976 -
   9.977 -
   9.978 -(* activate elements *)
   9.979 -
   9.980 -local
   9.981 -
   9.982 -fun axioms_export axs _ As =
   9.983 -  (Element.satisfy_thm axs #> Drule.implies_intr_list (Library.drop (length axs, As)), fn t => t);
   9.984 -
   9.985 -
   9.986 -(* NB: derived ids contain only facts at this stage *)
   9.987 -
   9.988 -fun activate_elem _ _ (Fixes fixes) (ctxt, mode) =
   9.989 -      ([], (ctxt |> ProofContext.add_fixes_i fixes |> snd, mode))
   9.990 -  | activate_elem _ _ (Constrains _) (ctxt, mode) =
   9.991 -      ([], (ctxt, mode))
   9.992 -  | activate_elem ax_in_ctxt _ (Assumes asms) (ctxt, Assumed axs) =
   9.993 -      let
   9.994 -        val asms' = Attrib.map_specs (Attrib.attribute_i (ProofContext.theory_of ctxt)) asms;
   9.995 -        val ts = maps (map #1 o #2) asms';
   9.996 -        val (ps, qs) = chop (length ts) axs;
   9.997 -        val (_, ctxt') =
   9.998 -          ctxt |> fold Variable.auto_fixes ts
   9.999 -          |> ProofContext.add_assms_i (axioms_export (if ax_in_ctxt then ps else [])) asms';
  9.1000 -      in ([], (ctxt', Assumed qs)) end
  9.1001 -  | activate_elem _ _ (Assumes asms) (ctxt, Derived ths) =
  9.1002 -      ([], (ctxt, Derived ths))
  9.1003 -  | activate_elem _ _ (Defines defs) (ctxt, Assumed axs) =
  9.1004 -      let
  9.1005 -        val defs' = Attrib.map_specs (Attrib.attribute_i (ProofContext.theory_of ctxt)) defs;
  9.1006 -        val asms = defs' |> map (fn ((name, atts), (t, ps)) =>
  9.1007 -            let val ((c, _), t') = LocalDefs.cert_def ctxt t
  9.1008 -            in (t', ((Binding.map_base (Thm.def_name_optional c) name, atts), [(t', ps)])) end);
  9.1009 -        val (_, ctxt') =
  9.1010 -          ctxt |> fold (Variable.auto_fixes o #1) asms
  9.1011 -          |> ProofContext.add_assms_i LocalDefs.def_export (map #2 asms);
  9.1012 -      in ([], (ctxt', Assumed axs)) end
  9.1013 -  | activate_elem _ _ (Defines defs) (ctxt, Derived ths) =
  9.1014 -      ([], (ctxt, Derived ths))
  9.1015 -  | activate_elem _ is_ext (Notes (kind, facts)) (ctxt, mode) =
  9.1016 -      let
  9.1017 -        val facts' = Attrib.map_facts (Attrib.attribute_i (ProofContext.theory_of ctxt)) facts;
  9.1018 -        val (res, ctxt') = ctxt |> local_note_qualified kind facts';
  9.1019 -      in (if is_ext then (map (#1 o #1) facts' ~~ map #2 res) else [], (ctxt', mode)) end;
  9.1020 -
  9.1021 -fun activate_elems ax_in_ctxt (((name, ps), mode), elems) ctxt =
  9.1022 -  let
  9.1023 -    val thy = ProofContext.theory_of ctxt;
  9.1024 -    val (res, (ctxt', _)) = fold_map (activate_elem ax_in_ctxt (name = ""))
  9.1025 -        elems (ProofContext.qualified_names ctxt, mode)
  9.1026 -      handle ERROR msg => err_in_locale ctxt msg [(name, map fst ps)];
  9.1027 -    val ctxt'' = if name = "" then ctxt'
  9.1028 -          else let
  9.1029 -              val ps' = map (fn (n, SOME T) => Free (n, T)) ps;
  9.1030 -            in if test_local_registration ctxt' (name, ps') then ctxt'
  9.1031 -              else let
  9.1032 -                  val ctxt'' = put_local_registration (name, ps') (I, (NameSpace.base name, ""))
  9.1033 -                    (Morphism.identity, ((Vartab.empty, []), (Vartab.empty, []) )) ctxt'
  9.1034 -                in case mode of
  9.1035 -                    Assumed axs =>
  9.1036 -                      fold (add_local_witness (name, ps') o
  9.1037 -                        Element.assume_witness thy o Element.witness_prop) axs ctxt''
  9.1038 -                  | Derived ths =>
  9.1039 -                     fold (add_local_witness (name, ps')) ths ctxt''
  9.1040 -                end
  9.1041 -            end
  9.1042 -  in (ProofContext.restore_naming ctxt ctxt'', res) end;
  9.1043 -
  9.1044 -fun activate_elemss ax_in_ctxt prep_facts =
  9.1045 -    fold_map (fn (((name, ps), mode), raw_elems) => fn ctxt =>
  9.1046 -      let
  9.1047 -        val elems = map (prep_facts ctxt) raw_elems;
  9.1048 -        val (ctxt', res) = apsnd flat
  9.1049 -            (activate_elems ax_in_ctxt (((name, ps), mode), elems) ctxt);
  9.1050 -        val elems' = elems |> map (Element.map_ctxt_attrib Args.closure);
  9.1051 -      in (((((name, ps), mode), elems'), res), ctxt') end);
  9.1052 -
  9.1053 -in
  9.1054 -
  9.1055 -(* CB: activate_facts prep_facts elemss ctxt,
  9.1056 -   where elemss is a list of pairs consisting of identifiers and
  9.1057 -   context elements, extends ctxt by the context elements yielding
  9.1058 -   ctxt' and returns ((elemss', facts), ctxt').
  9.1059 -   Identifiers in the argument are of the form ((name, ps), axs) and
  9.1060 -   assumptions use the axioms in the identifiers to set up exporters
  9.1061 -   in ctxt'.  elemss' does not contain identifiers and is obtained
  9.1062 -   from elemss and the intermediate context with prep_facts.
  9.1063 -   If read_facts or cert_facts is used for prep_facts, these also remove
  9.1064 -   the internal/external markers from elemss. *)
  9.1065 -
  9.1066 -fun activate_facts ax_in_ctxt prep_facts args =
  9.1067 -  activate_elemss ax_in_ctxt prep_facts args
  9.1068 -  #>> (apsnd flat o split_list);
  9.1069 -
  9.1070 -end;
  9.1071 -
  9.1072 -
  9.1073 -
  9.1074 -(** prepare locale elements **)
  9.1075 -
  9.1076 -(* expressions *)
  9.1077 -
  9.1078 -fun intern_expr thy (Locale xname) = Locale (intern thy xname)
  9.1079 -  | intern_expr thy (Merge exprs) = Merge (map (intern_expr thy) exprs)
  9.1080 -  | intern_expr thy (Rename (expr, xs)) = Rename (intern_expr thy expr, xs);
  9.1081 -
  9.1082 -
  9.1083 -(* propositions and bindings *)
  9.1084 -
  9.1085 -(* flatten (ctxt, prep_expr) ((ids, syn), expr)
  9.1086 -   normalises expr (which is either a locale
  9.1087 -   expression or a single context element) wrt.
  9.1088 -   to the list ids of already accumulated identifiers.
  9.1089 -   It returns ((ids', syn'), elemss) where ids' is an extension of ids
  9.1090 -   with identifiers generated for expr, and elemss is the list of
  9.1091 -   context elements generated from expr.
  9.1092 -   syn and syn' are symtabs mapping parameter names to their syntax.  syn'
  9.1093 -   is an extension of syn.
  9.1094 -   For details, see flatten_expr.
  9.1095 -
  9.1096 -   Additionally, for a locale expression, the elems are grouped into a single
  9.1097 -   Int; individual context elements are marked Ext.  In this case, the
  9.1098 -   identifier-like information of the element is as follows:
  9.1099 -   - for Fixes: (("", ps), []) where the ps have type info NONE
  9.1100 -   - for other elements: (("", []), []).
  9.1101 -   The implementation of activate_facts relies on identifier names being
  9.1102 -   empty strings for external elements.
  9.1103 -*)
  9.1104 -
  9.1105 -fun flatten (ctxt, _) ((ids, syn), Elem (Fixes fixes)) = let
  9.1106 -        val ids' = ids @ [(("", map (Binding.base_name o #1) fixes), ([], Assumed []))]
  9.1107 -      in
  9.1108 -        ((ids',
  9.1109 -         merge_syntax ctxt ids'
  9.1110 -           (syn, Symtab.make (map (fn fx => (Binding.base_name (#1 fx), #3 fx)) fixes))
  9.1111 -           handle Symtab.DUP x => err_in_locale ctxt
  9.1112 -             ("Conflicting syntax for parameter: " ^ quote x)
  9.1113 -             (map #1 ids')),
  9.1114 -         [((("", map (rpair NONE o Binding.base_name o #1) fixes), Assumed []), Ext (Fixes fixes))])
  9.1115 -      end
  9.1116 -  | flatten _ ((ids, syn), Elem elem) =
  9.1117 -      ((ids @ [(("", []), ([], Assumed []))], syn), [((("", []), Assumed []), Ext elem)])
  9.1118 -  | flatten (ctxt, prep_expr) ((ids, syn), Expr expr) =
  9.1119 -      apsnd (map (apsnd Int)) (flatten_expr ctxt ((ids, syn), prep_expr expr));
  9.1120 -
  9.1121 -local
  9.1122 -
  9.1123 -local
  9.1124 -
  9.1125 -fun declare_int_elem (Fixes fixes) ctxt =
  9.1126 -      ([], ctxt |> ProofContext.add_fixes_i (map (fn (x, T, mx) =>
  9.1127 -        (x, Option.map (Term.map_type_tfree (TypeInfer.param 0)) T, mx)) fixes) |> snd)
  9.1128 -  | declare_int_elem _ ctxt = ([], ctxt);
  9.1129 -
  9.1130 -fun declare_ext_elem prep_vars (Fixes fixes) ctxt =
  9.1131 -      let val (vars, _) = prep_vars fixes ctxt
  9.1132 -      in ([], ctxt |> ProofContext.add_fixes_i vars |> snd) end
  9.1133 -  | declare_ext_elem prep_vars (Constrains csts) ctxt =
  9.1134 -      let val (_, ctxt') = prep_vars (map (fn (x, T) => (Binding.name x, SOME T, NoSyn)) csts) ctxt
  9.1135 -      in ([], ctxt') end
  9.1136 -  | declare_ext_elem _ (Assumes asms) ctxt = (map #2 asms, ctxt)
  9.1137 -  | declare_ext_elem _ (Defines defs) ctxt = (map (fn (_, (t, ps)) => [(t, ps)]) defs, ctxt)
  9.1138 -  | declare_ext_elem _ (Notes _) ctxt = ([], ctxt);
  9.1139 -
  9.1140 -fun declare_elems prep_vars (((name, ps), Assumed _), elems) ctxt = ((case elems
  9.1141 -     of Int es => fold_map declare_int_elem es ctxt
  9.1142 -      | Ext e => declare_ext_elem prep_vars e ctxt |>> single)
  9.1143 -          handle ERROR msg => err_in_locale ctxt msg [(name, map fst ps)])
  9.1144 -  | declare_elems _ ((_, Derived _), elems) ctxt = ([], ctxt);
  9.1145 -
  9.1146 -in
  9.1147 -
  9.1148 -fun declare_elemss prep_vars fixed_params raw_elemss ctxt =
  9.1149 -  let
  9.1150 -    (* CB: fix of type bug of goal in target with context elements.
  9.1151 -       Parameters new in context elements must receive types that are
  9.1152 -       distinct from types of parameters in target (fixed_params).  *)
  9.1153 -    val ctxt_with_fixed = 
  9.1154 -      fold Variable.declare_term (map Free fixed_params) ctxt;
  9.1155 -    val int_elemss =
  9.1156 -      raw_elemss
  9.1157 -      |> map_filter (fn (id, Int es) => SOME (id, es) | _ => NONE)
  9.1158 -      |> unify_elemss ctxt_with_fixed fixed_params;
  9.1159 -    val (raw_elemss', _) =
  9.1160 -      fold_map (curry (fn ((id, Int _), (_, es) :: elemss) => ((id, Int es), elemss) | x => x))
  9.1161 -        raw_elemss int_elemss;
  9.1162 -  in fold_map (declare_elems prep_vars) raw_elemss' ctxt end;
  9.1163 -
  9.1164 -end;
  9.1165 -
  9.1166 -local
  9.1167 -
  9.1168 -val norm_term = Envir.beta_norm oo Term.subst_atomic;
  9.1169 -
  9.1170 -fun abstract_thm thy eq =
  9.1171 -  Thm.assume (Thm.cterm_of thy eq) |> Drule.gen_all |> Drule.abs_def;
  9.1172 -
  9.1173 -fun bind_def ctxt (name, ps) eq (xs, env, ths) =
  9.1174 -  let
  9.1175 -    val ((y, T), b) = LocalDefs.abs_def eq;
  9.1176 -    val b' = norm_term env b;
  9.1177 -    val th = abstract_thm (ProofContext.theory_of ctxt) eq;
  9.1178 -    fun err msg = err_in_locale ctxt (msg ^ ": " ^ quote y) [(name, map fst ps)];
  9.1179 -  in
  9.1180 -    exists (fn (x, _) => x = y) xs andalso
  9.1181 -      err "Attempt to define previously specified variable";
  9.1182 -    exists (fn (Free (y', _), _) => y = y' | _ => false) env andalso
  9.1183 -      err "Attempt to redefine variable";
  9.1184 -    (Term.add_frees b' xs, (Free (y, T), b') :: env, th :: ths)
  9.1185 -  end;
  9.1186 -
  9.1187 -
  9.1188 -(* CB: for finish_elems (Int and Ext),
  9.1189 -   extracts specification, only of assumed elements *)
  9.1190 -
  9.1191 -fun eval_text _ _ _ (Fixes _) text = text
  9.1192 -  | eval_text _ _ _ (Constrains _) text = text
  9.1193 -  | eval_text _ (_, Assumed _) is_ext (Assumes asms)
  9.1194 -        (((exts, exts'), (ints, ints')), (xs, env, defs)) =
  9.1195 -      let
  9.1196 -        val ts = maps (map #1 o #2) asms;
  9.1197 -        val ts' = map (norm_term env) ts;
  9.1198 -        val spec' =
  9.1199 -          if is_ext then ((exts @ ts, exts' @ ts'), (ints, ints'))
  9.1200 -          else ((exts, exts'), (ints @ ts, ints' @ ts'));
  9.1201 -      in (spec', (fold Term.add_frees ts' xs, env, defs)) end
  9.1202 -  | eval_text _ (_, Derived _) _ (Assumes _) text = text
  9.1203 -  | eval_text ctxt (id, Assumed _) _ (Defines defs) (spec, binds) =
  9.1204 -      (spec, fold (bind_def ctxt id o #1 o #2) defs binds)
  9.1205 -  | eval_text _ (_, Derived _) _ (Defines _) text = text
  9.1206 -  | eval_text _ _ _ (Notes _) text = text;
  9.1207 -
  9.1208 -
  9.1209 -(* for finish_elems (Int),
  9.1210 -   remove redundant elements of derived identifiers,
  9.1211 -   turn assumptions and definitions into facts,
  9.1212 -   satisfy hypotheses of facts *)
  9.1213 -
  9.1214 -fun finish_derived _ _ (Assumed _) (Fixes fixes) = SOME (Fixes fixes)
  9.1215 -  | finish_derived _ _ (Assumed _) (Constrains csts) = SOME (Constrains csts)
  9.1216 -  | finish_derived _ _ (Assumed _) (Assumes asms) = SOME (Assumes asms)
  9.1217 -  | finish_derived _ _ (Assumed _) (Defines defs) = SOME (Defines defs)
  9.1218 -
  9.1219 -  | finish_derived _ _ (Derived _) (Fixes _) = NONE
  9.1220 -  | finish_derived _ _ (Derived _) (Constrains _) = NONE
  9.1221 -  | finish_derived sign satisfy (Derived _) (Assumes asms) = asms
  9.1222 -      |> map (apsnd (map (fn (a, _) => ([Thm.assume (cterm_of sign a)], []))))
  9.1223 -      |> pair Thm.assumptionK |> Notes
  9.1224 -      |> Element.morph_ctxt satisfy |> SOME
  9.1225 -  | finish_derived sign satisfy (Derived _) (Defines defs) = defs
  9.1226 -      |> map (apsnd (fn (d, _) => [([Thm.assume (cterm_of sign d)], [])]))
  9.1227 -      |> pair Thm.definitionK |> Notes
  9.1228 -      |> Element.morph_ctxt satisfy |> SOME
  9.1229 -
  9.1230 -  | finish_derived _ satisfy _ (Notes facts) = Notes facts
  9.1231 -      |> Element.morph_ctxt satisfy |> SOME;
  9.1232 -
  9.1233 -(* CB: for finish_elems (Ext) *)
  9.1234 -
  9.1235 -fun closeup _ false elem = elem
  9.1236 -  | closeup ctxt true elem =
  9.1237 -      let
  9.1238 -        fun close_frees t =
  9.1239 -          let
  9.1240 -            val rev_frees =
  9.1241 -              Term.fold_aterms (fn Free (x, T) =>
  9.1242 -                if Variable.is_fixed ctxt x then I else insert (op =) (x, T) | _ => I) t [];
  9.1243 -          in Term.list_all_free (rev rev_frees, t) end;
  9.1244 -
  9.1245 -        fun no_binds [] = []
  9.1246 -          | no_binds _ = error "Illegal term bindings in locale element";
  9.1247 -      in
  9.1248 -        (case elem of
  9.1249 -          Assumes asms => Assumes (asms |> map (fn (a, propps) =>
  9.1250 -            (a, map (fn (t, ps) => (close_frees t, no_binds ps)) propps)))
  9.1251 -        | Defines defs => Defines (defs |> map (fn (a, (t, ps)) =>
  9.1252 -            (a, (close_frees (#2 (LocalDefs.cert_def ctxt t)), no_binds ps))))
  9.1253 -        | e => e)
  9.1254 -      end;
  9.1255 -
  9.1256 -
  9.1257 -fun finish_ext_elem parms _ (Fixes fixes, _) = Fixes (map (fn (b, _, mx) =>
  9.1258 -      let val x = Binding.base_name b
  9.1259 -      in (b, AList.lookup (op =) parms x, mx) end) fixes)
  9.1260 -  | finish_ext_elem parms _ (Constrains _, _) = Constrains []
  9.1261 -  | finish_ext_elem _ close (Assumes asms, propp) =
  9.1262 -      close (Assumes (map #1 asms ~~ propp))
  9.1263 -  | finish_ext_elem _ close (Defines defs, propp) =
  9.1264 -      close (Defines (map #1 defs ~~ map (fn [(t, ps)] => (t, ps)) propp))
  9.1265 -  | finish_ext_elem _ _ (Notes facts, _) = Notes facts;
  9.1266 -
  9.1267 -
  9.1268 -(* CB: finish_parms introduces type info from parms to identifiers *)
  9.1269 -(* CB: only needed for types that have been NONE so far???
  9.1270 -   If so, which are these??? *)
  9.1271 -
  9.1272 -fun finish_parms parms (((name, ps), mode), elems) =
  9.1273 -  (((name, map (fn (x, _) => (x, AList.lookup (op = : string * string -> bool) parms x)) ps), mode), elems);
  9.1274 -
  9.1275 -fun finish_elems ctxt parms _ ((text, wits), ((id, Int e), _)) =
  9.1276 -      let
  9.1277 -        val [(id' as (_, mode), es)] = unify_elemss ctxt parms [(id, e)];
  9.1278 -        val wits' = case mode of Assumed _ => wits | Derived ths => wits @ ths;
  9.1279 -        val text' = fold (eval_text ctxt id' false) es text;
  9.1280 -        val es' = map_filter
  9.1281 -          (finish_derived (ProofContext.theory_of ctxt) (Element.satisfy_morphism wits') mode) es;
  9.1282 -      in ((text', wits'), (id', map Int es')) end
  9.1283 -  | finish_elems ctxt parms do_close ((text, wits), ((id, Ext e), [propp])) =
  9.1284 -      let
  9.1285 -        val e' = finish_ext_elem parms (closeup ctxt do_close) (e, propp);
  9.1286 -        val text' = eval_text ctxt id true e' text;
  9.1287 -      in ((text', wits), (id, [Ext e'])) end
  9.1288 -
  9.1289 -in
  9.1290 -
  9.1291 -(* CB: only called by prep_elemss *)
  9.1292 -
  9.1293 -fun finish_elemss ctxt parms do_close =
  9.1294 -  foldl_map (apsnd (finish_parms parms) o finish_elems ctxt parms do_close);
  9.1295 -
  9.1296 -end;
  9.1297 -
  9.1298 -
  9.1299 -(* Remove duplicate Defines elements: temporary workaround to fix Afp/Category. *)
  9.1300 -
  9.1301 -fun defs_ord (defs1, defs2) =
  9.1302 -    list_ord (fn ((_, (d1, _)), (_, (d2, _))) =>
  9.1303 -      TermOrd.fast_term_ord (d1, d2)) (defs1, defs2);
  9.1304 -structure Defstab =
  9.1305 -    TableFun(type key = (Attrib.binding * (term * term list)) list val ord = defs_ord);
  9.1306 -
  9.1307 -fun rem_dup_defs es ds =
  9.1308 -    fold_map (fn e as (Defines defs) => (fn ds =>
  9.1309 -                 if Defstab.defined ds defs
  9.1310 -                 then (Defines [], ds)
  9.1311 -                 else (e, Defstab.update (defs, ()) ds))
  9.1312 -               | e => (fn ds => (e, ds))) es ds;
  9.1313 -fun rem_dup_elemss (Int es) ds = apfst Int (rem_dup_defs es ds)
  9.1314 -  | rem_dup_elemss (Ext e) ds = (Ext e, ds);
  9.1315 -fun rem_dup_defines raw_elemss =
  9.1316 -    fold_map (fn (id as (_, (Assumed _)), es) => (fn ds =>
  9.1317 -                     apfst (pair id) (rem_dup_elemss es ds))
  9.1318 -               | (id as (_, (Derived _)), es) => (fn ds =>
  9.1319 -                     ((id, es), ds))) raw_elemss Defstab.empty |> #1;
  9.1320 -
  9.1321 -(* CB: type inference and consistency checks for locales.
  9.1322 -
  9.1323 -   Works by building a context (through declare_elemss), extracting the
  9.1324 -   required information and adjusting the context elements (finish_elemss).
  9.1325 -   Can also universally close free vars in assms and defs.  This is only
  9.1326 -   needed for Ext elements and controlled by parameter do_close.
  9.1327 -
  9.1328 -   Only elements of assumed identifiers are considered.
  9.1329 -*)
  9.1330 -
  9.1331 -fun prep_elemss prep_vars prepp do_close context fixed_params raw_elemss raw_concl =
  9.1332 -  let
  9.1333 -    (* CB: contexts computed in the course of this function are discarded.
  9.1334 -       They are used for type inference and consistency checks only. *)
  9.1335 -    (* CB: fixed_params are the parameters (with types) of the target locale,
  9.1336 -       empty list if there is no target. *)
  9.1337 -    (* CB: raw_elemss are list of pairs consisting of identifiers and
  9.1338 -       context elements, the latter marked as internal or external. *)
  9.1339 -    val raw_elemss = rem_dup_defines raw_elemss;
  9.1340 -    val (raw_proppss, raw_ctxt) = declare_elemss prep_vars fixed_params raw_elemss context;
  9.1341 -    (* CB: raw_ctxt is context with additional fixed variables derived from
  9.1342 -       the fixes elements in raw_elemss,
  9.1343 -       raw_proppss contains assumptions and definitions from the
  9.1344 -       external elements in raw_elemss. *)
  9.1345 -    fun prep_prop raw_propp (raw_ctxt, raw_concl)  =
  9.1346 -      let
  9.1347 -        (* CB: add type information from fixed_params to context (declare_term) *)
  9.1348 -        (* CB: process patterns (conclusion and external elements only) *)
  9.1349 -        val (ctxt, all_propp) =
  9.1350 -          prepp (fold Variable.declare_term (map Free fixed_params) raw_ctxt, raw_concl @ raw_propp);
  9.1351 -        (* CB: add type information from conclusion and external elements to context *)
  9.1352 -        val ctxt = fold Variable.declare_term (maps (map fst) all_propp) ctxt;
  9.1353 -        (* CB: resolve schematic variables (patterns) in conclusion and external elements. *)
  9.1354 -        val all_propp' = map2 (curry (op ~~))
  9.1355 -          (#1 (#2 (ProofContext.bind_propp_schematic_i (ctxt, all_propp)))) (map (map snd) all_propp);
  9.1356 -        val (concl, propp) = chop (length raw_concl) all_propp';
  9.1357 -      in (propp, (ctxt, concl)) end
  9.1358 -
  9.1359 -    val (proppss, (ctxt, concl)) =
  9.1360 -      (fold_burrow o fold_burrow) prep_prop raw_proppss (raw_ctxt, raw_concl);
  9.1361 -
  9.1362 -    (* CB: obtain all parameters from identifier part of raw_elemss *)
  9.1363 -    val xs = map #1 (params_of' raw_elemss);
  9.1364 -    val typing = unify_frozen ctxt 0
  9.1365 -      (map (Variable.default_type raw_ctxt) xs)
  9.1366 -      (map (Variable.default_type ctxt) xs);
  9.1367 -    val parms = param_types (xs ~~ typing);
  9.1368 -    (* CB: parms are the parameters from raw_elemss, with correct typing. *)
  9.1369 -
  9.1370 -    (* CB: extract information from assumes and defines elements
  9.1371 -       (fixes, constrains and notes in raw_elemss don't have an effect on
  9.1372 -       text and elemss), compute final form of context elements. *)
  9.1373 -    val ((text, _), elemss) = finish_elemss ctxt parms do_close
  9.1374 -      ((((([], []), ([], [])), ([], [], [])), []), raw_elemss ~~ proppss);
  9.1375 -    (* CB: text has the following structure:
  9.1376 -           (((exts, exts'), (ints, ints')), (xs, env, defs))
  9.1377 -       where
  9.1378 -         exts: external assumptions (terms in external assumes elements)
  9.1379 -         exts': dito, normalised wrt. env
  9.1380 -         ints: internal assumptions (terms in internal assumes elements)
  9.1381 -         ints': dito, normalised wrt. env
  9.1382 -         xs: the free variables in exts' and ints' and rhss of definitions,
  9.1383 -           this includes parameters except defined parameters
  9.1384 -         env: list of term pairs encoding substitutions, where the first term
  9.1385 -           is a free variable; substitutions represent defines elements and
  9.1386 -           the rhs is normalised wrt. the previous env
  9.1387 -         defs: theorems representing the substitutions from defines elements
  9.1388 -           (thms are normalised wrt. env).
  9.1389 -       elemss is an updated version of raw_elemss:
  9.1390 -         - type info added to Fixes and modified in Constrains
  9.1391 -         - axiom and definition statement replaced by corresponding one
  9.1392 -           from proppss in Assumes and Defines
  9.1393 -         - Facts unchanged
  9.1394 -       *)
  9.1395 -  in ((parms, elemss, concl), text) end;
  9.1396 -
  9.1397 -in
  9.1398 -
  9.1399 -fun read_elemss x = prep_elemss ProofContext.read_vars ProofContext.read_propp_schematic x;
  9.1400 -fun cert_elemss x = prep_elemss ProofContext.cert_vars ProofContext.cert_propp_schematic x;
  9.1401 -
  9.1402 -end;
  9.1403 -
  9.1404 -
  9.1405 -(* facts and attributes *)
  9.1406 -
  9.1407 -local
  9.1408 -
  9.1409 -fun check_name name =
  9.1410 -  if NameSpace.is_qualified name then error ("Illegal qualified name: " ^ quote name)
  9.1411 -  else name;
  9.1412 -
  9.1413 -fun prep_facts _ _ _ ctxt (Int elem) = elem
  9.1414 -      |> Element.morph_ctxt (Morphism.thm_morphism (Thm.transfer (ProofContext.theory_of ctxt)))
  9.1415 -  | prep_facts prep_name get intern ctxt (Ext elem) = elem |> Element.map_ctxt
  9.1416 -     {var = I, typ = I, term = I,
  9.1417 -      binding = Binding.map_base prep_name,
  9.1418 -      fact = get ctxt,
  9.1419 -      attrib = Args.assignable o intern (ProofContext.theory_of ctxt)};
  9.1420 -
  9.1421 -in
  9.1422 -
  9.1423 -fun read_facts x = prep_facts check_name ProofContext.get_fact Attrib.intern_src x;
  9.1424 -fun cert_facts x = prep_facts I (K I) (K I) x;
  9.1425 -
  9.1426 -end;
  9.1427 -
  9.1428 -
  9.1429 -(* Get the specification of a locale *)
  9.1430 -
  9.1431 -(*The global specification is made from the parameters and global
  9.1432 -  assumptions, the local specification from the parameters and the
  9.1433 -  local assumptions.*)
  9.1434 -
  9.1435 -local
  9.1436 -
  9.1437 -fun gen_asms_of get thy name =
  9.1438 -  let
  9.1439 -    val ctxt = ProofContext.init thy;
  9.1440 -    val (_, raw_elemss) = flatten (ctxt, I) (([], Symtab.empty), Expr (Locale name));
  9.1441 -    val ((_, elemss, _), _) = read_elemss false ctxt [] raw_elemss [];
  9.1442 -  in
  9.1443 -    elemss |> get
  9.1444 -      |> maps (fn (_, es) => map (fn Int e => e) es)
  9.1445 -      |> maps (fn Assumes asms => asms | _ => [])
  9.1446 -      |> map (apsnd (map fst))
  9.1447 -  end;
  9.1448 -
  9.1449 -in
  9.1450 -
  9.1451 -fun parameters_of thy = #params o the_locale thy;
  9.1452 -
  9.1453 -fun intros thy = #intros o the_locale thy;
  9.1454 -  (*returns introduction rule for delta predicate and locale predicate
  9.1455 -    as a pair of singleton lists*)
  9.1456 -
  9.1457 -fun dests thy = #dests o the_locale thy;
  9.1458 -
  9.1459 -fun facts_of thy = map_filter (fn (Element.Notes (_, facts), _) => SOME facts
  9.1460 -  | _ => NONE) o #elems o the_locale thy;
  9.1461 -
  9.1462 -fun parameters_of_expr thy expr =
  9.1463 -  let
  9.1464 -    val ctxt = ProofContext.init thy;
  9.1465 -    val pts = params_of_expr ctxt [] (intern_expr thy expr)
  9.1466 -        ([], Symtab.empty, Symtab.empty);
  9.1467 -    val raw_params_elemss = make_raw_params_elemss pts;
  9.1468 -    val ((_, syn), raw_elemss) = flatten (ctxt, intern_expr thy)
  9.1469 -        (([], Symtab.empty), Expr expr);
  9.1470 -    val ((parms, _, _), _) =
  9.1471 -        read_elemss false ctxt [] (raw_params_elemss @ raw_elemss) [];
  9.1472 -  in map (fn p as (n, _) => (p, Symtab.lookup syn n |> the)) parms end;
  9.1473 -
  9.1474 -fun local_asms_of thy name =
  9.1475 -  gen_asms_of (single o Library.last_elem) thy name;
  9.1476 -
  9.1477 -fun global_asms_of thy name =
  9.1478 -  gen_asms_of I thy name;
  9.1479 -
  9.1480 -end;
  9.1481 -
  9.1482 -
  9.1483 -(* full context statements: imports + elements + conclusion *)
  9.1484 -
  9.1485 -local
  9.1486 -
  9.1487 -fun prep_context_statement prep_expr prep_elemss prep_facts
  9.1488 -    do_close fixed_params imports elements raw_concl context =
  9.1489 -  let
  9.1490 -    val thy = ProofContext.theory_of context;
  9.1491 -
  9.1492 -    val (import_params, import_tenv, import_syn) =
  9.1493 -      params_of_expr context fixed_params (prep_expr thy imports)
  9.1494 -        ([], Symtab.empty, Symtab.empty);
  9.1495 -    val includes = map_filter (fn Expr e => SOME e | Elem _ => NONE) elements;
  9.1496 -    val (incl_params, incl_tenv, incl_syn) = fold (params_of_expr context fixed_params)
  9.1497 -      (map (prep_expr thy) includes) (import_params, import_tenv, import_syn);
  9.1498 -
  9.1499 -    val ((import_ids, _), raw_import_elemss) =
  9.1500 -      flatten (context, prep_expr thy) (([], Symtab.empty), Expr imports);
  9.1501 -    (* CB: normalise "includes" among elements *)
  9.1502 -    val ((ids, syn), raw_elemsss) = foldl_map (flatten (context, prep_expr thy))
  9.1503 -      ((import_ids, incl_syn), elements);
  9.1504 -
  9.1505 -    val raw_elemss = flat raw_elemsss;
  9.1506 -    (* CB: raw_import_elemss @ raw_elemss is the normalised list of
  9.1507 -       context elements obtained from import and elements. *)
  9.1508 -    (* Now additional elements for parameters are inserted. *)
  9.1509 -    val import_params_ids = make_params_ids import_params;
  9.1510 -    val incl_params_ids =
  9.1511 -        make_params_ids (incl_params \\ import_params);
  9.1512 -    val raw_import_params_elemss =
  9.1513 -        make_raw_params_elemss (import_params, incl_tenv, incl_syn);
  9.1514 -    val raw_incl_params_elemss =
  9.1515 -        make_raw_params_elemss (incl_params \\ import_params, incl_tenv, incl_syn);
  9.1516 -    val ((parms, all_elemss, concl), (spec, (_, _, defs))) = prep_elemss do_close
  9.1517 -      context fixed_params
  9.1518 -      (raw_import_params_elemss @ raw_import_elemss @ raw_incl_params_elemss @ raw_elemss) raw_concl;
  9.1519 -
  9.1520 -    (* replace extended ids (for axioms) by ids *)
  9.1521 -    val (import_ids', incl_ids) = chop (length import_ids) ids;
  9.1522 -    val all_ids = import_params_ids @ import_ids' @ incl_params_ids @ incl_ids;
  9.1523 -    val all_elemss' = map (fn (((_, ps), _), (((n, ps'), mode), elems)) =>
  9.1524 -        (((n, map (fn p => (p, (the o AList.lookup (op =) ps') p)) ps), mode), elems))
  9.1525 -      (all_ids ~~ all_elemss);
  9.1526 -    (* CB: all_elemss and parms contain the correct parameter types *)
  9.1527 -
  9.1528 -    val (ps, qs) = chop (length raw_import_params_elemss + length raw_import_elemss) all_elemss';
  9.1529 -    val ((import_elemss, _), import_ctxt) =
  9.1530 -      activate_facts false prep_facts ps context;
  9.1531 -
  9.1532 -    val ((elemss, _), ctxt) =
  9.1533 -      activate_facts false prep_facts qs (ProofContext.set_stmt true import_ctxt);
  9.1534 -  in
  9.1535 -    ((((import_ctxt, import_elemss), (ctxt, elemss, syn)),
  9.1536 -      (parms, spec, defs)), concl)
  9.1537 -  end;
  9.1538 -
  9.1539 -fun prep_statement prep_locale prep_ctxt raw_locale elems concl ctxt =
  9.1540 -  let
  9.1541 -    val thy = ProofContext.theory_of ctxt;
  9.1542 -    val locale = Option.map (prep_locale thy) raw_locale;
  9.1543 -    val (fixed_params, imports) =
  9.1544 -      (case locale of
  9.1545 -        NONE => ([], empty)
  9.1546 -      | SOME name =>
  9.1547 -          let val {params = ps, ...} = the_locale thy name
  9.1548 -          in (map fst ps, Locale name) end);
  9.1549 -    val ((((locale_ctxt, _), (elems_ctxt, _, _)), _), concl') =
  9.1550 -      prep_ctxt false fixed_params imports (map Elem elems) concl ctxt;
  9.1551 -  in (locale, locale_ctxt, elems_ctxt, concl') end;
  9.1552 -
  9.1553 -fun prep_expr prep imports body ctxt =
  9.1554 -  let
  9.1555 -    val (((_, import_elemss), (ctxt', elemss, _)), _) = prep imports body ctxt;
  9.1556 -    val all_elems = maps snd (import_elemss @ elemss);
  9.1557 -  in (all_elems, ctxt') end;
  9.1558 -
  9.1559 -in
  9.1560 -
  9.1561 -val read_ctxt = prep_context_statement intern_expr read_elemss read_facts;
  9.1562 -val cert_ctxt = prep_context_statement (K I) cert_elemss cert_facts;
  9.1563 -
  9.1564 -fun read_context imports body ctxt = #1 (read_ctxt true [] imports (map Elem body) [] ctxt);
  9.1565 -fun cert_context imports body ctxt = #1 (cert_ctxt true [] imports (map Elem body) [] ctxt);
  9.1566 -
  9.1567 -val read_expr = prep_expr read_context;
  9.1568 -val cert_expr = prep_expr cert_context;
  9.1569 -
  9.1570 -fun read_context_statement loc = prep_statement (K I) read_ctxt loc;
  9.1571 -fun read_context_statement_cmd loc = prep_statement intern read_ctxt loc;
  9.1572 -fun cert_context_statement loc = prep_statement (K I) cert_ctxt loc;
  9.1573 -
  9.1574 -end;
  9.1575 -
  9.1576 -
  9.1577 -(* init *)
  9.1578 -
  9.1579 -fun init loc =
  9.1580 -  ProofContext.init
  9.1581 -  #> #2 o cert_context_statement (SOME loc) [] [];
  9.1582 -
  9.1583 -
  9.1584 -(* print locale *)
  9.1585 -
  9.1586 -fun print_locale thy show_facts imports body =
  9.1587 -  let val (all_elems, ctxt) = read_expr imports body (ProofContext.init thy) in
  9.1588 -    Pretty.big_list "locale elements:" (all_elems
  9.1589 -      |> (if show_facts then I else filter (fn Notes _ => false | _ => true))
  9.1590 -      |> map (Element.pretty_ctxt ctxt) |> filter_out null
  9.1591 -      |> map Pretty.chunks)
  9.1592 -    |> Pretty.writeln
  9.1593 -  end;
  9.1594 -
  9.1595 -
  9.1596 -
  9.1597 -(** store results **)
  9.1598 -
  9.1599 -(* join equations of an id with already accumulated ones *)
  9.1600 -
  9.1601 -fun join_eqns get_reg id eqns =
  9.1602 -  let
  9.1603 -    val eqns' = case get_reg id
  9.1604 -      of NONE => eqns
  9.1605 -        | SOME (_, _, eqns') => Termtab.join (fn _ => fn (_, e) => e) (eqns, eqns')
  9.1606 -            (* prefer equations from eqns' *)
  9.1607 -  in ((id, eqns'), eqns') end;
  9.1608 -
  9.1609 -
  9.1610 -(* collect witnesses and equations up to a particular target for a
  9.1611 -   registration; requires parameters and flattened list of identifiers
  9.1612 -   instead of recomputing it from the target *)
  9.1613 -
  9.1614 -fun collect_witnesses ctxt (imprt as ((impT, _), (imp, _))) parms ids ext_ts = let
  9.1615 -
  9.1616 -    val thy = ProofContext.theory_of ctxt;
  9.1617 -
  9.1618 -    val ts = map (var_inst_term (impT, imp)) ext_ts;
  9.1619 -    val (parms, parmTs) = split_list parms;
  9.1620 -    val parmvTs = map Logic.varifyT parmTs;
  9.1621 -    val vtinst = fold (Sign.typ_match thy) (parmvTs ~~ map Term.fastype_of ts) Vartab.empty;
  9.1622 -    val tinst = Vartab.dest vtinst |> map (fn ((x, 0), (_, T)) => (x, T))
  9.1623 -        |> Symtab.make;
  9.1624 -    val inst = Symtab.make (parms ~~ ts);
  9.1625 -
  9.1626 -    (* instantiate parameter names in ids *)
  9.1627 -    val ext_inst = Symtab.make (parms ~~ ext_ts);
  9.1628 -    fun ext_inst_names ps = map (the o Symtab.lookup ext_inst) ps;
  9.1629 -    val inst_ids = map (apfst (apsnd ext_inst_names)) ids;
  9.1630 -    val assumed_ids = map_filter (fn (id, (_, Assumed _)) => SOME id | _ => NONE) inst_ids;
  9.1631 -    val wits = maps (#2 o the o get_local_registration ctxt imprt) assumed_ids;
  9.1632 -    val eqns =
  9.1633 -      fold_map (join_eqns (get_local_registration ctxt imprt))
  9.1634 -        (map fst inst_ids) Termtab.empty |> snd |> Termtab.dest |> map snd;
  9.1635 -  in ((tinst, inst), wits, eqns) end;
  9.1636 -
  9.1637 -
  9.1638 -(* compute and apply morphism *)
  9.1639 -
  9.1640 -fun name_morph phi_name (lprfx, pprfx) b =
  9.1641 -  b
  9.1642 -  |> (if not (Binding.is_empty b) andalso pprfx <> ""
  9.1643 -        then Binding.add_prefix false pprfx else I)
  9.1644 -  |> (if not (Binding.is_empty b)
  9.1645 -        then Binding.add_prefix false lprfx else I)
  9.1646 -  |> phi_name;
  9.1647 -
  9.1648 -fun inst_morph thy phi_name param_prfx insts prems eqns export =
  9.1649 -  let
  9.1650 -    (* standardise export morphism *)
  9.1651 -    val exp_fact = Drule.zero_var_indexes_list o map Thm.strip_shyps o Morphism.fact export;
  9.1652 -    val exp_term = TermSubst.zero_var_indexes o Morphism.term export;
  9.1653 -      (* FIXME sync with exp_fact *)
  9.1654 -    val exp_typ = Logic.type_map exp_term;
  9.1655 -    val export' =
  9.1656 -      Morphism.morphism {binding = I, var = I, typ = exp_typ, term = exp_term, fact = exp_fact};
  9.1657 -  in
  9.1658 -    Morphism.binding_morphism (name_morph phi_name param_prfx) $>
  9.1659 -      Element.inst_morphism thy insts $>
  9.1660 -      Element.satisfy_morphism prems $>
  9.1661 -      Morphism.term_morphism (MetaSimplifier.rewrite_term thy eqns []) $>
  9.1662 -      Morphism.thm_morphism (MetaSimplifier.rewrite_rule eqns) $>
  9.1663 -      export'
  9.1664 -  end;
  9.1665 -
  9.1666 -fun activate_note thy phi_name param_prfx attrib insts prems eqns exp =
  9.1667 -  (Element.facts_map o Element.morph_ctxt)
  9.1668 -      (inst_morph thy phi_name param_prfx insts prems eqns exp)
  9.1669 -  #> Attrib.map_facts attrib;
  9.1670 -
  9.1671 -
  9.1672 -(* public interface to interpretation morphism *)
  9.1673 -
  9.1674 -fun get_interpret_morph thy phi_name param_prfx (exp, imp) target ext_ts =
  9.1675 -  let
  9.1676 -    val parms = the_locale thy target |> #params |> map fst;
  9.1677 -    val ids = flatten (ProofContext.init thy, intern_expr thy)
  9.1678 -      (([], Symtab.empty), Expr (Locale target)) |> fst |> fst;
  9.1679 -    val (insts, prems, eqns) = collect_witnesses (ProofContext.init thy) imp parms ids ext_ts;
  9.1680 -  in
  9.1681 -    inst_morph thy phi_name param_prfx insts prems eqns exp
  9.1682 -  end;
  9.1683 -
  9.1684 -(* store instantiations of args for all registered interpretations
  9.1685 -   of the theory *)
  9.1686 -
  9.1687 -fun note_thmss_registrations target (kind, args) thy =
  9.1688 -  let
  9.1689 -    val parms = the_locale thy target |> #params |> map fst;
  9.1690 -    val ids = flatten (ProofContext.init thy, intern_expr thy)
  9.1691 -      (([], Symtab.empty), Expr (Locale target)) |> fst |> fst;
  9.1692 -
  9.1693 -    val regs = get_global_registrations thy target;
  9.1694 -    (* add args to thy for all registrations *)
  9.1695 -
  9.1696 -    fun activate (ext_ts, ((phi_name, param_prfx), (exp, imp), _, _)) thy =
  9.1697 -      let
  9.1698 -        val (insts, prems, eqns) = collect_witnesses (ProofContext.init thy) imp parms ids ext_ts;
  9.1699 -        val args' = args
  9.1700 -          |> activate_note thy phi_name param_prfx
  9.1701 -               (Attrib.attribute_i thy) insts prems eqns exp;
  9.1702 -      in
  9.1703 -        thy
  9.1704 -        |> global_note_qualified kind args'
  9.1705 -        |> snd
  9.1706 -      end;
  9.1707 -  in fold activate regs thy end;
  9.1708 -
  9.1709 -
  9.1710 -(* locale results *)
  9.1711 -
  9.1712 -fun add_thmss loc kind args ctxt =
  9.1713 -  let
  9.1714 -    val (([(_, [Notes args'])], _), ctxt') =
  9.1715 -      activate_facts true cert_facts
  9.1716 -        [((("", []), Assumed []), [Ext (Notes (kind, args))])] ctxt;
  9.1717 -    val ctxt'' = ctxt' |> ProofContext.theory
  9.1718 -      (change_locale loc
  9.1719 -        (fn (axiom, elems, params, decls, regs, intros, dests) =>
  9.1720 -          (axiom, elems @ [(Notes args', stamp ())],
  9.1721 -            params, decls, regs, intros, dests))
  9.1722 -      #> note_thmss_registrations loc args');
  9.1723 -  in ctxt'' end;
  9.1724 -
  9.1725 -
  9.1726 -(* declarations *)
  9.1727 -
  9.1728 -local
  9.1729 -
  9.1730 -fun decl_attrib decl phi = Thm.declaration_attribute (K (decl phi));
  9.1731 -
  9.1732 -fun add_decls add loc decl =
  9.1733 -  ProofContext.theory (change_locale loc
  9.1734 -    (fn (axiom, elems, params, decls, regs, intros, dests) =>
  9.1735 -      (axiom, elems, params, add (decl, stamp ()) decls, regs, intros, dests))) #>
  9.1736 -  add_thmss loc Thm.internalK
  9.1737 -    [((Binding.empty, [Attrib.internal (decl_attrib decl)]), [([Drule.dummy_thm], [])])];
  9.1738 -
  9.1739 -in
  9.1740 -
  9.1741 -val add_type_syntax = add_decls (apfst o cons);
  9.1742 -val add_term_syntax = add_decls (apsnd o cons);
  9.1743 -val add_declaration = add_decls (K I);
  9.1744 -
  9.1745 -fun declarations_of thy loc =
  9.1746 -  the_locale thy loc |> #decls |> apfst (map fst) |> apsnd (map fst);
  9.1747 -
  9.1748 -end;
  9.1749 -
  9.1750 -
  9.1751 -
  9.1752 -(** define locales **)
  9.1753 -
  9.1754 -(* predicate text *)
  9.1755 -(* CB: generate locale predicates and delta predicates *)
  9.1756 -
  9.1757 -local
  9.1758 -
  9.1759 -(* introN: name of theorems for introduction rules of locale and
  9.1760 -     delta predicates;
  9.1761 -   axiomsN: name of theorem set with destruct rules for locale predicates,
  9.1762 -     also name suffix of delta predicates. *)
  9.1763 -
  9.1764 -val introN = "intro";
  9.1765 -val axiomsN = "axioms";
  9.1766 -
  9.1767 -fun atomize_spec thy ts =
  9.1768 -  let
  9.1769 -    val t = Logic.mk_conjunction_balanced ts;
  9.1770 -    val body = ObjectLogic.atomize_term thy t;
  9.1771 -    val bodyT = Term.fastype_of body;
  9.1772 -  in
  9.1773 -    if bodyT = propT then (t, propT, Thm.reflexive (Thm.cterm_of thy t))
  9.1774 -    else (body, bodyT, ObjectLogic.atomize (Thm.cterm_of thy t))
  9.1775 -  end;
  9.1776 -
  9.1777 -fun aprop_tr' n c = (Syntax.constN ^ c, fn ctxt => fn args =>
  9.1778 -  if length args = n then
  9.1779 -    Syntax.const "_aprop" $
  9.1780 -      Term.list_comb (Syntax.free (Consts.extern (ProofContext.consts_of ctxt) c), args)
  9.1781 -  else raise Match);
  9.1782 -
  9.1783 -(* CB: define one predicate including its intro rule and axioms
  9.1784 -   - bname: predicate name
  9.1785 -   - parms: locale parameters
  9.1786 -   - defs: thms representing substitutions from defines elements
  9.1787 -   - ts: terms representing locale assumptions (not normalised wrt. defs)
  9.1788 -   - norm_ts: terms representing locale assumptions (normalised wrt. defs)
  9.1789 -   - thy: the theory
  9.1790 -*)
  9.1791 -
  9.1792 -fun def_pred bname parms defs ts norm_ts thy =
  9.1793 -  let
  9.1794 -    val name = Sign.full_bname thy bname;
  9.1795 -
  9.1796 -    val (body, bodyT, body_eq) = atomize_spec thy norm_ts;
  9.1797 -    val env = Term.add_free_names body [];
  9.1798 -    val xs = filter (member (op =) env o #1) parms;
  9.1799 -    val Ts = map #2 xs;
  9.1800 -    val extraTs =
  9.1801 -      (Term.add_tfrees body [] \\ fold Term.add_tfreesT Ts [])
  9.1802 -      |> Library.sort_wrt #1 |> map TFree;
  9.1803 -    val predT = map Term.itselfT extraTs ---> Ts ---> bodyT;
  9.1804 -
  9.1805 -    val args = map Logic.mk_type extraTs @ map Free xs;
  9.1806 -    val head = Term.list_comb (Const (name, predT), args);
  9.1807 -    val statement = ObjectLogic.ensure_propT thy head;
  9.1808 -
  9.1809 -    val ([pred_def], defs_thy) =
  9.1810 -      thy
  9.1811 -      |> bodyT = propT ? Sign.add_advanced_trfuns ([], [], [aprop_tr' (length args) name], [])
  9.1812 -      |> Sign.declare_const [] ((Binding.name bname, predT), NoSyn) |> snd
  9.1813 -      |> PureThy.add_defs false
  9.1814 -        [((Thm.def_name bname, Logic.mk_equals (head, body)), [Thm.kind_internal])];
  9.1815 -    val defs_ctxt = ProofContext.init defs_thy |> Variable.declare_term head;
  9.1816 -
  9.1817 -    val cert = Thm.cterm_of defs_thy;
  9.1818 -
  9.1819 -    val intro = Goal.prove_global defs_thy [] norm_ts statement (fn _ =>
  9.1820 -      MetaSimplifier.rewrite_goals_tac [pred_def] THEN
  9.1821 -      Tactic.compose_tac (false, body_eq RS Drule.equal_elim_rule1, 1) 1 THEN
  9.1822 -      Tactic.compose_tac (false,
  9.1823 -        Conjunction.intr_balanced (map (Thm.assume o cert) norm_ts), 0) 1);
  9.1824 -
  9.1825 -    val conjuncts =
  9.1826 -      (Drule.equal_elim_rule2 OF [body_eq,
  9.1827 -        MetaSimplifier.rewrite_rule [pred_def] (Thm.assume (cert statement))])
  9.1828 -      |> Conjunction.elim_balanced (length ts);
  9.1829 -    val axioms = ts ~~ conjuncts |> map (fn (t, ax) =>
  9.1830 -      Element.prove_witness defs_ctxt t
  9.1831 -       (MetaSimplifier.rewrite_goals_tac defs THEN
  9.1832 -        Tactic.compose_tac (false, ax, 0) 1));
  9.1833 -  in ((statement, intro, axioms), defs_thy) end;
  9.1834 -
  9.1835 -fun assumes_to_notes (Assumes asms) axms =
  9.1836 -      fold_map (fn (a, spec) => fn axs =>
  9.1837 -          let val (ps, qs) = chop (length spec) axs
  9.1838 -          in ((a, [(ps, [])]), qs) end) asms axms
  9.1839 -      |> apfst (curry Notes Thm.assumptionK)
  9.1840 -  | assumes_to_notes e axms = (e, axms);
  9.1841 -
  9.1842 -(* CB: the following two change only "new" elems, these have identifier ("", _). *)
  9.1843 -
  9.1844 -(* turn Assumes into Notes elements *)
  9.1845 -
  9.1846 -fun change_assumes_elemss axioms elemss =
  9.1847 -  let
  9.1848 -    val satisfy = Element.morph_ctxt (Element.satisfy_morphism axioms);
  9.1849 -    fun change (id as ("", _), es) =
  9.1850 -          fold_map assumes_to_notes (map satisfy es)
  9.1851 -          #-> (fn es' => pair (id, es'))
  9.1852 -      | change e = pair e;
  9.1853 -  in
  9.1854 -    fst (fold_map change elemss (map Element.conclude_witness axioms))
  9.1855 -  end;
  9.1856 -
  9.1857 -(* adjust hyps of Notes elements *)
  9.1858 -
  9.1859 -fun change_elemss_hyps axioms elemss =
  9.1860 -  let
  9.1861 -    val satisfy = Element.morph_ctxt (Element.satisfy_morphism axioms);
  9.1862 -    fun change (id as ("", _), es) = (id, map (fn e as Notes _ => satisfy e | e => e) es)
  9.1863 -      | change e = e;
  9.1864 -  in map change elemss end;
  9.1865 -
  9.1866 -in
  9.1867 -
  9.1868 -(* CB: main predicate definition function *)
  9.1869 -
  9.1870 -fun define_preds pname (parms, ((exts, exts'), (ints, ints')), defs) elemss thy =
  9.1871 -  let
  9.1872 -    val ((elemss', more_ts), a_elem, a_intro, thy'') =
  9.1873 -      if null exts then ((elemss, []), [], [], thy)
  9.1874 -      else
  9.1875 -        let
  9.1876 -          val aname = if null ints then pname else pname ^ "_" ^ axiomsN;
  9.1877 -          val ((statement, intro, axioms), thy') =
  9.1878 -            thy
  9.1879 -            |> def_pred aname parms defs exts exts';
  9.1880 -          val elemss' = change_assumes_elemss axioms elemss;
  9.1881 -          val a_elem = [(("", []),
  9.1882 -            [Assumes [((Binding.name (pname ^ "_" ^ axiomsN), []), [(statement, [])])]])];
  9.1883 -          val (_, thy'') =
  9.1884 -            thy'
  9.1885 -            |> Sign.add_path aname
  9.1886 -            |> Sign.no_base_names
  9.1887 -            |> PureThy.note_thmss Thm.internalK [((Binding.name introN, []), [([intro], [])])]
  9.1888 -            ||> Sign.restore_naming thy';
  9.1889 -        in ((elemss', [statement]), a_elem, [intro], thy'') end;
  9.1890 -    val (predicate, stmt', elemss'', b_intro, thy'''') =
  9.1891 -      if null ints then (([], []), more_ts, elemss' @ a_elem, [], thy'')
  9.1892 -      else
  9.1893 -        let
  9.1894 -          val ((statement, intro, axioms), thy''') =
  9.1895 -            thy''
  9.1896 -            |> def_pred pname parms defs (ints @ more_ts) (ints' @ more_ts);
  9.1897 -          val cstatement = Thm.cterm_of thy''' statement;
  9.1898 -          val elemss'' = change_elemss_hyps axioms elemss';
  9.1899 -          val b_elem = [(("", []),
  9.1900 -               [Assumes [((Binding.name (pname ^ "_" ^ axiomsN), []), [(statement, [])])]])];
  9.1901 -          val (_, thy'''') =
  9.1902 -            thy'''
  9.1903 -            |> Sign.add_path pname
  9.1904 -            |> Sign.no_base_names
  9.1905 -            |> PureThy.note_thmss Thm.internalK
  9.1906 -                 [((Binding.name introN, []), [([intro], [])]),
  9.1907 -                  ((Binding.name axiomsN, []),
  9.1908 -                    [(map (Drule.standard o Element.conclude_witness) axioms, [])])]
  9.1909 -            ||> Sign.restore_naming thy''';
  9.1910 -        in (([cstatement], axioms), [statement], elemss'' @ b_elem, [intro], thy'''') end;
  9.1911 -  in (((elemss'', predicate, stmt'), (a_intro, b_intro)), thy'''') end;
  9.1912 -
  9.1913 -end;
  9.1914 -
  9.1915 -
  9.1916 -(* add_locale(_i) *)
  9.1917 -
  9.1918 -local
  9.1919 -
  9.1920 -(* turn Defines into Notes elements, accumulate definition terms *)
  9.1921 -
  9.1922 -fun defines_to_notes is_ext thy (Defines defs) defns =
  9.1923 -    let
  9.1924 -      val defs' = map (fn (_, (def, _)) => (Attrib.empty_binding, (def, []))) defs
  9.1925 -      val notes = map (fn (a, (def, _)) =>
  9.1926 -        (a, [([assume (cterm_of thy def)], [])])) defs
  9.1927 -    in
  9.1928 -      (if is_ext then SOME (Notes (Thm.definitionK, notes)) else NONE, defns @ [Defines defs'])
  9.1929 -    end
  9.1930 -  | defines_to_notes _ _ e defns = (SOME e, defns);
  9.1931 -
  9.1932 -fun change_defines_elemss thy elemss defns =
  9.1933 -  let
  9.1934 -    fun change (id as (n, _), es) defns =
  9.1935 -        let
  9.1936 -          val (es', defns') = fold_map (defines_to_notes (n="") thy) es defns
  9.1937 -        in ((id, map_filter I es'), defns') end
  9.1938 -  in fold_map change elemss defns end;
  9.1939 -
  9.1940 -fun gen_add_locale prep_ctxt prep_expr
  9.1941 -    predicate_name bname raw_imports raw_body thy =
  9.1942 -    (* predicate_name: "" - locale with predicate named as locale
  9.1943 -        "name" - locale with predicate named "name" *)
  9.1944 -  let
  9.1945 -    val thy_ctxt = ProofContext.init thy;
  9.1946 -    val name = Sign.full_bname thy bname;
  9.1947 -    val _ = is_some (get_locale thy name) andalso
  9.1948 -      error ("Duplicate definition of locale " ^ quote name);
  9.1949 -
  9.1950 -    val (((import_ctxt, import_elemss), (body_ctxt, body_elemss, syn)),
  9.1951 -      text as (parms, ((_, exts'), _), defs)) =
  9.1952 -        prep_ctxt raw_imports raw_body thy_ctxt;
  9.1953 -    val elemss = import_elemss @ body_elemss |>
  9.1954 -      map_filter (fn ((id, Assumed axs), elems) => SOME (id, elems) | _ => NONE);
  9.1955 -
  9.1956 -    val extraTs = List.foldr OldTerm.add_term_tfrees [] exts' \\
  9.1957 -      List.foldr OldTerm.add_typ_tfrees [] (map snd parms);
  9.1958 -    val _ = if null extraTs then ()
  9.1959 -      else warning ("Additional type variable(s) in locale specification " ^ quote bname);
  9.1960 -
  9.1961 -    val predicate_name' = case predicate_name of "" => bname | _ => predicate_name;
  9.1962 -    val (elemss', defns) = change_defines_elemss thy elemss [];
  9.1963 -    val elemss'' = elemss' @ [(("", []), defns)];
  9.1964 -    val (((elemss''', predicate as (pred_statement, pred_axioms), stmt'), intros), thy') =
  9.1965 -      define_preds predicate_name' text elemss'' thy;
  9.1966 -    val regs = pred_axioms
  9.1967 -      |> fold_map (fn (id, elems) => fn wts => let
  9.1968 -             val ts = flat (map_filter (fn (Assumes asms) =>
  9.1969 -               SOME (maps (map #1 o #2) asms) | _ => NONE) elems);
  9.1970 -             val (wts1, wts2) = chop (length ts) wts;
  9.1971 -           in ((apsnd (map fst) id, wts1), wts2) end) elemss'''
  9.1972 -      |> fst
  9.1973 -      |> map_filter (fn (("", _), _) => NONE | e => SOME e);
  9.1974 -    fun axiomify axioms elemss =
  9.1975 -      (axioms, elemss) |> foldl_map (fn (axs, (id, elems)) => let
  9.1976 -                   val ts = flat (map_filter (fn (Assumes asms) =>
  9.1977 -                     SOME (maps (map #1 o #2) asms) | _ => NONE) elems);
  9.1978 -                   val (axs1, axs2) = chop (length ts) axs;
  9.1979 -                 in (axs2, ((id, Assumed axs1), elems)) end)
  9.1980 -      |> snd;
  9.1981 -    val ((_, facts), ctxt) = activate_facts true (K I)
  9.1982 -      (axiomify pred_axioms elemss''') (ProofContext.init thy');
  9.1983 -    val view_ctxt = Assumption.add_view thy_ctxt pred_statement ctxt;
  9.1984 -    val export = Thm.close_derivation o Goal.norm_result o
  9.1985 -      singleton (ProofContext.export view_ctxt thy_ctxt);
  9.1986 -    val facts' = facts |> map (fn (a, ths) => ((a, []), [(map export ths, [])]));
  9.1987 -    val elems' = maps #2 (filter (fn ((s, _), _) => s = "") elemss''');
  9.1988 -    val elems'' = map_filter (fn (Fixes _) => NONE | e => SOME e) elems';
  9.1989 -    val axs' = map (Element.assume_witness thy') stmt';
  9.1990 -    val loc_ctxt = thy'
  9.1991 -      |> Sign.add_path bname
  9.1992 -      |> Sign.no_base_names
  9.1993 -      |> PureThy.note_thmss Thm.assumptionK facts' |> snd
  9.1994 -      |> Sign.restore_naming thy'
  9.1995 -      |> register_locale bname {axiom = axs',
  9.1996 -        elems = map (fn e => (e, stamp ())) elems'',
  9.1997 -        params = params_of elemss''' |> map (fn (x, SOME T) => ((x, T), the (Symtab.lookup syn x))),
  9.1998 -        decls = ([], []),
  9.1999 -        regs = regs,
  9.2000 -        intros = intros,
  9.2001 -        dests = map Element.conclude_witness pred_axioms}
  9.2002 -      |> init name;
  9.2003 -  in (name, loc_ctxt) end;
  9.2004 -
  9.2005 -in
  9.2006 -
  9.2007 -val add_locale = gen_add_locale cert_context (K I);
  9.2008 -val add_locale_cmd = gen_add_locale read_context intern_expr "";
  9.2009 -
  9.2010 -end;
  9.2011 -
  9.2012 -val _ = Context.>> (Context.map_theory
  9.2013 - (add_locale "" "var" empty [Fixes [(Binding.name (Name.internal "x"), NONE, NoSyn)]] #>
  9.2014 -  snd #> ProofContext.theory_of #>
  9.2015 -  add_locale "" "struct" empty [Fixes [(Binding.name (Name.internal "S"), NONE, Structure)]] #>
  9.2016 -  snd #> ProofContext.theory_of));
  9.2017 -
  9.2018 -
  9.2019 -
  9.2020 -
  9.2021 -(** Normalisation of locale statements ---
  9.2022 -    discharges goals implied by interpretations **)
  9.2023 -
  9.2024 -local
  9.2025 -
  9.2026 -fun locale_assm_intros thy =
  9.2027 -  Symtab.fold (fn (_, {intros = (a, _), ...}) => fn intros => (a @ intros))
  9.2028 -    (#2 (LocalesData.get thy)) [];
  9.2029 -fun locale_base_intros thy =
  9.2030 -  Symtab.fold (fn (_, {intros = (_, b), ...}) => fn intros => (b @ intros))
  9.2031 -    (#2 (LocalesData.get thy)) [];
  9.2032 -
  9.2033 -fun all_witnesses ctxt =
  9.2034 -  let
  9.2035 -    val thy = ProofContext.theory_of ctxt;
  9.2036 -    fun get registrations = Symtab.fold (fn (_, regs) => fn thms =>
  9.2037 -        (Registrations.dest thy regs |> map (fn (_, (_, (exp, _), wits, _)) =>
  9.2038 -          map (Element.conclude_witness #> Morphism.thm exp) wits) |> flat) @ thms)
  9.2039 -      registrations [];
  9.2040 -  in get (RegistrationsData.get (Context.Proof ctxt)) end;
  9.2041 -
  9.2042 -in
  9.2043 -
  9.2044 -fun intro_locales_tac eager ctxt facts st =
  9.2045 -  let
  9.2046 -    val wits = all_witnesses ctxt;
  9.2047 -    val thy = ProofContext.theory_of ctxt;
  9.2048 -    val intros = locale_base_intros thy @ (if eager then locale_assm_intros thy else []);
  9.2049 -  in
  9.2050 -    Method.intros_tac (wits @ intros) facts st
  9.2051 -  end;
  9.2052 -
  9.2053 -end;
  9.2054 -
  9.2055 -
  9.2056 -(** Interpretation commands **)
  9.2057 -
  9.2058 -local
  9.2059 -
  9.2060 -(* extract proof obligations (assms and defs) from elements *)
  9.2061 -
  9.2062 -fun extract_asms_elems ((id, Assumed _), elems) = (id, maps Element.prems_of elems)
  9.2063 -  | extract_asms_elems ((id, Derived _), _) = (id, []);
  9.2064 -
  9.2065 -
  9.2066 -(* activate instantiated facts in theory or context *)
  9.2067 -
  9.2068 -fun gen_activate_facts_elemss mk_ctxt note attrib put_reg add_wit add_eqn
  9.2069 -        phi_name all_elemss pss propss eq_attns (exp, imp) thmss thy_ctxt =
  9.2070 -  let
  9.2071 -    val ctxt = mk_ctxt thy_ctxt;
  9.2072 -    fun get_reg thy_ctxt = get_local_registration (mk_ctxt thy_ctxt);
  9.2073 -    fun test_reg thy_ctxt = test_local_registration (mk_ctxt thy_ctxt);
  9.2074 -
  9.2075 -    val (all_propss, eq_props) = chop (length all_elemss) propss;
  9.2076 -    val (all_thmss, eq_thms) = chop (length all_elemss) thmss;
  9.2077 -
  9.2078 -    (* Filter out fragments already registered. *)
  9.2079 -
  9.2080 -    val (new_elemss, xs) = split_list (filter_out (fn (((id, _), _), _) =>
  9.2081 -          test_reg thy_ctxt id) (all_elemss ~~ (pss ~~ (all_propss ~~ all_thmss))));
  9.2082 -    val (new_pss, ys) = split_list xs;
  9.2083 -    val (new_propss, new_thmss) = split_list ys;
  9.2084 -
  9.2085 -    val thy_ctxt' = thy_ctxt
  9.2086 -      (* add registrations *)
  9.2087 -      |> fold2 (fn ((id as (loc, _), _), _) => fn ps => put_reg id (phi_name, param_prefix loc ps) (exp, imp))
  9.2088 -           new_elemss new_pss
  9.2089 -      (* add witnesses of Assumed elements (only those generate proof obligations) *)
  9.2090 -      |> fold2 (fn (id, _) => fold (add_wit id)) new_propss new_thmss
  9.2091 -      (* add equations *)
  9.2092 -      |> fold2 (fn (id, _) => fold (add_eqn id)) eq_props
  9.2093 -          ((map o map) (Drule.abs_def o LocalDefs.meta_rewrite_rule ctxt o
  9.2094 -            Element.conclude_witness) eq_thms);
  9.2095 -
  9.2096 -    val prems = flat (map_filter
  9.2097 -          (fn ((id, Assumed _), _) => Option.map #2 (get_reg thy_ctxt' imp id)
  9.2098 -            | ((_, Derived _), _) => NONE) all_elemss);
  9.2099 -
  9.2100 -    val thy_ctxt'' = thy_ctxt'
  9.2101 -      (* add witnesses of Derived elements *)
  9.2102 -      |> fold (fn (id, thms) => fold
  9.2103 -           (add_wit id o Element.morph_witness (Element.satisfy_morphism prems)) thms)
  9.2104 -         (map_filter (fn ((_, Assumed _), _) => NONE
  9.2105 -            | ((id, Derived thms), _) => SOME (id, thms)) new_elemss)
  9.2106 -
  9.2107 -    fun activate_elem phi_name param_prfx insts prems eqns exp (Notes (kind, facts)) thy_ctxt =
  9.2108 -        let
  9.2109 -          val ctxt = mk_ctxt thy_ctxt;
  9.2110 -          val thy = ProofContext.theory_of ctxt;
  9.2111 -          val facts' = facts
  9.2112 -            |> activate_note thy phi_name param_prfx
  9.2113 -                 (attrib thy_ctxt) insts prems eqns exp;
  9.2114 -        in 
  9.2115 -          thy_ctxt
  9.2116 -          |> note kind facts'
  9.2117 -          |> snd
  9.2118 -        end
  9.2119 -      | activate_elem _ _ _ _ _ _ _ thy_ctxt = thy_ctxt;
  9.2120 -
  9.2121 -    fun activate_elems (((loc, ext_ts), _), _) ps thy_ctxt =
  9.2122 -      let
  9.2123 -        val ctxt = mk_ctxt thy_ctxt;
  9.2124 -        val thy = ProofContext.theory_of ctxt;
  9.2125 -        val {params, elems, ...} = the_locale thy loc;
  9.2126 -        val parms = map fst params;
  9.2127 -        val param_prfx = param_prefix loc ps;
  9.2128 -        val ids = flatten (ProofContext.init thy, intern_expr thy)
  9.2129 -          (([], Symtab.empty), Expr (Locale loc)) |> fst |> fst;
  9.2130 -        val (insts, prems, eqns) = collect_witnesses ctxt imp parms ids ext_ts;
  9.2131 -      in
  9.2132 -        thy_ctxt
  9.2133 -        |> fold (activate_elem phi_name param_prfx insts prems eqns exp o fst) elems
  9.2134 -      end;
  9.2135 -
  9.2136 -  in
  9.2137 -    thy_ctxt''
  9.2138 -    (* add equations as lemmas to context *)
  9.2139 -    |> (fold2 o fold2) (fn attn => fn thm => snd o yield_singleton (note Thm.lemmaK)
  9.2140 -         ((apsnd o map) (attrib thy_ctxt'') attn, [([Element.conclude_witness thm], [])]))
  9.2141 -            (unflat eq_thms eq_attns) eq_thms
  9.2142 -    (* add interpreted facts *)
  9.2143 -    |> fold2 activate_elems new_elemss new_pss
  9.2144 -  end;
  9.2145 -
  9.2146 -fun global_activate_facts_elemss x = gen_activate_facts_elemss
  9.2147 -  ProofContext.init
  9.2148 -  global_note_qualified
  9.2149 -  Attrib.attribute_i
  9.2150 -  put_global_registration
  9.2151 -  add_global_witness
  9.2152 -  add_global_equation
  9.2153 -  x;
  9.2154 -
  9.2155 -fun local_activate_facts_elemss x = gen_activate_facts_elemss
  9.2156 -  I
  9.2157 -  local_note_qualified
  9.2158 -  (Attrib.attribute_i o ProofContext.theory_of)
  9.2159 -  put_local_registration
  9.2160 -  add_local_witness
  9.2161 -  add_local_equation
  9.2162 -  x;
  9.2163 -
  9.2164 -fun prep_instantiations parse_term parse_prop ctxt parms (insts, eqns) =
  9.2165 -  let
  9.2166 -    (* parameters *)
  9.2167 -    val (parm_names, parm_types) = parms |> split_list
  9.2168 -      ||> map (TypeInfer.paramify_vars o Logic.varifyT);
  9.2169 -    val type_parms = fold Term.add_tvarsT parm_types [] |> map (Logic.mk_type o TVar);
  9.2170 -    val type_parm_names = fold Term.add_tfreesT (map snd parms) [] |> map fst;
  9.2171 -
  9.2172 -    (* parameter instantiations *)
  9.2173 -    val d = length parms - length insts;
  9.2174 -    val insts =
  9.2175 -      if d < 0 then error "More arguments than parameters in instantiation."
  9.2176 -      else insts @ replicate d NONE;
  9.2177 -    val (given_ps, given_insts) =
  9.2178 -      ((parm_names ~~ parm_types) ~~ insts) |> map_filter
  9.2179 -          (fn (_, NONE) => NONE
  9.2180 -            | ((n, T), SOME inst) => SOME ((n, T), inst))
  9.2181 -        |> split_list;
  9.2182 -    val (given_parm_names, given_parm_types) = given_ps |> split_list;
  9.2183 -
  9.2184 -    (* parse insts / eqns *)
  9.2185 -    val given_insts' = map (parse_term ctxt) given_insts;
  9.2186 -    val eqns' = map (parse_prop ctxt) eqns;
  9.2187 -
  9.2188 -    (* type inference and contexts *)
  9.2189 -    val arg = type_parms @ map2 TypeInfer.constrain given_parm_types given_insts' @ eqns';
  9.2190 -    val res = Syntax.check_terms ctxt arg;
  9.2191 -    val ctxt' = ctxt |> fold Variable.auto_fixes res;
  9.2192 -
  9.2193 -    (* instantiation *)
  9.2194 -    val (type_parms'', res') = chop (length type_parms) res;
  9.2195 -    val (given_insts'', eqns'') = chop (length given_insts) res';
  9.2196 -    val instT = Symtab.make (type_parm_names ~~ map Logic.dest_type type_parms'');
  9.2197 -    val inst = Symtab.make (given_parm_names ~~ given_insts'');
  9.2198 -
  9.2199 -    (* export from eigencontext *)
  9.2200 -    val export = Variable.export_morphism ctxt' ctxt;
  9.2201 -
  9.2202 -    (* import, its inverse *)
  9.2203 -    val domT = fold Term.add_tfrees res [] |> map TFree;
  9.2204 -    val importT = domT |> map (fn x => (Morphism.typ export x, x))
  9.2205 -      |> map_filter (fn (TFree _, _) => NONE  (* fixed point of export *)
  9.2206 -               | (TVar y, x) => SOME (fst y, x)
  9.2207 -               | _ => error "internal: illegal export in interpretation")
  9.2208 -      |> Vartab.make;
  9.2209 -    val dom = fold Term.add_frees res [] |> map Free;
  9.2210 -    val imprt = dom |> map (fn x => (Morphism.term export x, x))
  9.2211 -      |> map_filter (fn (Free _, _) => NONE  (* fixed point of export *)
  9.2212 -               | (Var y, x) => SOME (fst y, x)
  9.2213 -               | _ => error "internal: illegal export in interpretation")
  9.2214 -      |> Vartab.make;
  9.2215 -  in (((instT, inst), eqns''), (export, ((importT, domT), (imprt, dom)))) end;
  9.2216 -
  9.2217 -val read_instantiations = prep_instantiations Syntax.parse_term Syntax.parse_prop;
  9.2218 -val check_instantiations = prep_instantiations (K I) (K I);
  9.2219 -
  9.2220 -fun gen_prep_registration mk_ctxt test_reg activate
  9.2221 -    prep_attr prep_expr prep_insts
  9.2222 -    thy_ctxt phi_name raw_expr raw_insts =
  9.2223 -  let
  9.2224 -    val ctxt = mk_ctxt thy_ctxt;
  9.2225 -    val thy = ProofContext.theory_of ctxt;
  9.2226 -    val ctxt' = ProofContext.init thy;
  9.2227 -    fun prep_attn attn = (apsnd o map)
  9.2228 -      (Attrib.crude_closure ctxt o Args.assignable o prep_attr thy) attn;
  9.2229 -
  9.2230 -    val expr = prep_expr thy raw_expr;
  9.2231 -
  9.2232 -    val pts = params_of_expr ctxt' [] expr ([], Symtab.empty, Symtab.empty);
  9.2233 -    val params_ids = make_params_ids (#1 pts);
  9.2234 -    val raw_params_elemss = make_raw_params_elemss pts;
  9.2235 -    val ((ids, _), raw_elemss) = flatten (ctxt', I) (([], Symtab.empty), Expr expr);
  9.2236 -    val ((parms, all_elemss, _), (_, (_, defs, _))) =
  9.2237 -      read_elemss false ctxt' [] (raw_params_elemss @ raw_elemss) [];
  9.2238 -
  9.2239 -    (** compute instantiation **)
  9.2240 -
  9.2241 -    (* consistency check: equations need to be stored in a particular locale,
  9.2242 -       therefore if equations are present locale expression must be a name *)
  9.2243 -
  9.2244 -    val _ = case (expr, snd raw_insts) of
  9.2245 -        (Locale _, _) => () | (_, []) => ()
  9.2246 -      | (_, _) => error "Interpretations with `where' only permitted if locale expression is a name.";
  9.2247 -
  9.2248 -    (* read or certify instantiation *)
  9.2249 -    val (raw_insts', raw_eqns) = raw_insts;
  9.2250 -    val (raw_eq_attns, raw_eqns') = split_list raw_eqns;
  9.2251 -    val (((instT, inst1), eqns), morphs) = prep_insts ctxt parms (raw_insts', raw_eqns');
  9.2252 -    val eq_attns = map prep_attn raw_eq_attns;
  9.2253 -
  9.2254 -    (* defined params without given instantiation *)
  9.2255 -    val not_given = filter_out (Symtab.defined inst1 o fst) parms;
  9.2256 -    fun add_def (p, pT) inst =
  9.2257 -      let
  9.2258 -        val (t, T) = case find_first (fn (Free (a, _), _) => a = p) defs of
  9.2259 -               NONE => error ("Instance missing for parameter " ^ quote p)
  9.2260 -             | SOME (Free (_, T), t) => (t, T);
  9.2261 -        val d = Element.inst_term (instT, inst) t;
  9.2262 -      in Symtab.update_new (p, d) inst end;
  9.2263 -    val inst2 = fold add_def not_given inst1;
  9.2264 -    val inst_morphism = Element.inst_morphism thy (instT, inst2);
  9.2265 -    (* Note: insts contain no vars. *)
  9.2266 -
  9.2267 -    (** compute proof obligations **)
  9.2268 -
  9.2269 -    (* restore "small" ids *)
  9.2270 -    val ids' = map (fn ((n, ps), (_, mode)) =>
  9.2271 -          ((n, map (fn p => Free (p, (the o AList.lookup (op =) parms) p)) ps), mode))
  9.2272 -        ids;
  9.2273 -    val (_, all_elemss') = chop (length raw_params_elemss) all_elemss
  9.2274 -    (* instantiate ids and elements *)
  9.2275 -    val inst_elemss = (ids' ~~ all_elemss') |> map (fn (((n, ps), _), ((_, mode), elems)) =>
  9.2276 -      ((n, map (Morphism.term (inst_morphism $> fst morphs)) ps),
  9.2277 -        map (fn Int e => Element.morph_ctxt inst_morphism e) elems)
  9.2278 -      |> apfst (fn id => (id, map_mode (map (Element.morph_witness inst_morphism)) mode)));
  9.2279 -
  9.2280 -    (* equations *)
  9.2281 -    val eqn_elems = if null eqns then []
  9.2282 -      else [(Library.last_elem inst_elemss |> fst |> fst, eqns)];
  9.2283 -
  9.2284 -    val propss = map extract_asms_elems inst_elemss @ eqn_elems;
  9.2285 -
  9.2286 -  in
  9.2287 -    (propss, activate phi_name inst_elemss (map (snd o fst) ids) propss eq_attns morphs, morphs)
  9.2288 -  end;
  9.2289 -
  9.2290 -fun gen_prep_global_registration mk_ctxt = gen_prep_registration ProofContext.init
  9.2291 -  test_global_registration
  9.2292 -  global_activate_facts_elemss mk_ctxt;
  9.2293 -
  9.2294 -fun gen_prep_local_registration mk_ctxt = gen_prep_registration I
  9.2295 -  test_local_registration
  9.2296 -  local_activate_facts_elemss mk_ctxt;
  9.2297 -
  9.2298 -val prep_global_registration = gen_prep_global_registration
  9.2299 -  (K I) (K I) check_instantiations;
  9.2300 -val prep_global_registration_cmd = gen_prep_global_registration
  9.2301 -  Attrib.intern_src intern_expr read_instantiations;
  9.2302 -
  9.2303 -val prep_local_registration = gen_prep_local_registration
  9.2304 -  (K I) (K I) check_instantiations;
  9.2305 -val prep_local_registration_cmd = gen_prep_local_registration
  9.2306 -  Attrib.intern_src intern_expr read_instantiations;
  9.2307 -
  9.2308 -fun prep_registration_in_locale target expr thy =
  9.2309 -  (* target already in internal form *)
  9.2310 -  let
  9.2311 -    val ctxt = ProofContext.init thy;
  9.2312 -    val ((raw_target_ids, target_syn), _) = flatten (ctxt, I)
  9.2313 -        (([], Symtab.empty), Expr (Locale target));
  9.2314 -    val fixed = the_locale thy target |> #params |> map #1;
  9.2315 -    val ((all_ids, syn), raw_elemss) = flatten (ctxt, intern_expr thy)
  9.2316 -        ((raw_target_ids, target_syn), Expr expr);
  9.2317 -    val (target_ids, ids) = chop (length raw_target_ids) all_ids;
  9.2318 -    val ((parms, elemss, _), _) = read_elemss false ctxt fixed raw_elemss [];
  9.2319 -
  9.2320 -    (** compute proof obligations **)
  9.2321 -
  9.2322 -    (* restore "small" ids, with mode *)
  9.2323 -    val ids' = map (apsnd snd) ids;
  9.2324 -    (* remove Int markers *)
  9.2325 -    val elemss' = map (fn (_, es) =>
  9.2326 -        map (fn Int e => e) es) elemss
  9.2327 -    (* extract assumptions and defs *)
  9.2328 -    val ids_elemss = ids' ~~ elemss';
  9.2329 -    val propss = map extract_asms_elems ids_elemss;
  9.2330 -
  9.2331 -    (** activation function:
  9.2332 -        - add registrations to the target locale
  9.2333 -        - add induced registrations for all global registrations of
  9.2334 -          the target, unless already present
  9.2335 -        - add facts of induced registrations to theory **)
  9.2336 -
  9.2337 -    fun activate thmss thy =
  9.2338 -      let
  9.2339 -        val satisfy = Element.satisfy_thm (flat thmss);
  9.2340 -        val ids_elemss_thmss = ids_elemss ~~ thmss;
  9.2341 -        val regs = get_global_registrations thy target;
  9.2342 -
  9.2343 -        fun activate_id (((id, Assumed _), _), thms) thy =
  9.2344 -            thy |> put_registration_in_locale target id
  9.2345 -                |> fold (add_witness_in_locale target id) thms
  9.2346 -          | activate_id _ thy = thy;
  9.2347 -
  9.2348 -        fun activate_reg (ext_ts, ((phi_name, param_prfx), (exp, imp), _, _)) thy =
  9.2349 -          let
  9.2350 -            val (insts, wits, _) = collect_witnesses (ProofContext.init thy) imp fixed target_ids ext_ts;
  9.2351 -            val inst_parms = map (the o AList.lookup (op =) (map #1 fixed ~~ ext_ts));
  9.2352 -            val disch = Element.satisfy_thm wits;
  9.2353 -            val new_elemss = filter (fn (((name, ps), _), _) =>
  9.2354 -                not (test_global_registration thy (name, inst_parms ps))) (ids_elemss);
  9.2355 -            fun activate_assumed_id (((_, Derived _), _), _) thy = thy
  9.2356 -              | activate_assumed_id ((((name, ps), Assumed _), _), thms) thy = let
  9.2357 -                val ps' = inst_parms ps;
  9.2358 -              in
  9.2359 -                if test_global_registration thy (name, ps')
  9.2360 -                then thy
  9.2361 -                else thy
  9.2362 -                  |> put_global_registration (name, ps') (phi_name, param_prefix name ps) (exp, imp)
  9.2363 -                  |> fold (fn witn => fn thy => add_global_witness (name, ps')
  9.2364 -                     (Element.morph_witness (Element.inst_morphism thy insts) witn) thy) thms
  9.2365 -              end;
  9.2366 -
  9.2367 -            fun activate_derived_id ((_, Assumed _), _) thy = thy
  9.2368 -              | activate_derived_id (((name, ps), Derived ths), _) thy = let
  9.2369 -                val ps' = inst_parms ps;
  9.2370 -              in
  9.2371 -                if test_global_registration thy (name, ps')
  9.2372 -                then thy
  9.2373 -                else thy
  9.2374 -                  |> put_global_registration (name, ps') (phi_name, param_prefix name ps) (exp, imp)
  9.2375 -                  |> fold (fn witn => fn thy => add_global_witness (name, ps')
  9.2376 -                       (witn |> Element.map_witness (fn (t, th) =>  (* FIXME *)
  9.2377 -                       (Element.inst_term insts t,
  9.2378 -                        disch (Element.inst_thm thy insts (satisfy th))))) thy) ths
  9.2379 -              end;
  9.2380 -
  9.2381 -            fun activate_elem (loc, ps) (Notes (kind, facts)) thy =
  9.2382 -                let
  9.2383 -                  val att_morphism =
  9.2384 -                    Morphism.binding_morphism (name_morph phi_name param_prfx) $>
  9.2385 -                    Morphism.thm_morphism satisfy $>
  9.2386 -                    Element.inst_morphism thy insts $>
  9.2387 -                    Morphism.thm_morphism disch;
  9.2388 -                  val facts' = facts
  9.2389 -                    |> Attrib.map_facts (Attrib.attribute_i thy o Args.morph_values att_morphism)
  9.2390 -                    |> (map o apsnd o map o apfst o map) (disch o Element.inst_thm thy insts o satisfy)
  9.2391 -                    |> (map o apfst o apfst) (name_morph phi_name param_prfx);
  9.2392 -                in
  9.2393 -                  thy
  9.2394 -                  |> global_note_qualified kind facts'
  9.2395 -                  |> snd
  9.2396 -                end
  9.2397 -              | activate_elem _ _ thy = thy;
  9.2398 -
  9.2399 -            fun activate_elems ((id, _), elems) thy = fold (activate_elem id) elems thy;
  9.2400 -
  9.2401 -          in thy |> fold activate_assumed_id ids_elemss_thmss
  9.2402 -                 |> fold activate_derived_id ids_elemss
  9.2403 -                 |> fold activate_elems new_elemss end;
  9.2404 -      in
  9.2405 -        thy |> fold activate_id ids_elemss_thmss
  9.2406 -            |> fold activate_reg regs
  9.2407 -      end;
  9.2408 -
  9.2409 -  in (propss, activate) end;
  9.2410 -
  9.2411 -fun prep_propp propss = propss |> map (fn (_, props) =>
  9.2412 -  map (rpair [] o Element.mark_witness) props);
  9.2413 -
  9.2414 -fun prep_result propps thmss =
  9.2415 -  ListPair.map (fn ((_, props), thms) => map2 Element.make_witness props thms) (propps, thmss);
  9.2416 -
  9.2417 -fun gen_interpretation prep_registration after_qed prfx raw_expr raw_insts thy =
  9.2418 -  let
  9.2419 -    val (propss, activate, morphs) = prep_registration thy prfx raw_expr raw_insts;
  9.2420 -    fun after_qed' results =
  9.2421 -      ProofContext.theory (activate (prep_result propss results))
  9.2422 -      #> after_qed;
  9.2423 -  in
  9.2424 -    thy
  9.2425 -    |> ProofContext.init
  9.2426 -    |> Proof.theorem_i NONE after_qed' (prep_propp propss)
  9.2427 -    |> Element.refine_witness
  9.2428 -    |> Seq.hd
  9.2429 -    |> pair morphs
  9.2430 -  end;
  9.2431 -
  9.2432 -fun gen_interpret prep_registration after_qed name_morph expr insts int state =
  9.2433 -  let
  9.2434 -    val _ = Proof.assert_forward_or_chain state;
  9.2435 -    val ctxt = Proof.context_of state;
  9.2436 -    val (propss, activate, morphs) = prep_registration ctxt name_morph expr insts;
  9.2437 -    fun after_qed' results =
  9.2438 -      Proof.map_context (K (ctxt |> activate (prep_result propss results)))
  9.2439 -      #> Proof.put_facts NONE
  9.2440 -      #> after_qed;
  9.2441 -  in
  9.2442 -    state
  9.2443 -    |> Proof.local_goal (ProofDisplay.print_results int) (K I) ProofContext.bind_propp_i
  9.2444 -      "interpret" NONE after_qed' (map (pair (Binding.empty, [])) (prep_propp propss))
  9.2445 -    |> Element.refine_witness |> Seq.hd
  9.2446 -    |> pair morphs
  9.2447 -  end;
  9.2448 -
  9.2449 -fun standard_name_morph interp_prfx b =
  9.2450 -  if Binding.is_empty b then b
  9.2451 -  else Binding.map_prefix (fn ((lprfx, _) :: pprfx) =>
  9.2452 -    fold (Binding.add_prefix false o fst) pprfx
  9.2453 -    #> interp_prfx <> "" ? Binding.add_prefix true interp_prfx
  9.2454 -    #> Binding.add_prefix false lprfx
  9.2455 -  ) b;
  9.2456 -
  9.2457 -in
  9.2458 -
  9.2459 -val interpretation = gen_interpretation prep_global_registration;
  9.2460 -fun interpretation_cmd interp_prfx = snd ooo gen_interpretation prep_global_registration_cmd
  9.2461 -  I (standard_name_morph interp_prfx);
  9.2462 -
  9.2463 -fun interpretation_in_locale after_qed (raw_target, expr) thy =
  9.2464 -  let
  9.2465 -    val target = intern thy raw_target;
  9.2466 -    val (propss, activate) = prep_registration_in_locale target expr thy;
  9.2467 -    val raw_propp = prep_propp propss;
  9.2468 -
  9.2469 -    val (_, _, goal_ctxt, propp) = thy
  9.2470 -      |> ProofContext.init
  9.2471 -      |> cert_context_statement (SOME target) [] raw_propp;
  9.2472 -
  9.2473 -    fun after_qed' results =
  9.2474 -      ProofContext.theory (activate (prep_result propss results))
  9.2475 -      #> after_qed;
  9.2476 -  in
  9.2477 -    goal_ctxt
  9.2478 -    |> Proof.theorem_i NONE after_qed' propp
  9.2479 -    |> Element.refine_witness |> Seq.hd
  9.2480 -  end;
  9.2481 -
  9.2482 -val interpret = gen_interpret prep_local_registration;
  9.2483 -fun interpret_cmd interp_prfx = snd oooo gen_interpret prep_local_registration_cmd
  9.2484 -  Seq.single (standard_name_morph interp_prfx);
  9.2485 -
  9.2486 -end;
  9.2487 -
  9.2488 -end;
    10.1 --- a/src/Pure/Isar/new_locale.ML	Mon Jan 05 15:37:49 2009 +0100
    10.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    10.3 @@ -1,508 +0,0 @@
    10.4 -(*  Title:      Pure/Isar/new_locale.ML
    10.5 -    Author:     Clemens Ballarin, TU Muenchen
    10.6 -
    10.7 -New locale development --- experimental.
    10.8 -*)
    10.9 -
   10.10 -signature NEW_LOCALE =
   10.11 -sig
   10.12 -  type locale
   10.13 -
   10.14 -  val test_locale: theory -> string -> bool
   10.15 -  val register_locale: bstring ->
   10.16 -    (string * sort) list * (Binding.T * typ option * mixfix) list ->
   10.17 -    term option * term list ->
   10.18 -    (declaration * stamp) list * (declaration * stamp) list ->
   10.19 -    ((string * (Attrib.binding * (thm list * Attrib.src list) list) list) * stamp) list ->
   10.20 -    ((string * Morphism.morphism) * stamp) list -> theory -> theory
   10.21 -
   10.22 -  (* Locale name space *)
   10.23 -  val intern: theory -> xstring -> string
   10.24 -  val extern: theory -> string -> xstring
   10.25 -
   10.26 -  (* Specification *)
   10.27 -  val params_of: theory -> string -> (Binding.T * typ option * mixfix) list
   10.28 -  val instance_of: theory -> string -> Morphism.morphism -> term list
   10.29 -  val specification_of: theory -> string -> term option * term list
   10.30 -  val declarations_of: theory -> string -> declaration list * declaration list
   10.31 -
   10.32 -  (* Storing results *)
   10.33 -  val add_thmss: string -> string -> (Attrib.binding * (thm list * Attrib.src list) list) list ->
   10.34 -    Proof.context -> Proof.context
   10.35 -  val add_type_syntax: string -> declaration -> Proof.context -> Proof.context
   10.36 -  val add_term_syntax: string -> declaration -> Proof.context -> Proof.context
   10.37 -  val add_declaration: string -> declaration -> Proof.context -> Proof.context
   10.38 -  val add_dependency: string -> (string * Morphism.morphism) -> theory -> theory
   10.39 -
   10.40 -  (* Activation *)
   10.41 -  val activate_declarations: theory -> string * Morphism.morphism ->
   10.42 -    Proof.context -> Proof.context
   10.43 -  val activate_global_facts: string * Morphism.morphism -> theory -> theory
   10.44 -  val activate_local_facts: string * Morphism.morphism -> Proof.context -> Proof.context
   10.45 -  val init: string -> theory -> Proof.context
   10.46 -
   10.47 -  (* Reasoning about locales *)
   10.48 -  val witness_attrib: attribute
   10.49 -  val intro_attrib: attribute
   10.50 -  val unfold_attrib: attribute
   10.51 -  val intro_locales_tac: bool -> Proof.context -> thm list -> tactic
   10.52 -
   10.53 -  (* Registrations *)
   10.54 -  val add_global_registration: (string * (Morphism.morphism * Morphism.morphism)) ->
   10.55 -    theory -> theory
   10.56 -  val amend_global_registration: Morphism.morphism -> (string * Morphism.morphism) ->
   10.57 -    theory -> theory
   10.58 -  val get_global_registrations: theory -> (string * Morphism.morphism) list
   10.59 -
   10.60 -  (* Diagnostic *)
   10.61 -  val print_locales: theory -> unit
   10.62 -  val print_locale: theory -> bool -> bstring -> unit
   10.63 -end;
   10.64 -
   10.65 -
   10.66 -(*** Theorem list extensible via attribute --- to control intro_locales_tac ***)
   10.67 -
   10.68 -(* FIXME: consider moving named_thms.ML up in the build hierarchy and using that *)
   10.69 -functor ThmsFun() =
   10.70 -struct
   10.71 -
   10.72 -structure Data = GenericDataFun
   10.73 -(
   10.74 -  type T = thm list;
   10.75 -  val empty = [];
   10.76 -  val extend = I;
   10.77 -  fun merge _ = Thm.merge_thms;
   10.78 -);
   10.79 -
   10.80 -val get = Data.get o Context.Proof;
   10.81 -val add = Thm.declaration_attribute (Data.map o Thm.add_thm);
   10.82 -
   10.83 -end;
   10.84 -
   10.85 -
   10.86 -structure NewLocale: NEW_LOCALE =
   10.87 -struct
   10.88 -
   10.89 -datatype ctxt = datatype Element.ctxt;
   10.90 -
   10.91 -
   10.92 -(*** Basics ***)
   10.93 -
   10.94 -datatype locale = Loc of {
   10.95 -  (* extensible lists are in reverse order: decls, notes, dependencies *)
   10.96 -  parameters: (string * sort) list * (Binding.T * typ option * mixfix) list,
   10.97 -    (* type and term parameters *)
   10.98 -  spec: term option * term list,
   10.99 -    (* assumptions (as a single predicate expression) and defines *)
  10.100 -  decls: (declaration * stamp) list * (declaration * stamp) list,
  10.101 -    (* type and term syntax declarations *)
  10.102 -  notes: ((string * (Attrib.binding * (thm list * Attrib.src list) list) list) * stamp) list,
  10.103 -    (* theorem declarations *)
  10.104 -  dependencies: ((string * Morphism.morphism) * stamp) list
  10.105 -    (* locale dependencies (sublocale relation) *)
  10.106 -}
  10.107 -
  10.108 -
  10.109 -(*** Theory data ***)
  10.110 -
  10.111 -structure LocalesData = TheoryDataFun
  10.112 -(
  10.113 -  type T = NameSpace.T * locale Symtab.table;
  10.114 -    (* locale namespace and locales of the theory *)
  10.115 -
  10.116 -  val empty = NameSpace.empty_table;
  10.117 -  val copy = I;
  10.118 -  val extend = I;
  10.119 -
  10.120 -  fun join_locales _
  10.121 -   (Loc {parameters, spec, decls = (decls1, decls2), notes, dependencies},
  10.122 -    Loc {decls = (decls1', decls2'), notes = notes', dependencies = dependencies', ...}) =
  10.123 -      Loc {
  10.124 -        parameters = parameters,
  10.125 -        spec = spec,
  10.126 -        decls =
  10.127 -         (merge (eq_snd op =) (decls1, decls1'),
  10.128 -          merge (eq_snd op =) (decls2, decls2')),
  10.129 -        notes = merge (eq_snd op =) (notes, notes'),
  10.130 -        dependencies = merge (eq_snd op =) (dependencies, dependencies')};
  10.131 -
  10.132 -  fun merge _ = NameSpace.join_tables join_locales;
  10.133 -);
  10.134 -
  10.135 -val intern = NameSpace.intern o #1 o LocalesData.get;
  10.136 -val extern = NameSpace.extern o #1 o LocalesData.get;
  10.137 -
  10.138 -fun get_locale thy name = Symtab.lookup (#2 (LocalesData.get thy)) name;
  10.139 -
  10.140 -fun the_locale thy name = case get_locale thy name
  10.141 - of SOME loc => loc
  10.142 -  | NONE => error ("Unknown locale " ^ quote name);
  10.143 -
  10.144 -fun test_locale thy name = case get_locale thy name
  10.145 - of SOME _ => true | NONE => false;
  10.146 -
  10.147 -fun register_locale bname parameters spec decls notes dependencies thy =
  10.148 -  thy |> LocalesData.map (NameSpace.bind (Sign.naming_of thy) (Binding.name bname,
  10.149 -    Loc {parameters = parameters, spec = spec, decls = decls, notes = notes,
  10.150 -      dependencies = dependencies}) #> snd);
  10.151 -
  10.152 -fun change_locale name f thy =
  10.153 -  let
  10.154 -    val Loc {parameters, spec, decls, notes, dependencies} =
  10.155 -        the_locale thy name;
  10.156 -    val (parameters', spec', decls', notes', dependencies') =
  10.157 -      f (parameters, spec, decls, notes, dependencies);
  10.158 -  in
  10.159 -    thy
  10.160 -    |> (LocalesData.map o apsnd) (Symtab.update (name, Loc {parameters = parameters',
  10.161 -      spec = spec', decls = decls', notes = notes', dependencies = dependencies'}))
  10.162 -  end;
  10.163 -
  10.164 -fun print_locales thy =
  10.165 -  let val (space, locs) = LocalesData.get thy in
  10.166 -    Pretty.strs ("locales:" :: map #1 (NameSpace.extern_table (space, locs)))
  10.167 -    |> Pretty.writeln
  10.168 -  end;
  10.169 -
  10.170 -
  10.171 -(*** Primitive operations ***)
  10.172 -
  10.173 -fun params_of thy name =
  10.174 -  let
  10.175 -    val Loc {parameters = (_, params), ...} = the_locale thy name
  10.176 -  in params end;
  10.177 -
  10.178 -fun instance_of thy name morph =
  10.179 -  params_of thy name |>
  10.180 -    map ((fn (b, T, _) => Free (Binding.base_name b, the T)) #> Morphism.term morph);
  10.181 -
  10.182 -fun specification_of thy name =
  10.183 -  let
  10.184 -    val Loc {spec, ...} = the_locale thy name
  10.185 -  in spec end;
  10.186 -
  10.187 -fun declarations_of thy name =
  10.188 -  let
  10.189 -    val Loc {decls, ...} = the_locale thy name
  10.190 -  in
  10.191 -    decls |> apfst (map fst) |> apsnd (map fst)
  10.192 -  end;
  10.193 -
  10.194 -
  10.195 -(*** Activate context elements of locale ***)
  10.196 -
  10.197 -(** Identifiers: activated locales in theory or proof context **)
  10.198 -
  10.199 -type identifiers = (string * term list) list;
  10.200 -
  10.201 -val empty = ([] : identifiers);
  10.202 -
  10.203 -fun ident_eq thy ((n: string, ts), (m, ss)) = (m = n) andalso Pattern.matchess thy (ss, ts);
  10.204 -
  10.205 -local
  10.206 -
  10.207 -datatype 'a delayed = Ready of 'a | ToDo of ('a delayed * 'a delayed);
  10.208 -
  10.209 -structure IdentifiersData = GenericDataFun
  10.210 -(
  10.211 -  type T = identifiers delayed;
  10.212 -  val empty = Ready empty;
  10.213 -  val extend = I;
  10.214 -  fun merge _ = ToDo;
  10.215 -);
  10.216 -
  10.217 -in
  10.218 -
  10.219 -fun finish thy (ToDo (i1, i2)) = merge (ident_eq thy) (finish thy i1, finish thy i2)
  10.220 -  | finish _ (Ready ids) = ids;
  10.221 -
  10.222 -val _ = Context.>> (Context.map_theory (Theory.at_begin (fn thy =>
  10.223 -  (case IdentifiersData.get (Context.Theory thy) of
  10.224 -    Ready _ => NONE |
  10.225 -    ids => SOME (Context.theory_map (IdentifiersData.put (Ready (finish thy ids))) thy))
  10.226 -  )));
  10.227 -
  10.228 -fun get_global_idents thy =
  10.229 -  let val (Ready ids) = (IdentifiersData.get o Context.Theory) thy in ids end;
  10.230 -val put_global_idents = Context.theory_map o IdentifiersData.put o Ready;
  10.231 -
  10.232 -fun get_local_idents ctxt =
  10.233 -  let val (Ready ids) = (IdentifiersData.get o Context.Proof) ctxt in ids end;
  10.234 -val put_local_idents = Context.proof_map o IdentifiersData.put o Ready;
  10.235 -
  10.236 -end;
  10.237 -
  10.238 -
  10.239 -(** Resolve locale dependencies in a depth-first fashion **)
  10.240 -
  10.241 -local
  10.242 -
  10.243 -val roundup_bound = 120;
  10.244 -
  10.245 -fun add thy depth (name, morph) (deps, marked) =
  10.246 -  if depth > roundup_bound
  10.247 -  then error "Roundup bound exceeded (sublocale relation probably not terminating)."
  10.248 -  else
  10.249 -    let
  10.250 -      val Loc {parameters = (_, params), dependencies, ...} = the_locale thy name;
  10.251 -      val instance = instance_of thy name morph;
  10.252 -    in
  10.253 -      if member (ident_eq thy) marked (name, instance)
  10.254 -      then (deps, marked)
  10.255 -      else
  10.256 -        let
  10.257 -          val dependencies' =
  10.258 -            map (fn ((name, morph'), _) => (name, morph' $>  morph)) dependencies;
  10.259 -          val marked' = (name, instance) :: marked;
  10.260 -          val (deps', marked'') = fold_rev (add thy (depth + 1)) dependencies' ([], marked');
  10.261 -        in
  10.262 -          ((name, morph) :: deps' @ deps, marked'')
  10.263 -        end
  10.264 -    end;
  10.265 -
  10.266 -in
  10.267 -
  10.268 -fun roundup thy activate_dep (name, morph) (marked, input) =
  10.269 -  let
  10.270 -    (* Find all dependencies incuding new ones (which are dependencies enriching
  10.271 -      existing registrations). *)
  10.272 -    val (dependencies, marked') = add thy 0 (name, morph) ([], empty);
  10.273 -    (* Filter out exisiting fragments. *)
  10.274 -    val dependencies' = filter_out (fn (name, morph) =>
  10.275 -      member (ident_eq thy) marked (name, instance_of thy name morph)) dependencies;
  10.276 -  in
  10.277 -    (merge (ident_eq thy) (marked, marked'), input |> fold_rev (activate_dep thy) dependencies')
  10.278 -  end;
  10.279 -
  10.280 -end;
  10.281 -
  10.282 -
  10.283 -(* Declarations, facts and entire locale content *)
  10.284 -
  10.285 -fun activate_decls thy (name, morph) ctxt =
  10.286 -  let
  10.287 -    val Loc {decls = (typ_decls, term_decls), ...} = the_locale thy name;
  10.288 -  in
  10.289 -    ctxt |> fold_rev (fn (decl, _) => Context.proof_map (decl morph)) typ_decls |>
  10.290 -      fold_rev (fn (decl, _) => Context.proof_map (decl morph)) term_decls
  10.291 -  end;
  10.292 -
  10.293 -fun activate_notes activ_elem transfer thy (name, morph) input =
  10.294 -  let
  10.295 -    val Loc {notes, ...} = the_locale thy name;
  10.296 -    fun activate ((kind, facts), _) input =
  10.297 -      let
  10.298 -        val facts' = facts |> Element.facts_map (Element.morph_ctxt (transfer input $> morph))
  10.299 -      in activ_elem (Notes (kind, facts')) input end;
  10.300 -  in
  10.301 -    fold_rev activate notes input
  10.302 -  end;
  10.303 -
  10.304 -fun activate_all name thy activ_elem transfer (marked, input) =
  10.305 -  let
  10.306 -    val Loc {parameters = (_, params), spec = (asm, defs), ...} =
  10.307 -      the_locale thy name;
  10.308 -  in
  10.309 -    input |>
  10.310 -      (if not (null params) then activ_elem (Fixes params) else I) |>
  10.311 -      (* FIXME type parameters *)
  10.312 -      (if is_some asm then activ_elem (Assumes [(Attrib.empty_binding, [(the asm, [])])]) else I) |>
  10.313 -      (if not (null defs)
  10.314 -        then activ_elem (Defines (map (fn def => (Attrib.empty_binding, (def, []))) defs))
  10.315 -        else I) |>
  10.316 -      pair marked |> roundup thy (activate_notes activ_elem transfer) (name, Morphism.identity)
  10.317 -  end;
  10.318 -
  10.319 -
  10.320 -(** Public activation functions **)
  10.321 -
  10.322 -local
  10.323 -
  10.324 -fun init_global_elem (Notes (kind, facts)) thy =
  10.325 -      let
  10.326 -        val facts' = Attrib.map_facts (Attrib.attribute_i thy) facts
  10.327 -      in Locale.global_note_qualified kind facts' thy |> snd end
  10.328 -
  10.329 -fun init_local_elem (Fixes fixes) ctxt = ctxt |>
  10.330 -      ProofContext.add_fixes_i fixes |> snd
  10.331 -  | init_local_elem (Assumes assms) ctxt =
  10.332 -      let
  10.333 -        val assms' = Attrib.map_specs (Attrib.attribute_i (ProofContext.theory_of ctxt)) assms
  10.334 -      in
  10.335 -        ctxt |> fold Variable.auto_fixes (maps (map fst o snd) assms') |>
  10.336 -          ProofContext.add_assms_i Assumption.assume_export assms' |> snd
  10.337 -     end
  10.338 -  | init_local_elem (Defines defs) ctxt =
  10.339 -      let
  10.340 -        val defs' = Attrib.map_specs (Attrib.attribute_i (ProofContext.theory_of ctxt)) defs
  10.341 -      in
  10.342 -        ctxt |> fold Variable.auto_fixes (map (fst o snd) defs') |>
  10.343 -          ProofContext.add_assms_i LocalDefs.def_export (map (fn (attn, t) => (attn, [t])) defs') |>
  10.344 -          snd
  10.345 -      end
  10.346 -  | init_local_elem (Notes (kind, facts)) ctxt =
  10.347 -      let
  10.348 -        val facts' = Attrib.map_facts (Attrib.attribute_i (ProofContext.theory_of ctxt)) facts
  10.349 -      in Locale.local_note_qualified kind facts' ctxt |> snd end
  10.350 -
  10.351 -fun cons_elem false (Notes notes) elems = elems
  10.352 -  | cons_elem _ elem elems = elem :: elems
  10.353 -
  10.354 -in
  10.355 -
  10.356 -fun activate_declarations thy dep ctxt =
  10.357 -  roundup thy activate_decls dep (get_local_idents ctxt, ctxt) |> uncurry put_local_idents;
  10.358 -
  10.359 -fun activate_global_facts dep thy =
  10.360 -  roundup thy (activate_notes init_global_elem Element.transfer_morphism)
  10.361 -    dep (get_global_idents thy, thy) |>
  10.362 -  uncurry put_global_idents;
  10.363 -
  10.364 -fun activate_local_facts dep ctxt =
  10.365 -  roundup (ProofContext.theory_of ctxt)
  10.366 -  (activate_notes init_local_elem (Element.transfer_morphism o ProofContext.theory_of)) dep
  10.367 -    (get_local_idents ctxt, ctxt) |>
  10.368 -  uncurry put_local_idents;
  10.369 -
  10.370 -fun init name thy =
  10.371 -  activate_all name thy init_local_elem (Element.transfer_morphism o ProofContext.theory_of)
  10.372 -    (empty, ProofContext.init thy) |>
  10.373 -  uncurry put_local_idents;
  10.374 -
  10.375 -fun print_locale thy show_facts name =
  10.376 -  let
  10.377 -    val name' = intern thy name;
  10.378 -    val ctxt = init name' thy
  10.379 -  in
  10.380 -    Pretty.big_list "locale elements:"
  10.381 -      (activate_all name' thy (cons_elem show_facts) (K (Element.transfer_morphism thy))
  10.382 -        (empty, []) |> snd |> rev |>
  10.383 -        map (Element.pretty_ctxt ctxt) |> map Pretty.chunks) |> Pretty.writeln
  10.384 -  end
  10.385 -
  10.386 -end;
  10.387 -
  10.388 -
  10.389 -(*** Registrations: interpretations in theories ***)
  10.390 -
  10.391 -(* FIXME only global variant needed *)
  10.392 -structure RegistrationsData = GenericDataFun
  10.393 -(
  10.394 -  type T = ((string * (Morphism.morphism * Morphism.morphism)) * stamp) list;
  10.395 -(* FIXME mixins need to be stamped *)
  10.396 -    (* registrations, in reverse order of declaration *)
  10.397 -  val empty = [];
  10.398 -  val extend = I;
  10.399 -  fun merge _ data : T = Library.merge (eq_snd op =) data;
  10.400 -    (* FIXME consolidate with dependencies, consider one data slot only *)
  10.401 -);
  10.402 -
  10.403 -val get_global_registrations =
  10.404 -  Context.Theory #> RegistrationsData.get #> map fst #> map (apsnd op $>);
  10.405 -
  10.406 -fun add_global reg =
  10.407 -  (Context.theory_map o RegistrationsData.map) (cons (reg, stamp ()));
  10.408 -
  10.409 -fun add_global_registration (name, (base_morph, export)) thy =
  10.410 -  roundup thy (fn _ => fn (name', morph') => fn thy => add_global (name', (morph', export)) thy)
  10.411 -    (name, base_morph) (get_global_idents thy, thy) |>
  10.412 -    snd (* FIXME ?? uncurry put_global_idents *);
  10.413 -
  10.414 -fun amend_global_registration morph (name, base_morph) thy =
  10.415 -  let
  10.416 -    val regs = (Context.Theory #> RegistrationsData.get #> map fst) thy;
  10.417 -    val base = instance_of thy name base_morph;
  10.418 -    fun match (name', (morph', _)) =
  10.419 -      name = name' andalso eq_list (op aconv) (base, instance_of thy name' morph');
  10.420 -    val i = find_index match (rev regs);
  10.421 -    val _ = if i = ~1 then error ("No interpretation of locale " ^
  10.422 -        quote (extern thy name) ^ " and parameter instantiation " ^
  10.423 -        space_implode " " (map (quote o Syntax.string_of_term_global thy) base) ^ " available.")
  10.424 -      else ();
  10.425 -  in
  10.426 -    (Context.theory_map o RegistrationsData.map) (nth_map (length regs - 1 - i)
  10.427 -      (fn ((name, (base, export)), stamp) => ((name, (base $> morph, export)), stamp))) thy
  10.428 -  end;
  10.429 -
  10.430 -
  10.431 -(*** Storing results ***)
  10.432 -
  10.433 -(* Theorems *)
  10.434 -
  10.435 -fun add_thmss loc kind args ctxt =
  10.436 -  let
  10.437 -    val ([Notes args'], ctxt') = Element.activate_i [Notes (kind, args)] ctxt;
  10.438 -    val ctxt'' = ctxt' |> ProofContext.theory (
  10.439 -      change_locale loc
  10.440 -        (fn (parameters, spec, decls, notes, dependencies) =>
  10.441 -          (parameters, spec, decls, (args', stamp ()) :: notes, dependencies)) #>
  10.442 -      (* Registrations *)
  10.443 -      (fn thy => fold_rev (fn (name, morph) =>
  10.444 -            let
  10.445 -              val args'' = snd args' |> Element.facts_map (Element.morph_ctxt morph) |>
  10.446 -                Attrib.map_facts (Attrib.attribute_i thy)
  10.447 -            in Locale.global_note_qualified kind args'' #> snd end)
  10.448 -        (get_global_registrations thy |> filter (fn (name, _) => name = loc)) thy))
  10.449 -  in ctxt'' end;
  10.450 -
  10.451 -
  10.452 -(* Declarations *)
  10.453 -
  10.454 -local
  10.455 -
  10.456 -fun decl_attrib decl phi = Thm.declaration_attribute (K (decl phi));
  10.457 -
  10.458 -fun add_decls add loc decl =
  10.459 -  ProofContext.theory (change_locale loc
  10.460 -    (fn (parameters, spec, decls, notes, dependencies) =>
  10.461 -      (parameters, spec, add (decl, stamp ()) decls, notes, dependencies))) #>
  10.462 -  add_thmss loc Thm.internalK
  10.463 -    [((Binding.empty, [Attrib.internal (decl_attrib decl)]), [([Drule.dummy_thm], [])])];
  10.464 -
  10.465 -in
  10.466 -
  10.467 -val add_type_syntax = add_decls (apfst o cons);
  10.468 -val add_term_syntax = add_decls (apsnd o cons);
  10.469 -val add_declaration = add_decls (K I);
  10.470 -
  10.471 -end;
  10.472 -
  10.473 -(* Dependencies *)
  10.474 -
  10.475 -fun add_dependency loc dep =
  10.476 -  change_locale loc
  10.477 -    (fn (parameters, spec, decls, notes, dependencies) =>
  10.478 -      (parameters, spec, decls, notes, (dep, stamp ()) :: dependencies));
  10.479 -
  10.480 -
  10.481 -(*** Reasoning about locales ***)
  10.482 -
  10.483 -(** Storage for witnesses, intro and unfold rules **)
  10.484 -
  10.485 -structure Witnesses = ThmsFun();
  10.486 -structure Intros = ThmsFun();
  10.487 -structure Unfolds = ThmsFun();
  10.488 -
  10.489 -val witness_attrib = Witnesses.add;
  10.490 -val intro_attrib = Intros.add;
  10.491 -val unfold_attrib = Unfolds.add;
  10.492 -
  10.493 -(** Tactic **)
  10.494 -
  10.495 -fun intro_locales_tac eager ctxt facts st =
  10.496 -  Method.intros_tac
  10.497 -    (Witnesses.get ctxt @ Intros.get ctxt @ (if eager then Unfolds.get ctxt else [])) facts st;
  10.498 -
  10.499 -val _ = Context.>> (Context.map_theory
  10.500 -  (Method.add_methods
  10.501 -    [("intro_locales",
  10.502 -      Method.ctxt_args (fn ctxt => Method.METHOD (intro_locales_tac false ctxt ORELSE'
  10.503 -        Locale.intro_locales_tac false ctxt)),
  10.504 -      "back-chain introduction rules of locales without unfolding predicates"),
  10.505 -     ("unfold_locales",
  10.506 -      Method.ctxt_args (fn ctxt => Method.METHOD (intro_locales_tac true ctxt ORELSE'
  10.507 -        Locale.intro_locales_tac true ctxt)),
  10.508 -      "back-chain all introduction rules of locales")]));
  10.509 -
  10.510 -end;
  10.511 -
    11.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    11.2 +++ b/src/Pure/Isar/old_locale.ML	Mon Jan 05 15:55:04 2009 +0100
    11.3 @@ -0,0 +1,2485 @@
    11.4 +(*  Title:      Pure/Isar/locale.ML
    11.5 +    Author:     Clemens Ballarin, TU Muenchen
    11.6 +    Author:     Markus Wenzel, LMU/TU Muenchen
    11.7 +
    11.8 +Locales -- Isar proof contexts as meta-level predicates, with local
    11.9 +syntax and implicit structures.
   11.10 +
   11.11 +Draws basic ideas from Florian Kammueller's original version of
   11.12 +locales, but uses the richer infrastructure of Isar instead of the raw
   11.13 +meta-logic.  Furthermore, structured import of contexts (with merge
   11.14 +and rename operations) are provided, as well as type-inference of the
   11.15 +signature parts, and predicate definitions of the specification text.
   11.16 +
   11.17 +Interpretation enables the reuse of theorems of locales in other
   11.18 +contexts, namely those defined by theories, structured proofs and
   11.19 +locales themselves.
   11.20 +
   11.21 +See also:
   11.22 +
   11.23 +[1] Clemens Ballarin. Locales and Locale Expressions in Isabelle/Isar.
   11.24 +    In Stefano Berardi et al., Types for Proofs and Programs: International
   11.25 +    Workshop, TYPES 2003, Torino, Italy, LNCS 3085, pages 34-50, 2004.
   11.26 +[2] Clemens Ballarin. Interpretation of Locales in Isabelle: Managing
   11.27 +    Dependencies between Locales. Technical Report TUM-I0607, Technische
   11.28 +    Universitaet Muenchen, 2006.
   11.29 +[3] Clemens Ballarin. Interpretation of Locales in Isabelle: Theories and
   11.30 +    Proof Contexts. In J.M. Borwein and W.M. Farmer, MKM 2006, LNAI 4108,
   11.31 +    pages 31-43, 2006.
   11.32 +*)
   11.33 +
   11.34 +(* TODO:
   11.35 +- beta-eta normalisation of interpretation parameters
   11.36 +- dangling type frees in locales
   11.37 +- test subsumption of interpretations when merging theories
   11.38 +*)
   11.39 +
   11.40 +signature OLD_LOCALE =
   11.41 +sig
   11.42 +  datatype expr =
   11.43 +    Locale of string |
   11.44 +    Rename of expr * (string * mixfix option) option list |
   11.45 +    Merge of expr list
   11.46 +  val empty: expr
   11.47 +
   11.48 +  val intern: theory -> xstring -> string
   11.49 +  val intern_expr: theory -> expr -> expr
   11.50 +  val extern: theory -> string -> xstring
   11.51 +  val init: string -> theory -> Proof.context
   11.52 +
   11.53 +  (* The specification of a locale *)
   11.54 +  val parameters_of: theory -> string -> ((string * typ) * mixfix) list
   11.55 +  val parameters_of_expr: theory -> expr -> ((string * typ) * mixfix) list
   11.56 +  val local_asms_of: theory -> string -> (Attrib.binding * term list) list
   11.57 +  val global_asms_of: theory -> string -> (Attrib.binding * term list) list
   11.58 +
   11.59 +  (* Theorems *)
   11.60 +  val intros: theory -> string -> thm list * thm list
   11.61 +  val dests: theory -> string -> thm list
   11.62 +  (* Not part of the official interface.  DO NOT USE *)
   11.63 +  val facts_of: theory -> string -> (Attrib.binding * (thm list * Attrib.src list) list) list list
   11.64 +
   11.65 +  (* Not part of the official interface.  DO NOT USE *)
   11.66 +  val declarations_of: theory -> string -> declaration list * declaration list;
   11.67 +
   11.68 +  (* Processing of locale statements *)
   11.69 +  val read_context_statement: string option -> Element.context list ->
   11.70 +    (string * string list) list list -> Proof.context ->
   11.71 +    string option * Proof.context * Proof.context * (term * term list) list list
   11.72 +  val read_context_statement_cmd: xstring option -> Element.context list ->
   11.73 +    (string * string list) list list -> Proof.context ->
   11.74 +    string option * Proof.context * Proof.context * (term * term list) list list
   11.75 +  val cert_context_statement: string option -> Element.context_i list ->
   11.76 +    (term * term list) list list -> Proof.context ->
   11.77 +    string option * Proof.context * Proof.context * (term * term list) list list
   11.78 +  val read_expr: expr -> Element.context list -> Proof.context ->
   11.79 +    Element.context_i list * Proof.context
   11.80 +  val cert_expr: expr -> Element.context_i list -> Proof.context ->
   11.81 +    Element.context_i list * Proof.context
   11.82 +
   11.83 +  (* Diagnostic functions *)
   11.84 +  val print_locales: theory -> unit
   11.85 +  val print_locale: theory -> bool -> expr -> Element.context list -> unit
   11.86 +  val print_registrations: bool -> string -> Proof.context -> unit
   11.87 +
   11.88 +  val add_locale: string -> bstring -> expr -> Element.context_i list -> theory
   11.89 +    -> string * Proof.context
   11.90 +  val add_locale_cmd: bstring -> expr -> Element.context list -> theory
   11.91 +    -> string * Proof.context
   11.92 +
   11.93 +  (* Tactics *)
   11.94 +  val intro_locales_tac: bool -> Proof.context -> thm list -> tactic
   11.95 +
   11.96 +  (* Storing results *)
   11.97 +  val global_note_qualified: string ->
   11.98 +    ((Binding.T * attribute list) * (thm list * attribute list) list) list ->
   11.99 +    theory -> (string * thm list) list * theory
  11.100 +  val local_note_qualified: string ->
  11.101 +    ((Binding.T * attribute list) * (thm list * attribute list) list) list ->
  11.102 +    Proof.context -> (string * thm list) list * Proof.context
  11.103 +  val add_thmss: string -> string -> (Attrib.binding * (thm list * Attrib.src list) list) list ->
  11.104 +    Proof.context -> Proof.context
  11.105 +  val add_type_syntax: string -> declaration -> Proof.context -> Proof.context
  11.106 +  val add_term_syntax: string -> declaration -> Proof.context -> Proof.context
  11.107 +  val add_declaration: string -> declaration -> Proof.context -> Proof.context
  11.108 +
  11.109 +  (* Interpretation *)
  11.110 +  val get_interpret_morph: theory -> (Binding.T -> Binding.T) -> string * string ->
  11.111 +    (Morphism.morphism * ((typ Vartab.table * typ list) * (term Vartab.table * term list))) ->
  11.112 +    string -> term list -> Morphism.morphism
  11.113 +  val interpretation: (Proof.context -> Proof.context) ->
  11.114 +    (Binding.T -> Binding.T) -> expr ->
  11.115 +    term option list * (Attrib.binding * term) list ->
  11.116 +    theory ->
  11.117 +    (Morphism.morphism * ((typ Vartab.table * typ list) * (term Vartab.table * term list))) * Proof.state
  11.118 +  val interpretation_cmd: string -> expr -> string option list * (Attrib.binding * string) list ->
  11.119 +    theory -> Proof.state
  11.120 +  val interpretation_in_locale: (Proof.context -> Proof.context) ->
  11.121 +    xstring * expr -> theory -> Proof.state
  11.122 +  val interpret: (Proof.state -> Proof.state Seq.seq) ->
  11.123 +    (Binding.T -> Binding.T) -> expr ->
  11.124 +    term option list * (Attrib.binding * term) list ->
  11.125 +    bool -> Proof.state ->
  11.126 +    (Morphism.morphism * ((typ Vartab.table * typ list) * (term Vartab.table * term list))) * Proof.state
  11.127 +  val interpret_cmd: string -> expr -> string option list * (Attrib.binding * string) list ->
  11.128 +    bool -> Proof.state -> Proof.state
  11.129 +end;
  11.130 +
  11.131 +structure Old_Locale: OLD_LOCALE =
  11.132 +struct
  11.133 +
  11.134 +(* legacy operations *)
  11.135 +
  11.136 +fun merge_lists _ xs [] = xs
  11.137 +  | merge_lists _ [] ys = ys
  11.138 +  | merge_lists eq xs ys = xs @ filter_out (member eq xs) ys;
  11.139 +
  11.140 +fun merge_alists eq xs = merge_lists (eq_fst eq) xs;
  11.141 +
  11.142 +
  11.143 +(* auxiliary: noting name bindings with qualified base names *)
  11.144 +
  11.145 +fun global_note_qualified kind facts thy =
  11.146 +  thy
  11.147 +  |> Sign.qualified_names
  11.148 +  |> PureThy.note_thmss kind facts
  11.149 +  ||> Sign.restore_naming thy;
  11.150 +
  11.151 +fun local_note_qualified kind facts ctxt =
  11.152 +  ctxt
  11.153 +  |> ProofContext.qualified_names
  11.154 +  |> ProofContext.note_thmss_i kind facts
  11.155 +  ||> ProofContext.restore_naming ctxt;
  11.156 +
  11.157 +
  11.158 +(** locale elements and expressions **)
  11.159 +
  11.160 +datatype ctxt = datatype Element.ctxt;
  11.161 +
  11.162 +datatype expr =
  11.163 +  Locale of string |
  11.164 +  Rename of expr * (string * mixfix option) option list |
  11.165 +  Merge of expr list;
  11.166 +
  11.167 +val empty = Merge [];
  11.168 +
  11.169 +datatype 'a element =
  11.170 +  Elem of 'a | Expr of expr;
  11.171 +
  11.172 +fun map_elem f (Elem e) = Elem (f e)
  11.173 +  | map_elem _ (Expr e) = Expr e;
  11.174 +
  11.175 +type decl = declaration * stamp;
  11.176 +
  11.177 +type locale =
  11.178 + {axiom: Element.witness list,
  11.179 +    (* For locales that define predicates this is [A [A]], where A is the locale
  11.180 +       specification.  Otherwise [].
  11.181 +       Only required to generate the right witnesses for locales with predicates. *)
  11.182 +  elems: (Element.context_i * stamp) list,
  11.183 +    (* Static content, neither Fixes nor Constrains elements *)
  11.184 +  params: ((string * typ) * mixfix) list,                        (*all term params*)
  11.185 +  decls: decl list * decl list,                    (*type/term_syntax declarations*)
  11.186 +  regs: ((string * string list) * Element.witness list) list,
  11.187 +    (* Registrations: indentifiers and witnesses of locales interpreted in the locale. *)
  11.188 +  intros: thm list * thm list,
  11.189 +    (* Introduction rules: of delta predicate and locale predicate. *)
  11.190 +  dests: thm list}
  11.191 +    (* Destruction rules: projections from locale predicate to predicates of fragments. *)
  11.192 +
  11.193 +(* CB: an internal (Int) locale element was either imported or included,
  11.194 +   an external (Ext) element appears directly in the locale text. *)
  11.195 +
  11.196 +datatype ('a, 'b) int_ext = Int of 'a | Ext of 'b;
  11.197 +
  11.198 +
  11.199 +
  11.200 +(** substitutions on Vars -- clone from element.ML **)
  11.201 +
  11.202 +(* instantiate types *)
  11.203 +
  11.204 +fun var_instT_type env =
  11.205 +  if Vartab.is_empty env then I
  11.206 +  else Term.map_type_tvar (fn (x, S) => the_default (TVar (x, S)) (Vartab.lookup env x));
  11.207 +
  11.208 +fun var_instT_term env =
  11.209 +  if Vartab.is_empty env then I
  11.210 +  else Term.map_types (var_instT_type env);
  11.211 +
  11.212 +fun var_inst_term (envT, env) =
  11.213 +  if Vartab.is_empty env then var_instT_term envT
  11.214 +  else
  11.215 +    let
  11.216 +      val instT = var_instT_type envT;
  11.217 +      fun inst (Const (x, T)) = Const (x, instT T)
  11.218 +        | inst (Free (x, T)) = Free(x, instT T)
  11.219 +        | inst (Var (xi, T)) =
  11.220 +            (case Vartab.lookup env xi of
  11.221 +              NONE => Var (xi, instT T)
  11.222 +            | SOME t => t)
  11.223 +        | inst (b as Bound _) = b
  11.224 +        | inst (Abs (x, T, t)) = Abs (x, instT T, inst t)
  11.225 +        | inst (t $ u) = inst t $ inst u;
  11.226 +    in Envir.beta_norm o inst end;
  11.227 +
  11.228 +
  11.229 +(** management of registrations in theories and proof contexts **)
  11.230 +
  11.231 +type registration =
  11.232 +  {prfx: (Binding.T -> Binding.T) * (string * string),
  11.233 +      (* first component: interpretation name morphism;
  11.234 +         second component: parameter prefix *)
  11.235 +    exp: Morphism.morphism,
  11.236 +      (* maps content to its originating context *)
  11.237 +    imp: (typ Vartab.table * typ list) * (term Vartab.table * term list),
  11.238 +      (* inverse of exp *)
  11.239 +    wits: Element.witness list,
  11.240 +      (* witnesses of the registration *)
  11.241 +    eqns: thm Termtab.table,
  11.242 +      (* theorems (equations) interpreting derived concepts and indexed by lhs *)
  11.243 +    morph: unit
  11.244 +      (* interpreting morphism *)
  11.245 +  }
  11.246 +
  11.247 +structure Registrations :
  11.248 +  sig
  11.249 +    type T
  11.250 +    val empty: T
  11.251 +    val join: T * T -> T
  11.252 +    val dest: theory -> T ->
  11.253 +      (term list *
  11.254 +        (((Binding.T -> Binding.T) * (string * string)) *
  11.255 +         (Morphism.morphism * ((typ Vartab.table * typ list) * (term Vartab.table * term list))) *
  11.256 +         Element.witness list *
  11.257 +         thm Termtab.table)) list
  11.258 +    val test: theory -> T * term list -> bool
  11.259 +    val lookup: theory ->
  11.260 +      T * (term list * ((typ Vartab.table * typ list) * (term Vartab.table * term list))) ->
  11.261 +      (((Binding.T -> Binding.T) * (string * string)) * Element.witness list * thm Termtab.table) option
  11.262 +    val insert: theory -> term list -> ((Binding.T -> Binding.T) * (string * string)) ->
  11.263 +      (Morphism.morphism * ((typ Vartab.table * typ list) * (term Vartab.table * term list))) ->
  11.264 +      T ->
  11.265 +      T * (term list * (((Binding.T -> Binding.T) * (string * string)) * Element.witness list)) list
  11.266 +    val add_witness: term list -> Element.witness -> T -> T
  11.267 +    val add_equation: term list -> thm -> T -> T
  11.268 +(*
  11.269 +    val update_morph: term list -> Morphism.morphism -> T -> T
  11.270 +    val get_morph: theory -> T ->
  11.271 +      term list * ((typ Vartab.table * typ list) * (term Vartab.table * term list)) ->
  11.272 +      Morphism.morphism
  11.273 +*)
  11.274 +  end =
  11.275 +struct
  11.276 +  (* A registration is indexed by parameter instantiation.
  11.277 +     NB: index is exported whereas content is internalised. *)
  11.278 +  type T = registration Termtab.table;
  11.279 +
  11.280 +  fun mk_reg prfx exp imp wits eqns morph =
  11.281 +    {prfx = prfx, exp = exp, imp = imp, wits = wits, eqns = eqns, morph = morph};
  11.282 +
  11.283 +  fun map_reg f reg =
  11.284 +    let
  11.285 +      val {prfx, exp, imp, wits, eqns, morph} = reg;
  11.286 +      val (prfx', exp', imp', wits', eqns', morph') = f (prfx, exp, imp, wits, eqns, morph);
  11.287 +    in mk_reg prfx' exp' imp' wits' eqns' morph' end;
  11.288 +
  11.289 +  val empty = Termtab.empty;
  11.290 +
  11.291 +  (* term list represented as single term, for simultaneous matching *)
  11.292 +  fun termify ts =
  11.293 +    Term.list_comb (Const ("", map fastype_of ts ---> propT), ts);
  11.294 +  fun untermify t =
  11.295 +    let fun ut (Const _) ts = ts
  11.296 +          | ut (s $ t) ts = ut s (t::ts)
  11.297 +    in ut t [] end;
  11.298 +
  11.299 +  (* joining of registrations:
  11.300 +     - prefix and morphisms of right theory;
  11.301 +     - witnesses are equal, no attempt to subsumption testing;
  11.302 +     - union of equalities, if conflicting (i.e. two eqns with equal lhs)
  11.303 +       eqn of right theory takes precedence *)
  11.304 +  fun join (r1, r2) = Termtab.join (fn _ => fn ({eqns = e1, ...}, {prfx = n, exp, imp, wits = w, eqns = e2, morph = m}) =>
  11.305 +      mk_reg n exp imp w (Termtab.join (fn _ => fn (_, e) => e) (e1, e2)) m) (r1, r2);
  11.306 +
  11.307 +  fun dest_transfer thy regs =
  11.308 +    Termtab.dest regs |> map (apsnd (map_reg (fn (n, e, i, ws, es, m) =>
  11.309 +      (n, e, i, map (Element.transfer_witness thy) ws, Termtab.map (transfer thy) es, m))));
  11.310 +
  11.311 +  fun dest thy regs = dest_transfer thy regs |> map (apfst untermify) |>
  11.312 +    map (apsnd (fn {prfx, exp, imp, wits, eqns, ...} => (prfx, (exp, imp), wits, eqns)));
  11.313 +
  11.314 +  (* registrations that subsume t *)
  11.315 +  fun subsumers thy t regs =
  11.316 +    filter (fn (t', _) => Pattern.matches thy (t', t)) (dest_transfer thy regs);
  11.317 +
  11.318 +  (* test if registration that subsumes the query is present *)
  11.319 +  fun test thy (regs, ts) =
  11.320 +    not (null (subsumers thy (termify ts) regs));
  11.321 +      
  11.322 +  (* look up registration, pick one that subsumes the query *)
  11.323 +  fun lookup thy (regs, (ts, ((impT, _), (imp, _)))) =
  11.324 +    let
  11.325 +      val t = termify ts;
  11.326 +      val subs = subsumers thy t regs;
  11.327 +    in
  11.328 +      (case subs of
  11.329 +        [] => NONE
  11.330 +        | ((t', {prfx, exp = exp', imp = ((impT', domT'), (imp', dom')), wits, eqns, morph}) :: _) =>
  11.331 +          let
  11.332 +            val (tinst, inst) = Pattern.match thy (t', t) (Vartab.empty, Vartab.empty);
  11.333 +            val tinst' = domT' |> map (fn (T as TFree (x, _)) =>
  11.334 +                (x, T |> Morphism.typ exp' |> Envir.typ_subst_TVars tinst
  11.335 +                      |> var_instT_type impT)) |> Symtab.make;
  11.336 +            val inst' = dom' |> map (fn (t as Free (x, _)) =>
  11.337 +                (x, t |> Morphism.term exp' |> Envir.subst_vars (tinst, inst)
  11.338 +                      |> var_inst_term (impT, imp))) |> Symtab.make;
  11.339 +            val inst'_morph = Element.inst_morphism thy (tinst', inst');
  11.340 +          in SOME (prfx,
  11.341 +            map (Element.morph_witness inst'_morph) wits,
  11.342 +            Termtab.map (Morphism.thm inst'_morph) eqns)
  11.343 +          end)
  11.344 +    end;
  11.345 +
  11.346 +  (* add registration if not subsumed by ones already present,
  11.347 +     additionally returns registrations that are strictly subsumed *)
  11.348 +  fun insert thy ts prfx (exp, imp) regs =
  11.349 +    let
  11.350 +      val t = termify ts;
  11.351 +      val subs = subsumers thy t regs ;
  11.352 +    in (case subs of
  11.353 +        [] => let
  11.354 +                val sups =
  11.355 +                  filter (fn (t', _) => Pattern.matches thy (t, t')) (dest_transfer thy regs);
  11.356 +                val sups' = map (apfst untermify) sups |> map (fn (ts, {prfx, wits, ...}) => (ts, (prfx, wits)))
  11.357 +              in (Termtab.update (t, mk_reg prfx exp imp [] Termtab.empty ()) regs, sups') end
  11.358 +      | _ => (regs, []))
  11.359 +    end;
  11.360 +
  11.361 +  fun gen_add f ts regs =
  11.362 +    let
  11.363 +      val t = termify ts;
  11.364 +    in
  11.365 +      Termtab.update (t, map_reg f (the (Termtab.lookup regs t))) regs
  11.366 +    end;
  11.367 +
  11.368 +  (* add witness theorem to registration,
  11.369 +     only if instantiation is exact, otherwise exception Option raised *)
  11.370 +  fun add_witness ts wit regs =
  11.371 +    gen_add (fn (x, e, i, wits, eqns, m) => (x, e, i, Element.close_witness wit :: wits, eqns, m))
  11.372 +      ts regs;
  11.373 +
  11.374 +  (* add equation to registration, replaces previous equation with same lhs;
  11.375 +     only if instantiation is exact, otherwise exception Option raised;
  11.376 +     exception TERM raised if not a meta equality *)
  11.377 +  fun add_equation ts thm regs =
  11.378 +    gen_add (fn (x, e, i, thms, eqns, m) =>
  11.379 +      (x, e, i, thms, Termtab.update (thm |> prop_of |> Logic.dest_equals |> fst, Thm.close_derivation thm) eqns, m))
  11.380 +      ts regs;
  11.381 +
  11.382 +end;
  11.383 +
  11.384 +
  11.385 +(** theory data : locales **)
  11.386 +
  11.387 +structure LocalesData = TheoryDataFun
  11.388 +(
  11.389 +  type T = NameSpace.T * locale Symtab.table;
  11.390 +    (* 1st entry: locale namespace,
  11.391 +       2nd entry: locales of the theory *)
  11.392 +
  11.393 +  val empty = NameSpace.empty_table;
  11.394 +  val copy = I;
  11.395 +  val extend = I;
  11.396 +
  11.397 +  fun join_locales _
  11.398 +    ({axiom, elems, params, decls = (decls1, decls2), regs, intros, dests}: locale,
  11.399 +      {elems = elems', decls = (decls1', decls2'), regs = regs', ...}: locale) =
  11.400 +     {axiom = axiom,
  11.401 +      elems = merge_lists (eq_snd (op =)) elems elems',
  11.402 +      params = params,
  11.403 +      decls =
  11.404 +       (Library.merge (eq_snd (op =)) (decls1, decls1'),
  11.405 +        Library.merge (eq_snd (op =)) (decls2, decls2')),
  11.406 +      regs = merge_alists (op =) regs regs',
  11.407 +      intros = intros,
  11.408 +      dests = dests};
  11.409 +  fun merge _ = NameSpace.join_tables join_locales;
  11.410 +);
  11.411 +
  11.412 +
  11.413 +
  11.414 +(** context data : registrations **)
  11.415 +
  11.416 +structure RegistrationsData = GenericDataFun
  11.417 +(
  11.418 +  type T = Registrations.T Symtab.table;  (*registrations, indexed by locale name*)
  11.419 +  val empty = Symtab.empty;
  11.420 +  val extend = I;
  11.421 +  fun merge _ = Symtab.join (K Registrations.join);
  11.422 +);
  11.423 +
  11.424 +
  11.425 +(** access locales **)
  11.426 +
  11.427 +val intern = NameSpace.intern o #1 o LocalesData.get;
  11.428 +val extern = NameSpace.extern o #1 o LocalesData.get;
  11.429 +
  11.430 +fun get_locale thy name = Symtab.lookup (#2 (LocalesData.get thy)) name;
  11.431 +
  11.432 +fun the_locale thy name = case get_locale thy name
  11.433 + of SOME loc => loc
  11.434 +  | NONE => error ("Unknown locale " ^ quote name);
  11.435 +
  11.436 +fun register_locale bname loc thy =
  11.437 +  thy |> LocalesData.map (NameSpace.bind (Sign.naming_of thy)
  11.438 +    (Binding.name bname, loc) #> snd);
  11.439 +
  11.440 +fun change_locale name f thy =
  11.441 +  let
  11.442 +    val {axiom, elems, params, decls, regs, intros, dests} =
  11.443 +        the_locale thy name;
  11.444 +    val (axiom', elems', params', decls', regs', intros', dests') =
  11.445 +      f (axiom, elems, params, decls, regs, intros, dests);
  11.446 +  in
  11.447 +    thy
  11.448 +    |> (LocalesData.map o apsnd) (Symtab.update (name, {axiom = axiom',
  11.449 +          elems = elems', params = params',
  11.450 +          decls = decls', regs = regs', intros = intros', dests = dests'}))
  11.451 +  end;
  11.452 +
  11.453 +fun print_locales thy =
  11.454 +  let val (space, locs) = LocalesData.get thy in
  11.455 +    Pretty.strs ("locales:" :: map #1 (NameSpace.extern_table (space, locs)))
  11.456 +    |> Pretty.writeln
  11.457 +  end;
  11.458 +
  11.459 +
  11.460 +(* access registrations *)
  11.461 +
  11.462 +(* retrieve registration from theory or context *)
  11.463 +
  11.464 +fun get_registrations ctxt name =
  11.465 +  case Symtab.lookup (RegistrationsData.get ctxt) name of
  11.466 +      NONE => []
  11.467 +    | SOME reg => Registrations.dest (Context.theory_of ctxt) reg;
  11.468 +
  11.469 +fun get_global_registrations thy = get_registrations (Context.Theory thy);
  11.470 +fun get_local_registrations ctxt = get_registrations (Context.Proof ctxt);
  11.471 +
  11.472 +
  11.473 +fun get_registration ctxt imprt (name, ps) =
  11.474 +  case Symtab.lookup (RegistrationsData.get ctxt) name of
  11.475 +      NONE => NONE
  11.476 +    | SOME reg => Registrations.lookup (Context.theory_of ctxt) (reg, (ps, imprt));
  11.477 +
  11.478 +fun get_global_registration thy = get_registration (Context.Theory thy);
  11.479 +fun get_local_registration ctxt = get_registration (Context.Proof ctxt);
  11.480 +
  11.481 +
  11.482 +fun test_registration ctxt (name, ps) =
  11.483 +  case Symtab.lookup (RegistrationsData.get ctxt) name of
  11.484 +      NONE => false
  11.485 +    | SOME reg => Registrations.test (Context.theory_of ctxt) (reg, ps);
  11.486 +
  11.487 +fun test_global_registration thy = test_registration (Context.Theory thy);
  11.488 +fun test_local_registration ctxt = test_registration (Context.Proof ctxt);
  11.489 +
  11.490 +
  11.491 +(* add registration to theory or context, ignored if subsumed *)
  11.492 +
  11.493 +fun put_registration (name, ps) prfx morphs ctxt =
  11.494 +  RegistrationsData.map (fn regs =>
  11.495 +    let
  11.496 +      val thy = Context.theory_of ctxt;
  11.497 +      val reg = the_default Registrations.empty (Symtab.lookup regs name);
  11.498 +      val (reg', sups) = Registrations.insert thy ps prfx morphs reg;
  11.499 +      val _ = if not (null sups) then warning
  11.500 +                ("Subsumed interpretation(s) of locale " ^
  11.501 +                 quote (extern thy name) ^
  11.502 +                 "\nwith the following prefix(es):" ^
  11.503 +                  commas_quote (map (fn (_, ((_, (_, s)), _)) => s) sups))
  11.504 +              else ();
  11.505 +    in Symtab.update (name, reg') regs end) ctxt;
  11.506 +
  11.507 +fun put_global_registration id prfx morphs =
  11.508 +  Context.theory_map (put_registration id prfx morphs);
  11.509 +fun put_local_registration id prfx morphs =
  11.510 +  Context.proof_map (put_registration id prfx morphs);
  11.511 +
  11.512 +fun put_registration_in_locale name id =
  11.513 +  change_locale name (fn (axiom, elems, params, decls, regs, intros, dests) =>
  11.514 +    (axiom, elems, params, decls, regs @ [(id, [])], intros, dests));
  11.515 +
  11.516 +
  11.517 +(* add witness theorem to registration, ignored if registration not present *)
  11.518 +
  11.519 +fun add_witness (name, ps) thm =
  11.520 +  RegistrationsData.map (Symtab.map_entry name (Registrations.add_witness ps thm));
  11.521 +
  11.522 +fun add_global_witness id thm = Context.theory_map (add_witness id thm);
  11.523 +fun add_local_witness id thm = Context.proof_map (add_witness id thm);
  11.524 +
  11.525 +
  11.526 +fun add_witness_in_locale name id thm =
  11.527 +  change_locale name (fn (axiom, elems, params, decls, regs, intros, dests) =>
  11.528 +    let
  11.529 +      fun add (id', thms) =
  11.530 +        if id = id' then (id', thm :: thms) else (id', thms);
  11.531 +    in (axiom, elems, params, decls, map add regs, intros, dests) end);
  11.532 +
  11.533 +
  11.534 +(* add equation to registration, ignored if registration not present *)
  11.535 +
  11.536 +fun add_equation (name, ps) thm =
  11.537 +  RegistrationsData.map (Symtab.map_entry name (Registrations.add_equation ps thm));
  11.538 +
  11.539 +fun add_global_equation id thm = Context.theory_map (add_equation id thm);
  11.540 +fun add_local_equation id thm = Context.proof_map (add_equation id thm);
  11.541 +
  11.542 +(*
  11.543 +(* update morphism of registration, ignored if registration not present *)
  11.544 +
  11.545 +fun update_morph (name, ps) morph =
  11.546 +  RegistrationsData.map (Symtab.map_entry name (Registrations.update_morph ps morph));
  11.547 +
  11.548 +fun update_global_morph id morph = Context.theory_map (update_morph id morph);
  11.549 +fun update_local_morph id morph = Context.proof_map (update_morph id morph);
  11.550 +*)
  11.551 +
  11.552 +
  11.553 +(* printing of registrations *)
  11.554 +
  11.555 +fun print_registrations show_wits loc ctxt =
  11.556 +  let
  11.557 +    val thy = ProofContext.theory_of ctxt;
  11.558 +    val prt_term = Pretty.quote o Syntax.pretty_term ctxt;
  11.559 +    fun prt_term' t = if !show_types
  11.560 +          then Pretty.block [prt_term t, Pretty.brk 1, Pretty.str "::",
  11.561 +            Pretty.brk 1, (Pretty.quote o Syntax.pretty_typ ctxt) (type_of t)]
  11.562 +          else prt_term t;
  11.563 +    val prt_thm = prt_term o prop_of;
  11.564 +    fun prt_inst ts =
  11.565 +        Pretty.enclose "(" ")" (Pretty.breaks (map prt_term' ts));
  11.566 +    fun prt_prfx ((false, prfx), param_prfx) = [Pretty.str prfx, Pretty.brk 1, Pretty.str "(optional)", Pretty.brk 1, Pretty.str param_prfx]
  11.567 +      | prt_prfx ((true, prfx), param_prfx) = [Pretty.str prfx, Pretty.brk 1, Pretty.str param_prfx];
  11.568 +    fun prt_eqns [] = Pretty.str "no equations."
  11.569 +      | prt_eqns eqns = Pretty.block (Pretty.str "equations:" :: Pretty.brk 1 ::
  11.570 +          Pretty.breaks (map prt_thm eqns));
  11.571 +    fun prt_core ts eqns =
  11.572 +          [prt_inst ts, Pretty.fbrk, prt_eqns (Termtab.dest eqns |> map snd)];
  11.573 +    fun prt_witns [] = Pretty.str "no witnesses."
  11.574 +      | prt_witns witns = Pretty.block (Pretty.str "witnesses:" :: Pretty.brk 1 ::
  11.575 +          Pretty.breaks (map (Element.pretty_witness ctxt) witns))
  11.576 +    fun prt_reg (ts, (_, _, witns, eqns)) =
  11.577 +        if show_wits
  11.578 +          then Pretty.block (prt_core ts eqns @ [Pretty.fbrk, prt_witns witns])
  11.579 +          else Pretty.block (prt_core ts eqns)
  11.580 +
  11.581 +    val loc_int = intern thy loc;
  11.582 +    val regs = RegistrationsData.get (Context.Proof ctxt);
  11.583 +    val loc_regs = Symtab.lookup regs loc_int;
  11.584 +  in
  11.585 +    (case loc_regs of
  11.586 +        NONE => Pretty.str ("no interpretations")
  11.587 +      | SOME r => let
  11.588 +            val r' = Registrations.dest thy r;
  11.589 +            val r'' = Library.sort_wrt (fn (_, ((_, (_, prfx)), _, _, _)) => prfx) r';
  11.590 +          in Pretty.big_list ("interpretations:") (map prt_reg r'') end)
  11.591 +    |> Pretty.writeln
  11.592 +  end;
  11.593 +
  11.594 +
  11.595 +(* diagnostics *)
  11.596 +
  11.597 +fun err_in_locale ctxt msg ids =
  11.598 +  let
  11.599 +    val thy = ProofContext.theory_of ctxt;
  11.600 +    fun prt_id (name, parms) =
  11.601 +      [Pretty.block (Pretty.breaks (map Pretty.str (extern thy name :: parms)))];
  11.602 +    val prt_ids = flat (separate [Pretty.str " +", Pretty.brk 1] (map prt_id ids));
  11.603 +    val err_msg =
  11.604 +      if forall (fn (s, _) => s = "") ids then msg
  11.605 +      else msg ^ "\n" ^ Pretty.string_of (Pretty.block
  11.606 +        (Pretty.str "The error(s) above occurred in locale:" :: Pretty.brk 1 :: prt_ids));
  11.607 +  in error err_msg end;
  11.608 +
  11.609 +fun err_in_locale' ctxt msg ids' = err_in_locale ctxt msg (map fst ids');
  11.610 +
  11.611 +
  11.612 +fun pretty_ren NONE = Pretty.str "_"
  11.613 +  | pretty_ren (SOME (x, NONE)) = Pretty.str x
  11.614 +  | pretty_ren (SOME (x, SOME syn)) =
  11.615 +      Pretty.block [Pretty.str x, Pretty.brk 1, Syntax.pretty_mixfix syn];
  11.616 +
  11.617 +fun pretty_expr thy (Locale name) = Pretty.str (extern thy name)
  11.618 +  | pretty_expr thy (Rename (expr, xs)) =
  11.619 +      Pretty.block [pretty_expr thy expr, Pretty.brk 1, Pretty.block (map pretty_ren xs |> Pretty.breaks)]
  11.620 +  | pretty_expr thy (Merge es) =
  11.621 +      Pretty.separate "+" (map (pretty_expr thy) es) |> Pretty.block;
  11.622 +
  11.623 +fun err_in_expr _ msg (Merge []) = error msg
  11.624 +  | err_in_expr ctxt msg expr =
  11.625 +    error (msg ^ "\n" ^ Pretty.string_of (Pretty.block
  11.626 +      [Pretty.str "The error(s) above occured in locale expression:", Pretty.brk 1,
  11.627 +       pretty_expr (ProofContext.theory_of ctxt) expr]));
  11.628 +
  11.629 +
  11.630 +(** structured contexts: rename + merge + implicit type instantiation **)
  11.631 +
  11.632 +(* parameter types *)
  11.633 +
  11.634 +fun frozen_tvars ctxt Ts =
  11.635 +  #1 (Variable.importT_inst (map Logic.mk_type Ts) ctxt)
  11.636 +  |> map (fn ((xi, S), T) => (xi, (S, T)));
  11.637 +
  11.638 +fun unify_frozen ctxt maxidx Ts Us =
  11.639 +  let
  11.640 +    fun paramify NONE i = (NONE, i)
  11.641 +      | paramify (SOME T) i = apfst SOME (TypeInfer.paramify_dummies T i);
  11.642 +
  11.643 +    val (Ts', maxidx') = fold_map paramify Ts maxidx;
  11.644 +    val (Us', maxidx'') = fold_map paramify Us maxidx';
  11.645 +    val thy = ProofContext.theory_of ctxt;
  11.646 +
  11.647 +    fun unify (SOME T, SOME U) env = (Sign.typ_unify thy (U, T) env
  11.648 +          handle Type.TUNIFY => raise TYPE ("unify_frozen: failed to unify types", [U, T], []))
  11.649 +      | unify _ env = env;
  11.650 +    val (unifier, _) = fold unify (Ts' ~~ Us') (Vartab.empty, maxidx'');
  11.651 +    val Vs = map (Option.map (Envir.norm_type unifier)) Us';
  11.652 +    val unifier' = fold Vartab.update_new (frozen_tvars ctxt (map_filter I Vs)) unifier;
  11.653 +  in map (Option.map (Envir.norm_type unifier')) Vs end;
  11.654 +
  11.655 +fun params_of elemss =
  11.656 +  distinct (eq_fst (op = : string * string -> bool)) (maps (snd o fst) elemss);
  11.657 +
  11.658 +fun params_of' elemss =
  11.659 +  distinct (eq_fst (op = : string * string -> bool)) (maps (snd o fst o fst) elemss);
  11.660 +
  11.661 +fun param_prefix locale_name params = (NameSpace.base locale_name ^ "_locale", space_implode "_" params);
  11.662 +
  11.663 +
  11.664 +(* CB: param_types has the following type:
  11.665 +  ('a * 'b option) list -> ('a * 'b) list *)
  11.666 +fun param_types ps = map_filter (fn (_, NONE) => NONE | (x, SOME T) => SOME (x, T)) ps;
  11.667 +
  11.668 +
  11.669 +fun merge_syntax ctxt ids ss = Symtab.merge (op = : mixfix * mixfix -> bool) ss
  11.670 +  handle Symtab.DUP x => err_in_locale ctxt
  11.671 +    ("Conflicting syntax for parameter: " ^ quote x) (map fst ids);
  11.672 +
  11.673 +
  11.674 +(* Distinction of assumed vs. derived identifiers.
  11.675 +   The former may have axioms relating assumptions of the context to
  11.676 +   assumptions of the specification fragment (for locales with
  11.677 +   predicates).  The latter have witnesses relating assumptions of the
  11.678 +   specification fragment to assumptions of other (assumed) specification
  11.679 +   fragments. *)
  11.680 +
  11.681 +datatype 'a mode = Assumed of 'a | Derived of 'a;
  11.682 +
  11.683 +fun map_mode f (Assumed x) = Assumed (f x)
  11.684 +  | map_mode f (Derived x) = Derived (f x);
  11.685 +
  11.686 +
  11.687 +(* flatten expressions *)
  11.688 +
  11.689 +local
  11.690 +
  11.691 +fun unify_parms ctxt fixed_parms raw_parmss =
  11.692 +  let
  11.693 +    val thy = ProofContext.theory_of ctxt;
  11.694 +    val maxidx = length raw_parmss;
  11.695 +    val idx_parmss = (0 upto maxidx - 1) ~~ raw_parmss;
  11.696 +
  11.697 +    fun varify i = Term.map_type_tfree (fn (a, S) => TVar ((a, i), S));
  11.698 +    fun varify_parms (i, ps) = map (apsnd (varify i)) (param_types ps);
  11.699 +    val parms = fixed_parms @ maps varify_parms idx_parmss;
  11.700 +
  11.701 +    fun unify T U envir = Sign.typ_unify thy (U, T) envir
  11.702 +      handle Type.TUNIFY =>
  11.703 +        let
  11.704 +          val T' = Envir.norm_type (fst envir) T;
  11.705 +          val U' = Envir.norm_type (fst envir) U;
  11.706 +          val prt = Syntax.string_of_typ ctxt;
  11.707 +        in
  11.708 +          raise TYPE ("unify_parms: failed to unify types " ^
  11.709 +            prt U' ^ " and " ^ prt T', [U', T'], [])
  11.710 +        end;
  11.711 +    fun unify_list (T :: Us) = fold (unify T) Us
  11.712 +      | unify_list [] = I;
  11.713 +    val (unifier, _) = fold unify_list (map #2 (Symtab.dest (Symtab.make_list parms)))
  11.714 +      (Vartab.empty, maxidx);
  11.715 +
  11.716 +    val parms' = map (apsnd (Envir.norm_type unifier)) (distinct (eq_fst (op =)) parms);
  11.717 +    val unifier' = fold Vartab.update_new (frozen_tvars ctxt (map #2 parms')) unifier;
  11.718 +
  11.719 +    fun inst_parms (i, ps) =
  11.720 +      List.foldr OldTerm.add_typ_tfrees [] (map_filter snd ps)
  11.721 +      |> map_filter (fn (a, S) =>
  11.722 +          let val T = Envir.norm_type unifier' (TVar ((a, i), S))
  11.723 +          in if T = TFree (a, S) then NONE else SOME (a, T) end)
  11.724 +      |> Symtab.make;
  11.725 +  in map inst_parms idx_parmss end;
  11.726 +
  11.727 +in
  11.728 +
  11.729 +fun unify_elemss _ _ [] = []
  11.730 +  | unify_elemss _ [] [elems] = [elems]
  11.731 +  | unify_elemss ctxt fixed_parms elemss =
  11.732 +      let
  11.733 +        val thy = ProofContext.theory_of ctxt;
  11.734 +        val phis = unify_parms ctxt fixed_parms (map (snd o fst o fst) elemss)
  11.735 +          |> map (Element.instT_morphism thy);
  11.736 +        fun inst ((((name, ps), mode), elems), phi) =
  11.737 +          (((name, map (apsnd (Option.map (Morphism.typ phi))) ps),
  11.738 +              map_mode (map (Element.morph_witness phi)) mode),
  11.739 +            map (Element.morph_ctxt phi) elems);
  11.740 +      in map inst (elemss ~~ phis) end;
  11.741 +
  11.742 +
  11.743 +fun renaming xs parms = zip_options parms xs
  11.744 +  handle Library.UnequalLengths =>
  11.745 +    error ("Too many arguments in renaming: " ^
  11.746 +      commas (map (fn NONE => "_" | SOME x => quote (fst x)) xs));
  11.747 +
  11.748 +
  11.749 +(* params_of_expr:
  11.750 +   Compute parameters (with types and syntax) of locale expression.
  11.751 +*)
  11.752 +
  11.753 +fun params_of_expr ctxt fixed_params expr (prev_parms, prev_types, prev_syn) =
  11.754 +  let
  11.755 +    val thy = ProofContext.theory_of ctxt;
  11.756 +
  11.757 +    fun merge_tenvs fixed tenv1 tenv2 =
  11.758 +        let
  11.759 +          val [env1, env2] = unify_parms ctxt fixed
  11.760 +                [tenv1 |> Symtab.dest |> map (apsnd SOME),
  11.761 +                 tenv2 |> Symtab.dest |> map (apsnd SOME)]
  11.762 +        in
  11.763 +          Symtab.merge (op =) (Symtab.map (Element.instT_type env1) tenv1,
  11.764 +            Symtab.map (Element.instT_type env2) tenv2)
  11.765 +        end;
  11.766 +
  11.767 +    fun merge_syn expr syn1 syn2 =
  11.768 +        Symtab.merge (op = : mixfix * mixfix -> bool) (syn1, syn2)
  11.769 +        handle Symtab.DUP x => err_in_expr ctxt
  11.770 +          ("Conflicting syntax for parameter: " ^ quote x) expr;
  11.771 +
  11.772 +    fun params_of (expr as Locale name) =
  11.773 +          let
  11.774 +            val {params, ...} = the_locale thy name;
  11.775 +          in (map (fst o fst) params, params |> map fst |> Symtab.make,
  11.776 +               params |> map (apfst fst) |> Symtab.make) end
  11.777 +      | params_of (expr as Rename (e, xs)) =
  11.778 +          let
  11.779 +            val (parms', types', syn') = params_of e;
  11.780 +            val ren = renaming xs parms';
  11.781 +            (* renaming may reduce number of parameters *)
  11.782 +            val new_parms = map (Element.rename ren) parms' |> distinct (op =);
  11.783 +            val ren_syn = syn' |> Symtab.dest |> map (Element.rename_var_name ren);
  11.784 +            val new_syn = fold (Symtab.insert (op =)) ren_syn Symtab.empty
  11.785 +                handle Symtab.DUP x =>
  11.786 +                  err_in_expr ctxt ("Conflicting syntax for parameter: " ^ quote x) expr;
  11.787 +            val syn_types = map (apsnd (fn mx =>
  11.788 +                SOME (Type.freeze_type (#1 (TypeInfer.paramify_dummies (Syntax.mixfixT mx) 0)))))
  11.789 +              (Symtab.dest new_syn);
  11.790 +            val ren_types = types' |> Symtab.dest |> map (apfst (Element.rename ren));
  11.791 +            val (env :: _) = unify_parms ctxt []
  11.792 +                ((ren_types |> map (apsnd SOME)) :: map single syn_types);
  11.793 +            val new_types = fold (Symtab.insert (op =))
  11.794 +                (map (apsnd (Element.instT_type env)) ren_types) Symtab.empty;
  11.795 +          in (new_parms, new_types, new_syn) end
  11.796 +      | params_of (Merge es) =
  11.797 +          fold (fn e => fn (parms, types, syn) =>
  11.798 +                   let
  11.799 +                     val (parms', types', syn') = params_of e
  11.800 +                   in
  11.801 +                     (merge_lists (op =) parms parms', merge_tenvs [] types types',
  11.802 +                      merge_syn e syn syn')
  11.803 +                   end)
  11.804 +            es ([], Symtab.empty, Symtab.empty)
  11.805 +
  11.806 +      val (parms, types, syn) = params_of expr;
  11.807 +    in
  11.808 +      (merge_lists (op =) prev_parms parms, merge_tenvs fixed_params prev_types types,
  11.809 +       merge_syn expr prev_syn syn)
  11.810 +    end;
  11.811 +
  11.812 +fun make_params_ids params = [(("", params), ([], Assumed []))];
  11.813 +fun make_raw_params_elemss (params, tenv, syn) =
  11.814 +    [((("", map (fn p => (p, Symtab.lookup tenv p)) params), Assumed []),
  11.815 +      Int [Fixes (map (fn p =>
  11.816 +        (Binding.name p, Symtab.lookup tenv p, Symtab.lookup syn p |> the)) params)])];
  11.817 +
  11.818 +
  11.819 +(* flatten_expr:
  11.820 +   Extend list of identifiers by those new in locale expression expr.
  11.821 +   Compute corresponding list of lists of locale elements (one entry per
  11.822 +   identifier).
  11.823 +
  11.824 +   Identifiers represent locale fragments and are in an extended form:
  11.825 +     ((name, ps), (ax_ps, axs))
  11.826 +   (name, ps) is the locale name with all its parameters.
  11.827 +   (ax_ps, axs) is the locale axioms with its parameters;
  11.828 +     axs are always taken from the top level of the locale hierarchy,
  11.829 +     hence axioms may contain additional parameters from later fragments:
  11.830 +     ps subset of ax_ps.  axs is either singleton or empty.
  11.831 +
  11.832 +   Elements are enriched by identifier-like information:
  11.833 +     (((name, ax_ps), axs), elems)
  11.834 +   The parameters in ax_ps are the axiom parameters, but enriched by type
  11.835 +   info: now each entry is a pair of string and typ option.  Axioms are
  11.836 +   type-instantiated.
  11.837 +
  11.838 +*)
  11.839 +
  11.840 +fun flatten_expr ctxt ((prev_idents, prev_syntax), expr) =
  11.841 +  let
  11.842 +    val thy = ProofContext.theory_of ctxt;
  11.843 +
  11.844 +    fun rename_parms top ren ((name, ps), (parms, mode)) =
  11.845 +        ((name, map (Element.rename ren) ps),
  11.846 +         if top
  11.847 +         then (map (Element.rename ren) parms,
  11.848 +               map_mode (map (Element.morph_witness (Element.rename_morphism ren))) mode)
  11.849 +         else (parms, mode));
  11.850 +
  11.851 +    (* add (name, pTs) and its registrations, recursively; adjust hyps of witnesses *)
  11.852 +
  11.853 +    fun add_with_regs ((name, pTs), mode) (wits, ids, visited) =
  11.854 +        if member (fn (a, (b, _)) => a = b) visited (name, map #1 pTs)
  11.855 +        then (wits, ids, visited)
  11.856 +        else
  11.857 +          let
  11.858 +            val {params, regs, ...} = the_locale thy name;
  11.859 +            val pTs' = map #1 params;
  11.860 +            val ren = map #1 pTs' ~~ map (fn (x, _) => (x, NONE)) pTs;
  11.861 +              (* dummy syntax, since required by rename *)
  11.862 +            val pTs'' = map (fn ((p, _), (_, T)) => (p, T)) (pTs ~~ pTs');
  11.863 +            val [env] = unify_parms ctxt pTs [map (apsnd SOME) pTs''];
  11.864 +              (* propagate parameter types, to keep them consistent *)
  11.865 +            val regs' = map (fn ((name, ps), wits) =>
  11.866 +                ((name, map (Element.rename ren) ps),
  11.867 +                 map (Element.transfer_witness thy) wits)) regs;
  11.868 +            val new_regs = regs';
  11.869 +            val new_ids = map fst new_regs;
  11.870 +            val new_idTs =
  11.871 +              map (apsnd (map (fn p => (p, (the o AList.lookup (op =) pTs) p)))) new_ids;
  11.872 +
  11.873 +            val new_wits = new_regs |> map (#2 #> map
  11.874 +              (Element.morph_witness
  11.875 +                (Element.instT_morphism thy env $>
  11.876 +                  Element.rename_morphism ren $>
  11.877 +                  Element.satisfy_morphism wits)
  11.878 +                #> Element.close_witness));
  11.879 +            val new_ids' = map (fn (id, wits) =>
  11.880 +                (id, ([], Derived wits))) (new_ids ~~ new_wits);
  11.881 +            val new_idTs' = map (fn ((n, pTs), (_, ([], mode))) =>
  11.882 +                ((n, pTs), mode)) (new_idTs ~~ new_ids');
  11.883 +            val new_id = ((name, map #1 pTs), ([], mode));
  11.884 +            val (wits', ids', visited') = fold add_with_regs new_idTs'
  11.885 +              (wits @ flat new_wits, ids, visited @ [new_id]);
  11.886 +          in
  11.887 +            (wits', ids' @ [new_id], visited')
  11.888 +          end;
  11.889 +
  11.890 +    (* distribute top-level axioms over assumed ids *)
  11.891 +
  11.892 +    fun axiomify all_ps ((name, parms), (_, Assumed _)) axioms =
  11.893 +        let
  11.894 +          val {elems, ...} = the_locale thy name;
  11.895 +          val ts = maps
  11.896 +            (fn (Assumes asms, _) => maps (map #1 o #2) asms
  11.897 +              | _ => [])
  11.898 +            elems;
  11.899 +          val (axs1, axs2) = chop (length ts) axioms;
  11.900 +        in (((name, parms), (all_ps, Assumed axs1)), axs2) end
  11.901 +      | axiomify all_ps (id, (_, Derived ths)) axioms =
  11.902 +          ((id, (all_ps, Derived ths)), axioms);
  11.903 +
  11.904 +    (* identifiers of an expression *)
  11.905 +
  11.906 +    fun identify top (Locale name) =
  11.907 +    (* CB: ids_ax is a list of tuples of the form ((name, ps), axs),
  11.908 +       where name is a locale name, ps a list of parameter names and axs
  11.909 +       a list of axioms relating to the identifier, axs is empty unless
  11.910 +       identify at top level (top = true);
  11.911 +       parms is accumulated list of parameters *)
  11.912 +          let
  11.913 +            val {axiom, params, ...} = the_locale thy name;
  11.914 +            val ps = map (#1 o #1) params;
  11.915 +            val (_, ids'', _) = add_with_regs ((name, map #1 params), Assumed []) ([], [], []);
  11.916 +            val ids_ax = if top then fst (fold_map (axiomify ps) ids'' axiom) else ids'';
  11.917 +            in (ids_ax, ps) end
  11.918 +      | identify top (Rename (e, xs)) =
  11.919 +          let
  11.920 +            val (ids', parms') = identify top e;
  11.921 +            val ren = renaming xs parms'
  11.922 +              handle ERROR msg => err_in_locale' ctxt msg ids';
  11.923 +
  11.924 +            val ids'' = distinct (eq_fst (op =)) (map (rename_parms top ren) ids');
  11.925 +            val parms'' = distinct (op =) (maps (#2 o #1) ids'');
  11.926 +          in (ids'', parms'') end
  11.927 +      | identify top (Merge es) =
  11.928 +          fold (fn e => fn (ids, parms) =>
  11.929 +                   let
  11.930 +                     val (ids', parms') = identify top e
  11.931 +                   in
  11.932 +                     (merge_alists (op =) ids ids', merge_lists (op =) parms parms')
  11.933 +                   end)
  11.934 +            es ([], []);
  11.935 +
  11.936 +    fun inst_wit all_params (t, th) = let
  11.937 +         val {hyps, prop, ...} = Thm.rep_thm th;
  11.938 +         val ps = map (apsnd SOME) (fold Term.add_frees (prop :: hyps) []);
  11.939 +         val [env] = unify_parms ctxt all_params [ps];
  11.940 +         val t' = Element.instT_term env t;
  11.941 +         val th' = Element.instT_thm thy env th;
  11.942 +       in (t', th') end;
  11.943 +
  11.944 +    fun eval all_params tenv syn ((name, params), (locale_params, mode)) =
  11.945 +      let
  11.946 +        val {params = ps_mx, elems = elems_stamped, ...} = the_locale thy name;
  11.947 +        val elems = map fst elems_stamped;
  11.948 +        val ps = map fst ps_mx;
  11.949 +        fun lookup_syn x = (case Symtab.lookup syn x of SOME Structure => NONE | opt => opt);
  11.950 +        val locale_params' = map (fn p => (p, Symtab.lookup tenv p |> the)) locale_params;
  11.951 +        val mode' = map_mode (map (Element.map_witness (inst_wit all_params))) mode;
  11.952 +        val ren = map fst ps ~~ map (fn p => (p, lookup_syn p)) params;
  11.953 +        val [env] = unify_parms ctxt all_params [map (apfst (Element.rename ren) o apsnd SOME) ps];
  11.954 +        val (lprfx, pprfx) = param_prefix name params;
  11.955 +        val add_prefices = pprfx <> "" ? Binding.add_prefix false pprfx
  11.956 +          #> Binding.add_prefix false lprfx;
  11.957 +        val elem_morphism =
  11.958 +          Element.rename_morphism ren $>
  11.959 +          Morphism.binding_morphism add_prefices $>
  11.960 +          Element.instT_morphism thy env;
  11.961 +        val elems' = map (Element.morph_ctxt elem_morphism) elems;
  11.962 +      in (((name, map (apsnd SOME) locale_params'), mode'), elems') end;
  11.963 +
  11.964 +    (* parameters, their types and syntax *)
  11.965 +    val (all_params', tenv, syn) = params_of_expr ctxt [] expr ([], Symtab.empty, Symtab.empty);
  11.966 +    val all_params = map (fn p => (p, Symtab.lookup tenv p |> the)) all_params';
  11.967 +    (* compute identifiers and syntax, merge with previous ones *)
  11.968 +    val (ids, _) = identify true expr;
  11.969 +    val idents = subtract (eq_fst (op =)) prev_idents ids;
  11.970 +    val syntax = merge_syntax ctxt ids (syn, prev_syntax);
  11.971 +    (* type-instantiate elements *)
  11.972 +    val final_elemss = map (eval all_params tenv syntax) idents;
  11.973 +  in ((prev_idents @ idents, syntax), final_elemss) end;
  11.974 +
  11.975 +end;
  11.976 +
  11.977 +
  11.978 +(* activate elements *)
  11.979 +
  11.980 +local
  11.981 +
  11.982 +fun axioms_export axs _ As =
  11.983 +  (Element.satisfy_thm axs #> Drule.implies_intr_list (Library.drop (length axs, As)), fn t => t);
  11.984 +
  11.985 +
  11.986 +(* NB: derived ids contain only facts at this stage *)
  11.987 +
  11.988 +fun activate_elem _ _ (Fixes fixes) (ctxt, mode) =
  11.989 +      ([], (ctxt |> ProofContext.add_fixes_i fixes |> snd, mode))
  11.990 +  | activate_elem _ _ (Constrains _) (ctxt, mode) =
  11.991 +      ([], (ctxt, mode))
  11.992 +  | activate_elem ax_in_ctxt _ (Assumes asms) (ctxt, Assumed axs) =
  11.993 +      let
  11.994 +        val asms' = Attrib.map_specs (Attrib.attribute_i (ProofContext.theory_of ctxt)) asms;
  11.995 +        val ts = maps (map #1 o #2) asms';
  11.996 +        val (ps, qs) = chop (length ts) axs;
  11.997 +        val (_, ctxt') =
  11.998 +          ctxt |> fold Variable.auto_fixes ts
  11.999 +          |> ProofContext.add_assms_i (axioms_export (if ax_in_ctxt then ps else [])) asms';
 11.1000 +      in ([], (ctxt', Assumed qs)) end
 11.1001 +  | activate_elem _ _ (Assumes asms) (ctxt, Derived ths) =
 11.1002 +      ([], (ctxt, Derived ths))
 11.1003 +  | activate_elem _ _ (Defines defs) (ctxt, Assumed axs) =
 11.1004 +      let
 11.1005 +        val defs' = Attrib.map_specs (Attrib.attribute_i (ProofContext.theory_of ctxt)) defs;
 11.1006 +        val asms = defs' |> map (fn ((name, atts), (t, ps)) =>
 11.1007 +            let val ((c, _), t') = LocalDefs.cert_def ctxt t
 11.1008 +            in (t', ((Binding.map_base (Thm.def_name_optional c) name, atts), [(t', ps)])) end);
 11.1009 +        val (_, ctxt') =
 11.1010 +          ctxt |> fold (Variable.auto_fixes o #1) asms
 11.1011 +          |> ProofContext.add_assms_i LocalDefs.def_export (map #2 asms);
 11.1012 +      in ([], (ctxt', Assumed axs)) end
 11.1013 +  | activate_elem _ _ (Defines defs) (ctxt, Derived ths) =
 11.1014 +      ([], (ctxt, Derived ths))
 11.1015 +  | activate_elem _ is_ext (Notes (kind, facts)) (ctxt, mode) =
 11.1016 +      let
 11.1017 +        val facts' = Attrib.map_facts (Attrib.attribute_i (ProofContext.theory_of ctxt)) facts;
 11.1018 +        val (res, ctxt') = ctxt |> local_note_qualified kind facts';
 11.1019 +      in (if is_ext then (map (#1 o #1) facts' ~~ map #2 res) else [], (ctxt', mode)) end;
 11.1020 +
 11.1021 +fun activate_elems ax_in_ctxt (((name, ps), mode), elems) ctxt =
 11.1022 +  let
 11.1023 +    val thy = ProofContext.theory_of ctxt;
 11.1024 +    val (res, (ctxt', _)) = fold_map (activate_elem ax_in_ctxt (name = ""))
 11.1025 +        elems (ProofContext.qualified_names ctxt, mode)
 11.1026 +      handle ERROR msg => err_in_locale ctxt msg [(name, map fst ps)];
 11.1027 +    val ctxt'' = if name = "" then ctxt'
 11.1028 +          else let
 11.1029 +              val ps' = map (fn (n, SOME T) => Free (n, T)) ps;
 11.1030 +            in if test_local_registration ctxt' (name, ps') then ctxt'
 11.1031 +              else let
 11.1032 +                  val ctxt'' = put_local_registration (name, ps') (I, (NameSpace.base name, ""))
 11.1033 +                    (Morphism.identity, ((Vartab.empty, []), (Vartab.empty, []) )) ctxt'
 11.1034 +                in case mode of
 11.1035 +                    Assumed axs =>
 11.1036 +                      fold (add_local_witness (name, ps') o
 11.1037 +                        Element.assume_witness thy o Element.witness_prop) axs ctxt''
 11.1038 +                  | Derived ths =>
 11.1039 +                     fold (add_local_witness (name, ps')) ths ctxt''
 11.1040 +                end
 11.1041 +            end
 11.1042 +  in (ProofContext.restore_naming ctxt ctxt'', res) end;
 11.1043 +
 11.1044 +fun activate_elemss ax_in_ctxt prep_facts =
 11.1045 +    fold_map (fn (((name, ps), mode), raw_elems) => fn ctxt =>
 11.1046 +      let
 11.1047 +        val elems = map (prep_facts ctxt) raw_elems;
 11.1048 +        val (ctxt', res) = apsnd flat
 11.1049 +            (activate_elems ax_in_ctxt (((name, ps), mode), elems) ctxt);
 11.1050 +        val elems' = elems |> map (Element.map_ctxt_attrib Args.closure);
 11.1051 +      in (((((name, ps), mode), elems'), res), ctxt') end);
 11.1052 +
 11.1053 +in
 11.1054 +
 11.1055 +(* CB: activate_facts prep_facts elemss ctxt,
 11.1056 +   where elemss is a list of pairs consisting of identifiers and
 11.1057 +   context elements, extends ctxt by the context elements yielding
 11.1058 +   ctxt' and returns ((elemss', facts), ctxt').
 11.1059 +   Identifiers in the argument are of the form ((name, ps), axs) and
 11.1060 +   assumptions use the axioms in the identifiers to set up exporters
 11.1061 +   in ctxt'.  elemss' does not contain identifiers and is obtained
 11.1062 +   from elemss and the intermediate context with prep_facts.
 11.1063 +   If read_facts or cert_facts is used for prep_facts, these also remove
 11.1064 +   the internal/external markers from elemss. *)
 11.1065 +
 11.1066 +fun activate_facts ax_in_ctxt prep_facts args =
 11.1067 +  activate_elemss ax_in_ctxt prep_facts args
 11.1068 +  #>> (apsnd flat o split_list);
 11.1069 +
 11.1070 +end;
 11.1071 +
 11.1072 +
 11.1073 +
 11.1074 +(** prepare locale elements **)
 11.1075 +
 11.1076 +(* expressions *)
 11.1077 +
 11.1078 +fun intern_expr thy (Locale xname) = Locale (intern thy xname)
 11.1079 +  | intern_expr thy (Merge exprs) = Merge (map (intern_expr thy) exprs)
 11.1080 +  | intern_expr thy (Rename (expr, xs)) = Rename (intern_expr thy expr, xs);
 11.1081 +
 11.1082 +
 11.1083 +(* propositions and bindings *)
 11.1084 +
 11.1085 +(* flatten (ctxt, prep_expr) ((ids, syn), expr)
 11.1086 +   normalises expr (which is either a locale
 11.1087 +   expression or a single context element) wrt.
 11.1088 +   to the list ids of already accumulated identifiers.
 11.1089 +   It returns ((ids', syn'), elemss) where ids' is an extension of ids
 11.1090 +   with identifiers generated for expr, and elemss is the list of
 11.1091 +   context elements generated from expr.
 11.1092 +   syn and syn' are symtabs mapping parameter names to their syntax.  syn'
 11.1093 +   is an extension of syn.
 11.1094 +   For details, see flatten_expr.
 11.1095 +
 11.1096 +   Additionally, for a locale expression, the elems are grouped into a single
 11.1097 +   Int; individual context elements are marked Ext.  In this case, the
 11.1098 +   identifier-like information of the element is as follows:
 11.1099 +   - for Fixes: (("", ps), []) where the ps have type info NONE
 11.1100 +   - for other elements: (("", []), []).
 11.1101 +   The implementation of activate_facts relies on identifier names being
 11.1102 +   empty strings for external elements.
 11.1103 +*)
 11.1104 +
 11.1105 +fun flatten (ctxt, _) ((ids, syn), Elem (Fixes fixes)) = let
 11.1106 +        val ids' = ids @ [(("", map (Binding.base_name o #1) fixes), ([], Assumed []))]
 11.1107 +      in
 11.1108 +        ((ids',
 11.1109 +         merge_syntax ctxt ids'
 11.1110 +           (syn, Symtab.make (map (fn fx => (Binding.base_name (#1 fx), #3 fx)) fixes))
 11.1111 +           handle Symtab.DUP x => err_in_locale ctxt
 11.1112 +             ("Conflicting syntax for parameter: " ^ quote x)
 11.1113 +             (map #1 ids')),
 11.1114 +         [((("", map (rpair NONE o Binding.base_name o #1) fixes), Assumed []), Ext (Fixes fixes))])
 11.1115 +      end
 11.1116 +  | flatten _ ((ids, syn), Elem elem) =
 11.1117 +      ((ids @ [(("", []), ([], Assumed []))], syn), [((("", []), Assumed []), Ext elem)])
 11.1118 +  | flatten (ctxt, prep_expr) ((ids, syn), Expr expr) =
 11.1119 +      apsnd (map (apsnd Int)) (flatten_expr ctxt ((ids, syn), prep_expr expr));
 11.1120 +
 11.1121 +local
 11.1122 +
 11.1123 +local
 11.1124 +
 11.1125 +fun declare_int_elem (Fixes fixes) ctxt =
 11.1126 +      ([], ctxt |> ProofContext.add_fixes_i (map (fn (x, T, mx) =>
 11.1127 +        (x, Option.map (Term.map_type_tfree (TypeInfer.param 0)) T, mx)) fixes) |> snd)
 11.1128 +  | declare_int_elem _ ctxt = ([], ctxt);
 11.1129 +
 11.1130 +fun declare_ext_elem prep_vars (Fixes fixes) ctxt =
 11.1131 +      let val (vars, _) = prep_vars fixes ctxt
 11.1132 +      in ([], ctxt |> ProofContext.add_fixes_i vars |> snd) end
 11.1133 +  | declare_ext_elem prep_vars (Constrains csts) ctxt =
 11.1134 +      let val (_, ctxt') = prep_vars (map (fn (x, T) => (Binding.name x, SOME T, NoSyn)) csts) ctxt
 11.1135 +      in ([], ctxt') end
 11.1136 +  | declare_ext_elem _ (Assumes asms) ctxt = (map #2 asms, ctxt)
 11.1137 +  | declare_ext_elem _ (Defines defs) ctxt = (map (fn (_, (t, ps)) => [(t, ps)]) defs, ctxt)
 11.1138 +  | declare_ext_elem _ (Notes _) ctxt = ([], ctxt);
 11.1139 +
 11.1140 +fun declare_elems prep_vars (((name, ps), Assumed _), elems) ctxt = ((case elems
 11.1141 +     of Int es => fold_map declare_int_elem es ctxt
 11.1142 +      | Ext e => declare_ext_elem prep_vars e ctxt |>> single)
 11.1143 +          handle ERROR msg => err_in_locale ctxt msg [(name, map fst ps)])
 11.1144 +  | declare_elems _ ((_, Derived _), elems) ctxt = ([], ctxt);
 11.1145 +
 11.1146 +in
 11.1147 +
 11.1148 +fun declare_elemss prep_vars fixed_params raw_elemss ctxt =
 11.1149 +  let
 11.1150 +    (* CB: fix of type bug of goal in target with context elements.
 11.1151 +       Parameters new in context elements must receive types that are
 11.1152 +       distinct from types of parameters in target (fixed_params).  *)
 11.1153 +    val ctxt_with_fixed = 
 11.1154 +      fold Variable.declare_term (map Free fixed_params) ctxt;
 11.1155 +    val int_elemss =
 11.1156 +      raw_elemss
 11.1157 +      |> map_filter (fn (id, Int es) => SOME (id, es) | _ => NONE)
 11.1158 +      |> unify_elemss ctxt_with_fixed fixed_params;
 11.1159 +    val (raw_elemss', _) =
 11.1160 +      fold_map (curry (fn ((id, Int _), (_, es) :: elemss) => ((id, Int es), elemss) | x => x))
 11.1161 +        raw_elemss int_elemss;
 11.1162 +  in fold_map (declare_elems prep_vars) raw_elemss' ctxt end;
 11.1163 +
 11.1164 +end;
 11.1165 +
 11.1166 +local
 11.1167 +
 11.1168 +val norm_term = Envir.beta_norm oo Term.subst_atomic;
 11.1169 +
 11.1170 +fun abstract_thm thy eq =
 11.1171 +  Thm.assume (Thm.cterm_of thy eq) |> Drule.gen_all |> Drule.abs_def;
 11.1172 +
 11.1173 +fun bind_def ctxt (name, ps) eq (xs, env, ths) =
 11.1174 +  let
 11.1175 +    val ((y, T), b) = LocalDefs.abs_def eq;
 11.1176 +    val b' = norm_term env b;
 11.1177 +    val th = abstract_thm (ProofContext.theory_of ctxt) eq;
 11.1178 +    fun err msg = err_in_locale ctxt (msg ^ ": " ^ quote y) [(name, map fst ps)];
 11.1179 +  in
 11.1180 +    exists (fn (x, _) => x = y) xs andalso
 11.1181 +      err "Attempt to define previously specified variable";
 11.1182 +    exists (fn (Free (y', _), _) => y = y' | _ => false) env andalso
 11.1183 +      err "Attempt to redefine variable";
 11.1184 +    (Term.add_frees b' xs, (Free (y, T), b') :: env, th :: ths)
 11.1185 +  end;
 11.1186 +
 11.1187 +
 11.1188 +(* CB: for finish_elems (Int and Ext),
 11.1189 +   extracts specification, only of assumed elements *)
 11.1190 +
 11.1191 +fun eval_text _ _ _ (Fixes _) text = text
 11.1192 +  | eval_text _ _ _ (Constrains _) text = text
 11.1193 +  | eval_text _ (_, Assumed _) is_ext (Assumes asms)
 11.1194 +        (((exts, exts'), (ints, ints')), (xs, env, defs)) =
 11.1195 +      let
 11.1196 +        val ts = maps (map #1 o #2) asms;
 11.1197 +        val ts' = map (norm_term env) ts;
 11.1198 +        val spec' =
 11.1199 +          if is_ext then ((exts @ ts, exts' @ ts'), (ints, ints'))
 11.1200 +          else ((exts, exts'), (ints @ ts, ints' @ ts'));
 11.1201 +      in (spec', (fold Term.add_frees ts' xs, env, defs)) end
 11.1202 +  | eval_text _ (_, Derived _) _ (Assumes _) text = text
 11.1203 +  | eval_text ctxt (id, Assumed _) _ (Defines defs) (spec, binds) =
 11.1204 +      (spec, fold (bind_def ctxt id o #1 o #2) defs binds)
 11.1205 +  | eval_text _ (_, Derived _) _ (Defines _) text = text
 11.1206 +  | eval_text _ _ _ (Notes _) text = text;
 11.1207 +
 11.1208 +
 11.1209 +(* for finish_elems (Int),
 11.1210 +   remove redundant elements of derived identifiers,
 11.1211 +   turn assumptions and definitions into facts,
 11.1212 +   satisfy hypotheses of facts *)
 11.1213 +
 11.1214 +fun finish_derived _ _ (Assumed _) (Fixes fixes) = SOME (Fixes fixes)
 11.1215 +  | finish_derived _ _ (Assumed _) (Constrains csts) = SOME (Constrains csts)
 11.1216 +  | finish_derived _ _ (Assumed _) (Assumes asms) = SOME (Assumes asms)
 11.1217 +  | finish_derived _ _ (Assumed _) (Defines defs) = SOME (Defines defs)
 11.1218 +
 11.1219 +  | finish_derived _ _ (Derived _) (Fixes _) = NONE
 11.1220 +  | finish_derived _ _ (Derived _) (Constrains _) = NONE
 11.1221 +  | finish_derived sign satisfy (Derived _) (Assumes asms) = asms
 11.1222 +      |> map (apsnd (map (fn (a, _) => ([Thm.assume (cterm_of sign a)], []))))
 11.1223 +      |> pair Thm.assumptionK |> Notes
 11.1224 +      |> Element.morph_ctxt satisfy |> SOME
 11.1225 +  | finish_derived sign satisfy (Derived _) (Defines defs) = defs
 11.1226 +      |> map (apsnd (fn (d, _) => [([Thm.assume (cterm_of sign d)], [])]))
 11.1227 +      |> pair Thm.definitionK |> Notes
 11.1228 +      |> Element.morph_ctxt satisfy |> SOME
 11.1229 +
 11.1230 +  | finish_derived _ satisfy _ (Notes facts) = Notes facts
 11.1231 +      |> Element.morph_ctxt satisfy |> SOME;
 11.1232 +
 11.1233 +(* CB: for finish_elems (Ext) *)
 11.1234 +
 11.1235 +fun closeup _ false elem = elem
 11.1236 +  | closeup ctxt true elem =
 11.1237 +      let
 11.1238 +        fun close_frees t =
 11.1239 +          let
 11.1240 +            val rev_frees =
 11.1241 +              Term.fold_aterms (fn Free (x, T) =>
 11.1242 +                if Variable.is_fixed ctxt x then I else insert (op =) (x, T) | _ => I) t [];
 11.1243 +          in Term.list_all_free (rev rev_frees, t) end;
 11.1244 +
 11.1245 +        fun no_binds [] = []
 11.1246 +          | no_binds _ = error "Illegal term bindings in locale element";
 11.1247 +      in
 11.1248 +        (case elem of
 11.1249 +          Assumes asms => Assumes (asms |> map (fn (a, propps) =>
 11.1250 +            (a, map (fn (t, ps) => (close_frees t, no_binds ps)) propps)))
 11.1251 +        | Defines defs => Defines (defs |> map (fn (a, (t, ps)) =>
 11.1252 +            (a, (close_frees (#2 (LocalDefs.cert_def ctxt t)), no_binds ps))))
 11.1253 +        | e => e)
 11.1254 +      end;
 11.1255 +
 11.1256 +
 11.1257 +fun finish_ext_elem parms _ (Fixes fixes, _) = Fixes (map (fn (b, _, mx) =>
 11.1258 +      let val x = Binding.base_name b
 11.1259 +      in (b, AList.lookup (op =) parms x, mx) end) fixes)
 11.1260 +  | finish_ext_elem parms _ (Constrains _, _) = Constrains []
 11.1261 +  | finish_ext_elem _ close (Assumes asms, propp) =
 11.1262 +      close (Assumes (map #1 asms ~~ propp))
 11.1263 +  | finish_ext_elem _ close (Defines defs, propp) =
 11.1264 +      close (Defines (map #1 defs ~~ map (fn [(t, ps)] => (t, ps)) propp))
 11.1265 +  | finish_ext_elem _ _ (Notes facts, _) = Notes facts;
 11.1266 +
 11.1267 +
 11.1268 +(* CB: finish_parms introduces type info from parms to identifiers *)
 11.1269 +(* CB: only needed for types that have been NONE so far???
 11.1270 +   If so, which are these??? *)
 11.1271 +
 11.1272 +fun finish_parms parms (((name, ps), mode), elems) =
 11.1273 +  (((name, map (fn (x, _) => (x, AList.lookup (op = : string * string -> bool) parms x)) ps), mode), elems);
 11.1274 +
 11.1275 +fun finish_elems ctxt parms _ ((text, wits), ((id, Int e), _)) =
 11.1276 +      let
 11.1277 +        val [(id' as (_, mode), es)] = unify_elemss ctxt parms [(id, e)];
 11.1278 +        val wits' = case mode of Assumed _ => wits | Derived ths => wits @ ths;
 11.1279 +        val text' = fold (eval_text ctxt id' false) es text;
 11.1280 +        val es' = map_filter
 11.1281 +          (finish_derived (ProofContext.theory_of ctxt) (Element.satisfy_morphism wits') mode) es;
 11.1282 +      in ((text', wits'), (id', map Int es')) end
 11.1283 +  | finish_elems ctxt parms do_close ((text, wits), ((id, Ext e), [propp])) =
 11.1284 +      let
 11.1285 +        val e' = finish_ext_elem parms (closeup ctxt do_close) (e, propp);
 11.1286 +        val text' = eval_text ctxt id true e' text;
 11.1287 +      in ((text', wits), (id, [Ext e'])) end
 11.1288 +
 11.1289 +in
 11.1290 +
 11.1291 +(* CB: only called by prep_elemss *)
 11.1292 +
 11.1293 +fun finish_elemss ctxt parms do_close =
 11.1294 +  foldl_map (apsnd (finish_parms parms) o finish_elems ctxt parms do_close);
 11.1295 +
 11.1296 +end;
 11.1297 +
 11.1298 +
 11.1299 +(* Remove duplicate Defines elements: temporary workaround to fix Afp/Category. *)
 11.1300 +
 11.1301 +fun defs_ord (defs1, defs2) =
 11.1302 +    list_ord (fn ((_, (d1, _)), (_, (d2, _))) =>
 11.1303 +      TermOrd.fast_term_ord (d1, d2)) (defs1, defs2);
 11.1304 +structure Defstab =
 11.1305 +    TableFun(type key = (Attrib.binding * (term * term list)) list val ord = defs_ord);
 11.1306 +
 11.1307 +fun rem_dup_defs es ds =
 11.1308 +    fold_map (fn e as (Defines defs) => (fn ds =>
 11.1309 +                 if Defstab.defined ds defs
 11.1310 +                 then (Defines [], ds)
 11.1311 +                 else (e, Defstab.update (defs, ()) ds))
 11.1312 +               | e => (fn ds => (e, ds))) es ds;
 11.1313 +fun rem_dup_elemss (Int es) ds = apfst Int (rem_dup_defs es ds)
 11.1314 +  | rem_dup_elemss (Ext e) ds = (Ext e, ds);
 11.1315 +fun rem_dup_defines raw_elemss =
 11.1316 +    fold_map (fn (id as (_, (Assumed _)), es) => (fn ds =>
 11.1317 +                     apfst (pair id) (rem_dup_elemss es ds))
 11.1318 +               | (id as (_, (Derived _)), es) => (fn ds =>
 11.1319 +                     ((id, es), ds))) raw_elemss Defstab.empty |> #1;
 11.1320 +
 11.1321 +(* CB: type inference and consistency checks for locales.
 11.1322 +
 11.1323 +   Works by building a context (through declare_elemss), extracting the
 11.1324 +   required information and adjusting the context elements (finish_elemss).
 11.1325 +   Can also universally close free vars in assms and defs.  This is only
 11.1326 +   needed for Ext elements and controlled by parameter do_close.
 11.1327 +
 11.1328 +   Only elements of assumed identifiers are considered.
 11.1329 +*)
 11.1330 +
 11.1331 +fun prep_elemss prep_vars prepp do_close context fixed_params raw_elemss raw_concl =
 11.1332 +  let
 11.1333 +    (* CB: contexts computed in the course of this function are discarded.
 11.1334 +       They are used for type inference and consistency checks only. *)
 11.1335 +    (* CB: fixed_params are the parameters (with types) of the target locale,
 11.1336 +       empty list if there is no target. *)
 11.1337 +    (* CB: raw_elemss are list of pairs consisting of identifiers and
 11.1338 +       context elements, the latter marked as internal or external. *)
 11.1339 +    val raw_elemss = rem_dup_defines raw_elemss;
 11.1340 +    val (raw_proppss, raw_ctxt) = declare_elemss prep_vars fixed_params raw_elemss context;
 11.1341 +    (* CB: raw_ctxt is context with additional fixed variables derived from
 11.1342 +       the fixes elements in raw_elemss,
 11.1343 +       raw_proppss contains assumptions and definitions from the
 11.1344 +       external elements in raw_elemss. *)
 11.1345 +    fun prep_prop raw_propp (raw_ctxt, raw_concl)  =
 11.1346 +      let
 11.1347 +        (* CB: add type information from fixed_params to context (declare_term) *)
 11.1348 +        (* CB: process patterns (conclusion and external elements only) *)
 11.1349 +        val (ctxt, all_propp) =
 11.1350 +          prepp (fold Variable.declare_term (map Free fixed_params) raw_ctxt, raw_concl @ raw_propp);
 11.1351 +        (* CB: add type information from conclusion and external elements to context *)
 11.1352 +        val ctxt = fold Variable.declare_term (maps (map fst) all_propp) ctxt;
 11.1353 +        (* CB: resolve schematic variables (patterns) in conclusion and external elements. *)
 11.1354 +        val all_propp' = map2 (curry (op ~~))
 11.1355 +          (#1 (#2 (ProofContext.bind_propp_schematic_i (ctxt, all_propp)))) (map (map snd) all_propp);
 11.1356 +        val (concl, propp) = chop (length raw_concl) all_propp';
 11.1357 +      in (propp, (ctxt, concl)) end
 11.1358 +
 11.1359 +    val (proppss, (ctxt, concl)) =
 11.1360 +      (fold_burrow o fold_burrow) prep_prop raw_proppss (raw_ctxt, raw_concl);
 11.1361 +
 11.1362 +    (* CB: obtain all parameters from identifier part of raw_elemss *)
 11.1363 +    val xs = map #1 (params_of' raw_elemss);
 11.1364 +    val typing = unify_frozen ctxt 0
 11.1365 +      (map (Variable.default_type raw_ctxt) xs)
 11.1366 +      (map (Variable.default_type ctxt) xs);
 11.1367 +    val parms = param_types (xs ~~ typing);
 11.1368 +    (* CB: parms are the parameters from raw_elemss, with correct typing. *)
 11.1369 +
 11.1370 +    (* CB: extract information from assumes and defines elements
 11.1371 +       (fixes, constrains and notes in raw_elemss don't have an effect on
 11.1372 +       text and elemss), compute final form of context elements. *)
 11.1373 +    val ((text, _), elemss) = finish_elemss ctxt parms do_close
 11.1374 +      ((((([], []), ([], [])), ([], [], [])), []), raw_elemss ~~ proppss);
 11.1375 +    (* CB: text has the following structure:
 11.1376 +           (((exts, exts'), (ints, ints')), (xs, env, defs))
 11.1377 +       where
 11.1378 +         exts: external assumptions (terms in external assumes elements)
 11.1379 +         exts': dito, normalised wrt. env
 11.1380 +         ints: internal assumptions (terms in internal assumes elements)
 11.1381 +         ints': dito, normalised wrt. env
 11.1382 +         xs: the free variables in exts' and ints' and rhss of definitions,
 11.1383 +           this includes parameters except defined parameters
 11.1384 +         env: list of term pairs encoding substitutions, where the first term
 11.1385 +           is a free variable; substitutions represent defines elements and
 11.1386 +           the rhs is normalised wrt. the previous env
 11.1387 +         defs: theorems representing the substitutions from defines elements
 11.1388 +           (thms are normalised wrt. env).
 11.1389 +       elemss is an updated version of raw_elemss:
 11.1390 +         - type info added to Fixes and modified in Constrains
 11.1391 +         - axiom and definition statement replaced by corresponding one
 11.1392 +           from proppss in Assumes and Defines
 11.1393 +         - Facts unchanged
 11.1394 +       *)
 11.1395 +  in ((parms, elemss, concl), text) end;
 11.1396 +
 11.1397 +in
 11.1398 +
 11.1399 +fun read_elemss x = prep_elemss ProofContext.read_vars ProofContext.read_propp_schematic x;
 11.1400 +fun cert_elemss x = prep_elemss ProofContext.cert_vars ProofContext.cert_propp_schematic x;
 11.1401 +
 11.1402 +end;
 11.1403 +
 11.1404 +
 11.1405 +(* facts and attributes *)
 11.1406 +
 11.1407 +local
 11.1408 +
 11.1409 +fun check_name name =
 11.1410 +  if NameSpace.is_qualified name then error ("Illegal qualified name: " ^ quote name)
 11.1411 +  else name;
 11.1412 +
 11.1413 +fun prep_facts _ _ _ ctxt (Int elem) = elem
 11.1414 +      |> Element.morph_ctxt (Morphism.thm_morphism (Thm.transfer (ProofContext.theory_of ctxt)))
 11.1415 +  | prep_facts prep_name get intern ctxt (Ext elem) = elem |> Element.map_ctxt
 11.1416 +     {var = I, typ = I, term = I,
 11.1417 +      binding = Binding.map_base prep_name,
 11.1418 +      fact = get ctxt,
 11.1419 +      attrib = Args.assignable o intern (ProofContext.theory_of ctxt)};
 11.1420 +
 11.1421 +in
 11.1422 +
 11.1423 +fun read_facts x = prep_facts check_name ProofContext.get_fact Attrib.intern_src x;
 11.1424 +fun cert_facts x = prep_facts I (K I) (K I) x;
 11.1425 +
 11.1426 +end;
 11.1427 +
 11.1428 +
 11.1429 +(* Get the specification of a locale *)
 11.1430 +
 11.1431 +(*The global specification is made from the parameters and global
 11.1432 +  assumptions, the local specification from the parameters and the
 11.1433 +  local assumptions.*)
 11.1434 +
 11.1435 +local
 11.1436 +
 11.1437 +fun gen_asms_of get thy name =
 11.1438 +  let
 11.1439 +    val ctxt = ProofContext.init thy;
 11.1440 +    val (_, raw_elemss) = flatten (ctxt, I) (([], Symtab.empty), Expr (Locale name));
 11.1441 +    val ((_, elemss, _), _) = read_elemss false ctxt [] raw_elemss [];
 11.1442 +  in
 11.1443 +    elemss |> get
 11.1444 +      |> maps (fn (_, es) => map (fn Int e => e) es)
 11.1445 +      |> maps (fn Assumes asms => asms | _ => [])
 11.1446 +      |> map (apsnd (map fst))
 11.1447 +  end;
 11.1448 +
 11.1449 +in
 11.1450 +
 11.1451 +fun parameters_of thy = #params o the_locale thy;
 11.1452 +
 11.1453 +fun intros thy = #intros o the_locale thy;
 11.1454 +  (*returns introduction rule for delta predicate and locale predicate
 11.1455 +    as a pair of singleton lists*)
 11.1456 +
 11.1457 +fun dests thy = #dests o the_locale thy;
 11.1458 +
 11.1459 +fun facts_of thy = map_filter (fn (Element.Notes (_, facts), _) => SOME facts
 11.1460 +  | _ => NONE) o #elems o the_locale thy;
 11.1461 +
 11.1462 +fun parameters_of_expr thy expr =
 11.1463 +  let
 11.1464 +    val ctxt = ProofContext.init thy;
 11.1465 +    val pts = params_of_expr ctxt [] (intern_expr thy expr)
 11.1466 +        ([], Symtab.empty, Symtab.empty);
 11.1467 +    val raw_params_elemss = make_raw_params_elemss pts;
 11.1468 +    val ((_, syn), raw_elemss) = flatten (ctxt, intern_expr thy)
 11.1469 +        (([], Symtab.empty), Expr expr);
 11.1470 +    val ((parms, _, _), _) =
 11.1471 +        read_elemss false ctxt [] (raw_params_elemss @ raw_elemss) [];
 11.1472 +  in map (fn p as (n, _) => (p, Symtab.lookup syn n |> the)) parms end;
 11.1473 +
 11.1474 +fun local_asms_of thy name =
 11.1475 +  gen_asms_of (single o Library.last_elem) thy name;
 11.1476 +
 11.1477 +fun global_asms_of thy name =
 11.1478 +  gen_asms_of I thy name;
 11.1479 +
 11.1480 +end;
 11.1481 +
 11.1482 +
 11.1483 +(* full context statements: imports + elements + conclusion *)
 11.1484 +
 11.1485 +local
 11.1486 +
 11.1487 +fun prep_context_statement prep_expr prep_elemss prep_facts
 11.1488 +    do_close fixed_params imports elements raw_concl context =
 11.1489 +  let
 11.1490 +    val thy = ProofContext.theory_of context;
 11.1491 +
 11.1492 +    val (import_params, import_tenv, import_syn) =
 11.1493 +      params_of_expr context fixed_params (prep_expr thy imports)
 11.1494 +        ([], Symtab.empty, Symtab.empty);
 11.1495 +    val includes = map_filter (fn Expr e => SOME e | Elem _ => NONE) elements;
 11.1496 +    val (incl_params, incl_tenv, incl_syn) = fold (params_of_expr context fixed_params)
 11.1497 +      (map (prep_expr thy) includes) (import_params, import_tenv, import_syn);
 11.1498 +
 11.1499 +    val ((import_ids, _), raw_import_elemss) =
 11.1500 +      flatten (context, prep_expr thy) (([], Symtab.empty), Expr imports);
 11.1501 +    (* CB: normalise "includes" among elements *)
 11.1502 +    val ((ids, syn), raw_elemsss) = foldl_map (flatten (context, prep_expr thy))
 11.1503 +      ((import_ids, incl_syn), elements);
 11.1504 +
 11.1505 +    val raw_elemss = flat raw_elemsss;
 11.1506 +    (* CB: raw_import_elemss @ raw_elemss is the normalised list of
 11.1507 +       context elements obtained from import and elements. *)
 11.1508 +    (* Now additional elements for parameters are inserted. *)
 11.1509 +    val import_params_ids = make_params_ids import_params;
 11.1510 +    val incl_params_ids =
 11.1511 +        make_params_ids (incl_params \\ import_params);
 11.1512 +    val raw_import_params_elemss =
 11.1513 +        make_raw_params_elemss (import_params, incl_tenv, incl_syn);
 11.1514 +    val raw_incl_params_elemss =
 11.1515 +        make_raw_params_elemss (incl_params \\ import_params, incl_tenv, incl_syn);
 11.1516 +    val ((parms, all_elemss, concl), (spec, (_, _, defs))) = prep_elemss do_close
 11.1517 +      context fixed_params
 11.1518 +      (raw_import_params_elemss @ raw_import_elemss @ raw_incl_params_elemss @ raw_elemss) raw_concl;
 11.1519 +
 11.1520 +    (* replace extended ids (for axioms) by ids *)
 11.1521 +    val (import_ids', incl_ids) = chop (length import_ids) ids;
 11.1522 +    val all_ids = import_params_ids @ import_ids' @ incl_params_ids @ incl_ids;
 11.1523 +    val all_elemss' = map (fn (((_, ps), _), (((n, ps'), mode), elems)) =>
 11.1524 +        (((n, map (fn p => (p, (the o AList.lookup (op =) ps') p)) ps), mode), elems))
 11.1525 +      (all_ids ~~ all_elemss);
 11.1526 +    (* CB: all_elemss and parms contain the correct parameter types *)
 11.1527 +
 11.1528 +    val (ps, qs) = chop (length raw_import_params_elemss + length raw_import_elemss) all_elemss';
 11.1529 +    val ((import_elemss, _), import_ctxt) =
 11.1530 +      activate_facts false prep_facts ps context;
 11.1531 +
 11.1532 +    val ((elemss, _), ctxt) =
 11.1533 +      activate_facts false prep_facts qs (ProofContext.set_stmt true import_ctxt);
 11.1534 +  in
 11.1535 +    ((((import_ctxt, import_elemss), (ctxt, elemss, syn)),
 11.1536 +      (parms, spec, defs)), concl)
 11.1537 +  end;
 11.1538 +
 11.1539 +fun prep_statement prep_locale prep_ctxt raw_locale elems concl ctxt =
 11.1540 +  let
 11.1541 +    val thy = ProofContext.theory_of ctxt;
 11.1542 +    val locale = Option.map (prep_locale thy) raw_locale;
 11.1543 +    val (fixed_params, imports) =
 11.1544 +      (case locale of
 11.1545 +        NONE => ([], empty)
 11.1546 +      | SOME name =>
 11.1547 +          let val {params = ps, ...} = the_locale thy name
 11.1548 +          in (map fst ps, Locale name) end);
 11.1549 +    val ((((locale_ctxt, _), (elems_ctxt, _, _)), _), concl') =
 11.1550 +      prep_ctxt false fixed_params imports (map Elem elems) concl ctxt;
 11.1551 +  in (locale, locale_ctxt, elems_ctxt, concl') end;
 11.1552 +
 11.1553 +fun prep_expr prep imports body ctxt =
 11.1554 +  let
 11.1555 +    val (((_, import_elemss), (ctxt', elemss, _)), _) = prep imports body ctxt;
 11.1556 +    val all_elems = maps snd (import_elemss @ elemss);
 11.1557 +  in (all_elems, ctxt') end;
 11.1558 +
 11.1559 +in
 11.1560 +
 11.1561 +val read_ctxt = prep_context_statement intern_expr read_elemss read_facts;
 11.1562 +val cert_ctxt = prep_context_statement (K I) cert_elemss cert_facts;
 11.1563 +
 11.1564 +fun read_context imports body ctxt = #1 (read_ctxt true [] imports (map Elem body) [] ctxt);
 11.1565 +fun cert_context imports body ctxt = #1 (cert_ctxt true [] imports (map Elem body) [] ctxt);
 11.1566 +
 11.1567 +val read_expr = prep_expr read_context;
 11.1568 +val cert_expr = prep_expr cert_context;
 11.1569 +
 11.1570 +fun read_context_statement loc = prep_statement (K I) read_ctxt loc;
 11.1571 +fun read_context_statement_cmd loc = prep_statement intern read_ctxt loc;
 11.1572 +fun cert_context_statement loc = prep_statement (K I) cert_ctxt loc;
 11.1573 +
 11.1574 +end;
 11.1575 +
 11.1576 +
 11.1577 +(* init *)
 11.1578 +
 11.1579 +fun init loc =
 11.1580 +  ProofContext.init
 11.1581 +  #> #2 o cert_context_statement (SOME loc) [] [];
 11.1582 +
 11.1583 +
 11.1584 +(* print locale *)
 11.1585 +
 11.1586 +fun print_locale thy show_facts imports body =
 11.1587 +  let val (all_elems, ctxt) = read_expr imports body (ProofContext.init thy) in
 11.1588 +    Pretty.big_list "locale elements:" (all_elems
 11.1589 +      |> (if show_facts then I else filter (fn Notes _ => false | _ => true))
 11.1590 +      |> map (Element.pretty_ctxt ctxt) |> filter_out null
 11.1591 +      |> map Pretty.chunks)
 11.1592 +    |> Pretty.writeln
 11.1593 +  end;
 11.1594 +
 11.1595 +
 11.1596 +
 11.1597 +(** store results **)
 11.1598 +
 11.1599 +(* join equations of an id with already accumulated ones *)
 11.1600 +
 11.1601 +fun join_eqns get_reg id eqns =
 11.1602 +  let
 11.1603 +    val eqns' = case get_reg id
 11.1604 +      of NONE => eqns
 11.1605 +        | SOME (_, _, eqns') => Termtab.join (fn _ => fn (_, e) => e) (eqns, eqns')
 11.1606 +            (* prefer equations from eqns' *)
 11.1607 +  in ((id, eqns'), eqns') end;
 11.1608 +
 11.1609 +
 11.1610 +(* collect witnesses and equations up to a particular target for a
 11.1611 +   registration; requires parameters and flattened list of identifiers
 11.1612 +   instead of recomputing it from the target *)
 11.1613 +
 11.1614 +fun collect_witnesses ctxt (imprt as ((impT, _), (imp, _))) parms ids ext_ts = let
 11.1615 +
 11.1616 +    val thy = ProofContext.theory_of ctxt;
 11.1617 +
 11.1618 +    val ts = map (var_inst_term (impT, imp)) ext_ts;
 11.1619 +    val (parms, parmTs) = split_list parms;
 11.1620 +    val parmvTs = map Logic.varifyT parmTs;
 11.1621 +    val vtinst = fold (Sign.typ_match thy) (parmvTs ~~ map Term.fastype_of ts) Vartab.empty;
 11.1622 +    val tinst = Vartab.dest vtinst |> map (fn ((x, 0), (_, T)) => (x, T))
 11.1623 +        |> Symtab.make;
 11.1624 +    val inst = Symtab.make (parms ~~ ts);
 11.1625 +
 11.1626 +    (* instantiate parameter names in ids *)
 11.1627 +    val ext_inst = Symtab.make (parms ~~ ext_ts);
 11.1628 +    fun ext_inst_names ps = map (the o Symtab.lookup ext_inst) ps;
 11.1629 +    val inst_ids = map (apfst (apsnd ext_inst_names)) ids;
 11.1630 +    val assumed_ids = map_filter (fn (id, (_, Assumed _)) => SOME id | _ => NONE) inst_ids;
 11.1631 +    val wits = maps (#2 o the o get_local_registration ctxt imprt) assumed_ids;
 11.1632 +    val eqns =
 11.1633 +      fold_map (join_eqns (get_local_registration ctxt imprt))
 11.1634 +        (map fst inst_ids) Termtab.empty |> snd |> Termtab.dest |> map snd;
 11.1635 +  in ((tinst, inst), wits, eqns) end;
 11.1636 +
 11.1637 +
 11.1638 +(* compute and apply morphism *)
 11.1639 +
 11.1640 +fun name_morph phi_name (lprfx, pprfx) b =
 11.1641 +  b
 11.1642 +  |> (if not (Binding.is_empty b) andalso pprfx <> ""
 11.1643 +        then Binding.add_prefix false pprfx else I)
 11.1644 +  |> (if not (Binding.is_empty b)
 11.1645 +        then Binding.add_prefix false lprfx else I)
 11.1646 +  |> phi_name;
 11.1647 +
 11.1648 +fun inst_morph thy phi_name param_prfx insts prems eqns export =
 11.1649 +  let
 11.1650 +    (* standardise export morphism *)
 11.1651 +    val exp_fact = Drule.zero_var_indexes_list o map Thm.strip_shyps o Morphism.fact export;
 11.1652 +    val exp_term = TermSubst.zero_var_indexes o Morphism.term export;
 11.1653 +      (* FIXME sync with exp_fact *)
 11.1654 +    val exp_typ = Logic.type_map exp_term;
 11.1655 +    val export' =
 11.1656 +      Morphism.morphism {binding = I, var = I, typ = exp_typ, term = exp_term, fact = exp_fact};
 11.1657 +  in
 11.1658 +    Morphism.binding_morphism (name_morph phi_name param_prfx) $>
 11.1659 +      Element.inst_morphism thy insts $>
 11.1660 +      Element.satisfy_morphism prems $>
 11.1661 +      Morphism.term_morphism (MetaSimplifier.rewrite_term thy eqns []) $>
 11.1662 +      Morphism.thm_morphism (MetaSimplifier.rewrite_rule eqns) $>
 11.1663 +      export'
 11.1664 +  end;
 11.1665 +
 11.1666 +fun activate_note thy phi_name param_prfx attrib insts prems eqns exp =
 11.1667 +  (Element.facts_map o Element.morph_ctxt)
 11.1668 +      (inst_morph thy phi_name param_prfx insts prems eqns exp)
 11.1669 +  #> Attrib.map_facts attrib;
 11.1670 +
 11.1671 +
 11.1672 +(* public interface to interpretation morphism *)
 11.1673 +
 11.1674 +fun get_interpret_morph thy phi_name param_prfx (exp, imp) target ext_ts =
 11.1675 +  let
 11.1676 +    val parms = the_locale thy target |> #params |> map fst;
 11.1677 +    val ids = flatten (ProofContext.init thy, intern_expr thy)
 11.1678 +      (([], Symtab.empty), Expr (Locale target)) |> fst |> fst;
 11.1679 +    val (insts, prems, eqns) = collect_witnesses (ProofContext.init thy) imp parms ids ext_ts;
 11.1680 +  in
 11.1681 +    inst_morph thy phi_name param_prfx insts prems eqns exp
 11.1682 +  end;
 11.1683 +
 11.1684 +(* store instantiations of args for all registered interpretations
 11.1685 +   of the theory *)
 11.1686 +
 11.1687 +fun note_thmss_registrations target (kind, args) thy =
 11.1688 +  let
 11.1689 +    val parms = the_locale thy target |> #params |> map fst;
 11.1690 +    val ids = flatten (ProofContext.init thy, intern_expr thy)
 11.1691 +      (([], Symtab.empty), Expr (Locale target)) |> fst |> fst;
 11.1692 +
 11.1693 +    val regs = get_global_registrations thy target;
 11.1694 +    (* add args to thy for all registrations *)
 11.1695 +
 11.1696 +    fun activate (ext_ts, ((phi_name, param_prfx), (exp, imp), _, _)) thy =
 11.1697 +      let
 11.1698 +        val (insts, prems, eqns) = collect_witnesses (ProofContext.init thy) imp parms ids ext_ts;
 11.1699 +        val args' = args
 11.1700 +          |> activate_note thy phi_name param_prfx
 11.1701 +               (Attrib.attribute_i thy) insts prems eqns exp;
 11.1702 +      in
 11.1703 +        thy
 11.1704 +        |> global_note_qualified kind args'
 11.1705 +        |> snd
 11.1706 +      end;
 11.1707 +  in fold activate regs thy end;
 11.1708 +
 11.1709 +
 11.1710 +(* locale results *)
 11.1711 +
 11.1712 +fun add_thmss loc kind args ctxt =
 11.1713 +  let
 11.1714 +    val (([(_, [Notes args'])], _), ctxt') =
 11.1715 +      activate_facts true cert_facts
 11.1716 +        [((("", []), Assumed []), [Ext (Notes (kind, args))])] ctxt;
 11.1717 +    val ctxt'' = ctxt' |> ProofContext.theory
 11.1718 +      (change_locale loc
 11.1719 +        (fn (axiom, elems, params, decls, regs, intros, dests) =>
 11.1720 +          (axiom, elems @ [(Notes args', stamp ())],
 11.1721 +            params, decls, regs, intros, dests))
 11.1722 +      #> note_thmss_registrations loc args');
 11.1723 +  in ctxt'' end;
 11.1724 +
 11.1725 +
 11.1726 +(* declarations *)
 11.1727 +
 11.1728 +local
 11.1729 +
 11.1730 +fun decl_attrib decl phi = Thm.declaration_attribute (K (decl phi));
 11.1731 +
 11.1732 +fun add_decls add loc decl =
 11.1733 +  ProofContext.theory (change_locale loc
 11.1734 +    (fn (axiom, elems, params, decls, regs, intros, dests) =>
 11.1735 +      (axiom, elems, params, add (decl, stamp ()) decls, regs, intros, dests))) #>
 11.1736 +  add_thmss loc Thm.internalK
 11.1737 +    [((Binding.empty, [Attrib.internal (decl_attrib decl)]), [([Drule.dummy_thm], [])])];
 11.1738 +
 11.1739 +in
 11.1740 +
 11.1741 +val add_type_syntax = add_decls (apfst o cons);
 11.1742 +val add_term_syntax = add_decls (apsnd o cons);
 11.1743 +val add_declaration = add_decls (K I);
 11.1744 +
 11.1745 +fun declarations_of thy loc =
 11.1746 +  the_locale thy loc |> #decls |> apfst (map fst) |> apsnd (map fst);
 11.1747 +
 11.1748 +end;
 11.1749 +
 11.1750 +
 11.1751 +
 11.1752 +(** define locales **)
 11.1753 +
 11.1754 +(* predicate text *)
 11.1755 +(* CB: generate locale predicates and delta predicates *)
 11.1756 +
 11.1757 +local
 11.1758 +
 11.1759 +(* introN: name of theorems for introduction rules of locale and
 11.1760 +     delta predicates;
 11.1761 +   axiomsN: name of theorem set with destruct rules for locale predicates,
 11.1762 +     also name suffix of delta predicates. *)
 11.1763 +
 11.1764 +val introN = "intro";
 11.1765 +val axiomsN = "axioms";
 11.1766 +
 11.1767 +fun atomize_spec thy ts =
 11.1768 +  let
 11.1769 +    val t = Logic.mk_conjunction_balanced ts;
 11.1770 +    val body = ObjectLogic.atomize_term thy t;
 11.1771 +    val bodyT = Term.fastype_of body;
 11.1772 +  in
 11.1773 +    if bodyT = propT then (t, propT, Thm.reflexive (Thm.cterm_of thy t))
 11.1774 +    else (body, bodyT, ObjectLogic.atomize (Thm.cterm_of thy t))
 11.1775 +  end;
 11.1776 +
 11.1777 +fun aprop_tr' n c = (Syntax.constN ^ c, fn ctxt => fn args =>
 11.1778 +  if length args = n then
 11.1779 +    Syntax.const "_aprop" $
 11.1780 +      Term.list_comb (Syntax.free (Consts.extern (ProofContext.consts_of ctxt) c), args)
 11.1781 +  else raise Match);
 11.1782 +
 11.1783 +(* CB: define one predicate including its intro rule and axioms
 11.1784 +   - bname: predicate name
 11.1785 +   - parms: locale parameters
 11.1786 +   - defs: thms representing substitutions from defines elements
 11.1787 +   - ts: terms representing locale assumptions (not normalised wrt. defs)
 11.1788 +   - norm_ts: terms representing locale assumptions (normalised wrt. defs)
 11.1789 +   - thy: the theory
 11.1790 +*)
 11.1791 +
 11.1792 +fun def_pred bname parms defs ts norm_ts thy =
 11.1793 +  let
 11.1794 +    val name = Sign.full_bname thy bname;
 11.1795 +
 11.1796 +    val (body, bodyT, body_eq) = atomize_spec thy norm_ts;
 11.1797 +    val env = Term.add_free_names body [];
 11.1798 +    val xs = filter (member (op =) env o #1) parms;
 11.1799 +    val Ts = map #2 xs;
 11.1800 +    val extraTs =
 11.1801 +      (Term.add_tfrees body [] \\ fold Term.add_tfreesT Ts [])
 11.1802 +      |> Library.sort_wrt #1 |> map TFree;
 11.1803 +    val predT = map Term.itselfT extraTs ---> Ts ---> bodyT;
 11.1804 +
 11.1805 +    val args = map Logic.mk_type extraTs @ map Free xs;
 11.1806 +    val head = Term.list_comb (Const (name, predT), args);
 11.1807 +    val statement = ObjectLogic.ensure_propT thy head;
 11.1808 +
 11.1809 +    val ([pred_def], defs_thy) =
 11.1810 +      thy
 11.1811 +      |> bodyT = propT ? Sign.add_advanced_trfuns ([], [], [aprop_tr' (length args) name], [])
 11.1812 +      |> Sign.declare_const [] ((Binding.name bname, predT), NoSyn) |> snd
 11.1813 +      |> PureThy.add_defs false
 11.1814 +        [((Thm.def_name bname, Logic.mk_equals (head, body)), [Thm.kind_internal])];
 11.1815 +    val defs_ctxt = ProofContext.init defs_thy |> Variable.declare_term head;
 11.1816 +
 11.1817 +    val cert = Thm.cterm_of defs_thy;
 11.1818 +
 11.1819 +    val intro = Goal.prove_global defs_thy [] norm_ts statement (fn _ =>
 11.1820 +      MetaSimplifier.rewrite_goals_tac [pred_def] THEN
 11.1821 +      Tactic.compose_tac (false, body_eq RS Drule.equal_elim_rule1, 1) 1 THEN
 11.1822 +      Tactic.compose_tac (false,
 11.1823 +        Conjunction.intr_balanced (map (Thm.assume o cert) norm_ts), 0) 1);
 11.1824 +
 11.1825 +    val conjuncts =
 11.1826 +      (Drule.equal_elim_rule2 OF [body_eq,
 11.1827 +        MetaSimplifier.rewrite_rule [pred_def] (Thm.assume (cert statement))])
 11.1828 +      |> Conjunction.elim_balanced (length ts);
 11.1829 +    val axioms = ts ~~ conjuncts |> map (fn (t, ax) =>
 11.1830 +      Element.prove_witness defs_ctxt t
 11.1831 +       (MetaSimplifier.rewrite_goals_tac defs THEN
 11.1832 +        Tactic.compose_tac (false, ax, 0) 1));
 11.1833 +  in ((statement, intro, axioms), defs_thy) end;
 11.1834 +
 11.1835 +fun assumes_to_notes (Assumes asms) axms =
 11.1836 +      fold_map (fn (a, spec) => fn axs =>
 11.1837 +          let val (ps, qs) = chop (length spec) axs
 11.1838 +          in ((a, [(ps, [])]), qs) end) asms axms
 11.1839 +      |> apfst (curry Notes Thm.assumptionK)
 11.1840 +  | assumes_to_notes e axms = (e, axms);
 11.1841 +
 11.1842 +(* CB: the following two change only "new" elems, these have identifier ("", _). *)
 11.1843 +
 11.1844 +(* turn Assumes into Notes elements *)
 11.1845 +
 11.1846 +fun change_assumes_elemss axioms elemss =
 11.1847 +  let
 11.1848 +    val satisfy = Element.morph_ctxt (Element.satisfy_morphism axioms);
 11.1849 +    fun change (id as ("", _), es) =
 11.1850 +          fold_map assumes_to_notes (map satisfy es)
 11.1851 +          #-> (fn es' => pair (id, es'))
 11.1852 +      | change e = pair e;
 11.1853 +  in
 11.1854 +    fst (fold_map change elemss (map Element.conclude_witness axioms))
 11.1855 +  end;
 11.1856 +
 11.1857 +(* adjust hyps of Notes elements *)
 11.1858 +
 11.1859 +fun change_elemss_hyps axioms elemss =
 11.1860 +  let
 11.1861 +    val satisfy = Element.morph_ctxt (Element.satisfy_morphism axioms);
 11.1862 +    fun change (id as ("", _), es) = (id, map (fn e as Notes _ => satisfy e | e => e) es)
 11.1863 +      | change e = e;
 11.1864 +  in map change elemss end;
 11.1865 +
 11.1866 +in
 11.1867 +
 11.1868 +(* CB: main predicate definition function *)
 11.1869 +
 11.1870 +fun define_preds pname (parms, ((exts, exts'), (ints, ints')), defs) elemss thy =
 11.1871 +  let
 11.1872 +    val ((elemss', more_ts), a_elem, a_intro, thy'') =
 11.1873 +      if null exts then ((elemss, []), [], [], thy)
 11.1874 +      else
 11.1875 +        let
 11.1876 +          val aname = if null ints then pname else pname ^ "_" ^ axiomsN;
 11.1877 +          val ((statement, intro, axioms), thy') =
 11.1878 +            thy
 11.1879 +            |> def_pred aname parms defs exts exts';
 11.1880 +          val elemss' = change_assumes_elemss axioms elemss;
 11.1881 +          val a_elem = [(("", []),
 11.1882 +            [Assumes [((Binding.name (pname ^ "_" ^ axiomsN), []), [(statement, [])])]])];
 11.1883 +          val (_, thy'') =
 11.1884 +            thy'
 11.1885 +            |> Sign.add_path aname
 11.1886 +            |> Sign.no_base_names
 11.1887 +            |> PureThy.note_thmss Thm.internalK [((Binding.name introN, []), [([intro], [])])]
 11.1888 +            ||> Sign.restore_naming thy';
 11.1889 +        in ((elemss', [statement]), a_elem, [intro], thy'') end;
 11.1890 +    val (predicate, stmt', elemss'', b_intro, thy'''') =
 11.1891 +      if null ints then (([], []), more_ts, elemss' @ a_elem, [], thy'')
 11.1892 +      else
 11.1893 +        let
 11.1894 +          val ((statement, intro, axioms), thy''') =
 11.1895 +            thy''
 11.1896 +            |> def_pred pname parms defs (ints @ more_ts) (ints' @ more_ts);
 11.1897 +          val cstatement = Thm.cterm_of thy''' statement;
 11.1898 +          val elemss'' = change_elemss_hyps axioms elemss';
 11.1899 +          val b_elem = [(("", []),
 11.1900 +               [Assumes [((Binding.name (pname ^ "_" ^ axiomsN), []), [(statement, [])])]])];
 11.1901 +          val (_, thy'''') =
 11.1902 +            thy'''
 11.1903 +            |> Sign.add_path pname
 11.1904 +            |> Sign.no_base_names
 11.1905 +            |> PureThy.note_thmss Thm.internalK
 11.1906 +                 [((Binding.name introN, []), [([intro], [])]),
 11.1907 +                  ((Binding.name axiomsN, []),
 11.1908 +                    [(map (Drule.standard o Element.conclude_witness) axioms, [])])]
 11.1909 +            ||> Sign.restore_naming thy''';
 11.1910 +        in (([cstatement], axioms), [statement], elemss'' @ b_elem, [intro], thy'''') end;
 11.1911 +  in (((elemss'', predicate, stmt'), (a_intro, b_intro)), thy'''') end;
 11.1912 +
 11.1913 +end;
 11.1914 +
 11.1915 +
 11.1916 +(* add_locale(_i) *)
 11.1917 +
 11.1918 +local
 11.1919 +
 11.1920 +(* turn Defines into Notes elements, accumulate definition terms *)
 11.1921 +
 11.1922 +fun defines_to_notes is_ext thy (Defines defs) defns =
 11.1923 +    let
 11.1924 +      val defs' = map (fn (_, (def, _)) => (Attrib.empty_binding, (def, []))) defs
 11.1925 +      val notes = map (fn (a, (def, _)) =>
 11.1926 +        (a, [([assume (cterm_of thy def)], [])])) defs
 11.1927 +    in
 11.1928 +      (if is_ext then SOME (Notes (Thm.definitionK, notes)) else NONE, defns @ [Defines defs'])
 11.1929 +    end
 11.1930 +  | defines_to_notes _ _ e defns = (SOME e, defns);
 11.1931 +
 11.1932 +fun change_defines_elemss thy elemss defns =
 11.1933 +  let
 11.1934 +    fun change (id as (n, _), es) defns =
 11.1935 +        let
 11.1936 +          val (es', defns') = fold_map (defines_to_notes (n="") thy) es defns
 11.1937 +        in ((id, map_filter I es'), defns') end
 11.1938 +  in fold_map change elemss defns end;
 11.1939 +
 11.1940 +fun gen_add_locale prep_ctxt prep_expr
 11.1941 +    predicate_name bname raw_imports raw_body thy =
 11.1942 +    (* predicate_name: "" - locale with predicate named as locale
 11.1943 +        "name" - locale with predicate named "name" *)
 11.1944 +  let
 11.1945 +    val thy_ctxt = ProofContext.init thy;
 11.1946 +    val name = Sign.full_bname thy bname;
 11.1947 +    val _ = is_some (get_locale thy name) andalso
 11.1948 +      error ("Duplicate definition of locale " ^ quote name);
 11.1949 +
 11.1950 +    val (((import_ctxt, import_elemss), (body_ctxt, body_elemss, syn)),
 11.1951 +      text as (parms, ((_, exts'), _), defs)) =
 11.1952 +        prep_ctxt raw_imports raw_body thy_ctxt;
 11.1953 +    val elemss = import_elemss @ body_elemss |>
 11.1954 +      map_filter (fn ((id, Assumed axs), elems) => SOME (id, elems) | _ => NONE);
 11.1955 +
 11.1956 +    val extraTs = List.foldr OldTerm.add_term_tfrees [] exts' \\
 11.1957 +      List.foldr OldTerm.add_typ_tfrees [] (map snd parms);
 11.1958 +    val _ = if null extraTs then ()
 11.1959 +      else warning ("Additional type variable(s) in locale specification " ^ quote bname);
 11.1960 +
 11.1961 +    val predicate_name' = case predicate_name of "" => bname | _ => predicate_name;
 11.1962 +    val (elemss', defns) = change_defines_elemss thy elemss [];
 11.1963 +    val elemss'' = elemss' @ [(("", []), defns)];
 11.1964 +    val (((elemss''', predicate as (pred_statement, pred_axioms), stmt'), intros), thy') =
 11.1965 +      define_preds predicate_name' text elemss'' thy;
 11.1966 +    val regs = pred_axioms
 11.1967 +      |> fold_map (fn (id, elems) => fn wts => let
 11.1968 +             val ts = flat (map_filter (fn (Assumes asms) =>
 11.1969 +               SOME (maps (map #1 o #2) asms) | _ => NONE) elems);
 11.1970 +             val (wts1, wts2) = chop (length ts) wts;
 11.1971 +           in ((apsnd (map fst) id, wts1), wts2) end) elemss'''
 11.1972 +      |> fst
 11.1973 +      |> map_filter (fn (("", _), _) => NONE | e => SOME e);
 11.1974 +    fun axiomify axioms elemss =
 11.1975 +      (axioms, elemss) |> foldl_map (fn (axs, (id, elems)) => let
 11.1976 +                   val ts = flat (map_filter (fn (Assumes asms) =>
 11.1977 +                     SOME (maps (map #1 o #2) asms) | _ => NONE) elems);
 11.1978 +                   val (axs1, axs2) = chop (length ts) axs;
 11.1979 +                 in (axs2, ((id, Assumed axs1), elems)) end)
 11.1980 +      |> snd;
 11.1981 +    val ((_, facts), ctxt) = activate_facts true (K I)
 11.1982 +      (axiomify pred_axioms elemss''') (ProofContext.init thy');
 11.1983 +    val view_ctxt = Assumption.add_view thy_ctxt pred_statement ctxt;
 11.1984 +    val export = Thm.close_derivation o Goal.norm_result o
 11.1985 +      singleton (ProofContext.export view_ctxt thy_ctxt);
 11.1986 +    val facts' = facts |> map (fn (a, ths) => ((a, []), [(map export ths, [])]));
 11.1987 +    val elems' = maps #2 (filter (fn ((s, _), _) => s = "") elemss''');
 11.1988 +    val elems'' = map_filter (fn (Fixes _) => NONE | e => SOME e) elems';
 11.1989 +    val axs' = map (Element.assume_witness thy') stmt';
 11.1990 +    val loc_ctxt = thy'
 11.1991 +      |> Sign.add_path bname
 11.1992 +      |> Sign.no_base_names
 11.1993 +      |> PureThy.note_thmss Thm.assumptionK facts' |> snd
 11.1994 +      |> Sign.restore_naming thy'
 11.1995 +      |> register_locale bname {axiom = axs',
 11.1996 +        elems = map (fn e => (e, stamp ())) elems'',
 11.1997 +        params = params_of elemss''' |> map (fn (x, SOME T) => ((x, T), the (Symtab.lookup syn x))),
 11.1998 +        decls = ([], []),
 11.1999 +        regs = regs,
 11.2000 +        intros = intros,
 11.2001 +        dests = map Element.conclude_witness pred_axioms}
 11.2002 +      |> init name;
 11.2003 +  in (name, loc_ctxt) end;
 11.2004 +
 11.2005 +in
 11.2006 +
 11.2007 +val add_locale = gen_add_locale cert_context (K I);
 11.2008 +val add_locale_cmd = gen_add_locale read_context intern_expr "";
 11.2009 +
 11.2010 +end;
 11.2011 +
 11.2012 +val _ = Context.>> (Context.map_theory
 11.2013 + (add_locale "" "var" empty [Fixes [(Binding.name (Name.internal "x"), NONE, NoSyn)]] #>
 11.2014 +  snd #> ProofContext.theory_of #>
 11.2015 +  add_locale "" "struct" empty [Fixes [(Binding.name (Name.internal "S"), NONE, Structure)]] #>
 11.2016 +  snd #> ProofContext.theory_of));
 11.2017 +
 11.2018 +
 11.2019 +
 11.2020 +
 11.2021 +(** Normalisation of locale statements ---
 11.2022 +    discharges goals implied by interpretations **)
 11.2023 +
 11.2024 +local
 11.2025 +
 11.2026 +fun locale_assm_intros thy =
 11.2027 +  Symtab.fold (fn (_, {intros = (a, _), ...}) => fn intros => (a @ intros))
 11.2028 +    (#2 (LocalesData.get thy)) [];
 11.2029 +fun locale_base_intros thy =
 11.2030 +  Symtab.fold (fn (_, {intros = (_, b), ...}) => fn intros => (b @ intros))
 11.2031 +    (#2 (LocalesData.get thy)) [];
 11.2032 +
 11.2033 +fun all_witnesses ctxt =
 11.2034 +  let
 11.2035 +    val thy = ProofContext.theory_of ctxt;
 11.2036 +    fun get registrations = Symtab.fold (fn (_, regs) => fn thms =>
 11.2037 +        (Registrations.dest thy regs |> map (fn (_, (_, (exp, _), wits, _)) =>
 11.2038 +          map (Element.conclude_witness #> Morphism.thm exp) wits) |> flat) @ thms)
 11.2039 +      registrations [];
 11.2040 +  in get (RegistrationsData.get (Context.Proof ctxt)) end;
 11.2041 +
 11.2042 +in
 11.2043 +
 11.2044 +fun intro_locales_tac eager ctxt facts st =
 11.2045 +  let
 11.2046 +    val wits = all_witnesses ctxt;
 11.2047 +    val thy = ProofContext.theory_of ctxt;
 11.2048 +    val intros = locale_base_intros thy @ (if eager then locale_assm_intros thy else []);
 11.2049 +  in
 11.2050 +    Method.intros_tac (wits @ intros) facts st
 11.2051 +  end;
 11.2052 +
 11.2053 +end;
 11.2054 +
 11.2055 +
 11.2056 +(** Interpretation commands **)
 11.2057 +
 11.2058 +local
 11.2059 +
 11.2060 +(* extract proof obligations (assms and defs) from elements *)
 11.2061 +
 11.2062 +fun extract_asms_elems ((id, Assumed _), elems) = (id, maps Element.prems_of elems)
 11.2063 +  | extract_asms_elems ((id, Derived _), _) = (id, []);
 11.2064 +
 11.2065 +
 11.2066 +(* activate instantiated facts in theory or context *)
 11.2067 +
 11.2068 +fun gen_activate_facts_elemss mk_ctxt note attrib put_reg add_wit add_eqn
 11.2069 +        phi_name all_elemss pss propss eq_attns (exp, imp) thmss thy_ctxt =
 11.2070 +  let
 11.2071 +    val ctxt = mk_ctxt thy_ctxt;
 11.2072 +    fun get_reg thy_ctxt = get_local_registration (mk_ctxt thy_ctxt);
 11.2073 +    fun test_reg thy_ctxt = test_local_registration (mk_ctxt thy_ctxt);
 11.2074 +
 11.2075 +    val (all_propss, eq_props) = chop (length all_elemss) propss;
 11.2076 +    val (all_thmss, eq_thms) = chop (length all_elemss) thmss;
 11.2077 +
 11.2078 +    (* Filter out fragments already registered. *)
 11.2079 +
 11.2080 +    val (new_elemss, xs) = split_list (filter_out (fn (((id, _), _), _) =>
 11.2081 +          test_reg thy_ctxt id) (all_elemss ~~ (pss ~~ (all_propss ~~ all_thmss))));
 11.2082 +    val (new_pss, ys) = split_list xs;
 11.2083 +    val (new_propss, new_thmss) = split_list ys;
 11.2084 +
 11.2085 +    val thy_ctxt' = thy_ctxt
 11.2086 +      (* add registrations *)
 11.2087 +      |> fold2 (fn ((id as (loc, _), _), _) => fn ps => put_reg id (phi_name, param_prefix loc ps) (exp, imp))
 11.2088 +           new_elemss new_pss
 11.2089 +      (* add witnesses of Assumed elements (only those generate proof obligations) *)
 11.2090 +      |> fold2 (fn (id, _) => fold (add_wit id)) new_propss new_thmss
 11.2091 +      (* add equations *)
 11.2092 +      |> fold2 (fn (id, _) => fold (add_eqn id)) eq_props
 11.2093 +          ((map o map) (Drule.abs_def o LocalDefs.meta_rewrite_rule ctxt o
 11.2094 +            Element.conclude_witness) eq_thms);
 11.2095 +
 11.2096 +    val prems = flat (map_filter
 11.2097 +          (fn ((id, Assumed _), _) => Option.map #2 (get_reg thy_ctxt' imp id)
 11.2098 +            | ((_, Derived _), _) => NONE) all_elemss);
 11.2099 +
 11.2100 +    val thy_ctxt'' = thy_ctxt'
 11.2101 +      (* add witnesses of Derived elements *)
 11.2102 +      |> fold (fn (id, thms) => fold
 11.2103 +           (add_wit id o Element.morph_witness (Element.satisfy_morphism prems)) thms)
 11.2104 +         (map_filter (fn ((_, Assumed _), _) => NONE
 11.2105 +            | ((id, Derived thms), _) => SOME (id, thms)) new_elemss)
 11.2106 +
 11.2107 +    fun activate_elem phi_name param_prfx insts prems eqns exp (Notes (kind, facts)) thy_ctxt =
 11.2108 +        let
 11.2109 +          val ctxt = mk_ctxt thy_ctxt;
 11.2110 +          val thy = ProofContext.theory_of ctxt;
 11.2111 +          val facts' = facts
 11.2112 +            |> activate_note thy phi_name param_prfx
 11.2113 +                 (attrib thy_ctxt) insts prems eqns exp;
 11.2114 +        in 
 11.2115 +          thy_ctxt
 11.2116 +          |> note kind facts'
 11.2117 +          |> snd
 11.2118 +        end
 11.2119 +      | activate_elem _ _ _ _ _ _ _ thy_ctxt = thy_ctxt;
 11.2120 +
 11.2121 +    fun activate_elems (((loc, ext_ts), _), _) ps thy_ctxt =
 11.2122 +      let
 11.2123 +        val ctxt = mk_ctxt thy_ctxt;
 11.2124 +        val thy = ProofContext.theory_of ctxt;
 11.2125 +        val {params, elems, ...} = the_locale thy loc;
 11.2126 +        val parms = map fst params;
 11.2127 +        val param_prfx = param_prefix loc ps;
 11.2128 +        val ids = flatten (ProofContext.init thy, intern_expr thy)
 11.2129 +          (([], Symtab.empty), Expr (Locale loc)) |> fst |> fst;
 11.2130 +        val (insts, prems, eqns) = collect_witnesses ctxt imp parms ids ext_ts;
 11.2131 +      in
 11.2132 +        thy_ctxt
 11.2133 +        |> fold (activate_elem phi_name param_prfx insts prems eqns exp o fst) elems
 11.2134 +      end;
 11.2135 +
 11.2136 +  in
 11.2137 +    thy_ctxt''
 11.2138 +    (* add equations as lemmas to context *)
 11.2139 +    |> (fold2 o fold2) (fn attn => fn thm => snd o yield_singleton (note Thm.lemmaK)
 11.2140 +         ((apsnd o map) (attrib thy_ctxt'') attn, [([Element.conclude_witness thm], [])]))
 11.2141 +            (unflat eq_thms eq_attns) eq_thms
 11.2142 +    (* add interpreted facts *)
 11.2143 +    |> fold2 activate_elems new_elemss new_pss
 11.2144 +  end;
 11.2145 +
 11.2146 +fun global_activate_facts_elemss x = gen_activate_facts_elemss
 11.2147 +  ProofContext.init
 11.2148 +  global_note_qualified
 11.2149 +  Attrib.attribute_i
 11.2150 +  put_global_registration
 11.2151 +  add_global_witness
 11.2152 +  add_global_equation
 11.2153 +  x;
 11.2154 +
 11.2155 +fun local_activate_facts_elemss x = gen_activate_facts_elemss
 11.2156 +  I
 11.2157 +  local_note_qualified
 11.2158 +  (Attrib.attribute_i o ProofContext.theory_of)
 11.2159 +  put_local_registration
 11.2160 +  add_local_witness
 11.2161 +  add_local_equation
 11.2162 +  x;
 11.2163 +
 11.2164 +fun prep_instantiations parse_term parse_prop ctxt parms (insts, eqns) =
 11.2165 +  let
 11.2166 +    (* parameters *)
 11.2167 +    val (parm_names, parm_types) = parms |> split_list
 11.2168 +      ||> map (TypeInfer.paramify_vars o Logic.varifyT);
 11.2169 +    val type_parms = fold Term.add_tvarsT parm_types [] |> map (Logic.mk_type o TVar);
 11.2170 +    val type_parm_names = fold Term.add_tfreesT (map snd parms) [] |> map fst;
 11.2171 +
 11.2172 +    (* parameter instantiations *)
 11.2173 +    val d = length parms - length insts;
 11.2174 +    val insts =
 11.2175 +      if d < 0 then error "More arguments than parameters in instantiation."
 11.2176 +      else insts @ replicate d NONE;
 11.2177 +    val (given_ps, given_insts) =
 11.2178 +      ((parm_names ~~ parm_types) ~~ insts) |> map_filter
 11.2179 +          (fn (_, NONE) => NONE
 11.2180 +            | ((n, T), SOME inst) => SOME ((n, T), inst))
 11.2181 +        |> split_list;
 11.2182 +    val (given_parm_names, given_parm_types) = given_ps |> split_list;
 11.2183 +
 11.2184 +    (* parse insts / eqns *)
 11.2185 +    val given_insts' = map (parse_term ctxt) given_insts;
 11.2186 +    val eqns' = map (parse_prop ctxt) eqns;
 11.2187 +
 11.2188 +    (* type inference and contexts *)
 11.2189 +    val arg = type_parms @ map2 TypeInfer.constrain given_parm_types given_insts' @ eqns';
 11.2190 +    val res = Syntax.check_terms ctxt arg;
 11.2191 +    val ctxt' = ctxt |> fold Variable.auto_fixes res;
 11.2192 +
 11.2193 +    (* instantiation *)
 11.2194 +    val (type_parms'', res') = chop (length type_parms) res;
 11.2195 +    val (given_insts'', eqns'') = chop (length given_insts) res';
 11.2196 +    val instT = Symtab.make (type_parm_names ~~ map Logic.dest_type type_parms'');
 11.2197 +    val inst = Symtab.make (given_parm_names ~~ given_insts'');
 11.2198 +
 11.2199 +    (* export from eigencontext *)
 11.2200 +    val export = Variable.export_morphism ctxt' ctxt;
 11.2201 +
 11.2202 +    (* import, its inverse *)
 11.2203 +    val domT = fold Term.add_tfrees res [] |> map TFree;
 11.2204 +    val importT = domT |> map (fn x => (Morphism.typ export x, x))
 11.2205 +      |> map_filter (fn (TFree _, _) => NONE  (* fixed point of export *)
 11.2206 +               | (TVar y, x) => SOME (fst y, x)
 11.2207 +               | _ => error "internal: illegal export in interpretation")
 11.2208 +      |> Vartab.make;
 11.2209 +    val dom = fold Term.add_frees res [] |> map Free;
 11.2210 +    val imprt = dom |> map (fn x => (Morphism.term export x, x))
 11.2211 +      |> map_filter (fn (Free _, _) => NONE  (* fixed point of export *)
 11.2212 +               | (Var y, x) => SOME (fst y, x)
 11.2213 +               | _ => error "internal: illegal export in interpretation")
 11.2214 +      |> Vartab.make;
 11.2215 +  in (((instT, inst), eqns''), (export, ((importT, domT), (imprt, dom)))) end;
 11.2216 +
 11.2217 +val read_instantiations = prep_instantiations Syntax.parse_term Syntax.parse_prop;
 11.2218 +val check_instantiations = prep_instantiations (K I) (K I);
 11.2219 +
 11.2220 +fun gen_prep_registration mk_ctxt test_reg activate
 11.2221 +    prep_attr prep_expr prep_insts
 11.2222 +    thy_ctxt phi_name raw_expr raw_insts =
 11.2223 +  let
 11.2224 +    val ctxt = mk_ctxt thy_ctxt;
 11.2225 +    val thy = ProofContext.theory_of ctxt;
 11.2226 +    val ctxt' = ProofContext.init thy;
 11.2227 +    fun prep_attn attn = (apsnd o map)
 11.2228 +      (Attrib.crude_closure ctxt o Args.assignable o prep_attr thy) attn;
 11.2229 +
 11.2230 +    val expr = prep_expr thy raw_expr;
 11.2231 +
 11.2232 +    val pts = params_of_expr ctxt' [] expr ([], Symtab.empty, Symtab.empty);
 11.2233 +    val params_ids = make_params_ids (#1 pts);
 11.2234 +    val raw_params_elemss = make_raw_params_elemss pts;
 11.2235 +    val ((ids, _), raw_elemss) = flatten (ctxt', I) (([], Symtab.empty), Expr expr);
 11.2236 +    val ((parms, all_elemss, _), (_, (_, defs, _))) =
 11.2237 +      read_elemss false ctxt' [] (raw_params_elemss @ raw_elemss) [];
 11.2238 +
 11.2239 +    (** compute instantiation **)
 11.2240 +
 11.2241 +    (* consistency check: equations need to be stored in a particular locale,
 11.2242 +       therefore if equations are present locale expression must be a name *)
 11.2243 +
 11.2244 +    val _ = case (expr, snd raw_insts) of
 11.2245 +        (Locale _, _) => () | (_, []) => ()
 11.2246 +      | (_, _) => error "Interpretations with `where' only permitted if locale expression is a name.";
 11.2247 +
 11.2248 +    (* read or certify instantiation *)
 11.2249 +    val (raw_insts', raw_eqns) = raw_insts;
 11.2250 +    val (raw_eq_attns, raw_eqns') = split_list raw_eqns;
 11.2251 +    val (((instT, inst1), eqns), morphs) = prep_insts ctxt parms (raw_insts', raw_eqns');
 11.2252 +    val eq_attns = map prep_attn raw_eq_attns;
 11.2253 +
 11.2254 +    (* defined params without given instantiation *)
 11.2255 +    val not_given = filter_out (Symtab.defined inst1 o fst) parms;
 11.2256 +    fun add_def (p, pT) inst =
 11.2257 +      let
 11.2258 +        val (t, T) = case find_first (fn (Free (a, _), _) => a = p) defs of
 11.2259 +               NONE => error ("Instance missing for parameter " ^ quote p)
 11.2260 +             | SOME (Free (_, T), t) => (t, T);
 11.2261 +        val d = Element.inst_term (instT, inst) t;
 11.2262 +      in Symtab.update_new (p, d) inst end;
 11.2263 +    val inst2 = fold add_def not_given inst1;
 11.2264 +    val inst_morphism = Element.inst_morphism thy (instT, inst2);
 11.2265 +    (* Note: insts contain no vars. *)
 11.2266 +
 11.2267 +    (** compute proof obligations **)
 11.2268 +
 11.2269 +    (* restore "small" ids *)
 11.2270 +    val ids' = map (fn ((n, ps), (_, mode)) =>
 11.2271 +          ((n, map (fn p => Free (p, (the o AList.lookup (op =) parms) p)) ps), mode))
 11.2272 +        ids;
 11.2273 +    val (_, all_elemss') = chop (length raw_params_elemss) all_elemss
 11.2274 +    (* instantiate ids and elements *)
 11.2275 +    val inst_elemss = (ids' ~~ all_elemss') |> map (fn (((n, ps), _), ((_, mode), elems)) =>
 11.2276 +      ((n, map (Morphism.term (inst_morphism $> fst morphs)) ps),
 11.2277 +        map (fn Int e => Element.morph_ctxt inst_morphism e) elems)
 11.2278 +      |> apfst (fn id => (id, map_mode (map (Element.morph_witness inst_morphism)) mode)));
 11.2279 +
 11.2280 +    (* equations *)
 11.2281 +    val eqn_elems = if null eqns then []
 11.2282 +      else [(Library.last_elem inst_elemss |> fst |> fst, eqns)];
 11.2283 +
 11.2284 +    val propss = map extract_asms_elems inst_elemss @ eqn_elems;
 11.2285 +
 11.2286 +  in
 11.2287 +    (propss, activate phi_name inst_elemss (map (snd o fst) ids) propss eq_attns morphs, morphs)
 11.2288 +  end;
 11.2289 +
 11.2290 +fun gen_prep_global_registration mk_ctxt = gen_prep_registration ProofContext.init
 11.2291 +  test_global_registration
 11.2292 +  global_activate_facts_elemss mk_ctxt;
 11.2293 +
 11.2294 +fun gen_prep_local_registration mk_ctxt = gen_prep_registration I
 11.2295 +  test_local_registration
 11.2296 +  local_activate_facts_elemss mk_ctxt;
 11.2297 +
 11.2298 +val prep_global_registration = gen_prep_global_registration
 11.2299 +  (K I) (K I) check_instantiations;
 11.2300 +val prep_global_registration_cmd = gen_prep_global_registration
 11.2301 +  Attrib.intern_src intern_expr read_instantiations;
 11.2302 +
 11.2303 +val prep_local_registration = gen_prep_local_registration
 11.2304 +  (K I) (K I) check_instantiations;
 11.2305 +val prep_local_registration_cmd = gen_prep_local_registration
 11.2306 +  Attrib.intern_src intern_expr read_instantiations;
 11.2307 +
 11.2308 +fun prep_registration_in_locale target expr thy =
 11.2309 +  (* target already in internal form *)
 11.2310 +  let
 11.2311 +    val ctxt = ProofContext.init thy;
 11.2312 +    val ((raw_target_ids, target_syn), _) = flatten (ctxt, I)
 11.2313 +        (([], Symtab.empty), Expr (Locale target));
 11.2314 +    val fixed = the_locale thy target |> #params |> map #1;
 11.2315 +    val ((all_ids, syn), raw_elemss) = flatten (ctxt, intern_expr thy)
 11.2316 +        ((raw_target_ids, target_syn), Expr expr);
 11.2317 +    val (target_ids, ids) = chop (length raw_target_ids) all_ids;
 11.2318 +    val ((parms, elemss, _), _) = read_elemss false ctxt fixed raw_elemss [];
 11.2319 +
 11.2320 +    (** compute proof obligations **)
 11.2321 +
 11.2322 +    (* restore "small" ids, with mode *)
 11.2323 +    val ids' = map (apsnd snd) ids;
 11.2324 +    (* remove Int markers *)
 11.2325 +    val elemss' = map (fn (_, es) =>
 11.2326 +        map (fn Int e => e) es) elemss
 11.2327 +    (* extract assumptions and defs *)
 11.2328 +    val ids_elemss = ids' ~~ elemss';
 11.2329 +    val propss = map extract_asms_elems ids_elemss;
 11.2330 +
 11.2331 +    (** activation function:
 11.2332 +        - add registrations to the target locale
 11.2333 +        - add induced registrations for all global registrations of
 11.2334 +          the target, unless already present
 11.2335 +        - add facts of induced registrations to theory **)
 11.2336 +
 11.2337 +    fun activate thmss thy =
 11.2338 +      let
 11.2339 +        val satisfy = Element.satisfy_thm (flat thmss);
 11.2340 +        val ids_elemss_thmss = ids_elemss ~~ thmss;
 11.2341 +        val regs = get_global_registrations thy target;
 11.2342 +
 11.2343 +        fun activate_id (((id, Assumed _), _), thms) thy =
 11.2344 +            thy |> put_registration_in_locale target id
 11.2345 +                |> fold (add_witness_in_locale target id) thms
 11.2346 +          | activate_id _ thy = thy;
 11.2347 +
 11.2348 +        fun activate_reg (ext_ts, ((phi_name, param_prfx), (exp, imp), _, _)) thy =
 11.2349 +          let
 11.2350 +            val (insts, wits, _) = collect_witnesses (ProofContext.init thy) imp fixed target_ids ext_ts;
 11.2351 +            val inst_parms = map (the o AList.lookup (op =) (map #1 fixed ~~ ext_ts));
 11.2352 +            val disch = Element.satisfy_thm wits;
 11.2353 +            val new_elemss = filter (fn (((name, ps), _), _) =>
 11.2354 +                not (test_global_registration thy (name, inst_parms ps))) (ids_elemss);
 11.2355 +            fun activate_assumed_id (((_, Derived _), _), _) thy = thy
 11.2356 +              | activate_assumed_id ((((name, ps), Assumed _), _), thms) thy = let
 11.2357 +                val ps' = inst_parms ps;
 11.2358 +              in
 11.2359 +                if test_global_registration thy (name, ps')
 11.2360 +                then thy
 11.2361 +                else thy
 11.2362 +                  |> put_global_registration (name, ps') (phi_name, param_prefix name ps) (exp, imp)
 11.2363 +                  |> fold (fn witn => fn thy => add_global_witness (name, ps')
 11.2364 +                     (Element.morph_witness (Element.inst_morphism thy insts) witn) thy) thms
 11.2365 +              end;
 11.2366 +
 11.2367 +            fun activate_derived_id ((_, Assumed _), _) thy = thy
 11.2368 +              | activate_derived_id (((name, ps), Derived ths), _) thy = let
 11.2369 +                val ps' = inst_parms ps;
 11.2370 +              in
 11.2371 +                if test_global_registration thy (name, ps')
 11.2372 +                then thy
 11.2373 +                else thy
 11.2374 +                  |> put_global_registration (name, ps') (phi_name, param_prefix name ps) (exp, imp)
 11.2375 +                  |> fold (fn witn => fn thy => add_global_witness (name, ps')
 11.2376 +                       (witn |> Element.map_witness (fn (t, th) =>  (* FIXME *)
 11.2377 +                       (Element.inst_term insts t,
 11.2378 +                        disch (Element.inst_thm thy insts (satisfy th))))) thy) ths
 11.2379 +              end;
 11.2380 +
 11.2381 +            fun activate_elem (loc, ps) (Notes (kind, facts)) thy =
 11.2382 +                let
 11.2383 +                  val att_morphism =
 11.2384 +                    Morphism.binding_morphism (name_morph phi_name param_prfx) $>
 11.2385 +                    Morphism.thm_morphism satisfy $>
 11.2386 +                    Element.inst_morphism thy insts $>
 11.2387 +                    Morphism.thm_morphism disch;
 11.2388 +                  val facts' = facts
 11.2389 +                    |> Attrib.map_facts (Attrib.attribute_i thy o Args.morph_values att_morphism)
 11.2390 +                    |> (map o apsnd o map o apfst o map) (disch o Element.inst_thm thy insts o satisfy)
 11.2391 +                    |> (map o apfst o apfst) (name_morph phi_name param_prfx);
 11.2392 +                in
 11.2393 +                  thy
 11.2394 +                  |> global_note_qualified kind facts'
 11.2395 +                  |> snd
 11.2396 +                end
 11.2397 +              | activate_elem _ _ thy = thy;
 11.2398 +
 11.2399 +            fun activate_elems ((id, _), elems) thy = fold (activate_elem id) elems thy;
 11.2400 +
 11.2401 +          in thy |> fold activate_assumed_id ids_elemss_thmss
 11.2402 +                 |> fold activate_derived_id ids_elemss
 11.2403 +                 |> fold activate_elems new_elemss end;
 11.2404 +      in
 11.2405 +        thy |> fold activate_id ids_elemss_thmss
 11.2406 +            |> fold activate_reg regs
 11.2407 +      end;
 11.2408 +
 11.2409 +  in (propss, activate) end;
 11.2410 +
 11.2411 +fun prep_propp propss = propss |> map (fn (_, props) =>
 11.2412 +  map (rpair [] o Element.mark_witness) props);
 11.2413 +
 11.2414 +fun prep_result propps thmss =
 11.2415 +  ListPair.map (fn ((_, props), thms) => map2 Element.make_witness props thms) (propps, thmss);
 11.2416 +
 11.2417 +fun gen_interpretation prep_registration after_qed prfx raw_expr raw_insts thy =
 11.2418 +  let
 11.2419 +    val (propss, activate, morphs) = prep_registration thy prfx raw_expr raw_insts;
 11.2420 +    fun after_qed' results =
 11.2421 +      ProofContext.theory (activate (prep_result propss results))
 11.2422 +      #> after_qed;
 11.2423 +  in
 11.2424 +    thy
 11.2425 +    |> ProofContext.init
 11.2426 +    |> Proof.theorem_i NONE after_qed' (prep_propp propss)
 11.2427 +    |> Element.refine_witness
 11.2428 +    |> Seq.hd
 11.2429 +    |> pair morphs
 11.2430 +  end;
 11.2431 +
 11.2432 +fun gen_interpret prep_registration after_qed name_morph expr insts int state =
 11.2433 +  let
 11.2434 +    val _ = Proof.assert_forward_or_chain state;
 11.2435 +    val ctxt = Proof.context_of state;
 11.2436 +    val (propss, activate, morphs) = prep_registration ctxt name_morph expr insts;
 11.2437 +    fun after_qed' results =
 11.2438 +      Proof.map_context (K (ctxt |> activate (prep_result propss results)))
 11.2439 +      #> Proof.put_facts NONE
 11.2440 +      #> after_qed;
 11.2441 +  in
 11.2442 +    state
 11.2443 +    |> Proof.local_goal (ProofDisplay.print_results int) (K I) ProofContext.bind_propp_i
 11.2444 +      "interpret" NONE after_qed' (map (pair (Binding.empty, [])) (prep_propp propss))
 11.2445 +    |> Element.refine_witness |> Seq.hd
 11.2446 +    |> pair morphs
 11.2447 +  end;
 11.2448 +
 11.2449 +fun standard_name_morph interp_prfx b =
 11.2450 +  if Binding.is_empty b then b
 11.2451 +  else Binding.map_prefix (fn ((lprfx, _) :: pprfx) =>
 11.2452 +    fold (Binding.add_prefix false o fst) pprfx
 11.2453 +    #> interp_prfx <> "" ? Binding.add_prefix true interp_prfx
 11.2454 +    #> Binding.add_prefix false lprfx
 11.2455 +  ) b;
 11.2456 +
 11.2457 +in
 11.2458 +
 11.2459 +val interpretation = gen_interpretation prep_global_registration;
 11.2460 +fun interpretation_cmd interp_prfx = snd ooo gen_interpretation prep_global_registration_cmd
 11.2461 +  I (standard_name_morph interp_prfx);
 11.2462 +
 11.2463 +fun interpretation_in_locale after_qed (raw_target, expr) thy =
 11.2464 +  let
 11.2465 +    val target = intern thy raw_target;
 11.2466 +    val (propss, activate) = prep_registration_in_locale target expr thy;
 11.2467 +    val raw_propp = prep_propp propss;
 11.2468 +
 11.2469 +    val (_, _, goal_ctxt, propp) = thy
 11.2470 +      |> ProofContext.init
 11.2471 +      |> cert_context_statement (SOME target) [] raw_propp;
 11.2472 +
 11.2473 +    fun after_qed' results =
 11.2474 +      ProofContext.theory (activate (prep_result propss results))
 11.2475 +      #> after_qed;
 11.2476 +  in
 11.2477 +    goal_ctxt
 11.2478 +    |> Proof.theorem_i NONE after_qed' propp
 11.2479 +    |> Element.refine_witness |> Seq.hd
 11.2480 +  end;
 11.2481 +
 11.2482 +val interpret = gen_interpret prep_local_registration;
 11.2483 +fun interpret_cmd interp_prfx = snd oooo gen_interpret prep_local_registration_cmd
 11.2484 +  Seq.single (standard_name_morph interp_prfx);
 11.2485 +
 11.2486 +end;
 11.2487 +
 11.2488 +end;
    12.1 --- a/src/Pure/Isar/spec_parse.ML	Mon Jan 05 15:37:49 2009 +0100
    12.2 +++ b/src/Pure/Isar/spec_parse.ML	Mon Jan 05 15:55:04 2009 +0100
    12.3 @@ -24,7 +24,7 @@
    12.4    val locale_fixes: (Binding.T * string option * mixfix) list parser
    12.5    val locale_insts: (string option list * (Attrib.binding * string) list) parser
    12.6    val class_expr: string list parser
    12.7 -  val locale_expr: Locale.expr parser
    12.8 +  val locale_expr: Old_Locale.expr parser
    12.9    val locale_expression: Expression.expression parser
   12.10    val locale_keyword: string parser
   12.11    val context_element: Element.context parser
   12.12 @@ -117,9 +117,9 @@
   12.13  
   12.14  val locale_expr =
   12.15    let
   12.16 -    fun expr2 x = (P.xname >> Locale.Locale || P.$$$ "(" |-- P.!!! (expr0 --| P.$$$ ")")) x
   12.17 -    and expr1 x = (expr2 -- Scan.repeat1 (P.maybe rename) >> Locale.Rename || expr2) x
   12.18 -    and expr0 x = (plus1_unless locale_keyword expr1 >> (fn [e] => e | es => Locale.Merge es)) x;
   12.19 +    fun expr2 x = (P.xname >> Old_Locale.Locale || P.$$$ "(" |-- P.!!! (expr0 --| P.$$$ ")")) x
   12.20 +    and expr1 x = (expr2 -- Scan.repeat1 (P.maybe rename) >> Old_Locale.Rename || expr2) x
   12.21 +    and expr0 x = (plus1_unless locale_keyword expr1 >> (fn [e] => e | es => Old_Locale.Merge es)) x;
   12.22    in expr0 end;
   12.23  
   12.24  val locale_expression =
    13.1 --- a/src/Pure/Isar/theory_target.ML	Mon Jan 05 15:37:49 2009 +0100
    13.2 +++ b/src/Pure/Isar/theory_target.ML	Mon Jan 05 15:55:04 2009 +0100
    13.3 @@ -24,19 +24,19 @@
    13.4  (* new locales *)
    13.5  
    13.6  fun locale_extern new_locale x = 
    13.7 -  if new_locale then NewLocale.extern x else Locale.extern x;
    13.8 +  if new_locale then Locale.extern x else Old_Locale.extern x;
    13.9  fun locale_add_type_syntax new_locale x =
   13.10 -  if new_locale then NewLocale.add_type_syntax x else Locale.add_type_syntax x;
   13.11 +  if new_locale then Locale.add_type_syntax x else Old_Locale.add_type_syntax x;
   13.12  fun locale_add_term_syntax new_locale x =
   13.13 -  if new_locale then NewLocale.add_term_syntax x else Locale.add_term_syntax x;
   13.14 +  if new_locale then Locale.add_term_syntax x else Old_Locale.add_term_syntax x;
   13.15  fun locale_add_declaration new_locale x =
   13.16 -  if new_locale then NewLocale.add_declaration x else Locale.add_declaration x;
   13.17 +  if new_locale then Locale.add_declaration x else Old_Locale.add_declaration x;
   13.18  fun locale_add_thmss new_locale x =
   13.19 -  if new_locale then NewLocale.add_thmss x else Locale.add_thmss x;
   13.20 +  if new_locale then Locale.add_thmss x else Old_Locale.add_thmss x;
   13.21  fun locale_init new_locale x =
   13.22 -  if new_locale then NewLocale.init x else Locale.init x;
   13.23 +  if new_locale then Locale.init x else Old_Locale.init x;
   13.24  fun locale_intern new_locale x =
   13.25 -  if new_locale then NewLocale.intern x else Locale.intern x;
   13.26 +  if new_locale then Locale.intern x else Old_Locale.intern x;
   13.27  
   13.28  (* context data *)
   13.29  
   13.30 @@ -334,7 +334,7 @@
   13.31  
   13.32  fun init_target _ NONE = global_target
   13.33    | init_target thy (SOME target) =
   13.34 -      make_target target (NewLocale.test_locale thy (NewLocale.intern thy target))
   13.35 +      make_target target (Locale.test_locale thy (Locale.intern thy target))
   13.36        true (Class_Target.is_class thy target) ([], [], []) [];
   13.37  
   13.38  fun init_ctxt (Target {target, new_locale, is_locale, is_class, instantiation, overloading}) =
   13.39 @@ -384,7 +384,7 @@
   13.40  
   13.41  fun context "-" thy = init NONE thy
   13.42    | context target thy = init (SOME (locale_intern
   13.43 -      (NewLocale.test_locale thy (NewLocale.intern thy target)) thy target)) thy;
   13.44 +      (Locale.test_locale thy (Locale.intern thy target)) thy target)) thy;
   13.45  
   13.46  fun instantiation arities = init_lthy_ctxt (make_target "" false false false arities []);
   13.47  fun instantiation_cmd raw_arities thy =
    14.1 --- a/src/Pure/Tools/invoke.ML	Mon Jan 05 15:37:49 2009 +0100
    14.2 +++ b/src/Pure/Tools/invoke.ML	Mon Jan 05 15:55:04 2009 +0100
    14.3 @@ -6,9 +6,9 @@
    14.4  
    14.5  signature INVOKE =
    14.6  sig
    14.7 -  val invoke: string * Attrib.src list -> Locale.expr -> string option list ->
    14.8 +  val invoke: string * Attrib.src list -> Old_Locale.expr -> string option list ->
    14.9      (Binding.T * string option * mixfix) list -> bool -> Proof.state -> Proof.state
   14.10 -  val invoke_i: string * attribute list -> Locale.expr -> term option list ->
   14.11 +  val invoke_i: string * attribute list -> Old_Locale.expr -> term option list ->
   14.12      (Binding.T * typ option * mixfix) list -> bool -> Proof.state -> Proof.state
   14.13  end;
   14.14  
   14.15 @@ -104,8 +104,8 @@
   14.16  in
   14.17  
   14.18  fun invoke x =
   14.19 -  gen_invoke Attrib.attribute Locale.read_expr Syntax.parse_term ProofContext.add_fixes x;
   14.20 -fun invoke_i x = gen_invoke (K I) Locale.cert_expr (K I) ProofContext.add_fixes_i x;
   14.21 +  gen_invoke Attrib.attribute Old_Locale.read_expr Syntax.parse_term ProofContext.add_fixes x;
   14.22 +fun invoke_i x = gen_invoke (K I) Old_Locale.cert_expr (K I) ProofContext.add_fixes_i x;
   14.23  
   14.24  end;
   14.25