Legend:
Page
Library
Module
Module type
Parameter
Class
Class type
Source
Source file json_schema.ml
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246(* 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>.
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 for the Catala website. *)letname="json_schema"letextension="_schema.json"openCatala_utilsopenShared_astopenLcalc.AstopenLcalc.To_ocamlmoduleD=Dcalc.Ast(** Contains all format functions used to format a Lcalc Catala program
representation to a JSON schema describing the corresponding web form. *)moduleTo_json=structletto_camel_case(s:string):string=String.split_on_char'_'s|>(function|hd::tl->hd::List.mapString.capitalize_asciitl|l->l)|>String.concat""letformat_struct_field_name_camel_case(fmt:Format.formatter)(v:StructField.t):unit=lets=Format.asprintf"%a"StructField.format_tv|>String.to_ascii|>String.to_snake_case|>avoid_keywords|>to_camel_caseinFormat.fprintffmt"%s"sletrecfind_scope_def(target_name:string):'mexprcode_item_list->(ScopeName.t*'mexprscope_body)option=function|Nil->None|Cons(ScopeDef(name,body),_)whenString.equaltarget_name(Marked.unmark(ScopeName.get_infoname))->Some(name,body)|Cons(_,next_bind)->let_,next_scope=Bindlib.unbindnext_bindinfind_scope_deftarget_namenext_scopeletfmt_tlitfmt(tlit:typ_lit)=matchtlitwith|TUnit->Format.fprintffmt"\"type\": \"null\",@\n\"default\": null"|TInt|TRat->Format.fprintffmt"\"type\": \"number\",@\n\"default\": 0"|TMoney->Format.fprintffmt"\"type\": \"number\",@\n\"minimum\": 0,@\n\"default\": 0"|TBool->Format.fprintffmt"\"type\": \"boolean\",@\n\"default\": false"|TDate->Format.fprintffmt"\"type\": \"string\",@\n\"format\": \"date\""|TDuration->failwith"TODO: tlit duration"letrecfmt_typefmt(typ:typ)=matchMarked.unmarktypwith|TLittlit->fmt_tlitfmttlit|TStructsname->Format.fprintffmt"\"$ref\": \"#/definitions/%a\""format_struct_namesname|TEnumename->Format.fprintffmt"\"$ref\": \"#/definitions/%a\""format_enum_nameename|TArrayt->Format.fprintffmt"\"type\": \"array\",@\n\
\"default\": [],@\n\
@[<hov 2>\"items\": {@\n\
%a@]@\n\
}"fmt_typet|_->()letfmt_struct_properties(ctx:decl_ctx)(fmt:Format.formatter)(sname:StructName.t)=Format.fprintffmt"%a"(Format.pp_print_list~pp_sep:(funfmt()->Format.fprintffmt",@\n")(funfmt(field_name,field_type)->Format.fprintffmt"@[<hov 2>\"%a\": {@\n%a@]@\n}"format_struct_field_name_camel_casefield_namefmt_typefield_type))(StructField.Map.bindings(find_structsnamectx))letfmt_definitions(ctx:decl_ctx)(fmt:Format.formatter)((_scope_name,scope_body):ScopeName.t*'escope_body)=letget_namet=matchMarked.unmarktwith|TStructsname->Format.asprintf"%a"format_struct_namesname|TEnumename->Format.asprintf"%a"format_enum_nameename|_->failwith"unreachable: only structs and enums are collected."inletreccollect_required_type_defs_from_scope_input(input_struct:StructName.t):typlist=letreccollect(acc:typlist)(t:typ):typlist=matchMarked.unmarktwith|TStructs->(* Scope's input is a struct. *)(t::acc)@collect_required_type_defs_from_scope_inputs|TEnume->List.fold_leftcollect(t::acc)(List.mapsnd(EnumConstructor.Map.bindings(EnumName.Map.findectx.ctx_enums)))|TArrayt->collectacct|_->accinfind_structinput_structctx|>StructField.Map.bindings|>List.fold_left(funacc(_,field_typ)->collectaccfield_typ)[]|>List.sort_uniq(funtt'->String.compare(get_namet)(get_namet'))inletfmt_enum_propertiesfmtename=letenum_def=find_enumenamectxinFormat.fprintffmt"@[<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:(funfmt()->Format.fprintffmt",@\n")(funfmt(enum_cons,_)->Format.fprintffmt"@[<hov 2>{@\n\"type\": \"string\",@\n\"enum\": [\"%a\"]@]@\n}"format_enum_cons_nameenum_cons))(EnumConstructor.Map.bindingsenum_def)(Format.pp_print_list~pp_sep:(funfmt()->Format.fprintffmt",@\n")(funfmt(enum_cons,payload_type)->Format.fprintffmt"@[<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_nameenum_consfmt_typepayload_type))(EnumConstructor.Map.bindingsenum_def)inFormat.fprintffmt"@\n%a"(Format.pp_print_list~pp_sep:(funfmt()->Format.fprintffmt",@\n")(funfmttyp->matchMarked.unmarktypwith|TStructsname->Format.fprintffmt"@[<hov 2>\"%a\": {@\n\
\"type\": \"object\",@\n\
@[<hov 2>\"properties\": {@\n\
%a@]@\n\
}@]@\n\
}"format_struct_namesname(fmt_struct_propertiesctx)sname|TEnumename->Format.fprintffmt"@[<hov 2>\"%a\": {@\n\
\"type\": \"object\",@\n\
@[<hov 2>\"properties\": {@\n\
%a@]@]@\n"format_enum_nameenamefmt_enum_propertiesename|_->()))(collect_required_type_defs_from_scope_inputscope_body.scope_body_input_struct)letformat_program(fmt:Format.formatter)(scope:string)(prgm:'mLcalc.Ast.program)=matchfind_scope_defscopeprgm.code_itemswith|None->Cli.error_print"Internal error: scope '%s' not found."scope|Somescope_def->Cli.call_unstyled(fun_->Format.fprintffmt"{@[<hov 2>@\n\
\"type\": \"object\",@\n\
\"@[<hov 2>definitions\": {%a@]@\n\
},@\n\
\"@[<hov 2>properties\": {@\n\
%a@]@\n\
}@]@\n\
}"(fmt_definitionsprgm.decl_ctx)scope_def(fmt_struct_propertiesprgm.decl_ctx)(sndscope_def).scope_body_input_struct)endletapply~(source_file:Pos.input_file)~(output_file:stringoption)~(scope:stringoption)(prgm:'mLcalc.Ast.program)(type_ordering:Scopelang.Dependency.TVertex.tlist)=ignoresource_file;ignoretype_ordering;matchscopewith|Somes->File.with_formatter_of_opt_fileoutput_file(funfmt->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_programfmtsprgm)|None->Cli.error_print"A scope must be specified for the plugin: %s"namelet()=Driver.Plugin.register_lcalc~name~extensionapply