423 (cert_class thy class, cert_tyco thy tyco); |
423 (cert_class thy class, cert_tyco thy tyco); |
424 |
424 |
425 fun read_inst thy (raw_tyco, raw_class) = |
425 fun read_inst thy (raw_tyco, raw_class) = |
426 (read_class thy raw_class, read_tyco thy raw_tyco); |
426 (read_class thy raw_class, read_tyco thy raw_tyco); |
427 |
427 |
428 fun gen_add_syntax upd del mapp check_x check_raw_syn prep_syn prep_x target raw_x some_raw_syn thy = |
428 fun gen_add_syntax (mapp, upd, del) prep_x prep_syn check target raw_x some_raw_syn thy = |
429 let |
429 let |
430 val x = prep_x thy raw_x |> tap (check_x thy); |
430 val x = prep_x thy raw_x; |
431 fun prep_check raw_syn = prep_syn (raw_syn |> tap (check_raw_syn thy target)); |
431 fun make_syn raw_syn = (check thy x raw_syn: unit; prep_syn raw_syn); |
432 in case some_raw_syn |
432 in case some_raw_syn |
433 of SOME raw_syn => (map_name_syntax target o mapp) (upd (x, prep_check raw_syn)) thy |
433 of SOME raw_syn => (map_name_syntax target o mapp) (upd (x, make_syn raw_syn)) thy |
434 | NONE => (map_name_syntax target o mapp) (del x) thy |
434 | NONE => (map_name_syntax target o mapp) (del x) thy |
435 end; |
435 end; |
436 |
436 |
437 fun gen_add_syntax_class prep_class = |
437 fun gen_add_syntax_class prep_class = |
438 gen_add_syntax Symtab.update Symtab.delete_safe (apfst o apfst) (K I) ((K o K o K) ()) I prep_class; |
438 gen_add_syntax (apfst o apfst, Symtab.update, Symtab.delete_safe) prep_class I ((K o K o K) ()); |
439 |
439 |
440 fun gen_add_syntax_inst prep_inst = |
440 fun gen_add_syntax_inst prep_inst = |
441 gen_add_syntax Symreltab.update Symreltab.delete_safe (apfst o apsnd) (K I) ((K o K o K) ()) I prep_inst; |
441 gen_add_syntax (apfst o apsnd, Symreltab.update, Symreltab.delete_safe) prep_inst I ((K o K o K) ()); |
442 |
442 |
443 fun gen_add_syntax_tyco prep_tyco = |
443 fun gen_add_syntax_tyco prep_tyco = |
444 gen_add_syntax Symtab.update Symtab.delete_safe (apsnd o apfst) |
444 gen_add_syntax (apsnd o apfst, Symtab.update, Symtab.delete_safe) prep_tyco I |
445 (fn thy => fn tyco => fn (n, _) => if n <> Sign.arity_number thy tyco |
445 (fn thy => fn tyco => fn (n, _) => if n <> Sign.arity_number thy tyco |
446 then error ("Number of arguments mismatch in syntax for type constructor " ^ quote tyco) |
446 then error ("Number of arguments mismatch in syntax for type constructor " ^ quote tyco) |
447 else ()) ((K o K o K) ()) I prep_tyco; |
447 else ()); |
448 |
448 |
449 fun gen_add_syntax_const prep_const check_raw_syn prep_syn = |
449 fun gen_add_syntax_const prep_const prep_syn check_raw_syn = |
450 gen_add_syntax Symtab.update Symtab.delete_safe (apsnd o apsnd) |
450 gen_add_syntax (apsnd o apsnd, Symtab.update, Symtab.delete_safe) prep_const prep_syn |
451 (fn thy => fn c => fn (n, _) => if n > Code.args_number thy c |
451 (fn thy => fn c => fn (n, _) => if n > Code.args_number thy c |
452 then error ("Too many arguments in syntax for constant " ^ quote c) |
452 then error ("Too many arguments in syntax for constant " ^ quote c) |
453 else ()) check_raw_syn prep_syn prep_const; |
453 else ()) check_raw_syn; |
454 |
454 |
455 fun add_reserved target = |
455 fun add_reserved target = |
456 let |
456 let |
457 fun add sym syms = if member (op =) syms sym |
457 fun add sym syms = if member (op =) syms sym |
458 then error ("Reserved symbol " ^ quote sym ^ " already declared") |
458 then error ("Reserved symbol " ^ quote sym ^ " already declared") |
508 in |
508 in |
509 |
509 |
510 val add_syntax_class = gen_add_syntax_class cert_class; |
510 val add_syntax_class = gen_add_syntax_class cert_class; |
511 val add_syntax_inst = gen_add_syntax_inst cert_inst; |
511 val add_syntax_inst = gen_add_syntax_inst cert_inst; |
512 val add_syntax_tyco = gen_add_syntax_tyco cert_tyco; |
512 val add_syntax_tyco = gen_add_syntax_tyco cert_tyco; |
513 val add_syntax_const_simple = gen_add_syntax_const (K I) ((K o K o K) ()) Code_Printer.simple_const_syntax; |
513 val add_syntax_const_simple = gen_add_syntax_const (K I) Code_Printer.simple_const_syntax; |
514 val add_syntax_const = gen_add_syntax_const (K I) ((K o K o K) ()) I; |
514 val add_syntax_const = gen_add_syntax_const (K I) I; |
515 val allow_abort = gen_allow_abort (K I); |
515 val allow_abort = gen_allow_abort (K I); |
516 val add_reserved = add_reserved; |
516 val add_reserved = add_reserved; |
517 val add_include = add_include; |
517 val add_include = add_include; |
518 |
518 |
519 val add_syntax_class_cmd = gen_add_syntax_class read_class; |
519 val add_syntax_class_cmd = gen_add_syntax_class read_class; |
520 val add_syntax_inst_cmd = gen_add_syntax_inst read_inst; |
520 val add_syntax_inst_cmd = gen_add_syntax_inst read_inst; |
521 val add_syntax_tyco_cmd = gen_add_syntax_tyco read_tyco; |
521 val add_syntax_tyco_cmd = gen_add_syntax_tyco read_tyco; |
522 val add_syntax_const_simple_cmd = gen_add_syntax_const Code.read_const ((K o K o K) ()) Code_Printer.simple_const_syntax; |
522 val add_syntax_const_simple_cmd = gen_add_syntax_const Code.read_const Code_Printer.simple_const_syntax; |
523 val add_syntax_const_cmd = gen_add_syntax_const Code.read_const ((K o K o K) ()) I; |
523 val add_syntax_const_cmd = gen_add_syntax_const Code.read_const I; |
524 |
524 |
525 val allow_abort_cmd = gen_allow_abort Code.read_const; |
525 val allow_abort_cmd = gen_allow_abort Code.read_const; |
526 |
526 |
527 fun parse_args f args = |
527 fun parse_args f args = |
528 case Scan.read Token.stopper f args |
528 case Scan.read Token.stopper f args |