src/Pure/Syntax/syntax_ext.ML
changeset 80920 bbe2c56fe255
parent 80919 1a52cc1c3274
child 80922 e0b958719301
equal deleted inserted replaced
80919:1a52cc1c3274 80920:bbe2c56fe255
    27       parse_rules: (Ast.ast * Ast.ast) list,
    27       parse_rules: (Ast.ast * Ast.ast) list,
    28       parse_translation: (string * ((Proof.context -> term list -> term) * stamp)) list,
    28       parse_translation: (string * ((Proof.context -> term list -> term) * stamp)) list,
    29       print_translation: (string * ((Proof.context -> typ -> term list -> term) * stamp)) list,
    29       print_translation: (string * ((Proof.context -> typ -> term list -> term) * stamp)) list,
    30       print_rules: (Ast.ast * Ast.ast) list,
    30       print_rules: (Ast.ast * Ast.ast) list,
    31       print_ast_translation: (string * ((Proof.context -> Ast.ast list -> Ast.ast) * stamp)) list}
    31       print_ast_translation: (string * ((Proof.context -> Ast.ast list -> Ast.ast) * stamp)) list}
    32   val make_notation: {kind: string, name: string} -> string
    32   val block_annotation: int -> Markup.T -> string -> string
    33   val mfix_name: Proof.context -> Symbol_Pos.T list -> string
    33   val mfix_name: Proof.context -> Symbol_Pos.T list -> string
    34   val mfix_args: Proof.context -> Symbol_Pos.T list -> int
    34   val mfix_args: Proof.context -> Symbol_Pos.T list -> int
    35   val mixfix_args: Proof.context -> Input.source -> int
    35   val mixfix_args: Proof.context -> Input.source -> int
    36   val escape: string -> string
    36   val escape: string -> string
    37   val syn_ext: Proof.context -> string list -> mfix list ->
    37   val syn_ext: Proof.context -> string list -> mfix list ->
   121 datatype mfix = Mfix of Symbol_Pos.T list * typ * string * int list * int * Position.T;
   121 datatype mfix = Mfix of Symbol_Pos.T list * typ * string * int list * int * Position.T;
   122 
   122 
   123 
   123 
   124 (* properties *)
   124 (* properties *)
   125 
   125 
   126 fun make_notation {kind, name} =
   126 fun block_annotation indent notation_markup notation_name =
   127   Properties.print_eq (Markup.notationN, cartouche (implode_space (remove (op =) "" [kind, name])));
   127   let
       
   128     val (elem, props) = notation_markup |> notation_name <> "" ? Markup.name notation_name;
       
   129     val kind = Properties.get props Markup.kindN;
       
   130     val name = Properties.get props Markup.nameN;
       
   131     val s1 = if indent = 0 then [] else ["indent=" ^ Value.print_int indent];
       
   132     val s2 =
       
   133       if elem = Markup.notationN then
       
   134         [Properties.print_eq (elem, cartouche (implode_space (the_list kind @ the_list name)))]
       
   135       else raise Fail ("Bad markup element for notatio: " ^ quote elem)
       
   136   in cartouche (implode_space (s1 @ s2)) end;
   128 
   137 
   129 fun show_names names =
   138 fun show_names names =
   130   commas_quote (map (fn (name, pos) => Markup.markup (Position.markup pos) name) names);
   139   commas_quote (map (fn (name, pos) => Markup.markup (Position.markup pos) name) names);
   131 
   140 
   132 local
   141 local
   155   | SOME (_, NONE) => default1
   164   | SOME (_, NONE) => default1
   156   | SOME ((_, pos1), SOME (b, pos2)) =>
   165   | SOME ((_, pos1), SOME (b, pos2)) =>
   157       (parse (b, pos2) handle Fail msg =>
   166       (parse (b, pos2) handle Fail msg =>
   158         error (msg ^ " for property " ^ quote name ^ Position.here_list [pos1, pos2])));
   167         error (msg ^ " for property " ^ quote name ^ Position.here_list [pos1, pos2])));
   159 
   168 
   160 fun parse_notation (s, pos) =
   169 fun parse_notation ctxt (s, pos) =
   161   let
   170   let
   162     val (kind, name) =
   171     val (kind, name) =
   163       (case Symbol.explode_words s of
   172       (case Symbol.explode_words s of
   164         [] => ("", "")
   173         [] => ("", "")
   165       | a :: bs => (a, space_implode " " bs));
   174       | a :: bs => (a, space_implode " " bs));
   166   in
   175     val markup =
   167     if kind = "" orelse member (op =) Markup.notations kind then
   176       (case try (fn () => Markup_Kind.check_notation ctxt (kind, Position.none)) () of
   168       Markup.notation {kind = kind, name = name}
   177         SOME m => m
   169     else
   178       | NONE =>
   170       error ("Bad notation kind " ^ quote kind ^ Position.here pos ^
   179           error ("Bad notation kind " ^ quote kind ^ Position.here pos ^
   171         ", expected: " ^ commas_quote Markup.notations)
   180             ", expected: " ^ commas_quote (Markup_Kind.get_notation_kinds ctxt)));
   172   end;
   181   in markup |> Markup.properties (Markup.name_proper name) end;
   173 
   182 
   174 in
   183 in
   175 
   184 
   176 fun read_properties ss =
   185 fun read_properties ss =
   177   let
   186   let
   188 
   197 
   189 val get_string = get_property "" "" #1;
   198 val get_string = get_property "" "" #1;
   190 val get_bool = get_property false true (Value.parse_bool o #1);
   199 val get_bool = get_property false true (Value.parse_bool o #1);
   191 val get_nat = get_property 0 1 (Value.parse_nat o #1);
   200 val get_nat = get_property 0 1 (Value.parse_nat o #1);
   192 
   201 
   193 val get_notation_markup =
   202 fun get_notation_markup ctxt =
   194   get_property NONE (SOME Markup.notation0) (SOME o parse_notation) Markup.notationN;
   203   get_property NONE (SOME Markup.notation0) (SOME o parse_notation ctxt) Markup.notationN;
   195 
   204 
   196 fun get_expression_markup ctxt =
   205 fun get_expression_markup ctxt =
   197   get_property NONE (SOME Markup.expression0) (SOME o Markup_Kind.check_expression ctxt)
   206   get_property NONE (SOME Markup.expression0) (SOME o Markup_Kind.check_expression ctxt)
   198     Markup.expressionN;
   207     Markup.expressionN;
   199 
   208 
   240 fun read_block_properties ctxt ss =
   249 fun read_block_properties ctxt ss =
   241   let
   250   let
   242     val props = read_properties ss;
   251     val props = read_properties ss;
   243 
   252 
   244     val more_markups =
   253     val more_markups =
   245       the_list (get_notation_markup props) @
   254       the_list (get_notation_markup ctxt props) @
   246       the_list (get_expression_markup ctxt props);
   255       the_list (get_expression_markup ctxt props);
   247 
   256 
   248     val markup_name = get_string Markup.markupN props;
   257     val markup_name = get_string Markup.markupN props;
   249     val markup_props = props |> map_filter (fn (a, opt_b) =>
   258     val markup_props = props |> map_filter (fn (a, opt_b) =>
   250       if member (op =) Markup.block_properties (#1 a) then NONE
   259       if member (op =) Markup.block_properties (#1 a) then NONE