smarter generic_const: plain alias for non-dependent case (e.g. prospective datatype or record syntax);
authorwenzelm
Mon, 02 Apr 2012 20:50:41 +0200
changeset 47278 daeaf4824e9a
parent 47277 daef54bad420
child 47279 4bab649dedf0
smarter generic_const: plain alias for non-dependent case (e.g. prospective datatype or record syntax);
src/Pure/Isar/named_target.ML
--- a/src/Pure/Isar/named_target.ML	Mon Apr 02 20:12:17 2012 +0200
+++ b/src/Pure/Isar/named_target.ML	Mon Apr 02 20:50:41 2012 +0200
@@ -46,11 +46,38 @@
 
 (* consts in locale *)
 
-fun generic_const same_shape prmode ((b, mx), t) =
-  Proof_Context.generic_add_abbrev Print_Mode.internal (b, t)
-  #-> (fn (const as Const (c, _), _) => same_shape ?
-        (Proof_Context.generic_revert_abbrev (#1 prmode) c #>
-          Morphism.form (Proof_Context.generic_notation true prmode [(const, mx)])));
+fun generic_const same_shape prmode ((b, mx), t) context =
+  let
+    val const_alias =
+      if same_shape then
+        (case t of
+          Const (c, T) =>
+            let
+              val thy = Context.theory_of context;
+              val ctxt = Context.proof_of context;
+              val t' = Syntax.check_term ctxt (Const (c, dummyT))
+                |> singleton (Variable.polymorphic ctxt);
+            in
+              (case t' of
+                Const (c', T') =>
+                  if c = c' andalso Sign.typ_equiv thy (T, T') then SOME c else NONE
+              | _ => NONE)
+            end
+        | _ => NONE)
+      else NONE;
+  in
+    (case const_alias of
+      SOME c =>
+        context
+        |> Context.mapping (Sign.const_alias b c) (Proof_Context.const_alias b c)
+        |> Morphism.form (Proof_Context.generic_notation true prmode [(t, mx)])
+    | NONE =>
+        context
+        |> Proof_Context.generic_add_abbrev Print_Mode.internal (b, t)
+        |-> (fn (const as Const (c, _), _) => same_shape ?
+              (Proof_Context.generic_revert_abbrev (#1 prmode) c #>
+               Morphism.form (Proof_Context.generic_notation true prmode [(const, mx)]))))
+  end;
 
 fun locale_const (Target {target, is_class, ...}) (prmode as (mode, _)) ((b, mx), rhs) =
   Generic_Target.locale_declaration target true (fn phi =>