mirror of
https://github.com/CatalaLang/catala.git
synced 2024-11-08 07:51:43 +03:00
refactor(compiler): split web plugin into api_web and json_schema + factorize some util functions
This commit is contained in:
Emile Rolley
parent
26663f227d
commit
21af0c8c04
@ -81,20 +81,12 @@ let driver source_file (options : Cli.options) : int =
|
||||
Surface.Parser_driver.parse_top_level_file source_file language
|
||||
in
|
||||
let prgm = Surface.Fill_positions.fill_pos_with_legislative_info prgm in
|
||||
let get_output ?ext () =
|
||||
match options.output_file, ext with
|
||||
| Some "-", _ | None, None -> None, fun f -> f stdout
|
||||
| Some f, _ -> Some f, File.with_out_channel f
|
||||
| None, Some ext ->
|
||||
let src =
|
||||
match source_file with FileName f -> f | Contents _ -> "a"
|
||||
in
|
||||
let f = Filename.remove_extension src ^ ext in
|
||||
Some f, File.with_out_channel f
|
||||
let get_output ?ext =
|
||||
File.get_out_channel ~source_file ~output_file:options.output_file ?ext
|
||||
in
|
||||
let get_output_format ?ext () =
|
||||
let f, with_ = get_output ?ext () in
|
||||
f, fun f -> with_ (fun oc -> File.with_formatter_of_out_channel oc f)
|
||||
let get_output_format ?ext =
|
||||
File.get_formatter_of_out_channel ~source_file
|
||||
~output_file:options.output_file ?ext
|
||||
in
|
||||
(match backend with
|
||||
| `Makefile ->
|
||||
@ -340,13 +332,10 @@ let driver source_file (options : Cli.options) : int =
|
||||
(Option.value ~default:"stdout" output_file);
|
||||
Lcalc.To_ocaml.format_program fmt prgm type_ordering
|
||||
| `Plugin (Plugin.Lcalc p) ->
|
||||
let output_file, _ = get_output ~ext:p.Plugin.extension () in
|
||||
Cli.debug_print "Compiling program through backend \"%s\"..."
|
||||
p.Plugin.name;
|
||||
Cli.debug_print "Writing to %s..."
|
||||
(Option.value ~default:"stdout" output_file);
|
||||
p.Plugin.apply ~output_file ~scope:options.ex_scope prgm
|
||||
type_ordering
|
||||
p.Plugin.apply ~source_file ~output_file:options.output_file
|
||||
~scope:options.ex_scope prgm type_ordering
|
||||
| (`Python | `Scalc | `Plugin (Plugin.Scalc _)) as backend -> (
|
||||
let prgm = Scalc.Compile_from_lambda.translate_program prgm in
|
||||
match backend with
|
||||
@ -384,8 +373,8 @@ let driver source_file (options : Cli.options) : int =
|
||||
p.Plugin.name;
|
||||
Cli.debug_print "Writing to %s..."
|
||||
(Option.value ~default:"stdout" output_file);
|
||||
p.Plugin.apply ~output_file ~scope:options.ex_scope prgm
|
||||
type_ordering)))))));
|
||||
p.Plugin.apply ~source_file ~output_file
|
||||
~scope:options.ex_scope prgm type_ordering)))))));
|
||||
0
|
||||
with
|
||||
| Errors.StructuredError (msg, pos) ->
|
||||
|
||||
@ -15,6 +15,7 @@
|
||||
the License. *)
|
||||
|
||||
type 'ast plugin_apply_fun_typ =
|
||||
source_file:Utils.Pos.input_file ->
|
||||
output_file:string option ->
|
||||
scope:string option ->
|
||||
'ast ->
|
||||
|
||||
@ -17,6 +17,7 @@
|
||||
(** {2 catala-facing API} *)
|
||||
|
||||
type 'ast plugin_apply_fun_typ =
|
||||
source_file:Utils.Pos.input_file ->
|
||||
output_file:string option ->
|
||||
scope:string option ->
|
||||
'ast ->
|
||||
|
||||
@ -20,9 +20,7 @@
|
||||
It generates:
|
||||
|
||||
- the OCaml code,
|
||||
- the associated [js_of_ocaml] wrapper,
|
||||
- if a scope is specified in the options, the JSON schema used to build the
|
||||
web form. *)
|
||||
- the associated [js_of_ocaml] wrapper. *)
|
||||
|
||||
open Utils
|
||||
open Lcalc
|
||||
@ -31,26 +29,27 @@ open Lcalc.Backends
|
||||
open Lcalc.To_ocaml
|
||||
module D = Dcalc.Ast
|
||||
|
||||
let name = "web"
|
||||
let name = "api_web"
|
||||
let extension = ".ml"
|
||||
|
||||
let to_camel_case (s : string) : string =
|
||||
String.split_on_char '_' s
|
||||
|> (function hd :: tl -> hd :: List.map String.capitalize_ascii tl | l -> l)
|
||||
|> String.concat ""
|
||||
|
||||
let format_struct_field_name_camel_case
|
||||
(fmt : Format.formatter)
|
||||
(v : Dcalc.Ast.StructFieldName.t) : unit =
|
||||
let s =
|
||||
Format.asprintf "%a" Dcalc.Ast.StructFieldName.format_t v
|
||||
|> to_ascii |> to_lowercase |> avoid_keywords |> to_camel_case
|
||||
in
|
||||
Format.fprintf fmt "%s" s
|
||||
|
||||
(** Contains all format functions used to generating the [js_of_ocaml] wrapper
|
||||
of the corresponding Catala program. *)
|
||||
module To_jsoo = struct
|
||||
let to_camel_case (s : string) : string =
|
||||
String.split_on_char '_' s
|
||||
|> (function
|
||||
| hd :: tl -> hd :: List.map String.capitalize_ascii tl | l -> l)
|
||||
|> String.concat ""
|
||||
|
||||
let format_struct_field_name_camel_case
|
||||
(fmt : Format.formatter)
|
||||
(v : Dcalc.Ast.StructFieldName.t) : unit =
|
||||
let s =
|
||||
Format.asprintf "%a" Dcalc.Ast.StructFieldName.format_t v
|
||||
|> to_ascii |> to_lowercase |> avoid_keywords |> to_camel_case
|
||||
in
|
||||
Format.fprintf fmt "%s" s
|
||||
|
||||
let format_tlit (fmt : Format.formatter) (l : Dcalc.Ast.typ_lit) : unit =
|
||||
Dcalc.Print.format_base_type fmt
|
||||
(match l with
|
||||
@ -380,15 +379,18 @@ module To_jsoo = struct
|
||||
|
||||
let format_program
|
||||
(fmt : Format.formatter)
|
||||
(module_name : string)
|
||||
(module_name : string option)
|
||||
(prgm : 'm Lcalc.Ast.program)
|
||||
(type_ordering : Scopelang.Dependency.TVertex.t list) =
|
||||
let fmt_lib_name fmt _ =
|
||||
Format.fprintf fmt "%sLib"
|
||||
(List.nth (String.split_on_char ' ' module_name) 1
|
||||
|> String.split_on_char '_'
|
||||
|> List.map String.capitalize_ascii
|
||||
|> String.concat "")
|
||||
(Option.fold ~none:""
|
||||
~some:(fun name ->
|
||||
List.nth (String.split_on_char ' ' name) 1
|
||||
|> String.split_on_char '_'
|
||||
|> List.map String.capitalize_ascii
|
||||
|> String.concat "")
|
||||
module_name)
|
||||
in
|
||||
|
||||
Cli.call_unstyled (fun _ ->
|
||||
@ -411,240 +413,59 @@ module To_jsoo = struct
|
||||
(object%%js@ @[\n\
|
||||
%a@]@\n\
|
||||
end)@]@?"
|
||||
module_name (format_ctx type_ordering) prgm.decl_ctx
|
||||
(Option.fold ~none:"" ~some:(fun name -> name) module_name)
|
||||
(format_ctx type_ordering) prgm.decl_ctx
|
||||
(format_scopes_to_fun prgm.decl_ctx)
|
||||
prgm.scopes fmt_lib_name ()
|
||||
(format_scopes_to_callbacks prgm.decl_ctx)
|
||||
prgm.scopes)
|
||||
end
|
||||
|
||||
(** Contains all format functions used to format a Lcalc Catala program
|
||||
representation to a JSON schema describing the corresponding web form. *)
|
||||
module To_json = struct
|
||||
let rec find_scope_def (target_name : string) :
|
||||
('m expr, 'm) D.scopes -> ('m expr, 'm) D.scope_def option = function
|
||||
| D.Nil -> None
|
||||
| D.ScopeDef scope_def ->
|
||||
let name =
|
||||
Format.asprintf "%a" D.ScopeName.format_t scope_def.scope_name
|
||||
in
|
||||
if name = target_name then Some scope_def
|
||||
else
|
||||
let _, next_scope = Bindlib.unbind scope_def.scope_next in
|
||||
find_scope_def target_name next_scope
|
||||
|
||||
let fmt_tlit fmt (tlit : D.typ_lit) =
|
||||
match tlit with
|
||||
| TUnit -> Format.fprintf fmt "\"type\": \"null\",@\n\"default\": null"
|
||||
| TInt | TRat -> Format.fprintf fmt "\"type\": \"number\",@\n\"default\": 0"
|
||||
| TMoney ->
|
||||
Format.fprintf fmt
|
||||
"\"type\": \"number\",@\n\"minimum\": 0,@\n\"default\": 0"
|
||||
| TBool -> Format.fprintf fmt "\"type\": \"boolean\",@\n\"default\": false"
|
||||
| TDate -> Format.fprintf fmt "\"type\": \"string\",@\n\"format\": \"date\""
|
||||
| TDuration -> failwith "TODO: tlit duration"
|
||||
|
||||
let rec fmt_type fmt (typ : D.marked_typ) =
|
||||
match Marked.unmark typ with
|
||||
| D.TLit tlit -> fmt_tlit fmt tlit
|
||||
| D.TTuple (_, Some sname) ->
|
||||
Format.fprintf fmt "\"$ref\": \"#/definitions/%a\"" format_struct_name
|
||||
sname
|
||||
| D.TEnum (_, ename) ->
|
||||
Format.fprintf fmt "\"$ref\": \"#/definitions/%a\"" format_enum_name ename
|
||||
| D.TArray t ->
|
||||
Format.fprintf fmt
|
||||
"\"type\": \"array\",@\n\
|
||||
\"default\": [],@\n\
|
||||
@[<hov 2>\"items\": {@\n\
|
||||
%a@]@\n\
|
||||
}"
|
||||
fmt_type t
|
||||
| _ -> ()
|
||||
|
||||
let fmt_struct_properties
|
||||
(ctx : D.decl_ctx)
|
||||
(fmt : Format.formatter)
|
||||
(sname : D.StructName.t) =
|
||||
Format.fprintf fmt "%a"
|
||||
(Format.pp_print_list
|
||||
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@\n")
|
||||
(fun fmt (field_name, field_type) ->
|
||||
Format.fprintf fmt "@[<hov 2>\"%a\": {@\n%a@]@\n}"
|
||||
format_struct_field_name_camel_case field_name fmt_type field_type))
|
||||
(find_struct sname ctx)
|
||||
|
||||
let fmt_definitions
|
||||
(ctx : D.decl_ctx)
|
||||
(fmt : Format.formatter)
|
||||
(scope_def : ('m expr, 'm) D.scope_def) =
|
||||
let get_name t =
|
||||
match Marked.unmark t with
|
||||
| D.TTuple (_, Some sname) ->
|
||||
Format.asprintf "%a" format_struct_name sname
|
||||
| D.TEnum (_, ename) -> Format.asprintf "%a" format_enum_name ename
|
||||
| _ -> failwith "unreachable: only structs and enums are collected."
|
||||
in
|
||||
let rec collect_required_type_defs_from_scope_input
|
||||
(input_struct : D.StructName.t) : D.marked_typ list =
|
||||
let rec collect (acc : D.marked_typ list) (t : D.marked_typ) :
|
||||
D.marked_typ list =
|
||||
match Marked.unmark t with
|
||||
| D.TTuple (_, Some s) ->
|
||||
(* Scope's input is a struct. *)
|
||||
(t :: acc) @ collect_required_type_defs_from_scope_input s
|
||||
| D.TEnum (ts, _) -> List.fold_left collect (t :: acc) ts
|
||||
| D.TArray t -> collect acc t
|
||||
| _ -> acc
|
||||
in
|
||||
find_struct input_struct ctx
|
||||
|> List.fold_left (fun acc (_, field_typ) -> collect acc field_typ) []
|
||||
|> List.sort_uniq (fun t t' -> String.compare (get_name t) (get_name t'))
|
||||
in
|
||||
let fmt_enum_properties fmt ename =
|
||||
let enum_def = find_enum ename ctx in
|
||||
Format.fprintf fmt
|
||||
"@[<hov 2>\"kind\": {@\n\
|
||||
\"type\": \"string\",@\n\
|
||||
@[<hov 2>\"enum\": [@\n\
|
||||
%a@]@\n\
|
||||
]@]@\n\
|
||||
}@\n\
|
||||
},@\n\
|
||||
@[<hov 2>\"allOf\": [@\n\
|
||||
%a@]@\n\
|
||||
]@]@\n\
|
||||
}"
|
||||
(Format.pp_print_list
|
||||
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
|
||||
(fun fmt (enum_cons, _) ->
|
||||
Format.fprintf fmt "\"%a\"" format_enum_cons_name enum_cons))
|
||||
enum_def
|
||||
(Format.pp_print_list
|
||||
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@\n")
|
||||
(fun fmt (enum_cons, payload_type) ->
|
||||
Format.fprintf fmt
|
||||
"@[<hov 2>{@\n\
|
||||
@[<hov 2>\"if\": {@\n\
|
||||
@[<hov 2>\"properties\": {@\n\
|
||||
@[<hov 2>\"kind\": {@\n\
|
||||
\"const\": \"%a\"@]@\n\
|
||||
}@]@\n\
|
||||
}@]@\n\
|
||||
},@\n\
|
||||
@[<hov 2>\"then\": {@\n\
|
||||
@[<hov 2>\"properties\": {@\n\
|
||||
@[<hov 2>\"payload\": {@\n\
|
||||
%a@]@\n\
|
||||
}@]@\n\
|
||||
}@]@\n\
|
||||
}@]@\n\
|
||||
}"
|
||||
format_enum_cons_name enum_cons fmt_type payload_type))
|
||||
enum_def
|
||||
in
|
||||
|
||||
Format.fprintf fmt "@\n%a"
|
||||
(Format.pp_print_list
|
||||
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@\n")
|
||||
(fun fmt typ ->
|
||||
match Marked.unmark typ with
|
||||
| D.TTuple (_, Some sname) ->
|
||||
Format.fprintf fmt
|
||||
"@[<hov 2>\"%a\": {@\n\
|
||||
\"type\": \"object\",@\n\
|
||||
@[<hov 2>\"properties\": {@\n\
|
||||
%a@]@\n\
|
||||
}@]@\n\
|
||||
}"
|
||||
format_struct_name sname
|
||||
(fmt_struct_properties ctx)
|
||||
sname
|
||||
| D.TEnum (_, ename) ->
|
||||
Format.fprintf fmt
|
||||
"@[<hov 2>\"%a\": {@\n\
|
||||
\"type\": \"object\",@\n\
|
||||
@[<hov 2>\"properties\": {@\n\
|
||||
%a@]@]@\n"
|
||||
format_enum_name ename fmt_enum_properties ename
|
||||
| _ -> ()))
|
||||
(collect_required_type_defs_from_scope_input
|
||||
scope_def.scope_body.scope_body_input_struct)
|
||||
|
||||
let format_program
|
||||
(fmt : Format.formatter)
|
||||
(scope : string)
|
||||
(prgm : 'm Lcalc.Ast.program)
|
||||
(_type_ordering : Scopelang.Dependency.TVertex.t list) =
|
||||
match find_scope_def scope prgm.scopes with
|
||||
| None -> Cli.error_print "Internal error: scope '%s' not found." scope
|
||||
| Some scope_def ->
|
||||
Cli.call_unstyled (fun _ ->
|
||||
Format.fprintf fmt
|
||||
"{@[<hov 2>@\n\
|
||||
\"type\": \"object\",@\n\
|
||||
\"@[<hov 2>definitions\": {%a@]@\n\
|
||||
},@\n\
|
||||
\"@[<hov 2>properties\": {@\n\
|
||||
%a@]@\n\
|
||||
}@]@\n\
|
||||
}"
|
||||
(fmt_definitions prgm.decl_ctx)
|
||||
scope_def
|
||||
(fmt_struct_properties prgm.decl_ctx)
|
||||
scope_def.scope_body.scope_body_input_struct)
|
||||
end
|
||||
|
||||
let apply
|
||||
~(source_file : Pos.input_file)
|
||||
~(output_file : string option)
|
||||
~(scope : string option)
|
||||
~scope
|
||||
(prgm : 'm Lcalc.Ast.program)
|
||||
(type_ordering : Scopelang.Dependency.TVertex.t list) =
|
||||
let filename_without_ext_opt =
|
||||
Option.map
|
||||
(fun f -> Filename.basename f |> String.split_on_char '.' |> List.hd)
|
||||
output_file
|
||||
ignore scope;
|
||||
let output_file, with_formatter =
|
||||
File.get_formatter_of_out_channel ~source_file ~output_file ~ext:extension
|
||||
()
|
||||
in
|
||||
let dirname =
|
||||
match output_file with Some f -> Filename.dirname f | None -> ""
|
||||
in
|
||||
|
||||
File.with_formatter_of_opt_file output_file (fun fmt ->
|
||||
with_formatter (fun fmt ->
|
||||
Cli.trace_flag := true;
|
||||
Cli.debug_print "Writing OCaml code to %s..."
|
||||
(Option.value ~default:"stdout" output_file);
|
||||
To_ocaml.format_program fmt prgm type_ordering;
|
||||
File.ocamlformat_file_opt output_file);
|
||||
|
||||
let filename_without_ext =
|
||||
match output_file with
|
||||
| Some "-" -> output_file
|
||||
| Some f -> Some (Filename.basename f |> Filename.remove_extension)
|
||||
| None -> None
|
||||
in
|
||||
let jsoo_output_file, with_formatter =
|
||||
File.get_formatter_of_out_channel ~source_file
|
||||
~output_file:
|
||||
(Option.map
|
||||
(fun name ->
|
||||
if "-" = name then "-"
|
||||
else Filename.remove_extension name ^ "_api_web.ml")
|
||||
output_file)
|
||||
~ext:"_api_web.ml" ()
|
||||
in
|
||||
let module_name =
|
||||
match filename_without_ext_opt with
|
||||
| Some name -> Printf.sprintf "open %s" (String.capitalize_ascii name)
|
||||
| None -> ""
|
||||
in
|
||||
let jsoo_output_file_opt =
|
||||
Option.map
|
||||
(fun f -> Filename.concat dirname (f ^ "_api_web.ml"))
|
||||
filename_without_ext_opt
|
||||
(fun name -> Printf.sprintf "open %s" (String.capitalize_ascii name))
|
||||
filename_without_ext
|
||||
in
|
||||
|
||||
File.with_formatter_of_opt_file jsoo_output_file_opt (fun fmt ->
|
||||
Cli.log_print "module_name: %s\n"
|
||||
@@ Option.fold ~none:"none" ~some:(fun s -> s) module_name;
|
||||
with_formatter (fun fmt ->
|
||||
Cli.debug_print "Writing JSOO API code to %s..."
|
||||
(Option.value ~default:"stdout" jsoo_output_file_opt);
|
||||
(Option.value ~default:"stdout" jsoo_output_file);
|
||||
To_jsoo.format_program fmt module_name prgm type_ordering;
|
||||
File.ocamlformat_file_opt jsoo_output_file_opt);
|
||||
match scope with
|
||||
| Some s ->
|
||||
(* NOTE: Will needs to have the ui_schema + defs too.*)
|
||||
let json_file_opt =
|
||||
Option.map
|
||||
(fun f -> Filename.concat dirname (f ^ "_schema.json"))
|
||||
filename_without_ext_opt
|
||||
in
|
||||
|
||||
File.with_formatter_of_opt_file json_file_opt (fun fmt ->
|
||||
Cli.debug_print
|
||||
"Writing JSON schema corresponding to the scope '%s' to the file \
|
||||
%s..."
|
||||
s
|
||||
(Option.value ~default:"stdout" output_file);
|
||||
To_json.format_program fmt s prgm type_ordering)
|
||||
| None -> ()
|
||||
File.ocamlformat_file_opt jsoo_output_file)
|
||||
|
||||
let () = Driver.Plugin.register_lcalc ~name ~extension apply
|
||||
@ -5,9 +5,15 @@
|
||||
(libraries catala.driver))
|
||||
|
||||
(executable
|
||||
(name web)
|
||||
(name api_web)
|
||||
(modes plugin)
|
||||
(modules web)
|
||||
(modules api_web)
|
||||
(libraries catala.driver))
|
||||
|
||||
(executable
|
||||
(name json_schema)
|
||||
(modes plugin)
|
||||
(modules json_schema)
|
||||
(libraries catala.driver))
|
||||
|
||||
(documentation
|
||||
|
||||
245
compiler/plugins/json_schema.ml
Normal file
245
compiler/plugins/json_schema.ml
Normal file
@ -0,0 +1,245 @@
|
||||
(* This file is part of the Catala compiler, a specification language for tax
|
||||
and social benefits computation rules. Copyright (C) 2020 Inria,
|
||||
contributors: Emile Rolley <emile.rolley@tuta.io>, Louis Gesbert
|
||||
<louis.gesbert@inria.fr>.
|
||||
|
||||
Licensed under the Apache License, Version 2.0 (the "License"); you may not
|
||||
use this file except in compliance with the License. You may obtain a copy of
|
||||
the License at
|
||||
|
||||
http://www.apache.org/licenses/LICENSE-2.0
|
||||
|
||||
Unless required by applicable law or agreed to in writing, software
|
||||
distributed under the License is distributed on an "AS IS" BASIS, WITHOUT
|
||||
WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the
|
||||
License for the specific language governing permissions and limitations under
|
||||
the License. *)
|
||||
|
||||
(** Catala plugin for generating {{:https://json-schema.org} JSON schemas} used
|
||||
to build forms. *)
|
||||
|
||||
let name = "json_schema"
|
||||
let extension = "_schema.json"
|
||||
|
||||
open Utils
|
||||
open Lcalc.Ast
|
||||
open Lcalc.Backends
|
||||
open Lcalc.To_ocaml
|
||||
module D = Dcalc.Ast
|
||||
|
||||
(** Contains all format functions used to format a Lcalc Catala program
|
||||
representation to a JSON schema describing the corresponding web form. *)
|
||||
module To_json = struct
|
||||
let to_camel_case (s : string) : string =
|
||||
String.split_on_char '_' s
|
||||
|> (function
|
||||
| hd :: tl -> hd :: List.map String.capitalize_ascii tl | l -> l)
|
||||
|> String.concat ""
|
||||
|
||||
let format_struct_field_name_camel_case
|
||||
(fmt : Format.formatter)
|
||||
(v : Dcalc.Ast.StructFieldName.t) : unit =
|
||||
let s =
|
||||
Format.asprintf "%a" Dcalc.Ast.StructFieldName.format_t v
|
||||
|> to_ascii |> to_lowercase |> avoid_keywords |> to_camel_case
|
||||
in
|
||||
Format.fprintf fmt "%s" s
|
||||
|
||||
let rec find_scope_def (target_name : string) :
|
||||
('m expr, 'm) D.scopes -> ('m expr, 'm) D.scope_def option = function
|
||||
| D.Nil -> None
|
||||
| D.ScopeDef scope_def ->
|
||||
let name =
|
||||
Format.asprintf "%a" D.ScopeName.format_t scope_def.scope_name
|
||||
in
|
||||
if name = target_name then Some scope_def
|
||||
else
|
||||
let _, next_scope = Bindlib.unbind scope_def.scope_next in
|
||||
find_scope_def target_name next_scope
|
||||
|
||||
let fmt_tlit fmt (tlit : D.typ_lit) =
|
||||
match tlit with
|
||||
| TUnit -> Format.fprintf fmt "\"type\": \"null\",@\n\"default\": null"
|
||||
| TInt | TRat -> Format.fprintf fmt "\"type\": \"number\",@\n\"default\": 0"
|
||||
| TMoney ->
|
||||
Format.fprintf fmt
|
||||
"\"type\": \"number\",@\n\"minimum\": 0,@\n\"default\": 0"
|
||||
| TBool -> Format.fprintf fmt "\"type\": \"boolean\",@\n\"default\": false"
|
||||
| TDate -> Format.fprintf fmt "\"type\": \"string\",@\n\"format\": \"date\""
|
||||
| TDuration -> failwith "TODO: tlit duration"
|
||||
|
||||
let rec fmt_type fmt (typ : D.marked_typ) =
|
||||
match Marked.unmark typ with
|
||||
| D.TLit tlit -> fmt_tlit fmt tlit
|
||||
| D.TTuple (_, Some sname) ->
|
||||
Format.fprintf fmt "\"$ref\": \"#/definitions/%a\"" format_struct_name
|
||||
sname
|
||||
| D.TEnum (_, ename) ->
|
||||
Format.fprintf fmt "\"$ref\": \"#/definitions/%a\"" format_enum_name ename
|
||||
| D.TArray t ->
|
||||
Format.fprintf fmt
|
||||
"\"type\": \"array\",@\n\
|
||||
\"default\": [],@\n\
|
||||
@[<hov 2>\"items\": {@\n\
|
||||
%a@]@\n\
|
||||
}"
|
||||
fmt_type t
|
||||
| _ -> ()
|
||||
|
||||
let fmt_struct_properties
|
||||
(ctx : D.decl_ctx)
|
||||
(fmt : Format.formatter)
|
||||
(sname : D.StructName.t) =
|
||||
Format.fprintf fmt "%a"
|
||||
(Format.pp_print_list
|
||||
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@\n")
|
||||
(fun fmt (field_name, field_type) ->
|
||||
Format.fprintf fmt "@[<hov 2>\"%a\": {@\n%a@]@\n}"
|
||||
format_struct_field_name_camel_case field_name fmt_type field_type))
|
||||
(find_struct sname ctx)
|
||||
|
||||
let fmt_definitions
|
||||
(ctx : D.decl_ctx)
|
||||
(fmt : Format.formatter)
|
||||
(scope_def : ('m expr, 'm) D.scope_def) =
|
||||
let get_name t =
|
||||
match Marked.unmark t with
|
||||
| D.TTuple (_, Some sname) ->
|
||||
Format.asprintf "%a" format_struct_name sname
|
||||
| D.TEnum (_, ename) -> Format.asprintf "%a" format_enum_name ename
|
||||
| _ -> failwith "unreachable: only structs and enums are collected."
|
||||
in
|
||||
let rec collect_required_type_defs_from_scope_input
|
||||
(input_struct : D.StructName.t) : D.marked_typ list =
|
||||
let rec collect (acc : D.marked_typ list) (t : D.marked_typ) :
|
||||
D.marked_typ list =
|
||||
match Marked.unmark t with
|
||||
| D.TTuple (_, Some s) ->
|
||||
(* Scope's input is a struct. *)
|
||||
(t :: acc) @ collect_required_type_defs_from_scope_input s
|
||||
| D.TEnum (ts, _) -> List.fold_left collect (t :: acc) ts
|
||||
| D.TArray t -> collect acc t
|
||||
| _ -> acc
|
||||
in
|
||||
find_struct input_struct ctx
|
||||
|> List.fold_left (fun acc (_, field_typ) -> collect acc field_typ) []
|
||||
|> List.sort_uniq (fun t t' -> String.compare (get_name t) (get_name t'))
|
||||
in
|
||||
let fmt_enum_properties fmt ename =
|
||||
let enum_def = find_enum ename ctx in
|
||||
Format.fprintf fmt
|
||||
"@[<hov 2>\"kind\": {@\n\
|
||||
\"type\": \"string\",@\n\
|
||||
@[<hov 2>\"anyOf\": [@\n\
|
||||
%a@]@\n\
|
||||
]@]@\n\
|
||||
}@\n\
|
||||
},@\n\
|
||||
@[<hov 2>\"allOf\": [@\n\
|
||||
%a@]@\n\
|
||||
]@]@\n\
|
||||
}"
|
||||
(Format.pp_print_list
|
||||
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@\n")
|
||||
(fun fmt (enum_cons, _) ->
|
||||
Format.fprintf fmt
|
||||
"@[<hov 2>{@\n\"type\": \"string\",@\n\"enum\": [\"%a\"]@]@\n}"
|
||||
format_enum_cons_name enum_cons))
|
||||
enum_def
|
||||
(Format.pp_print_list
|
||||
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@\n")
|
||||
(fun fmt (enum_cons, payload_type) ->
|
||||
Format.fprintf fmt
|
||||
"@[<hov 2>{@\n\
|
||||
@[<hov 2>\"if\": {@\n\
|
||||
@[<hov 2>\"properties\": {@\n\
|
||||
@[<hov 2>\"kind\": {@\n\
|
||||
\"const\": \"%a\"@]@\n\
|
||||
}@]@\n\
|
||||
}@]@\n\
|
||||
},@\n\
|
||||
@[<hov 2>\"then\": {@\n\
|
||||
@[<hov 2>\"properties\": {@\n\
|
||||
@[<hov 2>\"payload\": {@\n\
|
||||
%a@]@\n\
|
||||
}@]@\n\
|
||||
}@]@\n\
|
||||
}@]@\n\
|
||||
}"
|
||||
format_enum_cons_name enum_cons fmt_type payload_type))
|
||||
enum_def
|
||||
in
|
||||
|
||||
Format.fprintf fmt "@\n%a"
|
||||
(Format.pp_print_list
|
||||
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@\n")
|
||||
(fun fmt typ ->
|
||||
match Marked.unmark typ with
|
||||
| D.TTuple (_, Some sname) ->
|
||||
Format.fprintf fmt
|
||||
"@[<hov 2>\"%a\": {@\n\
|
||||
\"type\": \"object\",@\n\
|
||||
@[<hov 2>\"properties\": {@\n\
|
||||
%a@]@\n\
|
||||
}@]@\n\
|
||||
}"
|
||||
format_struct_name sname
|
||||
(fmt_struct_properties ctx)
|
||||
sname
|
||||
| D.TEnum (_, ename) ->
|
||||
Format.fprintf fmt
|
||||
"@[<hov 2>\"%a\": {@\n\
|
||||
\"type\": \"object\",@\n\
|
||||
@[<hov 2>\"properties\": {@\n\
|
||||
%a@]@]@\n"
|
||||
format_enum_name ename fmt_enum_properties ename
|
||||
| _ -> ()))
|
||||
(collect_required_type_defs_from_scope_input
|
||||
scope_def.scope_body.scope_body_input_struct)
|
||||
|
||||
let format_program
|
||||
(fmt : Format.formatter)
|
||||
(scope : string)
|
||||
(prgm : 'm Lcalc.Ast.program) =
|
||||
match find_scope_def scope prgm.scopes with
|
||||
| None -> Cli.error_print "Internal error: scope '%s' not found." scope
|
||||
| Some scope_def ->
|
||||
Cli.call_unstyled (fun _ ->
|
||||
Format.fprintf fmt
|
||||
"{@[<hov 2>@\n\
|
||||
\"type\": \"object\",@\n\
|
||||
\"@[<hov 2>definitions\": {%a@]@\n\
|
||||
},@\n\
|
||||
\"@[<hov 2>properties\": {@\n\
|
||||
%a@]@\n\
|
||||
}@]@\n\
|
||||
}"
|
||||
(fmt_definitions prgm.decl_ctx)
|
||||
scope_def
|
||||
(fmt_struct_properties prgm.decl_ctx)
|
||||
scope_def.scope_body.scope_body_input_struct)
|
||||
end
|
||||
|
||||
let apply
|
||||
~(source_file : Pos.input_file)
|
||||
~(output_file : string option)
|
||||
~(scope : string option)
|
||||
(prgm : 'm Lcalc.Ast.program)
|
||||
(type_ordering : Scopelang.Dependency.TVertex.t list) =
|
||||
ignore type_ordering;
|
||||
let output_file, with_formatter =
|
||||
File.get_formatter_of_out_channel ~source_file ~output_file ~ext:extension
|
||||
()
|
||||
in
|
||||
match scope with
|
||||
| Some s ->
|
||||
with_formatter (fun fmt ->
|
||||
Cli.debug_print
|
||||
"Writing JSON schema corresponding to the scope '%s' to the file \
|
||||
%s..."
|
||||
s
|
||||
(Option.value ~default:"stdout" output_file);
|
||||
To_json.format_program fmt s prgm)
|
||||
| None -> Cli.error_print "A scope must be specified for the plugin: %s" name
|
||||
|
||||
let () = Driver.Plugin.register_lcalc ~name ~extension apply
|
||||
@ -23,7 +23,8 @@
|
||||
let name = "python-plugin"
|
||||
let extension = ".py"
|
||||
|
||||
let apply ~output_file ~scope prgm type_ordering =
|
||||
let apply ~source_file ~output_file ~scope prgm type_ordering =
|
||||
ignore source_file;
|
||||
ignore scope;
|
||||
Utils.File.with_formatter_of_opt_file output_file @@ fun fmt ->
|
||||
Scalc.To_python.format_program fmt prgm type_ordering
|
||||
|
||||
@ -46,9 +46,24 @@ let with_formatter_of_opt_file filename_opt f =
|
||||
| None -> finally (fun () -> flush stdout) (fun () -> f Format.std_formatter)
|
||||
| Some filename -> with_formatter_of_file filename f
|
||||
|
||||
let get_out_channel ~source_file ~output_file ?ext () =
|
||||
match output_file, ext with
|
||||
| Some "-", _ | None, None -> None, fun f -> f stdout
|
||||
| Some f, _ -> Some f, with_out_channel f
|
||||
| None, Some ext ->
|
||||
let src =
|
||||
match source_file with Pos.FileName f -> f | Pos.Contents _ -> "a"
|
||||
in
|
||||
let f = Filename.remove_extension src ^ ext in
|
||||
Some f, with_out_channel f
|
||||
|
||||
let get_formatter_of_out_channel ~source_file ~output_file ?ext () =
|
||||
let f, with_ = get_out_channel ~source_file ~output_file ?ext () in
|
||||
f, fun fmt -> with_ (fun oc -> with_formatter_of_out_channel oc fmt)
|
||||
|
||||
let ocamlformat_file_opt = function
|
||||
| Some f ->
|
||||
| Some f when "-" <> f ->
|
||||
Cli.debug_print "Formatting %s..." f;
|
||||
if Sys.command (Printf.sprintf "ocamlformat %s -i" f) <> 0 then
|
||||
Cli.error_print "Internal error: ocamlformat failed on %s" f
|
||||
| None -> ()
|
||||
| _ -> ()
|
||||
|
||||
@ -41,6 +41,28 @@ val with_formatter_of_opt_file : string option -> (Format.formatter -> 'a) -> 'a
|
||||
from the file [filename_opt] if there is some (see
|
||||
{!with_formatter_of_file}), otherwise, uses the [Format.std_formatter]. *)
|
||||
|
||||
val get_out_channel :
|
||||
source_file:Pos.input_file ->
|
||||
output_file:string option ->
|
||||
?ext:string ->
|
||||
unit ->
|
||||
string option * ((out_channel -> 'a) -> 'a)
|
||||
(** [get_output ~source_file ~output_file ?ext ()] returns the infered filename
|
||||
and its corresponding [with_out_channel] function. If the [output_file] is
|
||||
equal to [Some "-"] returns a wrapper around [stdout]. *)
|
||||
|
||||
val get_formatter_of_out_channel :
|
||||
source_file:Pos.input_file ->
|
||||
output_file:string option ->
|
||||
?ext:string ->
|
||||
unit ->
|
||||
string option * ((Format.formatter -> 'a) -> 'a)
|
||||
(** [get_output_format ~source_file ~output_file ?ext ()] returns the infered
|
||||
filename and its corresponding [with_formatter_of_out_channel] function. If
|
||||
the [output_file] is equal to [Some "-"] returns a wrapper around [stdout]. *)
|
||||
|
||||
(** {2 Utility functions on files} *)
|
||||
|
||||
val ocamlformat_file_opt : string option -> unit
|
||||
(** [ocamlformat_file_opt filename_opt] runs [ocamlformat] on the file
|
||||
[filename_opt] if there is some, otherwise, does nothing. *)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user