src/Tools/Code/code_target.ML
changeset 36960 01594f816e3a
parent 36959 f5417836dbea
child 37528 42804fb5dd92
equal deleted inserted replaced
36959:f5417836dbea 36960:01594f816e3a
   461 
   461 
   462 (* concrete syntax *)
   462 (* concrete syntax *)
   463 
   463 
   464 local
   464 local
   465 
   465 
   466 structure P = OuterParse
       
   467 and K = OuterKeyword
       
   468 
       
   469 fun zip_list (x::xs) f g =
   466 fun zip_list (x::xs) f g =
   470   f
   467   f
   471   #-> (fn y =>
   468   #-> (fn y =>
   472     fold_map (fn x => g |-- f >> pair x) xs
   469     fold_map (fn x => g |-- f >> pair x) xs
   473     #-> (fn xys => pair ((x, y) :: xys)));
   470     #-> (fn xys => pair ((x, y) :: xys)));
   474 
   471 
   475 fun parse_multi_syntax parse_thing parse_syntax =
   472 fun parse_multi_syntax parse_thing parse_syntax =
   476   P.and_list1 parse_thing
   473   Parse.and_list1 parse_thing
   477   #-> (fn things => Scan.repeat1 (P.$$$ "(" |-- P.name --
   474   #-> (fn things => Scan.repeat1 (Parse.$$$ "(" |-- Parse.name --
   478         (zip_list things parse_syntax (P.$$$ "and")) --| P.$$$ ")"));
   475         (zip_list things parse_syntax (Parse.$$$ "and")) --| Parse.$$$ ")"));
   479 
   476 
   480 in
   477 in
   481 
   478 
   482 val add_syntax_class = gen_add_syntax_class cert_class;
   479 val add_syntax_class = gen_add_syntax_class cert_class;
   483 val add_syntax_inst = gen_add_syntax_inst cert_inst;
   480 val add_syntax_inst = gen_add_syntax_inst cert_inst;
   505 (** Isar setup **)
   502 (** Isar setup **)
   506 
   503 
   507 val (inK, module_nameK, fileK) = ("in", "module_name", "file");
   504 val (inK, module_nameK, fileK) = ("in", "module_name", "file");
   508 
   505 
   509 val code_exprP =
   506 val code_exprP =
   510   (Scan.repeat1 P.term_group
   507   (Scan.repeat1 Parse.term_group
   511   -- Scan.repeat (P.$$$ inK |-- P.name
   508   -- Scan.repeat (Parse.$$$ inK |-- Parse.name
   512      -- Scan.option (P.$$$ module_nameK |-- P.name)
   509      -- Scan.option (Parse.$$$ module_nameK |-- Parse.name)
   513      -- Scan.option (P.$$$ fileK |-- P.name)
   510      -- Scan.option (Parse.$$$ fileK |-- Parse.name)
   514      -- Scan.optional (P.$$$ "(" |-- Args.parse --| P.$$$ ")") []
   511      -- Scan.optional (Parse.$$$ "(" |-- Args.parse --| Parse.$$$ ")") []
   515   ) >> (fn (raw_cs, seris) => export_code_cmd raw_cs seris));
   512   ) >> (fn (raw_cs, seris) => export_code_cmd raw_cs seris));
   516 
   513 
   517 val _ = List.app OuterKeyword.keyword [inK, module_nameK, fileK];
   514 val _ = List.app Keyword.keyword [inK, module_nameK, fileK];
   518 
   515 
   519 val _ =
   516 val _ =
   520   OuterSyntax.command "code_class" "define code syntax for class" K.thy_decl (
   517   Outer_Syntax.command "code_class" "define code syntax for class" Keyword.thy_decl (
   521     parse_multi_syntax P.xname (Scan.option P.string)
   518     parse_multi_syntax Parse.xname (Scan.option Parse.string)
   522     >> (Toplevel.theory oo fold) (fn (target, syns) =>
   519     >> (Toplevel.theory oo fold) (fn (target, syns) =>
   523           fold (fn (raw_class, syn) => add_syntax_class_cmd target raw_class syn) syns)
   520           fold (fn (raw_class, syn) => add_syntax_class_cmd target raw_class syn) syns)
   524   );
   521   );
   525 
   522 
   526 val _ =
   523 val _ =
   527   OuterSyntax.command "code_instance" "define code syntax for instance" K.thy_decl (
   524   Outer_Syntax.command "code_instance" "define code syntax for instance" Keyword.thy_decl (
   528     parse_multi_syntax (P.xname --| P.$$$ "::" -- P.xname) (Scan.option (P.minus >> K ()))
   525     parse_multi_syntax (Parse.xname --| Parse.$$$ "::" -- Parse.xname)
       
   526       (Scan.option (Parse.minus >> K ()))
   529     >> (Toplevel.theory oo fold) (fn (target, syns) =>
   527     >> (Toplevel.theory oo fold) (fn (target, syns) =>
   530           fold (fn (raw_inst, add_del) => add_syntax_inst_cmd target raw_inst add_del) syns)
   528           fold (fn (raw_inst, add_del) => add_syntax_inst_cmd target raw_inst add_del) syns)
   531   );
   529   );
   532 
   530 
   533 val _ =
   531 val _ =
   534   OuterSyntax.command "code_type" "define code syntax for type constructor" K.thy_decl (
   532   Outer_Syntax.command "code_type" "define code syntax for type constructor" Keyword.thy_decl (
   535     parse_multi_syntax P.xname (Code_Printer.parse_syntax I)
   533     parse_multi_syntax Parse.xname (Code_Printer.parse_syntax I)
   536     >> (Toplevel.theory oo fold) (fn (target, syns) =>
   534     >> (Toplevel.theory oo fold) (fn (target, syns) =>
   537           fold (fn (raw_tyco, syn) => add_syntax_tyco_cmd target raw_tyco syn) syns)
   535           fold (fn (raw_tyco, syn) => add_syntax_tyco_cmd target raw_tyco syn) syns)
   538   );
   536   );
   539 
   537 
   540 val _ =
   538 val _ =
   541   OuterSyntax.command "code_const" "define code syntax for constant" K.thy_decl (
   539   Outer_Syntax.command "code_const" "define code syntax for constant" Keyword.thy_decl (
   542     parse_multi_syntax P.term_group (Code_Printer.parse_syntax fst)
   540     parse_multi_syntax Parse.term_group (Code_Printer.parse_syntax fst)
   543     >> (Toplevel.theory oo fold) (fn (target, syns) =>
   541     >> (Toplevel.theory oo fold) (fn (target, syns) =>
   544       fold (fn (raw_const, syn) => add_syntax_const_simple_cmd target raw_const syn) syns)
   542       fold (fn (raw_const, syn) => add_syntax_const_simple_cmd target raw_const syn) syns)
   545   );
   543   );
   546 
   544 
   547 val _ =
   545 val _ =
   548   OuterSyntax.command "code_reserved" "declare words as reserved for target language" K.thy_decl (
   546   Outer_Syntax.command "code_reserved" "declare words as reserved for target language"
   549     P.name -- Scan.repeat1 P.name
   547     Keyword.thy_decl (
       
   548     Parse.name -- Scan.repeat1 Parse.name
   550     >> (fn (target, reserveds) => (Toplevel.theory o fold (add_reserved target)) reserveds)
   549     >> (fn (target, reserveds) => (Toplevel.theory o fold (add_reserved target)) reserveds)
   551   );
   550   );
   552 
   551 
   553 val _ =
   552 val _ =
   554   OuterSyntax.command "code_include" "declare piece of code to be included in generated code" K.thy_decl (
   553   Outer_Syntax.command "code_include" "declare piece of code to be included in generated code"
   555     P.name -- P.name -- (P.text :|-- (fn "-" => Scan.succeed NONE
   554     Keyword.thy_decl (
   556       | s => Scan.optional (P.$$$ "attach" |-- Scan.repeat1 P.term) [] >> pair s >> SOME))
   555     Parse.name -- Parse.name -- (Parse.text :|-- (fn "-" => Scan.succeed NONE
       
   556       | s => Scan.optional (Parse.$$$ "attach" |-- Scan.repeat1 Parse.term) [] >> pair s >> SOME))
   557     >> (fn ((target, name), content_consts) =>
   557     >> (fn ((target, name), content_consts) =>
   558         (Toplevel.theory o add_include_cmd target) (name, content_consts))
   558         (Toplevel.theory o add_include_cmd target) (name, content_consts))
   559   );
   559   );
   560 
   560 
   561 val _ =
   561 val _ =
   562   OuterSyntax.command "code_modulename" "alias module to other name" K.thy_decl (
   562   Outer_Syntax.command "code_modulename" "alias module to other name" Keyword.thy_decl (
   563     P.name -- Scan.repeat1 (P.name -- P.name)
   563     Parse.name -- Scan.repeat1 (Parse.name -- Parse.name)
   564     >> (fn (target, modlnames) => (Toplevel.theory o fold (add_module_alias target)) modlnames)
   564     >> (fn (target, modlnames) => (Toplevel.theory o fold (add_module_alias target)) modlnames)
   565   );
   565   );
   566 
   566 
   567 val _ =
   567 val _ =
   568   OuterSyntax.command "code_abort" "permit constant to be implemented as program abort" K.thy_decl (
   568   Outer_Syntax.command "code_abort" "permit constant to be implemented as program abort"
   569     Scan.repeat1 P.term_group >> (Toplevel.theory o fold allow_abort_cmd)
   569     Keyword.thy_decl (
   570   );
   570     Scan.repeat1 Parse.term_group >> (Toplevel.theory o fold allow_abort_cmd)
   571 
   571   );
   572 val _ =
   572 
   573   OuterSyntax.command "export_code" "generate executable code for constants"
   573 val _ =
   574     K.diag (P.!!! code_exprP >> (fn f => Toplevel.keep (f o Toplevel.theory_of)));
   574   Outer_Syntax.command "export_code" "generate executable code for constants"
       
   575     Keyword.diag (Parse.!!! code_exprP >> (fn f => Toplevel.keep (f o Toplevel.theory_of)));
   575 
   576 
   576 fun shell_command thyname cmd = Toplevel.program (fn _ =>
   577 fun shell_command thyname cmd = Toplevel.program (fn _ =>
   577   (use_thy thyname; case Scan.read Token.stopper (P.!!! code_exprP)
   578   (use_thy thyname; case Scan.read Token.stopper (Parse.!!! code_exprP)
   578     ((filter Token.is_proper o OuterSyntax.scan Position.none) cmd)
   579     ((filter Token.is_proper o Outer_Syntax.scan Position.none) cmd)
   579    of SOME f => (writeln "Now generating code..."; f (theory thyname))
   580    of SOME f => (writeln "Now generating code..."; f (theory thyname))
   580     | NONE => error ("Bad directive " ^ quote cmd)))
   581     | NONE => error ("Bad directive " ^ quote cmd)))
   581   handle Runtime.TOPLEVEL_ERROR => OS.Process.exit OS.Process.failure;
   582   handle Runtime.TOPLEVEL_ERROR => OS.Process.exit OS.Process.failure;
   582 
   583 
   583 end; (*local*)
   584 end; (*local*)