# HG changeset patch # User Christian Urban # Date 1267083652 -3600 # Node ID 853abc14c5c67b8c3826831bcb366822c31cda8f # Parent 9df6144e281b97148d86866a313d231e10431a11 added IsaMakefile...but so far included only a test for the parser diff -r 9df6144e281b -r 853abc14c5c6 IsaMakefile --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/IsaMakefile Thu Feb 25 08:40:52 2010 +0100 @@ -0,0 +1,36 @@ + +## targets + +default: Nominal2 +images: + +all: Nominal2 + + +## global settings + +SRC = $(ISABELLE_HOME)/src +OUT = $(ISABELLE_OUTPUT) +LOG = $(OUT)/log + +USEDIR = $(ISABELLE_TOOL) usedir -v true -t true ##-D generated + + +## Nominal2 + +Nominal2: $(LOG)/HOL-Nominal2.gz + +$(LOG)/HOL-Nominal2.gz: Nominal/ROOT.ML Nominal/*.thy + @$(USEDIR) HOL Nominal + +paper: $(LOG)/HOL-Nominal2-Paper.gz + +$(LOG)/HOL-Nominal2-Paper.gz: Paper/ROOT.ML Paper/document/root.tex Paper/*.thy + @$(USEDIR) -D generated HOL Paper + $(ISATOOL) document -o pdf Paper/generated + @cp Paper/document.pdf paper.pdf + +## clean + +clean: + @rm -f $(LOG)/HOL-Nominal2.gz diff -r 9df6144e281b -r 853abc14c5c6 Nominal/Parser.thy --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Nominal/Parser.thy Thu Feb 25 08:40:52 2010 +0100 @@ -0,0 +1,240 @@ +theory Parser +imports "Nominal2_Atoms" "Nominal2_Eqvt" "Nominal2_Supp" +begin + +atom_decl name + + +section{* Interface for nominal_datatype *} + +text {* + +Nominal-Datatype-part: + +1st Arg: string list + ^^^^^^^^^^^ + strings of the types to be defined + +2nd Arg: (string list * binding * mixfix * (binding * typ list * mixfix) list) list + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + type(s) to be defined constructors list + (ty args, name, syn) (name, typs, syn) + +Binder-Function-part: + +3rd Arg: (binding * typ option * mixfix) list + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + binding function(s) + to be defined + (name, type, syn) + +4th Arg: term list + ^^^^^^^^^ + the equations of the binding functions + (Trueprop equations) +*} + +text {*****************************************************} +ML {* +(* nominal datatype parser *) +local + structure P = OuterParse +in + +val _ = OuterKeyword.keyword "bind" +val anno_typ = Scan.option (P.name --| P.$$$ "::") -- P.typ + +(* binding specification *) +(* should use and_list *) +val bind_parser = + P.enum "," ((P.$$$ "bind" |-- P.term) -- (P.$$$ "in" |-- P.name)) + +val constr_parser = + P.binding -- Scan.repeat anno_typ + +(* datatype parser *) +val dt_parser = + ((P.type_args -- P.binding -- P.opt_infix) >> P.triple1) -- + (P.$$$ "=" |-- P.enum1 "|" ((constr_parser -- bind_parser -- P.opt_mixfix) >> P.triple_swap)) + +(* function equation parser *) +val fun_parser = + Scan.optional (P.$$$ "binder" |-- P.fixes -- SpecParse.where_alt_specs) ([],[]) + +(* main parser *) +val main_parser = + (P.and_list1 dt_parser) -- fun_parser + +end +*} + +(* adds "_raw" to the end of constants and types *) +ML {* +fun add_raw s = s ^ "_raw" +fun add_raws ss = map add_raw ss +fun raw_bind bn = Binding.suffix_name "_raw" bn + +fun replace_str ss s = + case (AList.lookup (op=) ss s) of + SOME s' => s' + | NONE => s + +fun replace_typ ty_ss (Type (a, Ts)) = Type (replace_str ty_ss a, map (replace_typ ty_ss) Ts) + | replace_typ ty_ss T = T + +fun raw_dts ty_ss dts = +let + val ty_ss' = ty_ss ~~ (add_raws ty_ss) + + fun raw_dts_aux1 (bind, tys, mx) = + (raw_bind bind, map (replace_typ ty_ss') tys, mx) + + fun raw_dts_aux2 (ty_args, bind, mx, constrs) = + (ty_args, raw_bind bind, mx, map raw_dts_aux1 constrs) +in + map raw_dts_aux2 dts +end + +fun replace_aterm trm_ss (Const (a, T)) = Const (replace_str trm_ss a, T) + | replace_aterm trm_ss (Free (a, T)) = Free (replace_str trm_ss a, T) + | replace_aterm trm_ss trm = trm + +fun replace_term trm_ss ty_ss trm = + trm |> Term.map_aterms (replace_aterm trm_ss) |> map_types (replace_typ ty_ss) +*} + +ML {* +fun get_constrs dts = + flat (map (fn (_, _, _, constrs) => constrs) dts) + +fun get_typed_constrs dts = + flat (map (fn (_, bn, _, constrs) => + (map (fn (bn', _, _) => (Binding.name_of bn, Binding.name_of bn')) constrs)) dts) + +fun get_constr_strs dts = + map (fn (bn, _, _) => Binding.name_of bn) (get_constrs dts) + +fun get_bn_fun_strs bn_funs = + map (fn (bn_fun, _, _) => Binding.name_of bn_fun) bn_funs +*} + +ML {* +fun raw_dts_decl dt_names dts lthy = +let + val thy = ProofContext.theory_of lthy + val conf = Datatype.default_config + + val dt_names' = add_raws dt_names + val dt_full_names = map (Sign.full_bname thy) dt_names + val dts' = raw_dts dt_full_names dts +in + lthy + |> Local_Theory.theory_result (Datatype.add_datatype conf dt_names' dts') +end +*} + +ML {* +fun raw_bn_fun_decl dt_names dts bn_funs bn_eqs lthy = +let + val thy = ProofContext.theory_of lthy + + val dt_names' = add_raws dt_names + val dt_full_names = map (Sign.full_bname thy) dt_names + val dt_full_names' = map (Sign.full_bname thy) dt_names' + + val ctrs_names = map (Sign.full_bname thy) (get_constr_strs dts) + val ctrs_names' = map (fn (x, y) => (Sign.full_bname_path thy (add_raw x) (add_raw y))) + (get_typed_constrs dts) + + val bn_fun_strs = get_bn_fun_strs bn_funs + val bn_fun_strs' = add_raws bn_fun_strs + + val bn_funs' = map (fn (bn, opt_ty, mx) => + (raw_bind bn, Option.map (replace_typ (dt_full_names ~~ dt_full_names')) opt_ty, mx)) bn_funs + + val bn_eqs' = map (fn trm => + (Attrib.empty_binding, + (replace_term ((ctrs_names ~~ ctrs_names') @ (bn_fun_strs ~~ bn_fun_strs')) (dt_full_names ~~ dt_full_names') trm))) bn_eqs +in + if null bn_eqs + then (([], []), lthy) + else Primrec.add_primrec bn_funs' bn_eqs' lthy +end +*} + +ML {* +fun nominal_datatype2 dts bn_funs bn_eqs lthy = +let + val dts_names = map (fn (_, s, _, _) => Binding.name_of s) dts +in + lthy + |> raw_dts_decl dts_names dts + ||>> raw_bn_fun_decl dts_names dts bn_funs bn_eqs +end +*} + +ML {* +(* makes a full named type out of a binding with tvars applied to it *) +fun mk_type thy bind tvrs = + Type (Sign.full_name thy bind, map (fn s => TVar ((s, 0), [])) tvrs) + +fun get_constrs2 thy dts = +let + val dts' = map (fn (tvrs, tname, _, constrs) => (mk_type thy tname tvrs, constrs)) dts +in + flat (map (fn (ty, constrs) => map (fn (bn, tys, mx) => (bn, tys ---> ty, mx)) constrs) dts') +end +*} + +ML {* +fun nominal_datatype2_cmd (dt_strs, (bn_fun_strs, bn_eq_strs)) lthy = +let + val thy = ProofContext.theory_of lthy + + fun prep_typ ((tvs, tname, mx), _) = (tname, length tvs, mx); + + (* adding the types for parsing datatypes *) + val lthy_tmp = lthy + |> Local_Theory.theory (Sign.add_types (map prep_typ dt_strs)) + + fun prep_cnstr lthy (((cname, atys), mx), binders) = + (cname, map (Syntax.read_typ lthy o snd) atys, mx) + + fun prep_dt lthy ((tvs, tname, mx), cnstrs) = + (tvs, tname, mx, map (prep_cnstr lthy) cnstrs) + + (* parsing the datatypes *) + val dts_prep = map (prep_dt lthy_tmp) dt_strs + + (* adding constructors for parsing functions *) + val lthy_tmp2 = lthy_tmp + |> Local_Theory.theory (Sign.add_consts_i (get_constrs2 thy dts_prep)) + + val (bn_fun_aux, bn_eq_aux) = fst (Specification.read_spec bn_fun_strs bn_eq_strs lthy_tmp2) + + fun prep_bn_fun ((bn, T), mx) = (bn, SOME T, mx) + + fun prep_bn_eq (attr, t) = t + + val bn_fun_prep = map prep_bn_fun bn_fun_aux + val bn_eq_prep = map prep_bn_eq bn_eq_aux +in + nominal_datatype2 dts_prep bn_fun_prep bn_eq_prep lthy |> snd +end +*} + +(* Command Keyword *) +ML {* +let + val kind = OuterKeyword.thy_decl +in + OuterSyntax.local_theory "nominal_datatype" "test" kind + (main_parser >> nominal_datatype2_cmd) +end +*} + + +end + + + diff -r 9df6144e281b -r 853abc14c5c6 Nominal/ROOT.ML --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Nominal/ROOT.ML Thu Feb 25 08:40:52 2010 +0100 @@ -0,0 +1,8 @@ +quick_and_dirty := true; + +no_document use_thys + ["Nominal2_Base", + "Nominal2_Eqvt", + "Nominal2_Atoms", + "Nominal2_Supp", + "Test"]; diff -r 9df6144e281b -r 853abc14c5c6 Nominal/Test.thy --- a/Nominal/Test.thy Thu Feb 25 07:57:17 2010 +0100 +++ b/Nominal/Test.thy Thu Feb 25 08:40:52 2010 +0100 @@ -1,238 +1,7 @@ theory Test -imports "Nominal2_Atoms" "Nominal2_Eqvt" "Nominal2_Supp" +imports "Parser" begin -atom_decl name - - -section{* Interface for nominal_datatype *} - -text {* - -Nominal-Datatype-part: - -1st Arg: string list - ^^^^^^^^^^^ - strings of the types to be defined - -2nd Arg: (string list * binding * mixfix * (binding * typ list * mixfix) list) list - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ - type(s) to be defined constructors list - (ty args, name, syn) (name, typs, syn) - -Binder-Function-part: - -3rd Arg: (binding * typ option * mixfix) list - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ - binding function(s) - to be defined - (name, type, syn) - -4th Arg: term list - ^^^^^^^^^ - the equations of the binding functions - (Trueprop equations) -*} - -text {*****************************************************} -ML {* -(* nominal datatype parser *) -local - structure P = OuterParse -in - -val _ = OuterKeyword.keyword "bind" -val anno_typ = Scan.option (P.name --| P.$$$ "::") -- P.typ - -(* binding specification *) -(* should use and_list *) -val bind_parser = - P.enum "," ((P.$$$ "bind" |-- P.term) -- (P.$$$ "in" |-- P.name)) - -val constr_parser = - P.binding -- Scan.repeat anno_typ - -(* datatype parser *) -val dt_parser = - ((P.type_args -- P.binding -- P.opt_infix) >> P.triple1) -- - (P.$$$ "=" |-- P.enum1 "|" ((constr_parser -- bind_parser -- P.opt_mixfix) >> P.triple_swap)) - -(* function equation parser *) -val fun_parser = - Scan.optional (P.$$$ "binder" |-- P.fixes -- SpecParse.where_alt_specs) ([],[]) - -(* main parser *) -val main_parser = - (P.and_list1 dt_parser) -- fun_parser - -end -*} - -(* adds "_raw" to the end of constants and types *) -ML {* -fun add_raw s = s ^ "_raw" -fun add_raws ss = map add_raw ss -fun raw_bind bn = Binding.suffix_name "_raw" bn - -fun replace_str ss s = - case (AList.lookup (op=) ss s) of - SOME s' => s' - | NONE => s - -fun replace_typ ty_ss (Type (a, Ts)) = Type (replace_str ty_ss a, map (replace_typ ty_ss) Ts) - | replace_typ ty_ss T = T - -fun raw_dts ty_ss dts = -let - val ty_ss' = ty_ss ~~ (add_raws ty_ss) - - fun raw_dts_aux1 (bind, tys, mx) = - (raw_bind bind, map (replace_typ ty_ss') tys, mx) - - fun raw_dts_aux2 (ty_args, bind, mx, constrs) = - (ty_args, raw_bind bind, mx, map raw_dts_aux1 constrs) -in - map raw_dts_aux2 dts -end - -fun replace_aterm trm_ss (Const (a, T)) = Const (replace_str trm_ss a, T) - | replace_aterm trm_ss (Free (a, T)) = Free (replace_str trm_ss a, T) - | replace_aterm trm_ss trm = trm - -fun replace_term trm_ss ty_ss trm = - trm |> Term.map_aterms (replace_aterm trm_ss) |> map_types (replace_typ ty_ss) -*} - -ML {* -fun get_constrs dts = - flat (map (fn (_, _, _, constrs) => constrs) dts) - -fun get_typed_constrs dts = - flat (map (fn (_, bn, _, constrs) => - (map (fn (bn', _, _) => (Binding.name_of bn, Binding.name_of bn')) constrs)) dts) - -fun get_constr_strs dts = - map (fn (bn, _, _) => Binding.name_of bn) (get_constrs dts) - -fun get_bn_fun_strs bn_funs = - map (fn (bn_fun, _, _) => Binding.name_of bn_fun) bn_funs -*} - -ML {* -fun raw_dts_decl dt_names dts lthy = -let - val thy = ProofContext.theory_of lthy - val conf = Datatype.default_config - - val dt_names' = add_raws dt_names - val dt_full_names = map (Sign.full_bname thy) dt_names - val dts' = raw_dts dt_full_names dts -in - lthy - |> Local_Theory.theory_result (Datatype.add_datatype conf dt_names' dts') -end -*} - -ML {* -fun raw_bn_fun_decl dt_names dts bn_funs bn_eqs lthy = -let - val thy = ProofContext.theory_of lthy - - val dt_names' = add_raws dt_names - val dt_full_names = map (Sign.full_bname thy) dt_names - val dt_full_names' = map (Sign.full_bname thy) dt_names' - - val ctrs_names = map (Sign.full_bname thy) (get_constr_strs dts) - val ctrs_names' = map (fn (x, y) => (Sign.full_bname_path thy (add_raw x) (add_raw y))) - (get_typed_constrs dts) - - val bn_fun_strs = get_bn_fun_strs bn_funs - val bn_fun_strs' = add_raws bn_fun_strs - - val bn_funs' = map (fn (bn, opt_ty, mx) => - (raw_bind bn, Option.map (replace_typ (dt_full_names ~~ dt_full_names')) opt_ty, mx)) bn_funs - - val bn_eqs' = map (fn trm => - (Attrib.empty_binding, - (replace_term ((ctrs_names ~~ ctrs_names') @ (bn_fun_strs ~~ bn_fun_strs')) (dt_full_names ~~ dt_full_names') trm))) bn_eqs -in - if null bn_eqs - then (([], []), lthy) - else Primrec.add_primrec bn_funs' bn_eqs' lthy -end -*} - -ML {* -fun nominal_datatype2 dts bn_funs bn_eqs lthy = -let - val dts_names = map (fn (_, s, _, _) => Binding.name_of s) dts -in - lthy - |> raw_dts_decl dts_names dts - ||>> raw_bn_fun_decl dts_names dts bn_funs bn_eqs -end -*} - -ML {* -(* makes a full named type out of a binding with tvars applied to it *) -fun mk_type thy bind tvrs = - Type (Sign.full_name thy bind, map (fn s => TVar ((s, 0), [])) tvrs) - -fun get_constrs2 thy dts = -let - val dts' = map (fn (tvrs, tname, _, constrs) => (mk_type thy tname tvrs, constrs)) dts -in - flat (map (fn (ty, constrs) => map (fn (bn, tys, mx) => (bn, tys ---> ty, mx)) constrs) dts') -end -*} - -ML {* -fun nominal_datatype2_cmd (dt_strs, (bn_fun_strs, bn_eq_strs)) lthy = -let - val thy = ProofContext.theory_of lthy - - fun prep_typ ((tvs, tname, mx), _) = (tname, length tvs, mx); - - (* adding the types for parsing datatypes *) - val lthy_tmp = lthy - |> Local_Theory.theory (Sign.add_types (map prep_typ dt_strs)) - - fun prep_cnstr lthy (((cname, atys), mx), binders) = - (cname, map (Syntax.read_typ lthy o snd) atys, mx) - - fun prep_dt lthy ((tvs, tname, mx), cnstrs) = - (tvs, tname, mx, map (prep_cnstr lthy) cnstrs) - - (* parsing the datatypes *) - val dts_prep = map (prep_dt lthy_tmp) dt_strs - - (* adding constructors for parsing functions *) - val lthy_tmp2 = lthy_tmp - |> Local_Theory.theory (Sign.add_consts_i (get_constrs2 thy dts_prep)) - - val (bn_fun_aux, bn_eq_aux) = fst (Specification.read_spec bn_fun_strs bn_eq_strs lthy_tmp2) - - fun prep_bn_fun ((bn, T), mx) = (bn, SOME T, mx) - - fun prep_bn_eq (attr, t) = t - - val bn_fun_prep = map prep_bn_fun bn_fun_aux - val bn_eq_prep = map prep_bn_eq bn_eq_aux -in - nominal_datatype2 dts_prep bn_fun_prep bn_eq_prep lthy |> snd -end -*} - -(* Command Keyword *) -ML {* -let - val kind = OuterKeyword.thy_decl -in - OuterSyntax.local_theory "nominal_datatype" "test" kind - (main_parser >> nominal_datatype2_cmd) -end -*} - text {* example 1 *} nominal_datatype lam = @@ -253,7 +22,8 @@ print_theorems -text {* examples 2 *} +text {* example 2 *} + nominal_datatype trm = Var "name" | App "trm" "trm"