224 lines
7.2 KiB
Plaintext
224 lines
7.2 KiB
Plaintext
(******************************************************************************
|
|
* ISABELLE COPYRIGHT NOTICE, LICENCE AND DISCLAIMER.
|
|
*
|
|
* Copyright (c) 1986-2016 University of Cambridge,
|
|
* Technische Universitaet Muenchen,
|
|
* and contributors.
|
|
* 2013-2016 Université Paris-Saclay, Univ. Paris-Sud, France
|
|
* 2013-2016 IRT SystemX, France
|
|
*
|
|
* All rights reserved.
|
|
*
|
|
* Redistribution and use in source and binary forms, with or without
|
|
* modification, are permitted provided that the following conditions are
|
|
* met:
|
|
*
|
|
* * Redistributions of source code must retain the above copyright
|
|
* notice, this list of conditions and the following disclaimer.
|
|
*
|
|
* * Redistributions in binary form must reproduce the above
|
|
* copyright notice, this list of conditions and the following
|
|
* disclaimer in the documentation and/or other materials provided
|
|
* with the distribution.
|
|
*
|
|
* * Neither the name of the copyright holders nor the names of its
|
|
* contributors may be used to endorse or promote products derived
|
|
* from this software without specific prior written permission.
|
|
*
|
|
* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
|
* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
|
|
* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
|
|
* A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
|
|
* OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
|
|
* SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
|
|
* LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
|
|
* DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
|
|
* THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
|
|
* (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
|
|
* OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
|
******************************************************************************)
|
|
|
|
chapter{* Part ... *}
|
|
|
|
theory Isabelle_code_target
|
|
imports Main
|
|
keywords "lazy_code_printing" "apply_code_printing" "apply_code_printing_reflect"
|
|
:: thy_decl
|
|
begin
|
|
|
|
subsection{* beginning (lazy code printing) *}
|
|
|
|
ML{*
|
|
structure Isabelle_Code_Target =
|
|
struct
|
|
(* Title: Tools/Code/code_target.ML
|
|
Author: Florian Haftmann, TU Muenchen
|
|
|
|
Generic infrastructure for target language data.
|
|
*)
|
|
|
|
open Basic_Code_Symbol;
|
|
open Basic_Code_Thingol;
|
|
|
|
|
|
|
|
(** checking and parsing of symbols **)
|
|
|
|
|
|
val parse_classrel_ident = Parse.class --| @{keyword "<"} -- Parse.class;
|
|
|
|
|
|
val parse_inst_ident = Parse.name --| @{keyword "::"} -- Parse.class;
|
|
|
|
|
|
|
|
(** serializations and serializer **)
|
|
|
|
(* serialization: abstract nonsense to cover different destinies for generated code *)
|
|
|
|
|
|
|
|
(* serializers: functions producing serializations *)
|
|
|
|
|
|
|
|
(** theory data **)
|
|
|
|
|
|
|
|
(** serializer usage **)
|
|
|
|
(* technical aside: pretty printing width *)
|
|
|
|
|
|
|
|
(* montage *)
|
|
|
|
|
|
|
|
(* code generation *)
|
|
|
|
fun prep_destination (s, pos) =
|
|
if s = "" then NONE
|
|
else
|
|
let
|
|
val _ = Position.report pos Markup.language_path;
|
|
val path = Path.explode s;
|
|
val _ = Position.report pos (Markup.path (Path.smart_implode path));
|
|
in SOME path end;
|
|
|
|
|
|
fun export_code_cmd all_public raw_cs seris ctxt =
|
|
Code_Target.export_code ctxt all_public
|
|
(Code_Thingol.read_const_exprs ctxt raw_cs)
|
|
((map o apfst o apsnd) prep_destination seris);
|
|
|
|
|
|
|
|
(** serializer configuration **)
|
|
|
|
(* reserved symbol names *)
|
|
|
|
|
|
|
|
(* checking of syntax *)
|
|
|
|
|
|
|
|
(* custom symbol names *)
|
|
|
|
|
|
|
|
(* custom printings *)
|
|
|
|
|
|
|
|
(* concrete syntax *)
|
|
|
|
|
|
(** Isar setup **)
|
|
|
|
fun parse_single_symbol_pragma parse_keyword parse_isa parse_target =
|
|
parse_keyword |-- Parse.!!! (parse_isa --| (@{keyword "\<rightharpoonup>"} || @{keyword "=>"})
|
|
-- Parse.and_list1 (@{keyword "("} |-- (Parse.name --| @{keyword ")"} -- Scan.option parse_target)));
|
|
|
|
fun parse_symbol_pragma parse_const parse_tyco parse_class parse_classrel parse_inst parse_module =
|
|
parse_single_symbol_pragma @{keyword "constant"} Parse.term parse_const
|
|
>> Constant
|
|
|| parse_single_symbol_pragma @{keyword "type_constructor"} Parse.type_const parse_tyco
|
|
>> Type_Constructor
|
|
|| parse_single_symbol_pragma @{keyword "type_class"} Parse.class parse_class
|
|
>> Type_Class
|
|
|| parse_single_symbol_pragma @{keyword "class_relation"} parse_classrel_ident parse_classrel
|
|
>> Class_Relation
|
|
|| parse_single_symbol_pragma @{keyword "class_instance"} parse_inst_ident parse_inst
|
|
>> Class_Instance
|
|
|| parse_single_symbol_pragma @{keyword "code_module"} Parse.name parse_module
|
|
>> Code_Symbol.Module;
|
|
|
|
fun parse_symbol_pragmas parse_const parse_tyco parse_class parse_classrel parse_inst parse_module =
|
|
Parse.enum1 "|" (Parse.group (fn () => "code symbol pragma")
|
|
(parse_symbol_pragma parse_const parse_tyco parse_class parse_classrel parse_inst parse_module));
|
|
|
|
end
|
|
*}
|
|
|
|
ML{*
|
|
structure Code_printing = struct
|
|
datatype code_printing = Code_printing of
|
|
(string * (bstring * Code_Printer.raw_const_syntax option) list,
|
|
string * (bstring * Code_Printer.tyco_syntax option) list,
|
|
string * (bstring * string option) list,
|
|
(string * string) * (bstring * unit option) list,
|
|
(xstring * string) * (bstring * unit option) list,
|
|
bstring * (bstring * (string * string list) option) list)
|
|
Code_Symbol.attr
|
|
list
|
|
|
|
structure Data_code = Theory_Data
|
|
(type T = code_printing list Symtab.table
|
|
val empty = Symtab.empty
|
|
val extend = I
|
|
val merge = Symtab.merge (K true))
|
|
|
|
val code_empty = ""
|
|
|
|
val () =
|
|
Outer_Syntax.command @{command_keyword lazy_code_printing} "declare dedicated printing for code symbols"
|
|
(Isabelle_Code_Target.parse_symbol_pragmas (Code_Printer.parse_const_syntax) (Code_Printer.parse_tyco_syntax)
|
|
Parse.string (Parse.minus >> K ()) (Parse.minus >> K ())
|
|
(Parse.text -- Scan.optional (@{keyword "attach"} |-- Scan.repeat1 Parse.term) [])
|
|
>> (fn code =>
|
|
Toplevel.theory (Data_code.map (Symtab.map_default (code_empty, []) (fn l => Code_printing code :: l)))))
|
|
|
|
fun apply_code_printing thy =
|
|
(case Symtab.lookup (Data_code.get thy) code_empty of SOME l => rev l | _ => [])
|
|
|> (fn l => fold (fn Code_printing l => fold Code_Target.set_printings l) l thy)
|
|
|
|
val () =
|
|
Outer_Syntax.command @{command_keyword apply_code_printing} "apply dedicated printing for code symbols"
|
|
(Parse.$$$ "(" -- Parse.$$$ ")" >> K (Toplevel.theory apply_code_printing))
|
|
|
|
fun reflect_ml source thy =
|
|
case ML_Context.exec (fn () =>
|
|
ML_Context.eval_source (ML_Compiler.verbose false ML_Compiler.flags) source) (Context.Theory thy) of
|
|
Context.Theory thy => thy
|
|
|
|
fun apply_code_printing_reflect thy =
|
|
(case Symtab.lookup (Data_code.get thy) code_empty of SOME l => rev l | _ => [])
|
|
|> (fn l => fold (fn Code_printing l =>
|
|
fold (fn Code_Symbol.Module (_, l) =>
|
|
fold (fn ("SML", SOME (txt, _)) => reflect_ml (Input.source false txt (Position.none, Position.none))
|
|
| _ => I) l
|
|
| _ => I) l) l thy)
|
|
|
|
val () =
|
|
Outer_Syntax.command @{command_keyword apply_code_printing_reflect} "apply dedicated printing for code symbols"
|
|
(Parse.ML_source >> (fn src => Toplevel.theory (apply_code_printing_reflect o reflect_ml src)))
|
|
|
|
end
|
|
|
|
*}
|
|
|
|
end
|