diff --git a/compiler/driver.ml b/compiler/driver.ml index f2ba87c6..a37c779d 100644 --- a/compiler/driver.ml +++ b/compiler/driver.ml @@ -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) -> diff --git a/compiler/plugin.ml b/compiler/plugin.ml index b7b6fd05..9dfaf6f5 100644 --- a/compiler/plugin.ml +++ b/compiler/plugin.ml @@ -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 -> diff --git a/compiler/plugin.mli b/compiler/plugin.mli index 0df3b1c2..0eb30c17 100644 --- a/compiler/plugin.mli +++ b/compiler/plugin.mli @@ -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 -> diff --git a/compiler/plugins/web.ml b/compiler/plugins/api_web.ml similarity index 66% rename from compiler/plugins/web.ml rename to compiler/plugins/api_web.ml index 5bbabe62..14e9eadc 100644 --- a/compiler/plugins/web.ml +++ b/compiler/plugins/api_web.ml @@ -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\ - @[\"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 "@[\"%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 - "@[\"kind\": {@\n\ - \"type\": \"string\",@\n\ - @[\"enum\": [@\n\ - %a@]@\n\ - ]@]@\n\ - }@\n\ - },@\n\ - @[\"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 - "@[{@\n\ - @[\"if\": {@\n\ - @[\"properties\": {@\n\ - @[\"kind\": {@\n\ - \"const\": \"%a\"@]@\n\ - }@]@\n\ - }@]@\n\ - },@\n\ - @[\"then\": {@\n\ - @[\"properties\": {@\n\ - @[\"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 - "@[\"%a\": {@\n\ - \"type\": \"object\",@\n\ - @[\"properties\": {@\n\ - %a@]@\n\ - }@]@\n\ - }" - format_struct_name sname - (fmt_struct_properties ctx) - sname - | D.TEnum (_, ename) -> - Format.fprintf fmt - "@[\"%a\": {@\n\ - \"type\": \"object\",@\n\ - @[\"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 - "{@[@\n\ - \"type\": \"object\",@\n\ - \"@[definitions\": {%a@]@\n\ - },@\n\ - \"@[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 diff --git a/compiler/plugins/dune b/compiler/plugins/dune index 1fad66dc..1b67068e 100644 --- a/compiler/plugins/dune +++ b/compiler/plugins/dune @@ -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 diff --git a/compiler/plugins/json_schema.ml b/compiler/plugins/json_schema.ml new file mode 100644 index 00000000..2264eee2 --- /dev/null +++ b/compiler/plugins/json_schema.ml @@ -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 , Louis Gesbert + . + + 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\ + @[\"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 "@[\"%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 + "@[\"kind\": {@\n\ + \"type\": \"string\",@\n\ + @[\"anyOf\": [@\n\ + %a@]@\n\ + ]@]@\n\ + }@\n\ + },@\n\ + @[\"allOf\": [@\n\ + %a@]@\n\ + ]@]@\n\ + }" + (Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.fprintf fmt ",@\n") + (fun fmt (enum_cons, _) -> + Format.fprintf fmt + "@[{@\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 + "@[{@\n\ + @[\"if\": {@\n\ + @[\"properties\": {@\n\ + @[\"kind\": {@\n\ + \"const\": \"%a\"@]@\n\ + }@]@\n\ + }@]@\n\ + },@\n\ + @[\"then\": {@\n\ + @[\"properties\": {@\n\ + @[\"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 + "@[\"%a\": {@\n\ + \"type\": \"object\",@\n\ + @[\"properties\": {@\n\ + %a@]@\n\ + }@]@\n\ + }" + format_struct_name sname + (fmt_struct_properties ctx) + sname + | D.TEnum (_, ename) -> + Format.fprintf fmt + "@[\"%a\": {@\n\ + \"type\": \"object\",@\n\ + @[\"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 + "{@[@\n\ + \"type\": \"object\",@\n\ + \"@[definitions\": {%a@]@\n\ + },@\n\ + \"@[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 diff --git a/compiler/plugins/python.ml b/compiler/plugins/python.ml index 02819332..24a8bb59 100644 --- a/compiler/plugins/python.ml +++ b/compiler/plugins/python.ml @@ -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 diff --git a/compiler/utils/file.ml b/compiler/utils/file.ml index a0a606a2..acb4f598 100644 --- a/compiler/utils/file.ml +++ b/compiler/utils/file.ml @@ -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 -> () + | _ -> () diff --git a/compiler/utils/file.mli b/compiler/utils/file.mli index f1bf0057..3a1c53e0 100644 --- a/compiler/utils/file.mli +++ b/compiler/utils/file.mli @@ -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. *)