src/Pure/sign.ML
changeset 33173 b8ca12f6681a
parent 33172 61ee96bc9895
child 33385 fb2358edcfb6
equal deleted inserted replaced
33172:61ee96bc9895 33173:b8ca12f6681a
    88   val add_modesyntax: Syntax.mode -> (string * string * mixfix) list -> theory -> theory
    88   val add_modesyntax: Syntax.mode -> (string * string * mixfix) list -> theory -> theory
    89   val add_modesyntax_i: Syntax.mode -> (string * typ * mixfix) list -> theory -> theory
    89   val add_modesyntax_i: Syntax.mode -> (string * typ * mixfix) list -> theory -> theory
    90   val del_modesyntax: Syntax.mode -> (string * string * mixfix) list -> theory -> theory
    90   val del_modesyntax: Syntax.mode -> (string * string * mixfix) list -> theory -> theory
    91   val del_modesyntax_i: Syntax.mode -> (string * typ * mixfix) list -> theory -> theory
    91   val del_modesyntax_i: Syntax.mode -> (string * typ * mixfix) list -> theory -> theory
    92   val notation: bool -> Syntax.mode -> (term * mixfix) list -> theory -> theory
    92   val notation: bool -> Syntax.mode -> (term * mixfix) list -> theory -> theory
    93   val declare_const: Properties.T -> (binding * typ) * mixfix -> theory -> term * theory
    93   val declare_const: (binding * typ) * mixfix -> theory -> term * theory
    94   val add_consts: (binding * string * mixfix) list -> theory -> theory
    94   val add_consts: (binding * string * mixfix) list -> theory -> theory
    95   val add_consts_i: (binding * typ * mixfix) list -> theory -> theory
    95   val add_consts_i: (binding * typ * mixfix) list -> theory -> theory
    96   val add_abbrev: string -> Properties.T -> binding * term -> theory -> (term * term) * theory
    96   val add_abbrev: string -> binding * term -> theory -> (term * term) * theory
    97   val revert_abbrev: string -> string -> theory -> theory
    97   val revert_abbrev: string -> string -> theory -> theory
    98   val add_const_constraint: string * typ option -> theory -> theory
    98   val add_const_constraint: string * typ option -> theory -> theory
    99   val primitive_class: binding * class list -> theory -> theory
    99   val primitive_class: binding * class list -> theory -> theory
   100   val primitive_classrel: class * class -> theory -> theory
   100   val primitive_classrel: class * class -> theory -> theory
   101   val primitive_arity: arity -> theory -> theory
   101   val primitive_arity: arity -> theory -> theory
   432 
   432 
   433 fun add_types types thy = thy |> map_sign (fn (naming, syn, tsig, consts) =>
   433 fun add_types types thy = thy |> map_sign (fn (naming, syn, tsig, consts) =>
   434   let
   434   let
   435     val syn' = Syntax.update_type_gram (map (fn (a, n, mx) => (Name.of_binding a, n, mx)) types) syn;
   435     val syn' = Syntax.update_type_gram (map (fn (a, n, mx) => (Name.of_binding a, n, mx)) types) syn;
   436     val decls = map (fn (a, n, mx) => (Binding.map_name (Syntax.type_name mx) a, n)) types;
   436     val decls = map (fn (a, n, mx) => (Binding.map_name (Syntax.type_name mx) a, n)) types;
   437     val tsig' = fold (Type.add_type naming []) decls tsig;
   437     val tsig' = fold (Type.add_type naming) decls tsig;
   438   in (naming, syn', tsig', consts) end);
   438   in (naming, syn', tsig', consts) end);
   439 
   439 
   440 
   440 
   441 (* add nonterminals *)
   441 (* add nonterminals *)
   442 
   442 
   443 fun add_nonterminals ns thy = thy |> map_sign (fn (naming, syn, tsig, consts) =>
   443 fun add_nonterminals ns thy = thy |> map_sign (fn (naming, syn, tsig, consts) =>
   444   let
   444   let
   445     val syn' = Syntax.update_consts (map Name.of_binding ns) syn;
   445     val syn' = Syntax.update_consts (map Name.of_binding ns) syn;
   446     val tsig' = fold (Type.add_nonterminal naming []) ns tsig;
   446     val tsig' = fold (Type.add_nonterminal naming) ns tsig;
   447   in (naming, syn', tsig', consts) end);
   447   in (naming, syn', tsig', consts) end);
   448 
   448 
   449 
   449 
   450 (* add type abbreviations *)
   450 (* add type abbreviations *)
   451 
   451 
   455       val ctxt = ProofContext.init thy;
   455       val ctxt = ProofContext.init thy;
   456       val syn' = Syntax.update_type_gram [(Name.of_binding a, length vs, mx)] syn;
   456       val syn' = Syntax.update_type_gram [(Name.of_binding a, length vs, mx)] syn;
   457       val b = Binding.map_name (Syntax.type_name mx) a;
   457       val b = Binding.map_name (Syntax.type_name mx) a;
   458       val abbr = (b, vs, certify_typ_mode Type.mode_syntax thy (parse_typ ctxt rhs))
   458       val abbr = (b, vs, certify_typ_mode Type.mode_syntax thy (parse_typ ctxt rhs))
   459         handle ERROR msg => cat_error msg ("in type abbreviation " ^ quote (Binding.str_of b));
   459         handle ERROR msg => cat_error msg ("in type abbreviation " ^ quote (Binding.str_of b));
   460       val tsig' = Type.add_abbrev naming [] abbr tsig;
   460       val tsig' = Type.add_abbrev naming abbr tsig;
   461     in (naming, syn', tsig', consts) end);
   461     in (naming, syn', tsig', consts) end);
   462 
   462 
   463 val add_tyabbrs = fold (gen_add_tyabbr Syntax.parse_typ);
   463 val add_tyabbrs = fold (gen_add_tyabbr Syntax.parse_typ);
   464 val add_tyabbrs_i = fold (gen_add_tyabbr (K I));
   464 val add_tyabbrs_i = fold (gen_add_tyabbr (K I));
   465 
   465 
   493 
   493 
   494 (* add constants *)
   494 (* add constants *)
   495 
   495 
   496 local
   496 local
   497 
   497 
   498 fun gen_add_consts parse_typ authentic tags raw_args thy =
   498 fun gen_add_consts parse_typ authentic raw_args thy =
   499   let
   499   let
   500     val ctxt = ProofContext.init thy;
   500     val ctxt = ProofContext.init thy;
   501     val prepT = Type.no_tvars o Term.no_dummyT o certify_typ thy o parse_typ ctxt;
   501     val prepT = Type.no_tvars o Term.no_dummyT o certify_typ thy o parse_typ ctxt;
   502     fun prep (raw_b, raw_T, raw_mx) =
   502     fun prep (raw_b, raw_T, raw_mx) =
   503       let
   503       let
   510         val T' = Logic.varifyT T;
   510         val T' = Logic.varifyT T;
   511       in ((b, T'), (c_syn, T', mx), Const (c, T)) end;
   511       in ((b, T'), (c_syn, T', mx), Const (c, T)) end;
   512     val args = map prep raw_args;
   512     val args = map prep raw_args;
   513   in
   513   in
   514     thy
   514     thy
   515     |> map_consts (fold (Consts.declare authentic (naming_of thy) tags o #1) args)
   515     |> map_consts (fold (Consts.declare authentic (naming_of thy) o #1) args)
   516     |> add_syntax_i (map #2 args)
   516     |> add_syntax_i (map #2 args)
   517     |> pair (map #3 args)
   517     |> pair (map #3 args)
   518   end;
   518   end;
   519 
   519 
   520 in
   520 in
   521 
   521 
   522 fun add_consts args = snd o gen_add_consts Syntax.parse_typ false [] args;
   522 fun add_consts args = snd o gen_add_consts Syntax.parse_typ false args;
   523 fun add_consts_i args = snd o gen_add_consts (K I) false [] args;
   523 fun add_consts_i args = snd o gen_add_consts (K I) false args;
   524 
   524 
   525 fun declare_const tags ((b, T), mx) thy =
   525 fun declare_const ((b, T), mx) thy =
   526   let
   526   let
   527     val pos = Binding.pos_of b;
   527     val pos = Binding.pos_of b;
   528     val ([const as Const (c, _)], thy') = gen_add_consts (K I) true tags [(b, T, mx)] thy;
   528     val ([const as Const (c, _)], thy') = gen_add_consts (K I) true [(b, T, mx)] thy;
   529     val _ = Position.report (Markup.const_decl c) pos;
   529     val _ = Position.report (Markup.const_decl c) pos;
   530   in (const, thy') end;
   530   in (const, thy') end;
   531 
   531 
   532 end;
   532 end;
   533 
   533 
   534 
   534 
   535 (* abbreviations *)
   535 (* abbreviations *)
   536 
   536 
   537 fun add_abbrev mode tags (b, raw_t) thy =
   537 fun add_abbrev mode (b, raw_t) thy =
   538   let
   538   let
   539     val pp = Syntax.pp_global thy;
   539     val pp = Syntax.pp_global thy;
   540     val prep_tm = no_frees pp o Term.no_dummy_patterns o cert_term_abbrev thy;
   540     val prep_tm = no_frees pp o Term.no_dummy_patterns o cert_term_abbrev thy;
   541     val t = (prep_tm raw_t handle TYPE (msg, _, _) => error msg | TERM (msg, _) => error msg)
   541     val t = (prep_tm raw_t handle TYPE (msg, _, _) => error msg | TERM (msg, _) => error msg)
   542       handle ERROR msg => cat_error msg ("in constant abbreviation " ^ quote (Binding.str_of b));
   542       handle ERROR msg => cat_error msg ("in constant abbreviation " ^ quote (Binding.str_of b));
   543     val (res, consts') = consts_of thy
   543     val (res, consts') = consts_of thy
   544       |> Consts.abbreviate pp (tsig_of thy) (naming_of thy) mode tags (b, t);
   544       |> Consts.abbreviate pp (tsig_of thy) (naming_of thy) mode (b, t);
   545   in (res, thy |> map_consts (K consts')) end;
   545   in (res, thy |> map_consts (K consts')) end;
   546 
   546 
   547 fun revert_abbrev mode c = map_consts (Consts.revert_abbrev mode c);
   547 fun revert_abbrev mode c = map_consts (Consts.revert_abbrev mode c);
   548 
   548 
   549 
   549