adbrucker
/
isabelle-hacks
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Theory restructuring.

This commit is contained in:
Achim D. Brucker 2018-06-17 23:17:51 +01:00
parent 4bc432fcbb
commit eed51f4515
1 changed files with 32 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

60
hiding_type_variables.thy
View File

@ -65,6 +65,7 @@ signature HIDE_TVAR = sig
theory -> theory
val lookup : theory -> string -> hide_varT option
val hide_tvar_tr' : string -> Proof.context -> typ -> term list -> term
val hide_tvar_ast_tr : Proof.context -> Ast.ast list -> Ast.ast
end
structure Hide_Tvar : HIDE_TVAR = struct
@ -183,10 +184,35 @@ structure Hide_Tvar : HIDE_TVAR = struct
| default_only => hide_type (* TODO *)
| noprint => reg_type
end
fun hide_tvar_ast_tr ctx (a::_)=
let
val thy = Proof_Context.theory_of ctx
val decorated_name = case a of
Ast.Constant s => s
| _ => error("AST type not supported.")
val name = Lexicon.unmark_type decorated_name
val default_info = case lookup thy name of
NONE => error("No default type vars registered: "^name)
| SOME e => e
val _ = if #parse_mode default_info = noparse
then error("Default type vars disabled (option noparse): "^name)
else ()
val type_vars_ast = map (fn n => Ast.Variable(n)) (#tvars default_info)
in
Ast.Appl ((Ast.Constant decorated_name)::type_vars_ast)
end
| hide_tvar_ast_tr _ _ = error("Empty AST.")
end
\<close>
section\<open>Registering Top-Level Isar Commands\<close>
section\<open>Register Parse Translation\<close>
syntax "_tvars_wildcard" :: "type \<Rightarrow> type" ("'_'_ _")
parse_ast_translation\<open>
[(@{syntax_const "_tvars_wildcard"}, Hide_Tvar.hide_tvar_ast_tr)]
\<close>
section\<open>Register Top-Level Isar Commands\<close>
ML\<open>
val modeP = (Parse.$$$ "("
|-- (Parse.name --| Parse.$$$ ","
@ -214,6 +240,11 @@ ML\<open>
section\<open>Examples\<close>
subsection\<open>Print Translation\<close>
datatype ('alpha, 'beta) foobar = foo 'alpha | bar 'beta
typed_print_translation {*
[(@{type_syntax foobar}, Hide_Tvar.hide_tvar_tr' "foobar")]
*}
type_synonym ('a, 'b, 'c, 'd) baz = "('a+'b, 'a \<times> 'b) foobar"
definition f::"('a, 'b) foobar \<Rightarrow> ('a, 'b) foobar \<Rightarrow> ('a, 'b) foobar"
@ -230,10 +261,6 @@ assert[string_of_thm_equal,
register_default_tvars "('alpha, 'beta) foobar" (always,active)
typed_print_translation {*
[(@{type_syntax foobar}, Hide_Tvar.hide_tvar_tr' "foobar")]
*}
update_default_tvars_mode "_ foobar" (noprint,noparse)
assert[string_of_thm_equal,
thm_def="f_def",
@ -252,29 +279,6 @@ assert[string_of_thm_equal,
subsection\<open>Parse Translation\<close>
update_default_tvars_mode "_ foobar" (noprint,active)
syntax "_tvars_wildcard" :: "type \<Rightarrow> type" ("'_'_ _")
parse_ast_translation\<open>
let
fun Lambda_ast_tr ctx (a::asts)=
let
val thy = Proof_Context.theory_of ctx
val decorated_name = case a of
Ast.Constant s => s
val name = Lexicon.unmark_type decorated_name
val default_info = case Hide_Tvar.lookup thy name of
NONE => error("No default type vars registered: "^name)
| SOME e => e
val _ = if #parse_mode default_info = Hide_Tvar.noparse
then error("Default type vars disabled (option noparse): "^name)
else ()
val type_vars = #tvars default_info
val type_vars_ast = map (fn n => Ast.Variable(n)) type_vars
in
Ast.Appl ((Ast.Constant decorated_name)::type_vars_ast)
end
in [(@{syntax_const "_tvars_wildcard"}, Lambda_ast_tr)] end;
\<close>
declare [[show_types]]
definition B :: "'alpha \<Rightarrow> __ foobar"
where "B = foo"