From 071ec352342d2d1af9addfe77c57b6f284e446db Mon Sep 17 00:00:00 2001 From: Louis Gesbert Date: Fri, 4 Mar 2022 19:25:06 +0100 Subject: [PATCH 1/4] Command-line: use a record for the options Should make it much easier and less error-prone to add new options. There is still a bit of boiler-plate, but at least it's contained in the Cli.options function and doesn't transpire in the interfaces. --- compiler/catala_web_interpreter.ml | 20 +- compiler/driver.ml | 61 +- compiler/driver.mli | 19 + compiler/utils/cli.ml | 46 +- compiler/utils/cli.mli | 40 +- french_law/js/french_law.js | 4402 ++++++++++++++-------------- 6 files changed, 2249 insertions(+), 2339 deletions(-) create mode 100644 compiler/driver.mli diff --git a/compiler/catala_web_interpreter.ml b/compiler/catala_web_interpreter.ml index 38aa18c8..26327eb7 100644 --- a/compiler/catala_web_interpreter.ml +++ b/compiler/catala_web_interpreter.ml @@ -8,9 +8,19 @@ let _ = (language : Js.js_string Js.t) (trace : bool) = driver (Contents (Js.to_string contents)) - false false false false "Interpret" - (Some (Js.to_string language)) - None trace false false - (Some (Js.to_string scope)) - None + { + Utils.Cli.debug = false; + unstyled = false; + wrap_weaved_output = false; + avoid_exceptions = false; + backend = "Interpret"; + plugins_dirs = []; + language = Some (Js.to_string language); + max_prec_digits = None; + trace = false; + disable_counterexamples = false; + optimize = false; + ex_scope = Some (Js.to_string scope); + output_file = None; + } end) diff --git a/compiler/driver.ml b/compiler/driver.ml index 75b1d90b..46375f2d 100644 --- a/compiler/driver.ml +++ b/compiler/driver.ml @@ -24,25 +24,16 @@ let languages = [ ("en", Cli.En); ("fr", Cli.Fr); ("pl", Cli.Pl) ] let extensions = [ (".catala_fr", "fr"); (".catala_en", "en"); (".catala_pl", "pl") ] (** Entry function for the executable. Returns a negative number in case of error. Usage: - [driver source_file debug dcalc unstyled wrap_weaved_output backend language max_prec_digits trace optimize scope_to_execute output_file]*) -let driver (source_file : Pos.input_file) (debug : bool) (unstyled : bool) - (wrap_weaved_output : bool) (avoid_exceptions : bool) (backend : string) - (language : string option) (max_prec_digits : int option) (trace : bool) - (disable_counterexamples : bool) (optimize : bool) (ex_scope : string option) - (output_file : string option) : int = + [driver source_file debug dcalc unstyled wrap_weaved_output backend plugins_dirs language max_prec_digits trace optimize scope_to_execute output_file]*) +let driver source_file (options : Cli.options) : int = try - Cli.debug_flag := debug; - Cli.style_flag := not unstyled; - Cli.trace_flag := trace; - Cli.optimize_flag := optimize; - Cli.disable_counterexamples := disable_counterexamples; - Cli.avoid_exceptions_flag := avoid_exceptions; + Cli.set_option_globals options; Cli.debug_print "Reading files..."; let filename = ref "" in - (match source_file with FileName f -> filename := f | Contents c -> Cli.contents := c); - (match max_prec_digits with None -> () | Some i -> Cli.max_prec_digits := i); + (match source_file with Pos.FileName f -> filename := f | Contents c -> Cli.contents := c); + (match options.max_prec_digits with None -> () | Some i -> Cli.max_prec_digits := i); let l = - match language with + match options.language with | Some l -> l | None -> ( (* Try to infer the language from the intput file extension. *) @@ -60,6 +51,7 @@ let driver (source_file : Pos.input_file) (debug : bool) (unstyled : bool) Errors.raise_error "The selected language (%s) is not supported by Catala" l in Cli.locale_lang := language; + let backend = options.backend in let backend = let backend = String.lowercase_ascii backend in if backend = "makefile" then Cli.Makefile @@ -88,7 +80,7 @@ let driver (source_file : Pos.input_file) (debug : bool) (unstyled : bool) Errors.raise_error "The Makefile backend does not work if the input is not a file" in let output_file = - match output_file with + match options.output_file with | Some f -> f | None -> Filename.remove_extension source_file ^ ".d" in @@ -117,7 +109,7 @@ let driver (source_file : Pos.input_file) (debug : bool) (unstyled : bool) | Cli.Html -> "HTML" | _ -> assert false (* should not happen *)); let output_file = - match output_file with + match options.output_file with | Some f -> f | None -> ( Filename.remove_extension source_file @@ -135,7 +127,7 @@ let driver (source_file : Pos.input_file) (debug : bool) (unstyled : bool) in Cli.debug_print "Writing to %s" output_file; let fmt = Format.formatter_of_out_channel oc in - if wrap_weaved_output then + if options.wrap_weaved_output then match backend with | Cli.Latex -> Literate.Latex.wrap_latex prgm.Surface.Ast.program_source_files language fmt @@ -151,7 +143,7 @@ let driver (source_file : Pos.input_file) (debug : bool) (unstyled : bool) Cli.debug_print "Name resolution..."; let ctxt = Surface.Name_resolution.form_context prgm in let scope_uid = - match (ex_scope, backend) with + match (options.ex_scope, backend) with | None, Cli.Interpret -> Errors.raise_error "No scope was provided for execution." | None, _ -> snd @@ -168,13 +160,13 @@ let driver (source_file : Pos.input_file) (debug : bool) (unstyled : bool) let prgm = Desugared.Desugared_to_scope.translate_program prgm in if backend = Cli.Scopelang then begin let fmt, at_end = - match output_file with + match options.output_file with | Some f -> let oc = open_out f in (Format.formatter_of_out_channel oc, fun _ -> close_out oc) | None -> (Format.std_formatter, fun _ -> ()) in - if Option.is_some ex_scope then + if Option.is_some options.ex_scope then Format.fprintf fmt "%a\n" Scopelang.Print.format_scope (scope_uid, Scopelang.Ast.ScopeMap.find scope_uid prgm.program_scopes) else Format.fprintf fmt "%a\n" Scopelang.Print.format_program prgm; @@ -184,7 +176,7 @@ let driver (source_file : Pos.input_file) (debug : bool) (unstyled : bool) Cli.debug_print "Translating to default calculus..."; let prgm, type_ordering = Scopelang.Scope_to_dcalc.translate_program prgm in let prgm = - if optimize then begin + if options.optimize then begin Cli.debug_print "Optimizing default calculus..."; Dcalc.Optimizations.optimize_program prgm end @@ -193,15 +185,15 @@ let driver (source_file : Pos.input_file) (debug : bool) (unstyled : bool) let prgrm_dcalc_expr = Bindlib.unbox (Dcalc.Ast.build_whole_program_expr prgm scope_uid) in if backend = Cli.Dcalc then begin let fmt, at_end = - match output_file with + match options.output_file with | Some f -> let oc = open_out f in (Format.formatter_of_out_channel oc, fun _ -> close_out oc) | None -> (Format.std_formatter, fun _ -> ()) in - if Option.is_some ex_scope then + if Option.is_some options.ex_scope then Format.fprintf fmt "%a\n" - (Dcalc.Print.format_scope ~debug prgm.decl_ctx) + (Dcalc.Print.format_scope ~debug:options.debug prgm.decl_ctx) (let _, _, s = List.find (fun (name, _, _) -> name = scope_uid) prgm.scopes in (scope_uid, s)) else Format.fprintf fmt "%a\n" (Dcalc.Print.format_expr prgm.decl_ctx) prgrm_dcalc_expr; @@ -248,11 +240,12 @@ let driver (source_file : Pos.input_file) (debug : bool) (unstyled : bool) | Cli.OCaml | Cli.Python | Cli.Lcalc | Cli.Scalc -> Cli.debug_print "Compiling program into lambda calculus..."; let prgm = - if avoid_exceptions then Lcalc.Compile_without_exceptions.translate_program prgm + if options.avoid_exceptions then + Lcalc.Compile_without_exceptions.translate_program prgm else Lcalc.Compile_with_exceptions.translate_program prgm in let prgm = - if optimize then begin + if options.optimize then begin Cli.debug_print "Optimizing lambda calculus..."; Lcalc.Optimizations.optimize_program prgm end @@ -260,15 +253,15 @@ let driver (source_file : Pos.input_file) (debug : bool) (unstyled : bool) in if backend = Cli.Lcalc then begin let fmt, at_end = - match output_file with + match options.output_file with | Some f -> let oc = open_out f in (Format.formatter_of_out_channel oc, fun _ -> close_out oc) | None -> (Format.std_formatter, fun _ -> ()) in - if Option.is_some ex_scope then + if Option.is_some options.ex_scope then Format.fprintf fmt "%a\n" - (Lcalc.Print.format_scope ~debug prgm.decl_ctx) + (Lcalc.Print.format_scope ~debug:options.debug prgm.decl_ctx) (let body = List.find (fun body -> body.Lcalc.Ast.scope_body_name = scope_uid) prgm.scopes in @@ -289,7 +282,7 @@ let driver (source_file : Pos.input_file) (debug : bool) (unstyled : bool) Errors.raise_error "This backend does not work if the input is not a file" in let new_output_file (extension : string) : string = - match output_file with + match options.output_file with | Some f -> f | None -> Filename.remove_extension source_file ^ extension in @@ -306,15 +299,15 @@ let driver (source_file : Pos.input_file) (debug : bool) (unstyled : bool) let prgm = Scalc.Compile_from_lambda.translate_program prgm in if backend = Cli.Scalc then begin let fmt, at_end = - match output_file with + match options.output_file with | Some f -> let oc = open_out f in (Format.formatter_of_out_channel oc, fun _ -> close_out oc) | None -> (Format.std_formatter, fun _ -> ()) in - if Option.is_some ex_scope then + if Option.is_some options.ex_scope then Format.fprintf fmt "%a\n" - (Scalc.Print.format_scope ~debug prgm.decl_ctx) + (Scalc.Print.format_scope ~debug:options.debug prgm.decl_ctx) (let body = List.find (fun body -> body.Scalc.Ast.scope_body_name = scope_uid) diff --git a/compiler/driver.mli b/compiler/driver.mli new file mode 100644 index 00000000..d2157f5a --- /dev/null +++ b/compiler/driver.mli @@ -0,0 +1,19 @@ +(* This file is part of the Catala compiler, a specification language for tax and social benefits + computation rules. Copyright (C) 2020 Inria, contributors: Denis Merigoux + , Emile Rolley + + 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. *) + +val driver : Utils.Pos.input_file -> Utils.Cli.options -> int +(** Entry function for the executable. Returns a negative number in case of error. *) + +val main : unit -> unit +(** Main program entry point, including command-line parsing and return code *) diff --git a/compiler/utils/cli.ml b/compiler/utils/cli.ml index 6aa8a843..9c143088 100644 --- a/compiler/utils/cli.ml +++ b/compiler/utils/cli.ml @@ -131,11 +131,53 @@ let output = "$(i, OUTPUT) is the file that will contain the output of the compiler. Defaults to \ $(i,FILE).$(i,EXT) where $(i,EXT) depends on the chosen backend.") -let catala_t f = +type options = { + debug : bool; + unstyled : bool; + wrap_weaved_output : bool; + avoid_exceptions : bool; + backend : string; + language : string option; + max_prec_digits : int option; + trace : bool; + disable_counterexamples : bool; + optimize : bool; + ex_scope : string option; + output_file : string option; +} + +let options = + let make debug unstyled wrap_weaved_output avoid_exceptions backend language max_prec_digits trace + disable_counterexamples optimize ex_scope output_file : options = + { + debug; + unstyled; + wrap_weaved_output; + avoid_exceptions; + backend; + language; + max_prec_digits; + trace; + disable_counterexamples; + optimize; + ex_scope; + output_file; + } + in Term.( - const f $ file $ debug $ unstyled $ wrap_weaved_output $ avoid_exceptions $ backend $ language + const make $ debug $ unstyled $ wrap_weaved_output $ avoid_exceptions $ backend $ language $ max_prec_digits_opt $ trace_opt $ disable_counterexamples_opt $ optimize $ ex_scope $ output) +let catala_t f = Term.(const f $ file $ options) + +let set_option_globals options : unit = + debug_flag := options.debug; + style_flag := not options.unstyled; + trace_flag := options.trace; + optimize_flag := options.optimize; + disable_counterexamples := options.disable_counterexamples; + avoid_exceptions_flag := options.avoid_exceptions + let version = "0.5.0" let info = diff --git a/compiler/utils/cli.mli b/compiler/utils/cli.mli index 339d2a5c..b2b87ba7 100644 --- a/compiler/utils/cli.mli +++ b/compiler/utils/cli.mli @@ -77,24 +77,28 @@ val ex_scope : string option Cmdliner.Term.t val output : string option Cmdliner.Term.t -val catala_t : - (string -> - bool -> - bool -> - bool -> - bool -> - string -> - string option -> - int option -> - bool -> - bool -> - bool -> - string option -> - string option -> - 'a) -> - 'a Cmdliner.Term.t -(** Main entry point: - [catala_t file debug unstyled wrap_weaved_output avoid_exceptions backend language max_prec_digits_opt trace_opt disable_counterexamples optimize ex_scope output] *) +type options = { + debug : bool; + unstyled : bool; + wrap_weaved_output : bool; + avoid_exceptions : bool; + backend : string; + language : string option; + max_prec_digits : int option; + trace : bool; + disable_counterexamples : bool; + optimize : bool; + ex_scope : string option; + output_file : string option; +} +(** {2 Command-line application} *) + +val options : options Cmdliner.Term.t + +val catala_t : (string -> options -> 'a) -> 'a Cmdliner.Term.t +(** Main entry point: [catala_t file options] *) + +val set_option_globals : options -> unit val version : string diff --git a/french_law/js/french_law.js b/french_law/js/french_law.js index 92bb2aae..4fe92a56 100644 --- a/french_law/js/french_law.js +++ b/french_law/js/french_law.js @@ -1,141 +1,136 @@ -// Generated by js_of_ocaml 4.0.0 -(function(a){typeof -globalThis!=="object"&&(this?b():(a.defineProperty(a.prototype,"_T_",{configurable:true,get:b}),_T_));function -b(){var -b=this||self;b.globalThis=b;delete -a.prototype._T_}}(Object));(function(u){"use strict";var -GB=u,GE=typeof -module==="object"&&module.exports||u,jo=214,jn=" is too large for shifting.",k$="Invalid_argument",jm="0.08",er="Map.bal",jl="@[",ko=640,B="Code de la s\xc3\xa9curit\xc3\xa9 sociale",l0="Article L521-1",eK=123,k_="577500",kn=152,k9="%ni",lZ=43200.,gk="ml_z_overflow",lY="EMFILE",W=86400.,aE=2020,km=139,aU=0xff,k8="ENOMEM",gu=-12,k7=-45,eJ="Titre 5 : Dispositions particuli\xc3\xa8res \xc3\xa0 la Guadeloupe, \xc3\xa0 la Guyane, \xc3\xa0 la Martinique, \xc3\xa0 La R\xc3\xa9union, \xc3\xa0 Saint-Barth\xc3\xa9lemy et \xc3\xa0 Saint-Martin",lX="559500",b0="Article 1",dB=122,jk="582700",lW=992015837,k6="EPROTONOSUPPORT",k="0",k5="ENETRESET",lV="EACCES",k4="EINVAL",kl="0.5",k3="EDOM",bH=128,jj="Sys_blocked_io",kk="fd ",k2="EFBIG",ji=548,gj="Chapitre 2 : Champ d'application",jh="0.0588",I=248,jg="EXDEV",eW=">",bm=153,lU=1027,lT="EINPROGRESS",k1="562800",bZ="Chapitre 5 : Prestations familiales et prestations assimil\xc3\xa9es",jf=246,k0=555,jd=598,je="%u",kZ="resetLog",cJ=2011,f="AllocationsFamiliales",kY=3268,jc="EHOSTUNREACH",kj=633,jb="./securite_sociale_R.catala_fr",H="Livre 5 : Prestations familiales et prestations assimil\xc3\xa9es",eI=108,ax="2",bB=127,dt=1024,ja="@{",eH=-2147483648,U="1",eP=133,eV="e",gi="Montant de la base mensuelle des allocations familiales",i$=" : flags Open_rdonly and Open_wronly are not compatible",i_="D\xc3\xa9cret n\xc2\xb0 2019-1387 du 18 d\xc3\xa9cembre 2019 portant rel\xc3\xa8vement du salaire minimum de croissance",az="-",lS=505,bV=803994948,ki="EAGAIN",gt=": Not a directory",i8=216,i9=" : file already exists",lR="smic",kX=184,bF=0xffffff,cD=2012,kh="EDESTADDRREQ",kW="EISCONN",lO=-43,lP=612,ao="./securite_sociale_D.catala_fr",lQ="EROFS",eG=86400,kg="Out_of_memory",lN="inf",gs="index out of bounds",lM="EPIPE",i7="ENOEXEC",eF="_bigarr02",lL="Circulaire interminist\xc3\xa9rielle N\xc2\xb0 DSS/SD2B/2017/352 du 22 d\xc3\xa9cembre 2017 relative \xc3\xa0 la revalorisation au 1er janvier 2018 des plafonds de ressources d\xe2\x80\x99attribution de certaines prestations familiales servies en m\xc3\xa9tropole, en Guadeloupe, en Guyane, en Martinique, \xc3\xa0 la R\xc3\xa9union, \xc3\xa0 Saint-Barth\xc3\xa9lemy, \xc3\xa0 Saint-Martin et \xc3\xa0 Mayotte",kf=0xffffffff,dA=111,gz=2147483647,kV=208,lK=180,i6="Martinique",kU=", characters ",i5="EPFNOSUPPORT",bh=0xffff,ke="EBUSY",eE=417088404,kd="ENETUNREACH",lJ="ENOLCK",i3="ENOTTY",i4=12520,gr=400,kT="ESHUTDOWN",lI=619,i1=-46,i2="ENXIO",aK=3600,eD=143,L="Chapitre 1er : Allocations familiales",gy="AllocationFamilialesAvril2008",lH="ERANGE",cx=2016,kS="retrieveLog",bg="\xc3\xa2ge_minimum_alin\xc3\xa9a_1_l521_3",lG="infinity",a0=1000,kc=142,p="",i0="^",bU=3600.,iZ=86400000,kb=264,ag="Partie l\xc3\xa9gislative",cw=0x3f,dq=124,dh="./epilogue.catala_fr",gq="Article L512-3",v="./decrets_divers.catala_fr",N="Titre 2 : Prestations g\xc3\xa9n\xc3\xa9rales d'entretien",dz=112,iY="Match_failure",kR=140,bW="Montant des plafonds de ressources",M="Annexe",ka=135,be=2021,j$="enfant_le_plus_\xc3\xa2g\xc3\xa9",eC=252,j_="EPROTOTYPE",bf=".",dg="montant_initial_majoration",bA="+",j9="EINTR",iX="ESRCH",j8=0xf0,a1="12.",j7="Guadeloupe",lF="ESOCKTNOSUPPORT",gJ=110,an="PrestationsFamiliales",gp=116,iW="%li",j5=576,j6="EALREADY",cF=2015,eB=365,bE="prise_en_compte",gh="Smic",gI=-32,bl=1023,j3=-1080,j4="EAFNOSUPPORT",ah="./securite_sociale_L.catala_fr",o="./prologue.catala_fr",eq=2299161,j2=969837588,gx="nan",lE=605,j1="ENFILE",iV=0xe0,j0=-1023,lD=117,kP="ECHILD",kQ=0xdfff,dy="compl\xc3\xa9ment_d\xc3\xa9gressif",go="Article L755-12",kO="ETOOMANYREFS",bj="/",lC="Assert_failure",ep=2400000.5,iU="ENAMETOOLONG",lB="568400",jZ=541,eO="ENOTDIR",lA="0.32",gw=1073741823,kN="ETIMEDOUT",iT="EMSGSIZE",eo=250,dp=1582,kM=513,lz="ENOTCONN",iR=115,iS="ECONNREFUSED",kL="src/time_Zone.ml",ly=1e14,jY="Arr\xc3\xaat\xc3\xa9 du 14 d\xc3\xa9cembre 2020 relatif au montant des plafonds de ressources de certaines prestations familiales et aux tranches du bar\xc3\xa8me applicable au recouvrement des indus et \xc3\xa0 la saisie des prestations",eA='"',kJ="Guyane",kK="EWOULDBLOCK",iQ="allocations_familiales",gg=1255,gn="<",lx="Fatal error: exception %s\n",jW=196,jX=0x800,cE=255,jV="EPERM",aJ=2019,gf="jsError",bd=0x8000,kI="Partie r\xc3\xa9glementaire - D\xc3\xa9crets en Conseil d'Etat",V="droit_ouvert_majoration",dx=146097,cI=256,jU=0.012,lw="Article L521-3",kH="End_of_file",jT="M\xc3\xa9tropole",ez=156,gv="Failure",lv="ENOSPC",iP=129,iO="\n",jS=204,dn="conditions_hors_\xc3\xa2ge",kG=218,eU="ENOENT",jR=534,K="Dispositions sp\xc3\xa9ciales relatives \xc3\xa0 Mayotte",jQ=562,jP="([^/]+)",lu=315,kF="ENETDOWN",gH="EnfantLePlus\xc3\x82g\xc3\xa9",gm=0xf,lt="EOVERFLOW",en=-48,kE=0xdc00,dm="montant_initial_m\xc3\xa9tropole_majoration",gG="ENOTEMPTY",iN="EBADF",al="camlinternalFormat.ml",jO="Division_by_zero",gl=520,iM="EMLINK",kD="Sys_error",lr=647,ls="x",lq=335,cv=2017,ds="Article D521-2",eT="Article D755-5",ge="Titre 1 : Champ d'application - G\xc3\xa9n\xc3\xa9ralit\xc3\xa9s",bD=60.,gd="EEXIST",cC=2014,gF="%d",kC="Printexc.handle_uncaught_exception",iL=32082,bY=1900,em=121,jN="EADDRNOTAVAIL",lp="buffer.ml",jM=119,dl="montant_avec_garde_altern\xc3\xa9e_majoration",jL="version_avril_2008",bT=120,ey=127686388,ca=103,lo="ENOBUFS",gc="16",cA=2013,cB=102,gb=512,ln=527,cH=113,iK=0x7ff0,t="D\xc3\xa9crets divers",ex=101,eN=132,iJ="0x",iI="D\xc3\xa9cret n\xc2\xb0 2020-1598 du 16 d\xc3\xa9cembre 2020 portant rel\xc3\xa8vement du salaire minimum de croissance",b$=1e7,n="Prologue",dk=254,aR=100,jJ="ECONNABORTED",jK="EFAULT",kA="Article 7",kB="ENODEV",jI=" : flags Open_text and Open_binary are not compatible",kz="%Li",jG="EIO",jH="EDEADLK",eS="3",am="Partie r\xc3\xa9glementaire - D\xc3\xa9crets simples",iH=105,ll="169.",lm=230,iG="Instruction interminist\xc3\xa9rielle n\xc2\xb0 DSS/SD2B/2018/279 du 17 d\xc3\xa9cembre 2018 relative \xc3\xa0 la revalorisation au 1er janvier 2019 des plafonds de ressources d\xe2\x80\x99attribution de certaines prestations familiales servies en m\xc3\xa9tropole, en Guadeloupe, en Guyane, en Martinique, \xc3\xa0 la R\xc3\xa9union, \xc3\xa0 Saint-Barth\xc3\xa9lemy, \xc3\xa0 Saint-Martin et \xc3\xa0 Mayotte",ky=591,bX=0.5,jF=584,a7="Article D521-1",jE="Instruction interministerielle no DSS/SD2B/2019/261 du 18 d\xc3\xa9cembre 2019 relative \xc3\xa0 la revalorisation au 1er janvier 2020 des plafonds de ressources d\xe2\x80\x99attribution de certaines prestations familiales servies en m\xc3\xa9tropole, en Guadeloupe, en Guyane, en Martinique, \xc3\xa0 La R\xc3\xa9union, \xc3\xa0 Saint-Barth\xc3\xa9lemy, \xc3\xa0 Saint-Martin et \xc3\xa0 Mayotte",jD=188,bG="Livre 7 : R\xc3\xa9gimes divers - Dispositions diverses",aw="input",iF="str.ml",jC=160,lk="prestations_familiales",dw="est_enfant_le_plus_\xc3\xa2g\xc3\xa9",jB="0.0463",iE="D\xc3\xa9cret n\xc2\xb0 2018-1173 du 19 d\xc3\xa9cembre 2018 portant rel\xc3\xa8vement du salaire minimum de croissance",eM="_z",lj="computeAllocationsFamiliales",dv="Unix.Unix_error",jz="0.55",jA="EHOSTDOWN",dj="droit_ouvert",ew=109,ga="mkdir",jy="ENOTSOCK",kx=136,li="Stack_overflow",el=": No such file or directory",ev="Interface du programme",lh="/static/",df="Titre 5 : D\xc3\xa9partements d'outre-mer",jx=-97,lg=253,lf="Not_found",di=1461,a6="InterfaceAllocationsFamiliales",f$=151,J="D\xc3\xa9cret n\xc2\xb02002-423 du 29 mars 2002 relatif aux prestations familiales \xc3\xa0 Mayotte",cz="1.",kw=32044,eL=", ",iD=626,bi=2018,le="Mayotte",jw="EOPNOTSUPP",iC="ENOPROTOOPT",gE=243,jv=2440588,gD="rmdir",kv="src/date.ml",ld=32752,ju="ECONNRESET",lc="ELOOP",eu=141,jt="ESPIPE",de="\xc3\x89pilogue",ku="EADDRINUSE",lb=1026,bk="Article L521-2",kt="ENOSYS",eR="Invalid integer: ",et=2440587.5,js="E2BIG",ks=359,iA="Pervasives.do_at_exit",iB="utf8",es=155,kr=258,bC=" ",gC="Fatal error: exception ",a2=0x80,kq="Undefined_recursive_module",ay="output",jr=569,jq=215,eQ="src/calendar_builder.ml",iz="EISDIR",la="_",cy="Montant du salaire minimum de croissance",gB="compare: functional value",f_="0.16",dr="droit_ouvert_forfaitaire",du="0.",ek=134,kp="%i",gA=114,cG=529348384,jp=426;function -FG(d,b,e,c,f){if(c<=b)for(var +// Generated by js_of_ocaml 3.8.0 +(function(D){"use strict";var +iu=214,it=" is too large for shifting.",jI="Invalid_argument",is="0.08",ee="Map.bal",ja=640,A="Code de la s\xc3\xa9curit\xc3\xa9 sociale",ki="Article L521-1",ev=123,jH="577500",i$=152,jG="%ni",kh=43200.,fX="ml_z_overflow",V=86400.,aE=2020,i_=139,aQ=0xff,f6=-12,jF=-45,eu="Titre 5 : Dispositions particuli\xc3\xa8res \xc3\xa0 la Guadeloupe, \xc3\xa0 la Guyane, \xc3\xa0 la Martinique, \xc3\xa0 La R\xc3\xa9union, \xc3\xa0 Saint-Barth\xc3\xa9lemy et \xc3\xa0 Saint-Martin",kg="559500",bW="Article 1",dq=122,ir="582700",kf=992015837,k="0",i9="0.5",bB=128,iq="Sys_blocked_io",i8="fd ",ip=548,fW="Chapitre 2 : Champ d'application",io="0.0588",P=248,eE=">",bg=153,ke=1027,jE="562800",bV="Chapitre 5 : Prestations familiales et prestations assimil\xc3\xa9es",im=246,jD=555,ik=598,il="%u",jC="resetLog",cB=2011,f="AllocationsFamiliales",jB=3268,i7=633,ij="./securite_sociale_R.catala_fr",G="Livre 5 : Prestations familiales et prestations assimil\xc3\xa9es",et=108,ax="2",bt=127,di=1024,es=-2147483648,T="1",ey=133,eD="e",fV="Montant de la base mensuelle des allocations familiales",ii=" : flags Open_rdonly and Open_wronly are not compatible",i6="([^/]*)",ih="D\xc3\xa9cret n\xc2\xb0 2019-1387 du 18 d\xc3\xa9cembre 2019 portant rel\xc3\xa8vement du salaire minimum de croissance",aA="-",kd=505,bR=803994948,ie=216,ig=" : file already exists",kc="smic",jA=184,bz=0xffffff,cv=2012,ka=-43,kb=612,ap="./securite_sociale_D.catala_fr",er=86400,i5="Out_of_memory",j$="inf",f5="index out of bounds",eq="_bigarr02",j_="Circulaire interminist\xc3\xa9rielle N\xc2\xb0 DSS/SD2B/2017/352 du 22 d\xc3\xa9cembre 2017 relative \xc3\xa0 la revalorisation au 1er janvier 2018 des plafonds de ressources d\xe2\x80\x99attribution de certaines prestations familiales servies en m\xc3\xa9tropole, en Guadeloupe, en Guyane, en Martinique, \xc3\xa0 la R\xc3\xa9union, \xc3\xa0 Saint-Barth\xc3\xa9lemy, \xc3\xa0 Saint-Martin et \xc3\xa0 Mayotte",i4=0xffffffff,dp=111,f_=2147483647,jz=208,j9=180,id="Martinique",bc=0xffff,ep=417088404,ic=12520,i3=400,j8=619,ib=-46,aI=3600,eo=143,K="Chapitre 1er : Allocations familiales",f9="AllocationFamilialesAvril2008",cp=2016,jy="retrieveLog",bb="\xc3\xa2ge_minimum_alin\xc3\xa9a_1_l521_3",j7="infinity",aW=1000,i2=142,t="",fU="^",bQ=3600.,ia=86400000,i1=264,ag="Partie l\xc3\xa9gislative",co=0x3f,df=124,c9="./epilogue.catala_fr",f4="Article L512-3",u="./decrets_divers.catala_fr",M="Titre 2 : Prestations g\xc3\xa9n\xc3\xa9rales d'entretien",dn=112,h$="Match_failure",jx=140,bS="Montant des plafonds de ressources",L="Annexe",i0=135,ba=2021,iZ="enfant_le_plus_\xc3\xa2g\xc3\xa9",f3=252,bu=".",c8="montant_initial_majoration",bs="+",iY=0xf0,aX="12.",iX="Guadeloupe",ge=110,ao="PrestationsFamiliales",f2=116,h_="%li",iW=576,cx=2015,en=365,by="prise_en_compte",fT="Smic",gd=-32,bf=1023,iV=-1080,ah="./securite_sociale_L.catala_fr",o="./prologue.catala_fr",ed=2299161,iU=969837588,f8="nan",j6=605,h9=0xe0,iT=-1023,j5=117,jw=0xdfff,dm="compl\xc3\xa9ment_d\xc3\xa9gressif",f1="Article L755-12",bx="/",j4="Assert_failure",ec=2400000.5,j3="568400",iS=541,j2="0.32",f7=1073741823,eb=250,de=1582,jv=513,h8=115,ju="src/time_Zone.ml",j1=1e14,iR="Arr\xc3\xaat\xc3\xa9 du 14 d\xc3\xa9cembre 2020 relatif au montant des plafonds de ressources de certaines prestations familiales et aux tranches du bar\xc3\xa8me applicable au recouvrement des indus et \xc3\xa0 la saisie des prestations",jt="Guyane",h7="allocations_familiales",fS=1255,f0="<",iP=196,iQ=0x800,cw=255,aH=2019,fR="jsError",a$=0x8000,js="Partie r\xc3\xa9glementaire - D\xc3\xa9crets en Conseil d'Etat",U="droit_ouvert_majoration",dl=146097,cA=256,iO=0.012,j0="Article L521-3",jr="End_of_file",iN="M\xc3\xa9tropole",em=156,jq="Failure",h6=129,iM=204,dd="conditions_hors_\xc3\xa2ge",jp=218,iL=534,J="Dispositions sp\xc3\xa9ciales relatives \xc3\xa0 Mayotte",iK=562,jZ=315,gc="EnfantLePlus\xc3\x82g\xc3\xa9",fZ=0xf,ea=-48,jo=0xdc00,dc="montant_initial_m\xc3\xa9tropole_majoration",am="camlinternalFormat.ml",iJ="Division_by_zero",fY=520,jn="Sys_error",jX=647,jY="x",jW=335,cn=2017,dh="Article D521-2",eC="Article D755-5",fQ="Titre 1 : Champ d'application - G\xc3\xa9n\xc3\xa9ralit\xc3\xa9s",bw=60.,cu=2014,jV="%d",h5=32082,bU=1900,d$=121,jU="buffer.ml",iI=119,db="montant_avec_garde_altern\xc3\xa9e_majoration",iH="version_avril_2008",bP=120,el=127686388,b7=103,fP="16",cs=2013,ct=102,fO=512,jT=527,cz=113,h4=0x7ff0,s="D\xc3\xa9crets divers",ek=101,ex=132,h3="0x",h2="D\xc3\xa9cret n\xc2\xb0 2020-1598 du 16 d\xc3\xa9cembre 2020 portant rel\xc3\xa8vement du salaire minimum de croissance",b6=1e7,n="Prologue",da=254,aO=100,jm="Article 7",iG=" : flags Open_text and Open_binary are not compatible",jl="%Li",eB="3",an="Partie r\xc3\xa9glementaire - D\xc3\xa9crets simples",h1=105,jR="169.",jS=230,h0="Instruction interminist\xc3\xa9rielle n\xc2\xb0 DSS/SD2B/2018/279 du 17 d\xc3\xa9cembre 2018 relative \xc3\xa0 la revalorisation au 1er janvier 2019 des plafonds de ressources d\xe2\x80\x99attribution de certaines prestations familiales servies en m\xc3\xa9tropole, en Guadeloupe, en Guyane, en Martinique, \xc3\xa0 la R\xc3\xa9union, \xc3\xa0 Saint-Barth\xc3\xa9lemy, \xc3\xa0 Saint-Martin et \xc3\xa0 Mayotte",jk=591,bT=0.5,iF=584,a3="Article D521-1",iE="Instruction interministerielle no DSS/SD2B/2019/261 du 18 d\xc3\xa9cembre 2019 relative \xc3\xa0 la revalorisation au 1er janvier 2020 des plafonds de ressources d\xe2\x80\x99attribution de certaines prestations familiales servies en m\xc3\xa9tropole, en Guadeloupe, en Guyane, en Martinique, \xc3\xa0 La R\xc3\xa9union, \xc3\xa0 Saint-Barth\xc3\xa9lemy, \xc3\xa0 Saint-Martin et \xc3\xa0 Mayotte",iD=188,bA="Livre 7 : R\xc3\xa9gimes divers - Dispositions diverses",aw="input",hZ="str.ml",iC=160,jQ="prestations_familiales",dk="est_enfant_le_plus_\xc3\xa2g\xc3\xa9",iB="0.0463",hY="D\xc3\xa9cret n\xc2\xb0 2018-1173 du 19 d\xc3\xa9cembre 2018 portant rel\xc3\xa8vement du salaire minimum de croissance",ew="_z",jO="Unix.Unix_error",jP="computeAllocationsFamiliales",iA="0.55",c$="droit_ouvert",ej=109,jj=136,jN="Stack_overflow",ei="Interface du programme",c7="Titre 5 : D\xc3\xa9partements d'outre-mer",iz=-97,jM="Not_found",c_=1461,a2="InterfaceAllocationsFamiliales",fN=151,I="D\xc3\xa9cret n\xc2\xb02002-423 du 29 mars 2002 relatif aux prestations familiales \xc3\xa0 Mayotte",cr="1.",jh=32044,ji=", ",hX=626,bd=2018,jg="static/",jL="Mayotte",gb=243,iy=2440588,jf="src/date.ml",jK=32752,eh=141,c6="\xc3\x89pilogue",jJ=1026,be="Article L521-2",eA="Invalid integer: ",eg=2440587.5,je=359,ef=155,jd=258,bv=" ",aY=0x80,jc="Undefined_recursive_module",ay="output",ix=569,iw=215,ez="src/calendar_builder.ml",cq="Montant du salaire minimum de croissance",ga="compare: functional value",fM="0.16",dg="droit_ouvert_forfaitaire",dj="0.",d_=134,jb="%i",f$=114,cy=529348384,iv=426;function +Dm(d,b,e,c,f){if(c<=b)for(var a=1;a<=f;a++)e[c+a]=d[b+a];else for(var a=f;a>=1;a--)e[c+a]=d[b+a];return 0}function -FJ(e,f,d){var +Dp(e,f,d){var a=new Array(d+1);a[0]=0;for(var b=1,c=f+1;b<=d;b++,c++)a[b]=e[c];return a}function -e8(c,b,a){var +eQ(c,b,a){var d=String.fromCharCode;if(b==0&&a<=4096&&a==c.length)return d.apply(null,c);var -e=p;for(;0=b.l||b.t==2&&c>=b.c.length)){b.c=d.t==4?e8(d.c,e,c):e==0&&d.c.length==c?d.c:d.c.substr(e,c);b.t=b.c.length==b.l?0:2}else -if(b.t==2&&f==b.c.length){b.c+=d.t==4?e8(d.c,e,c):e==0&&d.c.length==c?d.c:d.c.substr(e,c);b.t=b.c.length==b.l?0:2}else{if(b.t!=4)eX(b);var +bY(d,e,b,f,c){if(c==0)return 0;if(f==0&&(c>=b.l||b.t==2&&c>=b.c.length)){b.c=d.t==4?eQ(d.c,e,c):e==0&&d.c.length==c?d.c:d.c.substr(e,c);b.t=b.c.length==b.l?0:2}else +if(b.t==2&&f==b.c.length){b.c+=d.t==4?eQ(d.c,e,c):e==0&&d.c.length==c?d.c:d.c.substr(e,c);b.t=b.c.length==b.l?0:2}else{if(b.t!=4)eF(b);var g=d.c,h=b.c;if(d.t==4)if(f<=e)for(var a=0;a=0;a--)h[f+a]=g[e+a];else{var i=Math.min(c,g.length-e);for(var a=0;a>=1;if(b==0)return d;a+=a;c++;if(c==9)a.slice(0,1)}}function -cb(a){if(a.t==2)a.c+=cP(a.l-a.c.length,"\0");else -a.c=e8(a.c,0,a.c.length);a.t=0}function -l_(a,b){if(a===b)return 1;a.t&6&&cb(a);b.t&6&&cb(b);return a.c==b.c?1:0}function -Gq(b,a){throw[0,b,a]}function -mu(a){if(a.length<24){for(var -b=0;bbB)return false;return true}else +bD(a){return a}function +bZ(a,b,c,d,e){bY(bD(a),b,c,d,e);return 0}function +cI(b,a){if(b==0)return t;if(a.repeat)return a.repeat(b);var +d=t,c=0;for(;;){if(b&1)d+=a;b>>=1;if(b==0)return d;a+=a;c++;if(c==9)a.slice(0,1)}}function +b1(a){if(a.t==2)a.c+=cI(a.l-a.c.length,"\0");else +a.c=eQ(a.c,0,a.c.length);a.t=0}function +ks(a,b){if(a===b)return 1;a.t&6&&b1(a);b.t&6&&b1(b);return a.c==b.c?1:0}function +D5(b,a){throw[0,b,a]}function +kJ(a){if(a.length<24){for(var +b=0;bbt)return false;return true}else return!/[^\x00-\x7f]/.test(a)}function -g4(e){for(var -j=p,c=p,g,f,h,a,b=0,i=e.length;bgb){c.substr(0,1);j+=c;c=p;j+=e.slice(b,d)}else -c+=e.slice(b,d);if(d==i)break;b=d}a=1;if(++b=0xd7ff&&a<0xe000)a=2}else{a=3;if(++b0x10ffff)a=3}}}}}if(a<4){b-=a;c+="\ufffd"}else -if(a>bh)c+=String.fromCharCode(0xd7c0+(a>>10),kE+(a&0x3FF));else -c+=String.fromCharCode(a);if(c.length>dt){c.substr(0,1);j+=c;c=p}}return j+c}function -bn(c,a,b){this.t=c;this.c=a;this.l=b}bn.prototype.toString=function(){switch(this.t){case -9:return this.c;default:cb(this);case -0:if(mu(this.c)){this.t=9;return this.c}this.t=8;case -8:return this.c}};bn.prototype.toUtf16=function(){var -a=this.toString();if(this.t==9)return a;return g4(a)};bn.prototype.slice=function(){var +gx(e){for(var +j=t,c=t,g,f,h,a,b=0,i=e.length;bfO){c.substr(0,1);j+=c;c=t;j+=e.slice(b,d)}else +c+=e.slice(b,d);if(d==i)break;b=d}a=1;if(++b=0xd7ff&&a<0xe000)a=2}else{a=3;if(++b0x10ffff)a=3}}}}}if(a<4){b-=a;c+="\ufffd"}else +if(a>bc)c+=String.fromCharCode(0xd7c0+(a>>10),jo+(a&0x3FF));else +c+=String.fromCharCode(a);if(c.length>di){c.substr(0,1);j+=c;c=t}}return j+c}function +bC(c,a,b){this.t=c;this.c=a;this.l=b}bC.prototype.toString=function(){switch(this.t){case +9:return this.c;default:b1(this);case +0:if(kJ(this.c)){this.t=9;return this.c}this.t=8;case +8:return this.c}};bC.prototype.toUtf16=function(){var +a=this.toString();if(this.t==9)return a;return gx(a)};bC.prototype.slice=function(){var a=this.t==4?this.c.slice():this.c;return new -bn(this.t,a,this.l)};function -l$(a){return new -bn(0,a,a.length)}function -a(a){return l$(a)}function -g0(c,b){Gq(c,a(b))}var -X=[0];function -ad(a){g0(X.Invalid_argument,a)}function -l8(){ad(gs)}function -dD(a,b){switch(a.t&6){default:if(b>=a.c.length)return 0;case +bC(this.t,a,this.l)};function +kt(a){return new +bC(0,a,a.length)}function +a(a){return kt(a)}function +gu(c,b){D5(c,a(b))}var +ab=[0];function +ac(a){gu(ab.Invalid_argument,a)}function +kq(){ac(f5)}function +ds(a,b){switch(a.t&6){default:if(b>=a.c.length)return 0;case 0:return a.c.charCodeAt(b);case 4:return a.c[b]}}function -b4(b,a){if(a>>>0>=b.l)l8();return dD(b,a)}function -aa(a,c,b){b&=aU;if(a.t!=4){if(c==a.c.length){a.c+=String.fromCharCode(b);if(c+1==a.l)a.t=0;return 0}eX(a)}a.c[c]=b;return 0}function -a3(b,a,c){if(a>>>0>=b.l)l8();return aa(b,a,c)}function -a8(c,a){if(c.fun)return a8(c.fun,a);if(typeof +b0(b,a){if(a>>>0>=b.l)kq();return ds(b,a)}function +$(a,c,b){b&=aQ;if(a.t!=4){if(c==a.c.length){a.c+=String.fromCharCode(b);if(c+1==a.l)a.t=0;return 0}eF(a)}a.c[c]=b;return 0}function +a0(b,a,c){if(a>>>0>=b.l)kq();return $(b,a,c)}function +bE(c,a){if(c.fun)return bE(c.fun,a);if(typeof c!=="function")return c;var b=c.length|0;if(b===0)return c.apply(null,a);var e=a.length|0,d=b-e|0;if(d==0)return c.apply(null,a);else -if(d<0)return a8(c.apply(null,a.slice(0,b)),a.slice(b));else +if(d<0)return bE(c.apply(null,a.slice(0,b)),a.slice(b));else return function(){var e=arguments.length==0?1:arguments.length,d=new Array(a.length+e);for(var b=0;b>>0>=a.length-1)dC();return a}function -FO(a){if(isFinite(a)){if(Math.abs(a)>=2.2250738585072014e-308)return 0;if(a!=0)return 1;return 2}return isNaN(a)?4:3}function -bp(a){a.t&6&&cb(a);return a.c}var -GH=Math.log2&&Math.log2(1.1235582092889474E+307)==1020;function -GF(a){if(GH)return Math.floor(Math.log2(a));var +b=0;b>>0>=a.length-1)dr();return a}function +Du(a){if(isFinite(a)){if(Math.abs(a)>=2.2250738585072014e-308)return 0;if(a!=0)return 1;return 2}return isNaN(a)?4:3}function +a4(a){if((a.t&6)!=0)b1(a);return a.c}var +Ek=Math.log2&&Math.log2(1.1235582092889474E+307)==1020;function +Ei(a){if(Ek)return Math.floor(Math.log2(a));var b=0;if(a==0)return-Infinity;if(a>=1)while(a>=2){a/=2;b++}else while(a<1){a*=2;b--}return b}function -gR(c){var -a=new(u.Float32Array)(1);a[0]=c;var -b=new(u.Int32Array)(a.buffer);return b[0]|0}var -mi=Math.pow(2,-24);function -e6(a){throw a}function -cO(){e6(X.Division_by_zero)}function -y(b,c,a){this.lo=b&bF;this.mi=c&bF;this.hi=a&bh}y.prototype.caml_custom="_j";y.prototype.copy=function(){return new -y(this.lo,this.mi,this.hi)};y.prototype.ucompare=function(a){if(this.hi>a.hi)return 1;if(this.hia.mi)return 1;if(this.mia.lo)return 1;if(this.loc)return 1;if(ba.mi)return 1;if(this.mia.lo)return 1;if(this.loa.hi)return 1;if(this.hia.mi)return 1;if(this.mia.lo)return 1;if(this.loc)return 1;if(ba.mi)return 1;if(this.mia.lo)return 1;if(this.lo>24),c=-this.hi+(b>>24);return new -y(a,b,c)};y.prototype.add=function(a){var +x(a,b,c)};x.prototype.add=function(a){var b=this.lo+a.lo,c=this.mi+a.mi+(b>>24),d=this.hi+a.hi+(c>>24);return new -y(b,c,d)};y.prototype.sub=function(a){var +x(b,c,d)};x.prototype.sub=function(a){var b=this.lo-a.lo,c=this.mi-a.mi+(b>>24),d=this.hi-a.hi+(c>>24);return new -y(b,c,d)};y.prototype.mul=function(a){var -b=this.lo*a.lo,c=(b*mi|0)+this.mi*a.lo+this.lo*a.mi,d=(c*mi|0)+this.hi*a.lo+this.mi*a.mi+this.lo*a.hi;return new -y(b,c,d)};y.prototype.isZero=function(){return(this.lo|this.mi|this.hi)==0};y.prototype.isNeg=function(){return this.hi<<16<0};y.prototype.and=function(a){return new -y(this.lo&a.lo,this.mi&a.mi,this.hi&a.hi)};y.prototype.or=function(a){return new -y(this.lo|a.lo,this.mi|a.mi,this.hi|a.hi)};y.prototype.xor=function(a){return new -y(this.lo^a.lo,this.mi^a.mi,this.hi^a.hi)};y.prototype.shift_left=function(a){a=a&63;if(a==0)return this;if(a<24)return new -y(this.lo<>24-a,this.hi<>24-a);if(a<48)return new -y(0,this.lo<>48-a);return new -y(0,0,this.lo<>a|this.mi<<24-a,this.mi>>a|this.hi<<24-a,this.hi>>a);if(a<48)return new -y(this.mi>>a-24|this.hi<<48-a,this.hi>>a-24,0);return new -y(this.hi>>a-48,0,0)};y.prototype.shift_right=function(a){a=a&63;if(a==0)return this;var +x(b,c,d)};x.prototype.mul=function(a){var +b=this.lo*a.lo,c=(b*kB|0)+this.mi*a.lo+this.lo*a.mi,d=(c*kB|0)+this.hi*a.lo+this.mi*a.mi+this.lo*a.hi;return new +x(b,c,d)};x.prototype.isZero=function(){return(this.lo|this.mi|this.hi)==0};x.prototype.isNeg=function(){return this.hi<<16<0};x.prototype.and=function(a){return new +x(this.lo&a.lo,this.mi&a.mi,this.hi&a.hi)};x.prototype.or=function(a){return new +x(this.lo|a.lo,this.mi|a.mi,this.hi|a.hi)};x.prototype.xor=function(a){return new +x(this.lo^a.lo,this.mi^a.mi,this.hi^a.hi)};x.prototype.shift_left=function(a){a=a&63;if(a==0)return this;if(a<24)return new +x(this.lo<>24-a,this.hi<>24-a);if(a<48)return new +x(0,this.lo<>48-a);return new +x(0,0,this.lo<>a|this.mi<<24-a,this.mi>>a|this.hi<<24-a,this.hi>>a);if(a<48)return new +x(this.mi>>a-24|this.hi<<48-a,this.hi>>a-24,0);return new +x(this.hi>>a-48,0,0)};x.prototype.shift_right=function(a){a=a&63;if(a==0)return this;var c=this.hi<<16>>16;if(a<24)return new -y(this.lo>>a|this.mi<<24-a,this.mi>>a|c<<24-a,this.hi<<16>>a>>>16);var +x(this.lo>>a|this.mi<<24-a,this.mi>>a|c<<24-a,this.hi<<16>>a>>>16);var b=this.hi<<16>>31;if(a<48)return new -y(this.mi>>a-24|this.hi<<48-a,this.hi<<16>>a-24>>16,b&bh);return new -y(this.hi<<16>>a-32,b,b)};y.prototype.lsl1=function(){this.hi=this.hi<<1|this.mi>>23;this.mi=(this.mi<<1|this.lo>>23)&bF;this.lo=this.lo<<1&bF};y.prototype.lsr1=function(){this.lo=(this.lo>>>1|this.mi<<23)&bF;this.mi=(this.mi>>>1|this.hi<<23)&bF;this.hi=this.hi>>>1};y.prototype.udivmod=function(e){var +x(this.mi>>a-24|this.hi<<48-a,this.hi<<16>>a-24>>16,b&bc);return new +x(this.hi<<16>>a-32,b,b)};x.prototype.lsl1=function(){this.hi=this.hi<<1|this.mi>>23;this.mi=(this.mi<<1|this.lo>>23)&bz;this.lo=this.lo<<1&bz};x.prototype.lsr1=function(){this.lo=(this.lo>>>1|this.mi<<23)&bz;this.mi=(this.mi>>>1|this.hi<<23)&bz;this.hi=this.hi>>>1};x.prototype.udivmod=function(e){var c=0,b=this.copy(),a=e.copy(),d=new -y(0,0,0);while(b.ucompare(a)>0){c++;a.lsl1()}while(c>=0){c--;d.lsl1();if(b.ucompare(a)>=0){d.lo++;b=b.sub(a)}a.lsr1()}return{quotient:d,modulus:b}};y.prototype.div=function(a){var -b=this;if(a.isZero())cO();var -d=b.hi^a.hi;if(b.hi&bd)b=b.neg();if(a.hi&bd)a=a.neg();var -c=b.udivmod(a).quotient;if(d&bd)c=c.neg();return c};y.prototype.mod=function(b){var -a=this;if(b.isZero())cO();var -d=a.hi;if(a.hi&bd)a=a.neg();if(b.hi&bd)b=b.neg();var -c=a.udivmod(b).modulus;if(d&bd)c=c.neg();return c};y.prototype.toInt=function(){return this.lo|this.mi<<24};y.prototype.toFloat=function(){return(this.hi<<16)*Math.pow(2,32)+this.mi*Math.pow(2,24)+this.lo};y.prototype.toArray=function(){return[this.hi>>8,this.hi&aU,this.mi>>16,this.mi>>8&aU,this.mi&aU,this.lo>>16,this.lo>>8&aU,this.lo&aU]};y.prototype.lo32=function(){return this.lo|(this.mi&aU)<<24};y.prototype.hi32=function(){return this.mi>>>8&bh|this.hi<<16};function -b6(b,c,a){return new -y(b,c,a)}function -e0(a){if(!isFinite(a)){if(isNaN(a))return b6(1,0,iK);return a>0?b6(0,0,iK):b6(0,0,0xfff0)}var -f=a==0&&1/a==-Infinity?bd:a>=0?0:bd;if(f)a=-a;var -b=GF(a)+bl;if(b<=0){b=0;a/=Math.pow(2,-lb)}else{a/=Math.pow(2,b-lU);if(a<16){a*=2;b-=1}if(b==0)a/=2}var +x(0,0,0);while(b.ucompare(a)>0){c++;a.lsl1()}while(c>=0){c--;d.lsl1();if(b.ucompare(a)>=0){d.lo++;b=b.sub(a)}a.lsr1()}return{quotient:d,modulus:b}};x.prototype.div=function(a){var +b=this;if(a.isZero())cG();var +d=b.hi^a.hi;if(b.hi&a$)b=b.neg();if(a.hi&a$)a=a.neg();var +c=b.udivmod(a).quotient;if(d&a$)c=c.neg();return c};x.prototype.mod=function(b){var +a=this;if(b.isZero())cG();var +d=a.hi;if(a.hi&a$)a=a.neg();if(b.hi&a$)b=b.neg();var +c=a.udivmod(b).modulus;if(d&a$)c=c.neg();return c};x.prototype.toInt=function(){return this.lo|this.mi<<24};x.prototype.toFloat=function(){return(this.hi<<16)*Math.pow(2,32)+this.mi*Math.pow(2,24)+this.lo};x.prototype.toArray=function(){return[this.hi>>8,this.hi&aQ,this.mi>>16,this.mi>>8&aQ,this.mi&aQ,this.lo>>16,this.lo>>8&aQ,this.lo&aQ]};x.prototype.lo32=function(){return this.lo|(this.mi&aQ)<<24};x.prototype.hi32=function(){return this.mi>>>8&bc|this.hi<<16};function +b2(b,c,a){return new +x(b,c,a)}function +eI(a){if(!isFinite(a)){if(isNaN(a))return b2(1,0,h4);return a>0?b2(0,0,h4):b2(0,0,0xfff0)}var +f=a==0&&1/a==-Infinity?a$:a>=0?0:a$;if(f)a=-a;var +b=Ei(a)+bf;if(b<=0){b=0;a/=Math.pow(2,-jJ)}else{a/=Math.pow(2,b-ke);if(a<16){a*=2;b-=1}if(b==0)a/=2}var d=Math.pow(2,24),c=a|0;a=(a-c)*d;var e=a|0;a=(a-e)*d;var -g=a|0;c=c&gm|f|b<<4;return b6(g,e,c)}function -dG(a){return a.toArray()}function -l7(c,b,g){c.write(32,b.dims.length);c.write(32,b.kind|b.layout<<8);if(b.caml_custom==eF)for(var -a=0;a>4;if(c==2047)return(f|g|b&gm)==0?b&bd?-Infinity:Infinity:NaN;var -e=Math.pow(2,-24),a=(f*e+g)*e+(b&gm);if(c>0){a+=16;a*=Math.pow(2,c-lU)}else -a*=Math.pow(2,-lb);if(b&bd)a=-a;return a}function -gK(b){var +a(e*kn(c));return d}function +gm(c){var +a=new(D.Int32Array)(1);a[0]=c;var +b=new(D.Float32Array)(a.buffer);return b[0]}function +du(a){return new +x(a[7]<<0|a[6]<<8|a[5]<<16,a[4]<<0|a[3]<<8|a[2]<<16,a[1]<<0|a[0]<<8)}function +cF(d){var +f=d.lo,g=d.mi,b=d.hi,c=(b&0x7fff)>>4;if(c==2047)return(f|g|b&fZ)==0?b&a$?-Infinity:Infinity:NaN;var +e=Math.pow(2,-24),a=(f*e+g)*e+(b&fZ);if(c>0){a+=16;a*=Math.pow(2,c-ke)}else +a*=Math.pow(2,-jJ);if(b&a$)a=-a;return a}function +gf(b){var d=b.length,c=1;for(var -a=0;a>>24&aU|(a&bh)<<8,a>>>16&bh)}function -gT(a){return a.hi32()}function -gU(a){return a.lo32()}var -FL=eF;function -b1(c,d,b,a){this.kind=c;this.layout=d;this.dims=b;this.data=a}b1.prototype.caml_custom=FL;b1.prototype.offset=function(b){var +a=0;a>>24&aQ|(a&bc)<<8,a>>>16&bc)}function +gn(a){return a.hi32()}function +go(a){return a.lo32()}var +Dr=eq;function +bX(c,d,b,a){this.kind=c;this.layout=d;this.dims=b;this.data=a}bX.prototype.caml_custom=Dr;bX.prototype.offset=function(b){var c=0;if(typeof b==="number")b=[b];if(!(b instanceof -Array))ad("bigarray.js: invalid offset");if(this.dims.length!=b.length)ad("Bigarray.get/set: bad number of dimensions");if(this.layout==0)for(var -a=0;a=this.dims[a])dC();c=c*this.dims[a]+b[a]}else +Array))ac("bigarray.js: invalid offset");if(this.dims.length!=b.length)ac("Bigarray.get/set: bad number of dimensions");if(this.layout==0)for(var +a=0;a=this.dims[a])dr();c=c*this.dims[a]+b[a]}else for(var -a=this.dims.length-1;a>=0;a--){if(b[a]<1||b[a]>this.dims[a])dC();c=c*this.dims[a]+(b[a]-1)}return c};b1.prototype.get=function(a){switch(this.kind){case +a=this.dims.length-1;a>=0;a--){if(b[a]<1||b[a]>this.dims[a])dr();c=c*this.dims[a]+(b[a]-1)}return c};bX.prototype.get=function(a){switch(this.kind){case 7:var -d=this.data[a*2+0],b=this.data[a*2+1];return mh(d,b);case +d=this.data[a*2+0],b=this.data[a*2+1];return kA(d,b);case 10:case 11:var -e=this.data[a*2+0],c=this.data[a*2+1];return[dk,e,c];default:return this.data[a]}};b1.prototype.set=function(a,b){switch(this.kind){case -7:this.data[a*2+0]=gU(b);this.data[a*2+1]=gT(b);break;case +e=this.data[a*2+0],c=this.data[a*2+1];return[da,e,c];default:return this.data[a]}};bX.prototype.set=function(a,b){switch(this.kind){case +7:this.data[a*2+0]=go(b);this.data[a*2+1]=gn(b);break;case 10:case -11:this.data[a*2+0]=b[1];this.data[a*2+1]=b[2];break;default:this.data[a]=b;break}return 0};b1.prototype.fill=function(b){switch(this.kind){case +11:this.data[a*2+0]=b[1];this.data[a*2+1]=b[2];break;default:this.data[a]=b;break}return 0};bX.prototype.fill=function(b){switch(this.kind){case 7:var -c=gU(b),e=gT(b);if(c==e)this.data.fill(c);else +c=go(b),e=gn(b);if(c==e)this.data.fill(c);else for(var a=0;ab.data[a])return 1}break}return 0};function -cK(c,d,b,a){this.kind=c;this.layout=d;this.dims=b;this.data=a}cK.prototype=new -b1();cK.prototype.offset=function(a){if(typeof +cC(c,d,b,a){this.kind=c;this.layout=d;this.dims=b;this.data=a}cC.prototype=new +bX();cC.prototype.offset=function(a){if(typeof a!=="number")if(a instanceof Array&&a.length==1)a=a[0];else -ad("Ml_Bigarray_c_1_1.offset");if(a<0||a>=this.dims[0])dC();return a};cK.prototype.get=function(a){return this.data[a]};cK.prototype.set=function(a,b){this.data[a]=b;return 0};cK.prototype.fill=function(a){this.data.fill(a);return 0};function -l3(c,d,a,b){var -e=l5(c);if(gK(a)*e!=b.length)ad("length doesn't match dims");if(d==0&&a.length==1&&e==1)return new -cK(c,d,a,b);return new -b1(c,d,a,b)}function -b5(b){if(!X.Failure)X.Failure=[I,a(gv),-3];g0(X.Failure,b)}function -l4(b,v,r){var -i=b.read32s();if(i<0||i>16)b5("input_value: wrong number of bigarray dimensions");var -p=b.read32s(),j=p&aU,o=p>>8&1,h=[];if(r==eF)for(var +ac("Ml_Bigarray_c_1_1.offset");if(a<0||a>=this.dims[0])dr();return a};cC.prototype.get=function(a){return this.data[a]};cC.prototype.set=function(a,b){this.data[a]=b;return 0};cC.prototype.fill=function(a){this.data.fill(a);return 0};function +kl(c,d,a,b){var +e=kn(c);if(gf(a)*e!=b.length)ac("length doesn't match dims");if(d==0&&a.length==1&&e==1)return new +cC(c,d,a,b);return new +bX(c,d,a,b)}function +b8(a){gu(ab.Failure,a)}function +km(b,v,r){var +i=b.read32s();if(i<0||i>16)b8("input_value: wrong number of bigarray dimensions");var +p=b.read32s(),j=p&aQ,o=p>>8&1,h=[];if(r==eq)for(var a=0;a>>32-15;a=a9(a,0x1b873593);b^=a;b=b<<13|b>>>32-13;return(b+(b<<2)|0)+(0xe6546b64|0)|0}function -FY(a,b){a=at(a,gU(b));a=at(a,gT(b));return a}function -gP(a,b){return FY(a,e0(b))}function -l6(c){var -b=gK(c.dims),d=0;switch(c.kind){case +l=cF(du(e));g.set(a,[da,m,l])}break}v[0]=(4+i)*4;return kl(j,o,h,f)}function +kk(a,b,c){return a.compare(b,c)}function +a5(a,b){return Math.imul(a,b)}function +at(b,a){a=a5(a,0xcc9e2d51|0);a=a<<15|a>>>32-15;a=a5(a,0x1b873593);b^=a;b=b<<13|b>>>32-13;return(b+(b<<2)|0)+(0xe6546b64|0)|0}function +DB(a,b){a=at(a,go(b));a=at(a,gn(b));return a}function +gj(a,b){return DB(a,eI(b))}function +ko(c){var +b=gf(c.dims),d=0;switch(c.kind){case 2:case 3:case -12:if(b>cI)b=cI;var +12:if(b>cA)b=cA;var e=0,a=0;for(a=0;a+4<=c.data.length;a+=4){e=c.data[a+0]|c.data[a+1]<<8|c.data[a+2]<<16|c.data[a+3]<<24;d=at(d,e)}e=0;switch(b&3){case 3:e=c.data[a+2]<<16;case 2:e|=c.data[a+1]<<8;case 1:e|=c.data[a+0];d=at(d,e)}break;case 4:case -5:if(b>bH)b=bH;var +5:if(b>bB)b=bB;var e=0,a=0;for(a=0;a+2<=c.data.length;a+=2){e=c.data[a+0]|c.data[a+1]<<16;d=at(d,e)}if((b&1)!=0)d=at(d,c.data[a]);break;case 6:if(b>64)b=64;for(var a=0;a64)b=64;for(var -a=0;a32)b=32;for(var -a=0;a0?b(c,f,e):b(f,c,e);if(e&&a!=a)return d;if(+a!=+a)return+a;if((a|0)!=0)return a|0}return d}function -dH(a){return a +dw(a){return a instanceof -bn}function -e3(a){return dH(a)}function -mc(a){if(typeof -a==="number")return a0;else -if(dH(a))return eC;else -if(e3(a))return 1252;else +bC}function +eL(a){return dw(a)}function +kw(a){if(typeof +a==="number")return aW;else +if(dw(a))return f3;else +if(eL(a))return 1252;else if(a instanceof -Array&&a[0]===a[0]>>>0&&a[0]<=cE){var -b=a[0]|0;return b==dk?0:b}else +Array&&a[0]===a[0]>>>0&&a[0]<=cw){var +b=a[0]|0;return b==da?0:b}else if(a instanceof -String)return i4;else +String)return ic;else if(typeof -a=="string")return i4;else +a=="string")return ic;else if(a instanceof -Number)return a0;else -if(a&&a.caml_custom)return gg;else +Number)return aW;else +if(a&&a.caml_custom)return fS;else if(a&&a.compare)return 1256;else if(typeof a=="function")return 1247;else if(typeof a=="symbol")return 1251;return 1001}function -e2(a,b){if(ab.c?1:0}function -g2(a,b){return l9(a,b)}function -cL(a,b,d){var +eK(a,b){if(ab.c?1:0}function +gv(a,b){return kr(a,b)}function +cD(a,b,d){var e=[];for(;;){if(!(d&&a===b)){var -f=mc(a);if(f==eo){a=a[1];continue}var -g=mc(b);if(g==eo){b=b[1];continue}if(f!==g){if(f==a0){if(g==gg)return mb(a,b,-1,d);return-1}if(g==a0){if(f==gg)return mb(b,a,1,d);return 1}return fb)return 1;if(a!=b){if(!d)return NaN;if(a==a)return 1;if(b==b)return-1}break;case 1251:if(a!==b){if(!d)return NaN;return 1}break;case 1252:var -a=bp(a),b=bp(b);if(a!==b){if(ab)return 1}break;case +a=a4(a),b=a4(b);if(a!==b){if(ab)return 1}break;case 12520:var a=a.toString(),b=b.toString();if(a!==b){if(ab)return 1}break;case 246:case 254:default:if(a.length!=b.length)return a.length1)e.push(a,b,1);break}}if(e.length==0)return 0;var h=e.pop();b=e.pop();a=e.pop();if(h+10)if(c==0&&(b>=a.l||a.t==2&&b>=a.c.length))if(d==0){a.c=p;a.t=2}else{a.c=cP(b,String.fromCharCode(d));a.t=b==a.l?0:2}else{if(a.t!=4)eX(a);for(b+=c;c31)ad("format_int: format too long");var -a={justify:bA,signstyle:az,filler:bC,alternate:false,base:0,signedconv:false,width:0,uppercase:false,sign:1,prec:-1,conv:"f"};for(var +ku(a,b){return cD(a,b,true)}function +aa(a){if(a<0)ac("Bytes.create");return new +bC(a?2:9,t,a)}function +gh(b,a){if(a==0)cG();return b/a|0}function +y(a,b){return+(cD(a,b,false)==0)}function +Dv(a,c,b,d){if(b>0)if(c==0&&(b>=a.l||a.t==2&&b>=a.c.length))if(d==0){a.c=t;a.t=2}else{a.c=cI(b,String.fromCharCode(d));a.t=b==a.l?0:2}else{if(a.t!=4)eF(a);for(b+=c;c31)ac("format_int: format too long");var +a={justify:bs,signstyle:aA,filler:bv,alternate:false,base:0,signedconv:false,width:0,uppercase:false,sign:1,prec:-1,conv:"f"};for(var c=0;c=0&&b<=9){a.width=a.width*10+b;c++}c--;break;case".":a.prec=0;c++;while(b=d.charCodeAt(c)-48,b>=0&&b<=9){a.prec=a.prec*10+b;c++}c--;case"d":case"i":a.signedconv=true;case"u":a.base=10;break;case"x":a.base=16;break;case"X":a.base=16;a.uppercase=true;break;case"o":a.base=8;break;case"e":case"f":case"g":a.signedconv=true;a.conv=b;break;case"E":case"F":case"G":a.signedconv=true;a.uppercase=true;a.conv=b.toLowerCase();break}}return a}function -gN(b,f){if(b.uppercase)f=f.toUpperCase();var -e=f.length;if(b.signedconv&&(b.sign<0||b.signstyle!=az))e++;if(b.alternate){if(b.base==8)e+=1;if(b.base==16)e+=2}var -c=p;if(b.justify==bA&&b.filler==bC)for(var -d=e;d=0&&b<=9){a.width=a.width*10+b;c++}c--;break;case".":a.prec=0;c++;while(b=d.charCodeAt(c)-48,b>=0&&b<=9){a.prec=a.prec*10+b;c++}c--;case"d":case"i":a.signedconv=true;case"u":a.base=10;break;case"x":a.base=16;break;case"X":a.base=16;a.uppercase=true;break;case"o":a.base=8;break;case"e":case"f":case"g":a.signedconv=true;a.conv=b;break;case"E":case"F":case"G":a.signedconv=true;a.uppercase=true;a.conv=b.toLowerCase();break}}return a}function +gi(b,f){if(b.uppercase)f=f.toUpperCase();var +e=f.length;if(b.signedconv&&(b.sign<0||b.signstyle!=aA))e++;if(b.alternate){if(b.base==8)e+=1;if(b.base==16)e+=2}var +c=t;if(b.justify==bs&&b.filler==bv)for(var +d=e;d20){c-=20;a/=Math.pow(10,c);a+=new -Array(c+1).join(k);if(b>0)a=a+bf+new +c=parseInt(a.toString().split(bs)[1]);if(c>20){c-=20;a/=Math.pow(10,c);a+=new +Array(c+1).join(k);if(b>0)a=a+bu+new Array(b+1).join(k);return a}else return a.toFixed(b)}}var -a,e=gZ(i),d=e.prec<0?6:e.prec;if(c<0||c==0&&1/c==-Infinity){e.sign=-1;c=-c}if(isNaN(c)){a=gx;e.filler=bC}else -if(!isFinite(c)){a=lN;e.filler=bC}else +a,e=gt(i),d=e.prec<0?6:e.prec;if(c<0||c==0&&1/c==-Infinity){e.sign=-1;c=-c}if(isNaN(c)){a=f8;e.filler=bv}else +if(!isFinite(c)){a=j$;e.filler=bv}else switch(e.conv){case"e":var -a=c.toExponential(d),b=a.length;if(a.charAt(b-3)==eV)a=a.slice(0,b-1)+k+a.slice(b-1);break;case"f":a=j(c,d);break;case"g":d=d?d:1;a=c.toExponential(d-1);var -h=a.indexOf(eV),g=+a.slice(h+1);if(g<-4||c>=1e21||c.toFixed(0).length>d){var -b=h-1;while(a.charAt(b)==k)b--;if(a.charAt(b)==bf)b--;a=a.slice(0,b+1)+a.slice(h);b=a.length;if(a.charAt(b-3)==eV)a=a.slice(0,b-1)+k+a.slice(b-1);break}else{var +a=c.toExponential(d),b=a.length;if(a.charAt(b-3)==eD)a=a.slice(0,b-1)+k+a.slice(b-1);break;case"f":a=j(c,d);break;case"g":d=d?d:1;a=c.toExponential(d-1);var +h=a.indexOf(eD),g=+a.slice(h+1);if(g<-4||c>=1e21||c.toFixed(0).length>d){var +b=h-1;while(a.charAt(b)==k)b--;if(a.charAt(b)==bu)b--;a=a.slice(0,b+1)+a.slice(h);b=a.length;if(a.charAt(b-3)==eD)a=a.slice(0,b-1)+k+a.slice(b-1);break}else{var f=d;if(g<0){f-=g+1;a=c.toFixed(f)}else while(a=c.toFixed(f),a.length>d+1)f--;if(f){var -b=a.length-1;while(a.charAt(b)==k)b--;if(a.charAt(b)==bf)b--;a=a.slice(0,b+1)}}break}return gN(e,a)}function -eY(e,c){if(bp(e)==gF)return a(p+c);var -b=gZ(e);if(c<0)if(b.signedconv){b.sign=-1;c=-c}else +b=a.length-1;while(a.charAt(b)==k)b--;if(a.charAt(b)==bu)b--;a=a.slice(0,b+1)}}break}return gi(e,a)}function +eG(e,c){if(a4(e)==jV)return a(t+c);var +b=gt(e);if(c<0)if(b.signedconv){b.sign=-1;c=-c}else c>>>=0;var -d=c.toString(b.base);if(b.prec>=0){b.filler=bC;var -f=b.prec-d.length;if(f>0)d=cP(f,k)+d}return gN(b,d)}var -mo=0;function -aA(){return mo++}function -aV(a){return a.toUtf16()}function -dL(){return typeof -u.process!=="undefined"&&typeof -u.process.versions!=="undefined"&&typeof -u.process.versions.node!=="undefined"}function -GI(){function -a(a){if(a.charAt(0)===bj)return[p,a.substring(1)];return}function -b(c){var -g=/^([a-zA-Z]:|[\\/]{2}[^\\/]+[\\/]+[^\\/]+)?([\\/])?([\s\S]*?)$/,a=g.exec(c),b=a[1]||p,e=Boolean(b&&b.charAt(1)!==":");if(Boolean(a[2]||e)){var -d=a[1]||p,f=a[2]||p;return[d,c.substring(d.length+f.length)]}return}return dL()&&u.process&&u.process.platform?u.process.platform==="win32"?b:a:a}var -g6=GI();function -ms(a){return a.slice(-1)!==bj?a+bj:a}if(dL()&&u.process&&u.process.cwd)var -dE=u.process.cwd().replace(/\\/g,bj);else +d=c.toString(b.base);if(b.prec>=0){b.filler=bv;var +f=b.prec-d.length;if(f>0)d=cI(f,k)+d}return gi(b,d)}var +kG=0;function +aj(){return kG++}function +aR(a){return a.toUtf16()}if(D.process&&D.process.cwd)var +dt=D.process.cwd().replace(/\\/g,bx);else var -dE="/static";dE=ms(dE);function -Ge(a){a=aV(a);if(!g6(a))a=dE+a;var -e=g6(a),d=e[1].split(bj),b=[];for(var -c=0;c1)b.pop();break;case".":break;default:b.push(d[c]);break}b.unshift(e[0]);b.orig=a;return b}function -Gy(e){for(var -f=p,b=f,a,h,c=0,g=e.length;cgb){b.substr(0,1);f+=b;b=p;f+=e.slice(c,d)}else -b+=e.slice(c,d);if(d==g)break;c=d}if(a>6);b+=String.fromCharCode(a2|a&cw)}else -if(a<0xd800||a>=kQ)b+=String.fromCharCode(iV|a>>12,a2|a>>6&cw,a2|a&cw);else -if(a>=0xdbff||c+1==g||(h=e.charCodeAt(c+1))kQ)b+="\xef\xbf\xbd";else{c++;a=(a<<10)+h-0x35fdc00;b+=String.fromCharCode(j8|a>>18,a2|a>>12&cw,a2|a>>6&cw,a2|a&cw)}if(b.length>dt){b.substr(0,1);f+=b;b=p}}return f+b}function -FN(a){var -b=9;if(!mu(a))b=8,a=Gy(a);return new -bn(b,a,a.length)}function -aL(a){return FN(a)}var -GX=[js,lV,ki,iN,ke,kP,jH,k3,gd,jK,k2,j9,k4,jG,iz,lY,iM,iU,j1,kB,eU,i7,lJ,k8,lv,kt,eO,gG,i3,i2,jV,lM,lH,lQ,jt,iX,jg,kK,lT,j6,jy,kh,iT,j_,iC,k6,lF,jw,i5,j4,ku,jN,kF,kd,k5,jJ,ju,lo,kW,lz,kT,kO,kN,iS,jA,jc,lc,lt];function -cg(d,f,e,a){var -b=GX.indexOf(d);if(b<0){if(a==null)a=-9999;b=[0,a]}var -c=[b,aL(f||p),aL(e||p)];return c}var -mm={};function -bK(a){return mm[a]}function -cf(b,a){throw[0,b].concat(a)}function -FM(a){return new -bn(4,a,a.length)}function -Q(a){g0(X.Sys_error,a)}function -Go(a){Q(a+el)}function -aW(a){return a.l}function -l1(){}function -ar(a){this.data=a}ar.prototype=new -l1();ar.prototype.truncate=function(a){var -b=this.data;this.data=ac(a|0);b2(b,0,this.data,0,a)};ar.prototype.length=function(){return aW(this.data)};ar.prototype.write=function(b,d,g,a){var +dt="/static";if(dt.slice(-1)!==bx)dt+=bx;function +DT(a){a=aR(a);if(a.charCodeAt(0)!=47)a=dt+a;var +d=a.split(bx),b=[];for(var +c=0;c1)b.pop();break;case".":break;case"":if(b.length==0)b.push(t);break;default:b.push(d[c]);break}b.orig=a;return b}function +Ds(a){return new +bC(4,a,a.length)}function +Ec(e){for(var +f=t,b=f,a,h,c=0,g=e.length;cfO){b.substr(0,1);f+=b;b=t;f+=e.slice(c,d)}else +b+=e.slice(c,d);if(d==g)break;c=d}if(a>6);b+=String.fromCharCode(aY|a&co)}else +if(a<0xd800||a>=jw)b+=String.fromCharCode(h9|a>>12,aY|a>>6&co,aY|a&co);else +if(a>=0xdbff||c+1==g||(h=e.charCodeAt(c+1))jw)b+="\xef\xbf\xbd";else{c++;a=(a<<10)+h-0x35fdc00;b+=String.fromCharCode(iY|a>>18,aY|a>>12&co,aY|a>>6&co,aY|a&co)}if(b.length>di){b.substr(0,1);f+=b;b=t}}return f+b}function +Dt(a){var +b=9;if(!kJ(a))b=8,a=Ec(a);return new +bC(b,a,a.length)}function +a6(a){return Dt(a)}function +W(a){gu(ab.Sys_error,a)}function +D3(a){a=a4(a);W(a+": No such file or directory")}function +aS(a){return a.l}function +kj(){}function +as(a){this.data=a}as.prototype=new +kj();as.prototype.truncate=function(a){var +b=this.data;this.data=aa(a|0);bY(b,0,this.data,0,a)};as.prototype.length=function(){return aS(this.data)};as.prototype.write=function(b,d,g,a){var c=this.length();if(b+a>=c){var -e=ac(b+a),f=this.data;this.data=e;b2(f,0,this.data,0,c)}b3(d,g,this.data,b,a);return 0};ar.prototype.read=function(c,a,d,b){var -e=this.length();b2(this.data,c,a,d,b);return 0};ar.prototype.read_one=function(a){return b4(this.data,a)};ar.prototype.close=function(){};ar.prototype.constructor=ar;function -aF(b,a){this.content={};this.root=b;this.lookupFun=a}aF.prototype.nm=function(a){return this.root+a};aF.prototype.create_dir_if_needed=function(d){var -c=d.split(bj),b=p;for(var -a=0;a>1|1;if(h=0)}function -gQ(d,b){var +a=c}eN[d]=a+1;return h==b[a+1]?b[a]:0}function +kz(a,b){return+(cD(a,b,false)>=0)}function +gk(d,b){var e=b.length,a,c;for(a=0;a+4<=e;a+=4){c=b.charCodeAt(a)|b.charCodeAt(a+1)<<8|b.charCodeAt(a+2)<<16|b.charCodeAt(a+3)<<24;d=at(d,c)}c=0;switch(e&3){case 3:c=b.charCodeAt(a+2)<<16;case 2:c|=b.charCodeAt(a+1)<<8;case 1:c|=b.charCodeAt(a);d=at(d,c)}d^=e;return d}function -FZ(a,b){return gQ(a,bp(b))}function -FW(d,b){var +DC(a,b){return gk(a,a4(b))}function +Dz(d,b){var e=b.length,a,c;for(a=0;a+4<=e;a+=4){c=b[a]|b[a+1]<<8|b[a+2]<<16|b[a+3]<<24;d=at(d,c)}c=0;switch(e&3){case 3:c=b[a+2]<<16;case 2:c|=b[a+1]<<8;case 1:c|=b[a];d=at(d,c)}d^=e;return d}function -mj(a){switch(a.t&6){default:cb(a);case -0:return a.c;case -4:return a.c}}function -FV(b,c){var -a=mj(c);return typeof -a==="string"?gQ(b,a):FW(b,a)}function -FX(a){a^=a>>>16;a=a9(a,0x85ebca6b|0);a^=a>>>13;a=a9(a,0xc2b2ae35|0);a^=a>>>16;return a}function -FU(j,l,n,m){var -f,g,h,d,c,b,a,e,i;d=l;if(d<0||d>cI)d=cI;c=j;b=n;f=[m];g=0;h=1;while(g0){a=f[g++];if(a&&a.caml_custom){if(cM[a.caml_custom]&&cM[a.caml_custom].hash){var -k=cM[a.caml_custom].hash(a);b=at(b,k);c--}}else +Dy(a,b){switch(b.t&6){default:b1(b);case +0:a=gk(a,b.c);break;case +2:a=Dz(a,b.c)}return a}function +DA(a){a^=a>>>16;a=a5(a,0x85ebca6b|0);a^=a>>>13;a=a5(a,0xc2b2ae35|0);a^=a>>>16;return a}function +Dx(j,l,n,m){var +f,g,h,d,c,b,a,e,i;d=l;if(d<0||d>cA)d=cA;c=j;b=n;f=[m];g=0;h=1;while(g0){a=f[g++];if(a&&a.caml_custom){if(cE[a.caml_custom]&&cE[a.caml_custom].hash){var +k=cE[a.caml_custom].hash(a);b=at(b,k);c--}}else if(a instanceof Array&&a[0]===(a[0]|0))switch(a[0]){case 248:b=at(b,a[2]);c--;break;case 250:f[--g]=a[1];break;default:var o=a.length-1<<10|a[0];b=at(b,o);for(e=1,i=a.length;e=d)break;f[h++]=a[e]}break}else -if(dH(a)){b=FV(b,a);c--}else -if(e3(a)){b=FZ(b,a);c--}else +if(dw(a)){b=Dy(b,a);c--}else +if(eL(a)){b=DC(b,a);c--}else if(typeof -a==="string"){b=gQ(b,a);c--}else +a==="string"){b=gk(b,a);c--}else if(a===(a|0)){b=at(b,a+a+1);c--}else -if(a===+a){b=gP(b,a);c--}}b=FX(b);return b&0x3FFFFFFF}function -F0(a,c,l){if(!isFinite(a)){if(isNaN(a))return aL(gx);return aL(a>0?lG:"-infinity")}var +if(a===+a){b=gj(b,a);c--}}b=DA(b);return b&0x3FFFFFFF}function +DD(a,c,l){if(!isFinite(a)){if(isNaN(a))return a6(f8);return a6(a>0?j7:"-infinity")}var i=a==0&&1/a==-Infinity?1:a>=0?0:1;if(i)a=-a;var d=0;if(a==0);else if(a<1)while(a<1&&d>-1022){a*=2;d--}else while(a>=2){a/=2;d++}var -j=d<0?p:bA,e=p;if(i)e=az;else +j=d<0?t:bs,e=t;if(i)e=aA;else switch(l){case -43:e=bA;break;case -32:e=bC;break;default:break}if(c>=0&&c<13){var +43:e=bs;break;case +32:e=bv;break;default:break}if(c>=0&&c<13){var g=Math.pow(2,c*4);a=Math.round(a*g)/g}var b=a.toString(16);if(c>=0){var -h=b.indexOf(bf);if(h<0)b+=bf+cP(c,k);else{var -f=h+1+c;if(b.length>24&bF,a>>31&bh)}function -F$(a){return a.toInt()}function -F5(a){return+a.isNeg()}function -F8(a){return a.neg()}function -F3(g,c){var -a=gZ(g);if(a.signedconv&&F5(c)){a.sign=-1;c=F8(c)}var -b=p,h=F9(a.base),f="0123456789abcdef";do{var -e=c.udivmod(h);c=e.quotient;b=f.charAt(F$(e.modulus))+b}while(!F6(c));if(a.prec>=0){a.filler=bC;var -d=a.prec-b.length;if(d>0)b=cP(d,k)+b}return gN(a,b)}function -F_(a,b){return a.or(b)}function -e1(a){return a.toFloat()}function -cc(a){return a.slice(1)}function -Gc(c){var +h=b.indexOf(bu);if(h<0)b+=bu+cI(c,k);else{var +f=h+1+c;if(b.length>24&bz,a>>31&bc)}function +DO(a){return a.toInt()}function +DI(a){return+a.isNeg()}function +DL(a){return a.neg()}function +DG(g,c){var +a=gt(g);if(a.signedconv&&DI(c)){a.sign=-1;c=DL(c)}var +b=t,h=DM(a.base),f="0123456789abcdef";do{var +e=c.udivmod(h);c=e.quotient;b=f.charAt(DO(e.modulus))+b}while(!DJ(c));if(a.prec>=0){a.filler=bv;var +d=a.prec-b.length;if(d>0)b=cI(d,k)+b}return gi(a,b)}function +DN(a,b){return a.or(b)}function +eJ(a){return a.toFloat()}function +DQ(){return typeof +module!=="undefined"&&module&&module.exports?module.exports:D}function +b9(a){return a.slice(1)}function +DR(c){var d=c.length,b=new Array(d+1);b[0]=0;for(var a=0;a0){var c=new Array(b);for(var -a=0;abl){a-=bl;b*=Math.pow(2,bl);if(a>bl){a-=bl;b*=Math.pow(2,bl)}}if(a<-bl){a+=bl;b*=Math.pow(2,-bl)}b*=Math.pow(2,a);return b}function -Gd(a,b){return+(cL(a,b,false)<=0)}function -gX(a,b){return+(cL(a,b,false)<0)}function -bJ(a,d){if(a<0)dC();var +a=0;abf){a-=bf;b*=Math.pow(2,bf);if(a>bf){a-=bf;b*=Math.pow(2,bf)}}if(a<-bf){a+=bf;b*=Math.pow(2,-bf)}b*=Math.pow(2,a);return b}function +DS(a,b){return+(cD(a,b,false)<=0)}function +gr(a,b){return+(cD(a,b,false)<0)}function +bF(a,d){if(a<0)dr();var a=a+1|0,b=new Array(a);b[0]=0;for(var c=1;c>>32-b,c)}function g(c,b,d,e,h,f,g){return a(b&d|~b&e,c,b,h,f,g)}function @@ -717,41 +669,41 @@ h(d,b,e,c,h,f,g){return a(b&c|e&~c,d,b,h,f,g)}function i(c,b,d,e,h,f,g){return a(b^d^e,c,b,h,f,g)}function j(c,b,d,e,h,f,g){return a(d^(b|~e),c,b,h,f,g)}function k(f,n){var -e=n;f[e>>2]|=a2<<8*(e&3);for(e=(e&~0x3)+8;(e&0x3F)<60;e+=4)f[(e>>2)-1]=0;f[(e>>2)-1]=n<<3;f[e>>2]=n>>29&0x1FFFFFFF;var +e=n;f[e>>2]|=aY<<8*(e&3);for(e=(e&~0x3)+8;(e&0x3F)<60;e+=4)f[(e>>2)-1]=0;f[(e>>2)-1]=n<<3;f[e>>2]=n>>29&0x1FFFFFFF;var k=[0x67452301,0xEFCDAB89,0x98BADCFE,0x10325476];for(e=0;e>8*m&0xFF;return o}return function(i,g,f){var -e=[],h=mj(i);if(typeof -h==="string"){var -d=h;for(var +m=0;m<4;m++)o[e*4+m]=k[e]>>8*m&0xFF;return o}return function(h,g,f){var +e=[];switch(h.t&6){default:b1(h);case +0:var +d=h.c;for(var a=0;a>2]=d.charCodeAt(b)|d.charCodeAt(b+1)<<8|d.charCodeAt(b+2)<<16|d.charCodeAt(b+3)<<24}for(;a>2]|=d.charCodeAt(a+g)<<8*(a&3)}else{var -c=h;for(var +b=a+g;e[a>>2]=d.charCodeAt(b)|d.charCodeAt(b+1)<<8|d.charCodeAt(b+2)<<16|d.charCodeAt(b+3)<<24}for(;a>2]|=d.charCodeAt(a+g)<<8*(a&3);break;case +4:var +c=h.c;for(var a=0;a>2]=c[b]|c[b+1]<<8|c[b+2]<<16|c[b+3]<<24}for(;a>2]|=c[a+g]<<8*(a&3)}return Gu(k(e,f))}}();function -Gg(c,b,a){return Gf(bI(c),b,a)}function -Gh(){return 0}var -bq=new +b=a+g;e[a>>2]=c[b]|c[b+1]<<8|c[b+2]<<16|c[b+3]<<24}for(;a>2]|=c[a+g]<<8*(a&3)}return D9(k(e,f))}}();function +DV(c,b,a){return DU(bD(c),b,a)}var +bj=new Array();function -cd(c){var -a=bq[c];if(!a.opened)Q("Cannot flush a closed channel");if(!a.buffer||a.buffer==p)return 0;if(a.fd&&X.fds[a.fd]&&X.fds[a.fd].output){var -b=X.fds[a.fd].output;switch(b.length){case -2:b(c,a.buffer);break;default:b(a.buffer)}}a.buffer=p;return 0}function -mq(e,f){var -b=bq[e],d=a(f),c=E(d);b.file.write(b.offset,d,0,c);b.offset+=c;return 0}function -GC(a){var -a=g4(a),b=u;if(b.process&&b.process.stdout&&b.process.stdout.write)b.process.stderr.write(a);else{if(a.charCodeAt(a.length-1)==10)a=a.substr(0,a.length-1);var +gs(c){var +a=bj[c];if(!a.opened)W("Cannot flush a closed channel");if(!a.buffer||a.buffer==t)return 0;if(a.fd&&ab.fds[a.fd]&&ab.fds[a.fd].output){var +b=ab.fds[a.fd].output;switch(b.length){case +2:b(c,a.buffer);break;default:b(a.buffer)}}a.buffer=t;return 0}function +kI(e,f){var +b=bj[e],d=a(f),c=E(d);b.file.write(b.offset,d,0,c);b.offset+=c;return 0}function +Eg(a){var +a=gx(a),b=D;if(b.process&&b.process.stdout&&b.process.stdout.write)b.process.stderr.write(a);else{if(a.charCodeAt(a.length-1)==10)a=a.substr(0,a.length-1);var c=b.console;c&&c.error&&c.error(a)}}function -GD(a){var -a=g4(a),b=u;if(b.process&&b.process.stdout&&b.process.stdout.write)b.process.stdout.write(a);else{if(a.charCodeAt(a.length-1)==10)a=a.substr(0,a.length-1);var +Eh(a){var +a=gx(a),b=D;if(b.process&&b.process.stdout&&b.process.stdout.write)b.process.stdout.write(a);else{if(a.charCodeAt(a.length-1)==10)a=a.substr(0,a.length-1);var c=b.console;c&&c.log&&c.log(a)}}function -e9(c,e,d,a){if(X.fds===undefined)X.fds=new +eS(c,e,d,a){if(ab.fds===undefined)ab.fds=new Array();a=a?a:{};var -b={};b.file=d;b.offset=a.append?d.length():0;b.flags=a;b.output=e;X.fds[c]=b;if(!X.fd_last_idx||c>X.fd_last_idx)X.fd_last_idx=c;return c}function -GZ(c,b,g){var +b={};b.file=d;b.offset=a.append?d.length():0;b.flags=a;b.output=e;ab.fds[c]=b;if(!ab.fd_last_idx||c>ab.fd_last_idx)ab.fd_last_idx=c;return c}function +EA(c,b,g){var a={};while(b){switch(b[1]){case 0:a.rdonly=1;break;case 1:a.wronly=1;break;case @@ -761,111 +713,104 @@ a={};while(b){switch(b[1]){case 5:a.excl=1;break;case 6:a.binary=1;break;case 7:a.text=1;break;case -8:a.nonblock=1;break}b=b[2]}if(a.rdonly&&a.wronly)Q(bp(c)+i$);if(a.text&&a.binary)Q(bp(c)+jI);var -d=mD(c),e=d.device.open(d.rest,a),f=X.fd_last_idx?X.fd_last_idx:0;return e9(f+1,mq,e,a)}e9(0,mq,new -ar(ac(0)));e9(1,GD,new -ar(ac(0)));e9(2,GC,new -ar(ac(0)));function -Gi(a){var -c=X.fds[a];if(c.flags.wronly)Q(kk+a+" is writeonly");var -d=null;if(a==0&&dL()){var -e=require("fs");d=function(){return aL(e.readFileSync(0,iB))}}var -b={file:c.file,offset:c.offset,fd:a,opened:true,out:false,refill:d};bq[b.fd]=b;return b.fd}function -mk(c){var -b=X.fds[c];if(b.flags.rdonly)Q(kk+c+" is readonly");var -a={file:b.file,offset:b.offset,fd:c,opened:true,out:true,buffer:p};bq[a.fd]=a;return a.fd}function -Gj(){var +8:a.nonblock=1;break}b=b[2]}if(a.rdonly&&a.wronly)W(a4(c)+ii);if(a.text&&a.binary)W(a4(c)+iG);var +d=kS(c),e=d.device.open(d.rest,a),f=ab.fd_last_idx?ab.fd_last_idx:0;return eS(f+1,kI,e,a)}eS(0,kI,new +as(aa(0)));eS(1,Eh,new +as(aa(0)));eS(2,Eg,new +as(aa(0)));function +DW(c){var +b=ab.fds[c];if(b.flags.wronly)W(i8+c+" is writeonly");var +a={file:b.file,offset:b.offset,fd:c,opened:true,out:false,refill:null};bj[a.fd]=a;return a.fd}function +kC(c){var +b=ab.fds[c];if(b.flags.rdonly)W(i8+c+" is readonly");var +a={file:b.file,offset:b.offset,fd:c,opened:true,out:true,buffer:t};bj[a.fd]=a;return a.fd}function +DX(){var b=0;for(var -a=0;a>>0)return a[0];else -if(dH(a))return eC;else -if(e3(a))return eC;else +if(dw(a))return f3;else +if(eL(a))return f3;else if(a instanceof Function||typeof a=="function")return 247;else -if(a&&a.caml_custom)return cE;else -return a0}function -a4(b,c,a){if(a&&u.toplevelReloc)b=u.toplevelReloc(a);X[b+1]=c;if(a)X[a]=c}function -g1(a,b){mm[bp(a)]=b;return 0}function -Gr(a){a[2]=mo++;return a}function -g3(a,b){return l_(a,b)}function -Gt(){ad(gs)}function -D(b,a){if(a>>>0>=E(b))Gt();return cQ(b,a)}function -ai(a,b){return 1-g3(a,b)}function -Gv(){return 0x7FFFFFFF/4|0}function -Gp(){e6(X.Not_found)}function -mr(c){var -a=u,b=aV(c);if(a.process&&a.process.env&&a.process.env[b]!=undefined)return aL(a.process.env[b]);if(u.jsoo_static_env&&u.jsoo_static_env[b])return aL(u.jsoo_static_env[b]);Gp()}function -Gw(){if(u.crypto)if(typeof -u.crypto.getRandomValues==="function"){var -a=new(u.Uint32Array)(1);u.crypto.getRandomValues(a);return[0,a[0]]}else -if(u.crypto.randomBytes==="function"){var -b=u.crypto.randomBytes(4),a=new(u.Uint32Array)(b);return[0,a[0]]}var -c=new -Date().getTime(),d=c^kf*Math.random();return[0,d]}function -dK(a){var +if(a&&a.caml_custom)return cw;else +return aW}function +a1(b,c,a){if(a&&D.toplevelReloc)b=D.toplevelReloc(a);ab[b+1]=c;if(a)ab[a]=c}var +kD={};function +D6(a,b){kD[a4(a)]=b;return 0}function +D7(a){a[2]=kG++;return a}function +gw(a,b){return ks(a,b)}function +D8(){ac(f5)}function +C(b,a){if(a>>>0>=E(b))D8();return cJ(b,a)}function +ad(a,b){return 1-gw(a,b)}function +D_(){return[0,a("js_of_ocaml")]}function +D$(){return 0x7FFFFFFF/4|0}function +Ea(){return[0,a("Unix"),32,0]}function +D4(){eP(ab.Not_found)}function +eR(c){var +a=D,b=aR(c);if(a.process&&a.process.env&&a.process.env[b]!=undefined)return a6(a.process.env[b]);if(D.jsoo_static_env&&D.jsoo_static_env[b])return a6(D.jsoo_static_env[b]);D4()}function +Eb(){var +a=new +Date().getTime(),b=a^i4*Math.random();return[0,b]}function +dy(a){var b=1;while(a&&a.joo_tramp){a=a.joo_tramp.apply(null,a.joo_args);b++}return a}function -aj(b,a){return{joo_tramp:b,joo_args:a}}function -Gx(c,a){if(typeof -a==="function"){c.fun=a;return 0}if(a.fun){c.fun=a.fun;return 0}var -b=a.length;while(b--)c[b]=a[b];return 0}function -mp(a){return a}function +ak(b,a){return{joo_tramp:b,joo_args:a}}function +kH(a){return a}function +eO(a){return kD[a]}function c(a){if(a instanceof -Array)return a;if(u.RangeError&&a +Array)return a;if(D.RangeError&&a instanceof -u.RangeError&&a.message&&a.message.match(/maximum call stack/i))return mp(X.Stack_overflow);if(u.InternalError&&a +D.RangeError&&a.message&&a.message.match(/maximum call stack/i))return kH(ab.Stack_overflow);if(D.InternalError&&a instanceof -u.InternalError&&a.message&&a.message.match(/too much recursion/i))return mp(X.Stack_overflow);if(a +D.InternalError&&a.message&&a.message.match(/too much recursion/i))return kH(ab.Stack_overflow);if(a instanceof -u.Error&&bK(gf))return[0,bK(gf),a];return[0,X.Failure,aL(String(a))]}var -r=function(A){"use strict";var -f=b$,ab=7,u=9007199254740992,I=q(u),N="0123456789abcdefghijklmnopqrstuvwxyz",g=GB.BigInt,G=typeof +D.Error&&eO(fR))return[0,eO(fR),a];return[0,ab.Failure,a6(String(a))]}var +q=function(A){"use strict";var +f=b6,ac=7,u=9007199254740992,J=p(u),O="0123456789abcdefghijklmnopqrstuvwxyz",g=D.BigInt,H=typeof g==="function";function d(a,b,c,f){if(typeof a==="undefined")return d[0];if(typeof -b!=="undefined")return+b===10&&!c?e(a):af(a,b,c,f);return e(a)}function -a(b,a){this.value=b;this.sign=a;this.isSmall=false;this.caml_custom=eM}a.prototype=Object.create(d.prototype);function -b(a){this.value=a;this.sign=a<0;this.isSmall=true;this.caml_custom=eM}b.prototype=Object.create(d.prototype);function -c(a){this.value=a;this.caml_custom=eM}c.prototype=Object.create(d.prototype);function +b!=="undefined")return+b===10&&!c?e(a):ag(a,b,c,f);return e(a)}function +a(b,a){this.value=b;this.sign=a;this.isSmall=false;this.caml_custom=ew}a.prototype=Object.create(d.prototype);function +b(a){this.value=a;this.sign=a<0;this.isSmall=true;this.caml_custom=ew}b.prototype=Object.create(d.prototype);function +c(a){this.value=a;this.caml_custom=ew}c.prototype=Object.create(d.prototype);function m(a){return-u0)return Math.floor(a);return Math.ceil(a)}function -O(g,h){var +s(a){if(a>0)return Math.floor(a);return Math.ceil(a)}function +P(g,h){var i=g.length,j=h.length,e=new Array(i),b=0,d=f,c,a;for(a=0;a=d?1:0;e[a]=c-b*d}while(a0)e.push(b);return e}function -v(a,b){if(a.length>=b.length)return O(a,b);return O(b,a)}function +v(a,b){if(a.length>=b.length)return P(a,b);return P(b,a)}function B(g,a){var h=g.length,d=new Array(h),c=f,e,b;for(b=0;b0){d[b++]=a%c;a=Math.floor(a/c)}return d}a.prototype.add=function(f){var @@ -875,29 +820,29 @@ a(B(c,Math.abs(d)),this.sign);return new a(v(c,d),this.sign)};a.prototype.plus=a.prototype.add;b.prototype.add=function(g){var f=e(g),c=this.value;if(c<0!==f.sign)return this.subtract(f.negate());var d=f.value;if(f.isSmall){if(m(c+d))return new -b(c+d);d=q(Math.abs(d))}return new +b(c+d);d=p(Math.abs(d))}return new a(B(d,Math.abs(c)),c<0)};b.prototype.plus=b.prototype.add;c.prototype.add=function(a){return new c(this.value+e(a).value)};c.prototype.plus=c.prototype.add;function y(d,h){var g=d.length,i=h.length,c=new Array(g),e=0,j=f,a,b;for(a=0;a=0)c=y(e,f);else{c=y(f,e);d=!d}c=n(c);if(typeof c==="number"){if(d)c=-c;return new b(c)}return new a(c,d)}function -F(h,l,k){var +G(h,l,k){var j=h.length,c=new Array(j),i=-l,g=f,e,d;for(e=0;e=0)};b.prototype.minus=b.prototype.subtract;c.prototype.subtract=function(a){return new +b(a-d);return G(d,Math.abs(a),a>=0)};b.prototype.minus=b.prototype.subtract;c.prototype.subtract=function(a){return new c(this.value-e(a).value)};c.prototype.minus=c.prototype.subtract;a.prototype.negate=function(){return new a(this.value,!this.sign)};b.prototype.negate=function(){var c=this.sign,a=new @@ -906,58 +851,58 @@ c(-this.value)};a.prototype.abs=function(){return new a(this.value,false)};b.prototype.abs=function(){return new b(Math.abs(this.value))};c.prototype.abs=function(){return new c(this.value>=0?this.value:-this.value)};function -M(g,j){var +N(g,j){var i=g.length,l=j.length,n=i+l,c=C(n),m=f,e,d,a,h,k;for(a=0;a0){e[b++]=a%c;a=Math.floor(a/c)}return e}function -Y(c,b){var +Z(c,b){var a=[];while(b-->0)a.push(0);return a.concat(c)}function -D(b,c){var -a=Math.max(b.length,c.length);if(a<=30)return M(b,c);a=Math.ceil(a/2);var -f=b.slice(a),d=b.slice(0,a),i=c.slice(a),h=c.slice(0,a),e=D(d,h),g=D(f,i),k=D(v(d,f),v(h,i)),j=v(v(e,Y(y(y(k,e),g),a)),Y(g,2*a));s(j);return j}function -ak(a,b){return-(jU*a)-jU*b+0.000015*a*b>0}a.prototype.multiply=function(j){var +E(b,c){var +a=Math.max(b.length,c.length);if(a<=30)return N(b,c);a=Math.ceil(a/2);var +f=b.slice(a),d=b.slice(0,a),i=c.slice(a),h=c.slice(0,a),e=E(d,h),g=E(f,i),k=E(v(d,f),v(h,i)),j=v(v(e,Z(y(y(k,e),g),a)),Z(g,2*a));r(j);return j}function +al(a,b){return-(iO*a)-iO*b+0.000015*a*b>0}a.prototype.multiply=function(j){var h=e(j),c=this.value,b=h.value,i=this.sign!==h.sign,g;if(h.isSmall){if(b===0)return d[0];if(b===1)return this;if(b===-1)return this.negate();g=Math.abs(b);if(g=0;d--){j=g-1;if(b[d+h]!==l)j=Math.floor((b[d+h]*g+b[d+h-1])/l);c=0;e=0;m=i.length;for(a=0;ah)d=(d+1)*i;c=Math.ceil(d/m);do{j=w(b,c);if(o(j,a)<=0)break;c--}while(c);e.push(c);a=y(a,j)}e.reverse();return[n(e),n(a)]}function -P(i,e){var -g=i.length,h=C(g),j=f,a,d,b,c;b=0;for(a=g-1;a>=0;--a){c=b*j+i[a];d=t(c/e);b=c-d*e;h[a]=d|0}return[h,b|0]}function +ad(q,k){var +r=q.length,h=k.length,g=f,s=C(k.length),l=k[h-1],o=Math.ceil(g/(2*l)),b=w(q,o),i=w(k,o),j,d,c,e,a,m,p;if(b.length<=r)b.push(0);i.push(0);l=i[h-1];for(d=r-h;d>=0;d--){j=g-1;if(b[d+h]!==l)j=Math.floor((b[d+h]*g+b[d+h-1])/l);c=0;e=0;m=i.length;for(a=0;ah)d=(d+1)*i;c=Math.ceil(d/m);do{j=w(b,c);if(o(j,a)<=0)break;c--}while(c);e.push(c);a=y(a,j)}e.reverse();return[n(e),n(a)]}function +Q(i,e){var +g=i.length,h=C(g),j=f,a,d,b,c;b=0;for(a=g-1;a>=0;--a){c=b*j+i[a];d=s(c/e);b=c-d*e;h[a]=d|0}return[h,b|0]}function i(h,w){var -m,j=e(w);if(G)return[new +m,j=e(w);if(H)return[new c(h.value/j.value),new c(h.value%j.value)];var l=h.value,i=j.value,g;if(i===0)throw new Error("Cannot divide by zero");if(h.isSmall){if(j.isSmall)return[new -b(t(l/i)),new +b(s(l/i)),new b(l%i)];return[d[0],h]}if(j.isSmall){if(i===1)return[h,d[0]];if(i==-1)return[h.negate(),d[0]];var -r=Math.abs(i);if(rd?1:-1;if(a<0!==b.sign)return a<0?-1:1;return a<0?1:-1};b.prototype.compareTo=b.prototype.compare;c.prototype.compare=function(a){if(a===Infinity)return-1;if(a===-Infinity)return 1;var b=this.value,c=e(a).value;return b===c?0:b>c?1:-1};c.prototype.compareTo=c.prototype.compare;a.prototype.equals=function(a){return this.compare(a)===0};c.prototype.eq=c.prototype.equals=b.prototype.eq=b.prototype.equals=a.prototype.eq=a.prototype.equals;a.prototype.notEquals=function(a){return this.compare(a)!==0};c.prototype.neq=c.prototype.notEquals=b.prototype.neq=b.prototype.notEquals=a.prototype.neq=a.prototype.notEquals;a.prototype.greater=function(a){return this.compare(a)>0};c.prototype.gt=c.prototype.greater=b.prototype.gt=b.prototype.greater=a.prototype.gt=a.prototype.greater;a.prototype.lesser=function(a){return this.compare(a)<0};c.prototype.lt=c.prototype.lesser=b.prototype.lt=b.prototype.lesser=a.prototype.lt=a.prototype.lesser;a.prototype.greaterOrEquals=function(a){return this.compare(a)>=0};c.prototype.geq=c.prototype.greaterOrEquals=b.prototype.geq=b.prototype.greaterOrEquals=a.prototype.geq=a.prototype.greaterOrEquals;a.prototype.lesserOrEquals=function(a){return this.compare(a)<=0};c.prototype.leq=c.prototype.lesserOrEquals=b.prototype.leq=b.prototype.lesserOrEquals=a.prototype.leq=a.prototype.lesserOrEquals;a.prototype.isEven=function(){return(this.value[0]&1)===0};b.prototype.isEven=function(){return(this.value&1)===0};c.prototype.isEven=function(){return(this.value&g(1))===g(0)};a.prototype.isOdd=function(){return(this.value[0]&1)===1};b.prototype.isOdd=function(){return(this.value&1)===1};c.prototype.isOdd=function(){return(this.value&g(1))===g(1)};a.prototype.isPositive=function(){return!this.sign};b.prototype.isPositive=function(){return this.value>0};c.prototype.isPositive=b.prototype.isPositive;a.prototype.isNegative=function(){return this.sign};b.prototype.isNegative=function(){return this.value<0};c.prototype.isNegative=b.prototype.isNegative;a.prototype.isUnit=function(){return false};b.prototype.isUnit=function(){return Math.abs(this.value)===1};c.prototype.isUnit=function(){return this.abs().value===g(1)};a.prototype.isZero=function(){return false};b.prototype.isZero=function(){return this.value===0};c.prototype.isZero=function(){return this.value===g(0)};a.prototype.isDivisibleBy=function(b){var a=e(b);if(a.isZero())return false;if(a.isUnit())return true;if(a.compareAbs(2)===0)return this.isEven();return this.mod(a).isZero()};c.prototype.isDivisibleBy=b.prototype.isDivisibleBy=a.prototype.isDivisibleBy;function -S(b){var +U(b){var a=b.abs();if(a.isUnit())return false;if(a.equals(2)||a.equals(3)||a.equals(5))return true;if(a.isEven()||a.isDivisibleBy(3)||a.isDivisibleBy(5))return false;if(a.lesser(49))return true}function -K(d,e){var -g=d.prev(),c=g,h=0,f,i,b,a;while(c.isEven())c=c.divide(2),h++;next:for(b=0;b-u)return new b(c-1);return new -a(I,true)};c.prototype.prev=function(){return new +a(J,true)};c.prototype.prev=function(){return new c(this.value-g(1))};var h=[1];while(2*h[h.length-1]<=f)h.push(2*h[h.length-1]);var x=h.length,j=h[x-1];function -Z(a){return Math.abs(a)<=f}a.prototype.shiftLeft=function(c){var -a=e(c).toJSNumber();if(!Z(a))throw new -Error(String(a)+jn);if(a<0)return this.shiftRight(-a);var +_(a){return Math.abs(a)<=f}a.prototype.shiftLeft=function(c){var +a=e(c).toJSNumber();if(!_(a))throw new +Error(String(a)+it);if(a<0)return this.shiftRight(-a);var b=this;if(b.isZero())return b;while(a>=x){b=b.multiply(j);a-=x-1}return b.multiply(h[a])};c.prototype.shiftLeft=b.prototype.shiftLeft=a.prototype.shiftLeft;a.prototype.shiftRight=function(d){var -a,b=e(d).toJSNumber();if(!Z(b))throw new -Error(String(b)+jn);if(b<0)return this.shiftLeft(-b);var +a,b=e(d).toJSNumber();if(!_(b))throw new +Error(String(b)+it);if(b<0)return this.shiftLeft(-b);var c=this;while(b>=x){if(c.isZero()||c.isNegative()&&c.isUnit())return c;a=i(c,j);c=a[1].isNegative()?a[0].prev():a[0];b-=x-1}a=i(c,h[b]);return a[1].isNegative()?a[0].prev():a[0]};c.prototype.shiftRight=b.prototype.shiftRight=a.prototype.shiftRight;function -J(h,a,q){a=e(a);var -m=h.isNegative(),p=a.isNegative(),l=m?h.not():h,o=p?a.not():a,b=0,c=0,k=null,n=null,f=[];while(!l.isZero()||!o.isZero()){k=i(l,j);b=k[1].toJSNumber();if(m)b=j-1-b;n=i(o,j);c=n[1].toJSNumber();if(p)c=j-1-c;l=k[0];o=n[0];f.push(q(b,c))}var -g=q(m?1:0,p?1:0)!==0?r(-1):r(0);for(var -d=f.length-1;d>=0;d-=1)g=g.multiply(j).add(r(f[d]));return g}a.prototype.not=function(){return this.negate().prev()};c.prototype.not=b.prototype.not=a.prototype.not;a.prototype.and=function(a){return J(this,a,function(a,b){return a&b})};c.prototype.and=b.prototype.and=a.prototype.and;a.prototype.or=function(a){return J(this,a,function(a,b){return a|b})};c.prototype.or=b.prototype.or=a.prototype.or;a.prototype.xor=function(a){return J(this,a,function(a,b){return a^b})};c.prototype.xor=b.prototype.xor=a.prototype.xor;var -H=1<<30,aa=(f&-f)*(f&-f)|H;function -E(c){var +K(h,a,r){a=e(a);var +m=h.isNegative(),p=a.isNegative(),l=m?h.not():h,o=p?a.not():a,b=0,c=0,k=null,n=null,f=[];while(!l.isZero()||!o.isZero()){k=i(l,j);b=k[1].toJSNumber();if(m)b=j-1-b;n=i(o,j);c=n[1].toJSNumber();if(p)c=j-1-c;l=k[0];o=n[0];f.push(r(b,c))}var +g=r(m?1:0,p?1:0)!==0?q(-1):q(0);for(var +d=f.length-1;d>=0;d-=1)g=g.multiply(j).add(q(f[d]));return g}a.prototype.not=function(){return this.negate().prev()};c.prototype.not=b.prototype.not=a.prototype.not;a.prototype.and=function(a){return K(this,a,function(a,b){return a&b})};c.prototype.and=b.prototype.and=a.prototype.and;a.prototype.or=function(a){return K(this,a,function(a,b){return a|b})};c.prototype.or=b.prototype.or=a.prototype.or;a.prototype.xor=function(a){return K(this,a,function(a,b){return a^b})};c.prototype.xor=b.prototype.xor=a.prototype.xor;var +I=1<<30,ab=(f&-f)*(f&-f)|I;function +F(c){var a=c.value,b=typeof -a==="number"?a|H:typeof -a==="bigint"?a|g(H):a[0]+a[1]*f|aa;return b&-b}function -R(b,a){if(a.compareTo(b)<=0){var -f=R(b,a.square(a)),d=f.p,c=f.e,e=d.multiply(a);return e.compareTo(b)<=0?{p:e,e:c*2+1}:{p:d,e:c*2}}return{p:r(1),e:0}}a.prototype.bitLength=function(){var -a=this;if(a.compareTo(r(0))<0)a=a.negate().subtract(r(1));if(a.compareTo(r(0))===0)return r(0);return r(R(a,r(2)).e).add(r(1))};c.prototype.bitLength=b.prototype.bitLength=a.prototype.bitLength;function -T(a,b){a=e(a);b=e(b);return a.greater(b)?a:b}function -L(a,b){a=e(a);b=e(b);return a.lesser(b)?a:b}function -Q(a,b){a=e(a).abs();b=e(b).abs();if(a.equals(b))return a;if(a.isZero())return b;if(b.isZero())return a;var -c=d[1],f,g;while(a.isEven()&&b.isEven()){f=L(E(a),E(b));a=a.divide(f);b=b.divide(f);c=c.multiply(f)}while(a.isEven())a=a.divide(E(a));do{while(b.isEven())b=b.divide(E(b));if(a.greater(b)){g=b;b=a;a=g}b=b.subtract(a)}while(!b.isZero());return c.isUnit()?a:a.multiply(c)}function -ae(a,b){a=e(a).abs();b=e(b).abs();return a.divide(Q(a,b)).multiply(b)}function -ah(a,b){a=e(a);b=e(b);var -g=L(a,b),n=T(a,b),h=n.subtract(g).add(1);if(h.isSmall)return g.add(Math.floor(Math.random()*h));var +a==="number"?a|I:typeof +a==="bigint"?a|g(I):a[0]+a[1]*f|ab;return b&-b}function +S(b,a){if(a.compareTo(b)<=0){var +f=S(b,a.square(a)),d=f.p,c=f.e,e=d.multiply(a);return e.compareTo(b)<=0?{p:e,e:c*2+1}:{p:d,e:c*2}}return{p:q(1),e:0}}a.prototype.bitLength=function(){var +a=this;if(a.compareTo(q(0))<0)a=a.negate().subtract(q(1));if(a.compareTo(q(0))===0)return q(0);return q(S(a,q(2)).e).add(q(1))};c.prototype.bitLength=b.prototype.bitLength=a.prototype.bitLength;function +V(a,b){a=e(a);b=e(b);return a.greater(b)?a:b}function +M(a,b){a=e(a);b=e(b);return a.lesser(b)?a:b}function +R(a,b){a=e(a).abs();b=e(b).abs();if(a.equals(b))return a;if(a.isZero())return b;if(b.isZero())return a;var +c=d[1],f,g;while(a.isEven()&&b.isEven()){f=M(F(a),F(b));a=a.divide(f);b=b.divide(f);c=c.multiply(f)}while(a.isEven())a=a.divide(F(a));do{while(b.isEven())b=b.divide(F(b));if(a.greater(b)){g=b;b=a;a=g}b=b.subtract(a)}while(!b.isZero());return c.isUnit()?a:a.multiply(c)}function +af(a,b){a=e(a).abs();b=e(b).abs();return a.divide(R(a,b)).multiply(b)}function +ai(a,b){a=e(a);b=e(b);var +g=M(a,b),n=V(a,b),h=n.subtract(g).add(1);if(h.isSmall)return g.add(Math.floor(Math.random()*h));var j=z(h,f).value,l=[],k=true;for(var c=0;c=i){if(c===U&&i===1)continue;throw new -Error(c+" is not a valid digit in base "+g+bf)}}g=e(g);var -h=[],j=b[0]===az;for(a=j?1:0;a=i){if(c===T&&i===1)continue;throw new +Error(c+" is not a valid digit in base "+g+bu)}}g=e(g);var +h=[],j=b[0]===aA;for(a=j?1:0;a=0;a--){b=b.add(e[a].times(c));c=c.times(f)}return g?b.negate():b}function -ai(b,a){a=a||N;if(b=0){e=c.divmod(b);c=e.quotient;var d=e.remainder;if(d.isNegative()){d=b.minus(d).abs();c=c.next()}g.push(d.toJSNumber())}g.push(c.toJSNumber());return{value:g.reverse(),isNegative:f}}function -$(d,c,b){var -a=z(d,c);return(a.isNegative?az:p)+a.value.map(function(a){return ai(a,b)}).join(p)}a.prototype.toArray=function(a){return z(this,a)};b.prototype.toArray=function(a){return z(this,a)};c.prototype.toArray=function(a){return z(this,a)};a.prototype.toString=function(a,f){if(a===A)a=10;if(a!==10)return $(this,a,f);var +aa(d,c,b){var +a=z(d,c);return(a.isNegative?aA:t)+a.value.map(function(a){return aj(a,b)}).join(t)}a.prototype.toArray=function(a){return z(this,a)};b.prototype.toArray=function(a){return z(this,a)};c.prototype.toArray=function(a){return z(this,a)};a.prototype.toString=function(a,f){if(a===A)a=10;if(a!==10)return aa(this,a,f);var d=this.value,c=d.length,e=String(d[--c]),h="0000000",b;while(--c>=0){b=String(d[c]);e+=h.slice(b.length)+b}var -g=this.sign?az:p;return g+e};b.prototype.toString=function(a,b){if(a===A)a=10;if(a!=10)return $(this,a,b);return String(this.value)};c.prototype.toString=b.prototype.toString;c.prototype.toJSON=a.prototype.toJSON=b.prototype.toJSON=function(){return this.toString()};a.prototype.valueOf=function(){return parseInt(this.toString(),10)};a.prototype.toJSNumber=a.prototype.valueOf;b.prototype.valueOf=function(){return this.value};b.prototype.toJSNumber=b.prototype.valueOf;c.prototype.valueOf=c.prototype.toJSNumber=function(){return parseInt(this.toString(),10)};function -X(d){if(m(+d)){var -n=+d;if(n===t(n))return G?new +g=this.sign?aA:t;return g+e};b.prototype.toString=function(a,b){if(a===A)a=10;if(a!=10)return aa(this,a,b);return String(this.value)};c.prototype.toString=b.prototype.toString;c.prototype.toJSON=a.prototype.toJSON=b.prototype.toJSON=function(){return this.toString()};a.prototype.valueOf=function(){return parseInt(this.toString(),10)};a.prototype.toJSNumber=a.prototype.valueOf;b.prototype.valueOf=function(){return this.value};b.prototype.toJSNumber=b.prototype.valueOf;c.prototype.valueOf=c.prototype.toJSNumber=function(){return parseInt(this.toString(),10)};function +Y(d){if(m(+d)){var +n=+d;if(n===s(n))return H?new c(g(n)):new b(n);throw new -Error(eR+d)}var -q=d[0]===az;if(q)d=d.slice(1);var +Error(eA+d)}var +q=d[0]===aA;if(q)d=d.slice(1);var h=d.split(/e/i);if(h.length>2)throw new -Error(eR+h.join(eV));if(h.length===2){var -e=h[1];if(e[0]===bA)e=e.slice(1);e=+e;if(e!==t(e)||!m(e))throw new -Error(eR+e+" is not a valid exponent.");var -f=h[0],i=f.indexOf(bf);if(i>=0){e-=f.length-i-1;f=f.slice(0,i)+f.slice(i+1)}if(e<0)throw new +Error(eA+h.join(eD));if(h.length===2){var +e=h[1];if(e[0]===bs)e=e.slice(1);e=+e;if(e!==s(e)||!m(e))throw new +Error(eA+e+" is not a valid exponent.");var +f=h[0],i=f.indexOf(bu);if(i>=0){e-=f.length-i-1;f=f.slice(0,i)+f.slice(i+1)}if(e<0)throw new Error("Cannot include negative exponent part for integers");f+=new Array(e+1).join(k);d=f}var -r=/^([0-9][0-9]*)$/.test(d);if(!r)throw new -Error(eR+d);if(G)return new -c(g(q?az+d:d));var -p=[],j=d.length,o=ab,l=j-o;while(j>0){p.push(+d.slice(l,j));l-=o;if(l<0)l=0;j-=o}s(p);return new +t=/^([0-9][0-9]*)$/.test(d);if(!t)throw new +Error(eA+d);if(H)return new +c(g(q?aA+d:d));var +p=[],j=d.length,o=ac,l=j-o;while(j>0){p.push(+d.slice(l,j));l-=o;if(l<0)l=0;j-=o}r(p);return new a(p,q)}function -ag(a){if(G)return new -c(g(a));if(m(a)){if(a!==t(a))throw new +ah(a){if(H)return new +c(g(a));if(m(a)){if(a!==s(a))throw new Error(a+" is not an integer.");return new -b(a)}return X(a.toString())}function +b(a)}return Y(a.toString())}function e(a){if(typeof -a==="number")return ag(a);if(typeof -a==="string")return X(a);if(typeof +a==="number")return ah(a);if(typeof +a==="string")return Y(a);if(typeof a==="bigint")return new c(a);return a}for(var -l=0;l0)d[-l]=e(-l)}d.one=d[1];d.zero=d[0];d.minusOne=d[-1];d.max=T;d.min=L;d.gcd=Q;d.lcm=ae;d.isInstance=function(d){return d +l=0;l0)d[-l]=e(-l)}d.one=d[1];d.zero=d[0];d.minusOne=d[-1];d.max=V;d.min=M;d.gcd=R;d.lcm=af;d.isInstance=function(d){return d instanceof a||d instanceof b||d instanceof -c};d.randBetween=ah;d.fromArray=function(b,a,c){return W(b.map(e),e(a||10),c)};return d}();function -aG(a){var -b=a.toJSNumber()|0;if(a.equals(r(b)))return b;return a}function -mv(a){return aG(r(a).abs())}function -mw(a,b){return aG(r(a).add(r(b)))}function -ch(a,b){return r(a).compare(r(b))}function -mx(b,a){a=r(a);if(a.equals(r(0)))cO();return aG(r(b).divide(r(a)))}function -GT(b,a){a=r(a);if(a.equals(r(0)))cO();return aG(r(b).mod(a))}function -my(a,b){return[0,mx(a,b),GT(a,b)]}function -mz(a,b){return mx(a,b)}function -GJ(a,b){return r(a).equals(r(b))}function -GL(a,b){return aG(r.gcd(r(a),r(b)).abs())}function -Gz(c,e,g){e=r(e);var +c};d.randBetween=ai;d.fromArray=function(b,a,c){return X(b.map(e),e(a||10),c)};return d}();function +aF(a){var +b=a.toJSNumber()|0;if(a.equals(q(b)))return b;return a}function +kK(a){return aF(q(a).abs())}function +kL(a,b){return aF(q(a).add(q(b)))}function +b$(a,b){return q(a).compare(q(b))}function +kM(b,a){a=q(a);if(a.equals(q(0)))cG();return aF(q(b).divide(q(a)))}function +Ev(b,a){a=q(a);if(a.equals(q(0)))cG();return aF(q(b).mod(a))}function +kN(a,b){return[0,kM(a,b),Ev(a,b)]}function +kO(a,b){return kM(a,b)}function +El(a,b){return q(a).equals(q(b))}function +En(a,b){return aF(q.gcd(q(a),q(b)).abs())}function +Ed(c,e,g){e=q(e);var a=e.toArray(Math.pow(2,32));c.write(8,a.isNegative?1:0);var f=a.value.length,d=f*4;c.write(32,d);for(var -b=f-1;b>=0;b--){c.write(8,a.value[b]>>>0&aU);c.write(8,a.value[b]>>>8&aU);c.write(8,a.value[b]>>>16&aU);c.write(8,a.value[b]>>>24&aU)}g[0]=4*(1+((d+3)/4|0));g[1]=8*(1+((d+7)/8|0))}function -GA(b,g){var +b=f-1;b>=0;b--){c.write(8,a.value[b]>>>0&aQ);c.write(8,a.value[b]>>>8&aQ);c.write(8,a.value[b]>>>16&aQ);c.write(8,a.value[b]>>>24&aQ)}g[0]=4*(1+((d+3)/4|0));g[1]=8*(1+((d+7)/8|0))}function +Ee(b,g){var e;switch(b.read8u()){case 1:e=true;break;case -0:e=false;break;default:b5("input_value: z (malformed input)")}var -f=b.read32u(),c=r(0);for(var +0:e=false;break;default:b8("input_value: z (malformed input)")}var +f=b.read32u(),c=q(0);for(var d=0;d>>0);c=a.shiftLeft(d*32).add(c)}if(e)c=c.negate();g[0]=f+4;return aG(c)}function -GM(d){var -b=r(d).toArray(Math.pow(2,32)),a=0;for(var +a=q(b.read8u());a=a.add(b.read8u()<<8);a=a.add(b.read8u()<<16);a=a.add(b.read8u()<<24>>>0);c=a.shiftLeft(d*32).add(c)}if(e)c=c.negate();g[0]=f+4;return aF(c)}function +Eo(d){var +b=q(d).toArray(Math.pow(2,32)),a=0;for(var c=0;c=48&&a<=57)return a-48;if(a>=97&&a<=cB)return a-97+10;if(a>=65&&a<=70)return a-65+10}var -e=0;if(a[e]==az)e++;for(;e=c)ad("Z.of_substring_base: invalid digit")}return aG(r(a,c))}function -ci(d,a,b,c){a=bp(a);if(b!=0||c!=a.length){if(a.length-b=0?1:0}function -e_(a){a=r(a);if(!GK(a))e6(bK(gk));var -b=r(kf),d=a.and(b).toJSNumber(),c=a.shiftRight(32).and(b).toJSNumber(),e=mh(d,c);return e}function -e$(){return new -Date().getTime()/a0}function -cS(e){var +if(d==jY||d=="X")c=16;else +if(d=="b"||d=="B")c=2;if(c!=10){a=a.substring(b+1);if(g==-1)a=aA+a}}}}if(a[0]==bs)a=a.substring(1);a=a.replace(/^0+/,t);if(a==aA||a==t)a=k;function +h(a){if(a>=48&&a<=57)return a-48;if(a>=97&&a<=ct)return a-97+10;if(a>=65&&a<=70)return a-65+10}var +e=0;if(a[e]==aA)e++;for(;e=c)ac("Z.of_substring_base: invalid digit")}return aF(q(a,c))}function +ca(d,a,b,c){a=a4(a);if(b!=0||c!=a.length){if(a.length-b=0?1:0}function +eT(a){a=q(a);if(!Em(a))eP(eO(fX));var +b=q(i4),d=a.and(b).toJSNumber(),c=a.shiftRight(32).and(b).toJSNumber(),e=kA(d,c);return e}function +eU(){return new +Date().getTime()/aW}function +cK(e){var a=new -Date(e*a0),b=a.getTime(),d=new -Date(Date.UTC(a.getUTCFullYear(),0,1)).getTime(),c=Math.floor((b-d)/iZ);return[0,a.getUTCSeconds(),a.getUTCMinutes(),a.getUTCHours(),a.getUTCDate(),a.getUTCMonth(),a.getUTCFullYear()-bY,a.getUTCDay(),c,false|0]}function -fa(){return 0}function -GY(h){var +Date(e*aW),b=a.getTime(),d=new +Date(Date.UTC(a.getUTCFullYear(),0,1)).getTime(),c=Math.floor((b-d)/ia);return[0,a.getUTCSeconds(),a.getUTCMinutes(),a.getUTCHours(),a.getUTCDate(),a.getUTCMonth(),a.getUTCFullYear()-bU,a.getUTCDay(),c,false|0]}function +eV(){return 0}function +Ez(h){var a=new -Date(h*a0),b=a.getTime(),e=new -Date(a.getFullYear(),0,1).getTime(),c=Math.floor((b-e)/iZ),d=new +Date(h*aW),b=a.getTime(),e=new +Date(a.getFullYear(),0,1).getTime(),c=Math.floor((b-e)/ia),d=new Date(a.getFullYear(),0,1),f=new -Date(a.getFullYear(),6,1),g=Math.max(d.getTimezoneOffset(),f.getTimezoneOffset());return[0,a.getSeconds(),a.getMinutes(),a.getHours(),a.getDate(),a.getMonth(),a.getFullYear()-bY,a.getDay(),c,a.getTimezoneOffset()f)a+=eL;var -c=e[d];if(typeof -c=="number")a+=c.toString();else -if(c -instanceof -bn)a+=eA+c.toString()+eA;else -if(typeof -c=="string")a+=eA+c.toString()+eA;else -a+=la}a+=")"}else -if(b[0]==I)a+=b[1];return a}function -md(a){if(a -instanceof -Array&&(a[0]==0||a[0]==I)){var -c=bK(kC);if(c)c(a,false);else{var -d=FS(a),b=bK(iA);if(b)b(0);u.console.error(gC+d+iO)}}else -throw a}function -Gs(){var -a=u;if(a.process&&a.process.on)a.process.on("uncaughtException",function(b,c){md(b);a.process.exit(2)});else -if(a.addEventListener)a.addEventListener("error",function(a){if(a.error)md(a.error)})}Gs();function -d(a,b){return a.length==1?a(b):a8(a,[b])}function -g(a,b,c){return a.length==2?a(b,c):a8(a,[b,c])}function -P(a,b,c,d){return a.length==3?a(b,c,d):a8(a,[b,c,d])}function -f9(a,b,c,d,e,f){return a.length==5?a(b,c,d,e,f):a8(a,[b,c,d,e,f])}function -FF(a,b,c,d,e,f,g,h){return a.length==7?a(b,c,d,e,f,g,h):a8(a,[b,c,d,e,f,g,h])}FT();var -fc=[I,a(kg),-1],ha=[I,a(kD),-2],dM=[I,a(gv),-3],g8=[I,a(k$),-4],hb=[I,a(jO),-6],aH=[I,a(lf),-7],g_=[I,a(iY),-8],g$=[I,a(li),-9],F=[I,a(lC),-11],hc=[I,a(kq),gu],FE=[4,0,0,0,[12,45,[4,0,0,0,0]]],fn=[0,[11,a('File "'),[2,0,[11,a('", line '),[4,0,0,0,[11,a(kU),[4,0,0,0,[12,45,[4,0,0,0,[11,a(": "),[2,0,0]]]]]]]]]],a('File "%s", line %d, characters %d-%d: %s')],cr=[0,0,0],ej=[0,a(kZ),a(kS),a(lj)];a4(11,hc,kq);a4(10,F,lC);a4(9,[I,a(jj),-10],jj);a4(8,g$,li);a4(7,g_,iY);a4(6,aH,lf);a4(5,hb,jO);a4(4,[I,a(kH),-5],kH);a4(3,g8,k$);a4(2,dM,gv);a4(1,ha,kD);a4(0,fc,kg);var -mT=a("output_substring"),mQ=a("%.12g"),mP=a(bf),mN=a("true"),mO=a("false"),mE=a("Stdlib.Exit"),mG=b6(0,0,ld),mI=b6(0,0,65520),mK=b6(1,0,ld),mW=a("\\\\"),mX=a("\\'"),mY=a("\\b"),mZ=a("\\t"),m0=a("\\n"),m1=a("\\r"),mV=a("Char.chr"),m2=a("hd"),m5=a("String.blit / Bytes.blit_string"),m4=a("Bytes.blit"),m3=a("String.sub / Bytes.sub"),m7=a("String.contains_from / Bytes.contains_from"),m_=a("Array.blit"),m9=a("Array.sub"),nd=a("Map.remove_min_elt"),ne=[0,0,0,0],nf=[0,a("map.ml"),gr,10],ng=[0,0,0],m$=a(er),na=a(er),nb=a(er),nc=a(er),nh=a("Stdlib.Queue.Empty"),nj=a("CamlinternalLazy.Undefined"),nq=a("Buffer.add_substring/add_subbytes"),np=a("Buffer.add: cannot grow buffer"),no=[0,a(lp),93,2],nn=[0,a(lp),94,2],nz=a("%c"),nA=a("%s"),nB=a(kp),nC=a(iW),nD=a(k9),nE=a(kz),nF=a("%f"),nG=a("%B"),nH=a("%{"),nI=a("%}"),nJ=a("%("),nK=a("%)"),nL=a("%a"),nM=a("%t"),nN=a("%?"),nO=a("%r"),nP=a("%_r"),nQ=[0,a(al),850,23],n1=[0,a(al),814,21],nT=[0,a(al),815,21],n2=[0,a(al),818,21],nU=[0,a(al),819,21],n3=[0,a(al),822,19],nV=[0,a(al),823,19],n4=[0,a(al),826,22],nW=[0,a(al),827,22],n5=[0,a(al),831,30],nX=[0,a(al),832,30],nZ=[0,a(al),836,26],nR=[0,a(al),837,26],n0=[0,a(al),846,28],nS=[0,a(al),847,28],nY=[0,a(al),851,23],o8=a(je),o6=[0,a(al),1558,4],o7=a("Printf: bad conversion %["),o9=[0,a(al),1626,39],o_=[0,a(al),1649,31],o$=[0,a(al),1650,31],pa=a("Printf: bad conversion %_"),pb=a(ja),pc=a(jl),pd=a(ja),pe=a(jl),o4=a(gx),o2=a("neg_infinity"),o3=a(lG),o1=a(bf),oW=[0,ca],oK=a("%+nd"),oL=a("% nd"),oN=a("%+ni"),oO=a("% ni"),oP=a("%nx"),oQ=a("%#nx"),oR=a("%nX"),oS=a("%#nX"),oT=a("%no"),oU=a("%#no"),oJ=a("%nd"),oM=a(k9),oV=a("%nu"),ox=a("%+ld"),oy=a("% ld"),oA=a("%+li"),oB=a("% li"),oC=a("%lx"),oD=a("%#lx"),oE=a("%lX"),oF=a("%#lX"),oG=a("%lo"),oH=a("%#lo"),ow=a("%ld"),oz=a(iW),oI=a("%lu"),ok=a("%+Ld"),ol=a("% Ld"),on=a("%+Li"),oo=a("% Li"),op=a("%Lx"),oq=a("%#Lx"),or=a("%LX"),os=a("%#LX"),ot=a("%Lo"),ou=a("%#Lo"),oj=a("%Ld"),om=a(kz),ov=a("%Lu"),n9=a("%+d"),n_=a("% d"),oa=a("%+i"),ob=a("% i"),oc=a("%x"),od=a("%#x"),oe=a("%X"),of=a("%#X"),og=a("%o"),oh=a("%#o"),n8=a(gF),n$=a(kp),oi=a(je),nr=a("@]"),ns=a("@}"),nt=a("@?"),nu=a("@\n"),nv=a("@."),nw=a("@@"),nx=a("@%"),ny=a("@"),n6=a("CamlinternalFormat.Type_mismatch"),pi=a(p),pj=[0,[11,a(eL),[2,0,[2,0,0]]],a(", %s%s")],pI=[0,[11,a(gC),[2,0,[12,10,0]]],a(lx)],pJ=[0,[11,a("Fatal error in uncaught exception handler: exception "),[2,0,[12,10,0]]],a("Fatal error in uncaught exception handler: exception %s\n")],pH=a("Fatal error: out of memory in uncaught exception handler"),pF=[0,[11,a(gC),[2,0,[12,10,0]]],a(lx)],pB=[0,[2,0,[12,10,0]],a("%s\n")],pt=a("Raised at"),pu=a("Re-raised at"),pv=a("Raised by primitive operation at"),pw=a("Called from"),px=a(" (inlined)"),pz=a(p),py=[0,[2,0,[12,32,[2,0,[11,a(' in file "'),[2,0,[12,34,[2,0,[11,a(", line "),[4,0,0,0,[11,a(kU),FE]]]]]]]]]],a('%s %s in file "%s"%s, line %d, characters %d-%d')],pA=[0,[2,0,[11,a(" unknown location"),0]],a("%s unknown location")],po=a("Out of memory"),pp=a("Stack overflow"),pq=a("Pattern matching failed"),pr=a("Assertion failed"),ps=a("Undefined recursive module"),pk=[0,[12,40,[2,0,[2,0,[12,41,0]]]],a("(%s%s)")],pl=a(p),pm=a(p),pn=[0,[12,40,[2,0,[12,41,0]]],a("(%s)")],ph=[0,[4,0,0,0,0],a(gF)],pf=[0,[3,0,0],a("%S")],pg=a(la),pC=[0,a(p),a("(Cannot print locations:\n bytecode executable program file not found)"),a("(Cannot print locations:\n bytecode executable program file appears to be corrupt)"),a("(Cannot print locations:\n bytecode executable program file has wrong magic number)"),a("(Cannot print locations:\n bytecode executable program file cannot be opened;\n -- too many open files. Try running with OCAMLRUNPARAM=b=2)")],pM=a("Fun.Finally_raised: "),pK=a("Stdlib.Fun.Finally_raised"),pN=a(ls),FC=a("OCAMLRUNPARAM"),FA=a("CAMLRUNPARAM"),pO=a(p),p$=[3,0,3],qa=a(bf),p6=a(eW),p7=a("<\/"),p8=a(p),p2=a(eW),p3=a(gn),p4=a(p),p0=a("\n"),pZ=[0,a(p)],pV=a(p),pW=a(p),pX=a(p),pY=a(p),pT=[0,a(p),0,a(p)],pS=a(p),pR=a("Stdlib.Format.String_tag"),qn=a(p),qs=a(js),qu=a(lV),qv=a(ki),qw=a(iN),qx=a(ke),qy=a(kP),qz=a(jH),qA=a(k3),qB=a(gd),qC=a(jK),qD=a(k2),qE=a(j9),qF=a(k4),qG=a(jG),qH=a(iz),qI=a(lY),qJ=a(iM),qK=a(iU),qL=a(j1),qM=a(kB),qN=a(eU),qO=a(i7),qP=a(lJ),qQ=a(k8),qR=a(lv),qS=a(kt),qT=a(eO),qU=a(gG),qV=a(i3),qW=a(i2),qX=a(jV),qY=a(lM),qZ=a(lH),q0=a(lQ),q1=a(jt),q2=a(iX),q3=a(jg),q4=a(kK),q5=a(lT),q6=a(j6),q7=a(jy),q8=a(kh),q9=a(iT),q_=a(j_),q$=a(iC),ra=a(k6),rb=a(lF),rc=a(jw),rd=a(i5),re=a(j4),rf=a(ku),rg=a(jN),rh=a(kF),ri=a(kd),rj=a(k5),rk=a(jJ),rl=a(ju),rm=a(lo),rn=a(kW),ro=a(lz),rp=a(kT),rq=a(kO),rr=a(kN),rs=a(iS),rt=a(jA),ru=a(jc),rv=a(lc),rw=a(lt),rx=[0,[11,a("EUNKNOWNERR "),[4,0,0,0,0]],a("EUNKNOWNERR %d")],qt=[0,[11,a("Unix.Unix_error(Unix."),[2,0,[11,a(eL),[3,0,[11,a(eL),[3,0,[12,41,0]]]]]]],a("Unix.Unix_error(Unix.%s, %S, %S)")],qo=a(dv),qp=a(p),qq=a(p),qr=a(dv),ry=a("0.0.0.0"),rz=a("127.0.0.1"),Fz=a("::"),Fy=a("::1"),rP=a(p),rQ=a(p),rW=[0,92],rY=a("\\( group not closed by \\)"),rX=[0,a(iF),gl,10],rZ=a("[ class not closed by ]"),r0=a("spurious \\) in regular expression"),rS=a("too many r* or r+ where r is nullable"),rT=a(p),rU=a(p),rR=[0,a(iF),213,11],r6=[0,a(kL),52,4],r5=[0,a(kL),58,34],r4=a("Not a valid time zone"),ug=a("Not a month"),ue=a("Not a day"),ub=a("from_business: bad week"),uc=a("from_business: bad date"),to=[0,a(kv),jM,4],tn=[0,a(kv),dB,4],tg=[0,-4713,12,31],th=[0,kY,1,23],ti=[0,dp,10,14],tj=[0,dp,10,5],te=a("Date.Out_of_bounds"),tf=a("Date.Undefined"),tE=a("Date.Period.Not_computable"),tN=[0,31,59,90,bT,f$,181,212,gE,273,304,334,eB],uk=[0,a(eQ),429,6],uj=[0,a(eQ),lm,4],ui=[0,a(eQ),167,6],uh=[0,a(eQ),67,4],uo=a("[a-zA-Z]+"),ut=b6(1,0,0),up=a("Z.Overflow"),uq=a(gk),ux=a(p),uy=a("+inf"),uz=a("-inf"),uA=a(lN),uB=a("undef"),uD=[0,a("q.ml"),486,25],uC=a("Q.of_string: invalid digit"),uv=a("impossible case"),uE=a("Runtime.EmptyError"),uF=a("Runtime.AssertionFailed"),uH=a("Runtime.ConflictError"),uJ=a("Runtime.ImpossibleDate"),uL=a("Runtime.NoValueProvided"),Ep=[0,0],Eq=[1,0],Er=[2,0],Eo=[0,a(dh),74,11,74,27,[0,a(ev),[0,a(de),[0,a(t),0]]]],Es=[0,a(a6),[0,a("enfants_\xc3\xa0_charge"),0]],EM=[0,a(dh),90,20,90,69,[0,a(ev),[0,a(de),[0,a(t),0]]]],Eu=[0,a(a6),[0,a("allocations_familiales.personne_charge_effective_permanente_est_parent"),0]],Et=[0,a(o),90,10,90,57,[0,a(n),0]],EL=[0,a(dh),93,20,93,74,[0,a(ev),[0,a(de),[0,a(t),0]]]],Ew=[0,a(a6),[0,a("allocations_familiales.personne_charge_effective_permanente_remplit_titre_I"),0]],Ev=[0,a(o),91,10,91,62,[0,a(n),0]],Ey=[0,a(a6),[0,a("allocations_familiales.ressources_m\xc3\xa9nage"),0]],Ex=[0,a(o),92,10,92,27,[0,a(n),0]],EA=[0,a(a6),[0,a("allocations_familiales.r\xc3\xa9sidence"),0]],Ez=[0,a(o),93,10,93,19,[0,a(n),0]],EC=[0,a(a6),[0,a("allocations_familiales.date_courante"),0]],EB=[0,a(o),96,10,96,23,[0,a(n),0]],EE=[0,a(a6),[0,a("allocations_familiales.enfants_\xc3\xa0_charge"),0]],ED=[0,a(o),99,10,99,26,[0,a(n),0]],EK=[0,a(dh),96,20,96,66,[0,a(ev),[0,a(de),[0,a(t),0]]]],EG=[0,a(a6),[0,a("allocations_familiales.avait_enfant_\xc3\xa0_charge_avant_1er_janvier_2012"),0]],EF=[0,a(o),bT,10,bT,54,[0,a(n),0]],EH=[0,a(a6),[0,a(iQ),[0,a(f),0]]],EI=[0,a(a6),[0,a(iQ),[0,a(f),0]]],EJ=[0,a(a6),[0,a("i_montant_vers\xc3\xa9"),0]],DS=[0,a(f),[0,a(dl),[0,a(aw),0]]],DT=[0,a(f),[0,a(dl),0]],DU=[0,a(f),[0,a(dl),[0,a(ay),0]]],DV=[0,a(f),[0,a(dl),0]],DC=[0,a(f),[0,a(bE),[0,a(aw),0]]],DD=[0,a(f),[0,a(bE),0]],DE=[0,a(f),[0,a(bE),[0,a(ay),0]]],DF=[0,a(f),[0,a(bE),0]],DG=a(cz),DL=a(kl),DM=a(du),DH=[0,a(f),[0,a(dg),[0,a(aw),0]]],DI=[0,a(f),[0,a(dg),0]],DJ=[0,a(f),[0,a(dg),[0,a(ay),0]]],DK=[0,a(f),[0,a(dg),0]],DB=[0,a(o),ka,11,ka,49,[0,a(n),0]],Dt=a(a1),Du=[0,a(ao),272,5,274,41,[0,a(ds),[0,a(L),[0,a(N),[0,a(H),[0,a(am),[0,a(B),0]]]]]]],Dv=a(a1),Dw=a(cz),Dx=a(a1),Do=a(a1),Dp=[0,a(ao),262,5,kb,42,[0,a(ds),[0,a(L),[0,a(N),[0,a(H),[0,a(am),[0,a(B),0]]]]]]],Dq=a(a1),Dr=a(cz),Ds=a(a1),Dn=[0,a(o),eD,11,eD,52,[0,a(n),0]],Dm=a(k),Dc=[0,a(f),[0,a(V),[0,a(aw),0]]],Dd=[0,a(f),[0,a(V),0]],De=[0,a(f),[0,a(V),[0,a(ay),0]]],Df=[0,a(f),[0,a(V),0]],Dg=a(U),Dh=a(gc),Di=[0,a(ao),382,5,385,23,[0,a(eT),[0,a(bZ),[0,a(df),[0,a(bG),[0,a(am),[0,a(B),0]]]]]]],Dj=a("0.0567"),C5=[0,a(f),[0,a(V),[0,a(aw),0]]],C6=[0,a(f),[0,a(V),0]],C7=[0,a(f),[0,a(V),[0,a(ay),0]]],C8=[0,a(f),[0,a(V),0]],C9=a(U),C_=a("11"),C$=a(gc),Da=[0,a(ao),373,5,376,42,[0,a(eT),[0,a(bZ),[0,a(df),[0,a(bG),[0,a(am),[0,a(B),0]]]]]]],Db=a("0.0369"),C4=[0,a(o),ek,11,ek,37,[0,a(n),0]],C0=[0,a(f),[0,a(dm),[0,a(aw),0]]],C1=[0,a(f),[0,a(dm),0]],C2=[0,a(f),[0,a(dm),[0,a(ay),0]]],C3=[0,a(f),[0,a(dm),0]],CZ=[0,a(o),ek,11,ek,37,[0,a(n),0]],CW=[8,0],CX=[0,a(v),lq,5,lq,24,[0,a(kA),[0,a(J),[0,a(K),[0,a(t),0]]]]],CU=a(U),CV=[0,a(ao),350,5,351,69,[0,a(eT),[0,a(bZ),[0,a(df),[0,a(bG),[0,a(am),[0,a(B),0]]]]]]],CT=[0,a(o),ew,11,ew,31,[0,a(n),0]],CM=[0,a(f),[0,a(dr),[0,a(aw),0]]],CN=[0,a(f),[0,a(dr),0]],CO=[0,a(f),[0,a(dr),[0,a(ay),0]]],CP=[0,a(f),[0,a(dr),0]],CQ=a(U),CD=[0,a(f),[0,a(V),[0,a(aw),0]]],CE=[0,a(f),[0,a(V),0]],CF=[0,a(f),[0,a(V),[0,a(ay),0]]],CG=[0,a(f),[0,a(V),0]],CH=[0,a(dh),27,5,27,44,[0,a("R\xc3\xa8gles diverses"),[0,a(de),[0,a(t),0]]]],CI=a(k),Cx=[0,a(f),[0,a(V),[0,a(aw),0]]],Cy=[0,a(f),[0,a(V),0]],Cz=[0,a(f),[0,a(V),[0,a(ay),0]]],CA=[0,a(f),[0,a(V),0]],CB=[0,a(ao),eN,3,eN,41,[0,a(a7),[0,a(L),[0,a(N),[0,a(H),[0,a(am),[0,a(B),0]]]]]]],CC=a("0.04"),Cr=[0,a(f),[0,a(V),[0,a(aw),0]]],Cs=[0,a(f),[0,a(V),0]],Ct=[0,a(f),[0,a(V),[0,a(ay),0]]],Cu=[0,a(f),[0,a(V),0]],Cv=[0,a(ao),95,3,96,44,[0,a(a7),[0,a(L),[0,a(N),[0,a(H),[0,a(am),[0,a(B),0]]]]]]],Cw=a(jm),Cl=[0,a(f),[0,a(V),[0,a(aw),0]]],Cm=[0,a(f),[0,a(V),0]],Cn=[0,a(f),[0,a(V),[0,a(ay),0]]],Co=[0,a(f),[0,a(V),0]],Cp=[0,a(ao),55,3,55,41,[0,a(a7),[0,a(L),[0,a(N),[0,a(H),[0,a(am),[0,a(B),0]]]]]]],Cq=a(f_),Ck=[0,a(o),eP,11,eP,47,[0,a(n),0]],Cj=[0,a(o),eP,11,eP,47,[0,a(n),0]],Ca=[0,a(ao),cH,3,cH,41,[0,a(a7),[0,a(L),[0,a(N),[0,a(H),[0,a(am),[0,a(B),0]]]]]]],Cb=a(U),Cc=a(jm),Cd=a(k),B8=[0,a(ao),74,3,75,44,[0,a(a7),[0,a(L),[0,a(N),[0,a(H),[0,a(am),[0,a(B),0]]]]]]],B9=a(U),B_=a(f_),B$=a(k),B4=[0,a(ao),35,3,35,41,[0,a(a7),[0,a(L),[0,a(N),[0,a(H),[0,a(am),[0,a(B),0]]]]]]],B5=a(U),B6=a(lA),B7=a(k),B3=[0,a(o),dA,11,dA,47,[0,a(n),0]],BW=[0,a(ao),cH,3,cH,41,[0,a(a7),[0,a(L),[0,a(N),[0,a(H),[0,a(am),[0,a(B),0]]]]]]],BX=a(ax),BY=a(ax),BZ=a("0.1025"),B0=a(k),BR=[0,a(ao),74,3,75,44,[0,a(a7),[0,a(L),[0,a(N),[0,a(H),[0,a(am),[0,a(B),0]]]]]]],BS=a(ax),BT=a(ax),BU=a("0.205"),BV=a(k),BM=[0,a(ao),35,3,35,41,[0,a(a7),[0,a(L),[0,a(N),[0,a(H),[0,a(am),[0,a(B),0]]]]]]],BN=a(ax),BO=a(ax),BP=a("0.41"),BQ=a(k),BL=[0,a(o),dz,11,dz,56,[0,a(n),0]],BH=[0,a(ao),gE,5,gE,43,[0,a(ds),[0,a(L),[0,a(N),[0,a(H),[0,a(am),[0,a(B),0]]]]]]],BI=a("0.0559"),BF=[0,a(ao),229,5,lm,46,[0,a(ds),[0,a(L),[0,a(N),[0,a(H),[0,a(am),[0,a(B),0]]]]]]],BG=a("0.1117"),BD=[0,a(ao),jq,5,jq,43,[0,a(ds),[0,a(L),[0,a(N),[0,a(H),[0,a(am),[0,a(B),0]]]]]]],BE=a("0.20234"),BC=[0,a(o),bH,11,bH,47,[0,a(n),0]],Bv=a(a1),Bw=[0,a(ao),170,5,171,68,[0,a(a7),[0,a(L),[0,a(N),[0,a(H),[0,a(am),[0,a(B),0]]]]]]],Bx=a(a1),By=a(cz),Bz=a(a1),Bq=a(a1),Br=[0,a(ao),162,5,163,68,[0,a(a7),[0,a(L),[0,a(N),[0,a(H),[0,a(am),[0,a(B),0]]]]]]],Bs=a(a1),Bt=a(cz),Bu=a(a1),Bp=[0,a(o),eu,11,eu,31,[0,a(n),0]],Bo=a(k),Bn=[0,a(o),eu,11,eu,31,[0,a(n),0]],Bh=[0,a(f),[0,a(bg),[0,a(aw),0]]],Bi=[0,a(f),[0,a(bg),0]],Bj=[0,a(f),[0,a(bg),[0,a(ay),0]]],Bk=[0,a(f),[0,a(bg),0]],Bl=[0,a(ah),313,5,lu,58,[0,a(lw),[0,a(L),[0,a(N),[0,a(H),[0,a(ag),[0,a(B),0]]]]]]],A_=[0,a(f),[0,a(dw),[0,a(aw),0]]],A$=[0,a(f),[0,a(dw),0]],Ba=[0,a(f),[0,a(dw),[0,a(ay),0]]],Bb=[0,a(f),[0,a(dw),0]],Bc=[0,a(f),[0,a(bg),[0,a(aw),0]]],Bd=[0,a(f),[0,a(bg),0]],Be=[0,a(f),[0,a(bg),[0,a(ay),0]]],Bf=[0,a(f),[0,a(bg),0]],Bg=[0,a(ah),299,5,300,58,[0,a(lw),[0,a(L),[0,a(N),[0,a(H),[0,a(ag),[0,a(B),0]]]]]]],A9=[0,a(o),eN,11,eN,34,[0,a(n),0]],Ee=[8,0],Ef=a(U),Eg=[0,a(v),344,5,345,72,[0,a(kA),[0,a(J),[0,a(K),[0,a(t),0]]]]],Ec=a(U),Ed=[0,a(ah),406,5,407,72,[0,a(go),[0,a(bZ),[0,a(eJ),[0,a(bG),[0,a(ag),[0,a(B),0]]]]]]],Eb=[0,a(o),eI,11,eI,28,[0,a(n),0]],D$=a(ax),Ea=[0,a(ah),ex,5,ex,70,[0,a(l0),[0,a(L),[0,a(N),[0,a(H),[0,a(ag),[0,a(B),0]]]]]]],AW=[0,a(f),[0,a(bE),[0,a(aw),0]]],AX=[0,a(f),[0,a(bE),0]],AY=[0,a(f),[0,a(bE),[0,a(ay),0]]],AZ=[0,a(f),[0,a(bE),0]],A0=a(cz),A1=a(kl),A2=a(du),AN=[0,a(v),lS,5,lS,49,[0,a(M),[0,a(J),[0,a(K),[0,a(t),0]]]]],AO=a(k),AP=a("5728"),AQ=a(k),AJ=[0,a(v),497,5,498,53,[0,a(M),[0,a(J),[0,a(K),[0,a(t),0]]]]],AK=a(k),AL=a("0.0717"),AM=a(k),AF=[0,a(v),489,5,490,53,[0,a(M),[0,a(J),[0,a(K),[0,a(t),0]]]]],AG=a(k),AH=a("0.0847"),AI=a(k),AB=[0,a(v),481,5,482,53,[0,a(M),[0,a(J),[0,a(K),[0,a(t),0]]]]],AC=a(k),AD=a("0.0976"),AE=a(k),Ax=[0,a(v),473,5,474,53,[0,a(M),[0,a(J),[0,a(K),[0,a(t),0]]]]],Ay=a(k),Az=a("0.115"),AA=a(k),At=[0,a(v),465,5,466,53,[0,a(M),[0,a(J),[0,a(K),[0,a(t),0]]]]],Au=a(k),Av=a("0.1163"),Aw=a(k),Ap=[0,a(v),457,5,458,53,[0,a(M),[0,a(J),[0,a(K),[0,a(t),0]]]]],Aq=a(k),Ar=a("0.122"),As=a(k),Al=[0,a(v),449,5,450,53,[0,a(M),[0,a(J),[0,a(K),[0,a(t),0]]]]],Am=a(k),An=a("0.1278"),Ao=a(k),Ah=[0,a(v),441,5,442,53,[0,a(M),[0,a(J),[0,a(K),[0,a(t),0]]]]],Ai=a(k),Aj=a("0.1335"),Ak=a(k),Ad=[0,a(v),433,5,434,53,[0,a(M),[0,a(J),[0,a(K),[0,a(t),0]]]]],Ae=a(k),Af=a("0.1393"),Ag=a(k),z$=[0,a(v),425,5,jp,53,[0,a(M),[0,a(J),[0,a(K),[0,a(t),0]]]]],Aa=a(k),Ab=a("0.145"),Ac=a(k),z_=[0,a(o),em,11,em,54,[0,a(n),0]],z7=a(k),z8=a(jh),z9=a(k),z1=[0,a(v),j5,5,j5,69,[0,a(M),[0,a(J),[0,a(K),[0,a(t),0]]]]],z2=a(U),z3=a("0.3068"),z4=a(k),zX=[0,a(v),jr,5,jr,69,[0,a(M),[0,a(J),[0,a(K),[0,a(t),0]]]]],zY=a(U),zZ=a("0.2936"),z0=a(k),zT=[0,a(v),jQ,5,jQ,69,[0,a(M),[0,a(J),[0,a(K),[0,a(t),0]]]]],zU=a(U),zV=a("0.284"),zW=a(k),zP=[0,a(v),k0,5,k0,69,[0,a(M),[0,a(J),[0,a(K),[0,a(t),0]]]]],zQ=a(U),zR=a("0.2672"),zS=a(k),zL=[0,a(v),ji,5,ji,69,[0,a(M),[0,a(J),[0,a(K),[0,a(t),0]]]]],zM=a(U),zN=a("0.273"),zO=a(k),zH=[0,a(v),jZ,5,jZ,69,[0,a(M),[0,a(J),[0,a(K),[0,a(t),0]]]]],zI=a(U),zJ=a("0.2555"),zK=a(k),zD=[0,a(v),jR,5,jR,69,[0,a(M),[0,a(J),[0,a(K),[0,a(t),0]]]]],zE=a(U),zF=a("0.2496"),zG=a(k),zz=[0,a(v),ln,5,ln,69,[0,a(M),[0,a(J),[0,a(K),[0,a(t),0]]]]],zA=a(U),zB=a("0.2437"),zC=a(k),zv=[0,a(v),gl,5,gl,69,[0,a(M),[0,a(J),[0,a(K),[0,a(t),0]]]]],zw=a(U),zx=a("0.2379"),zy=a(k),zr=[0,a(v),kM,5,kM,69,[0,a(M),[0,a(J),[0,a(K),[0,a(t),0]]]]],zs=a(U),zt=a("0.232"),zu=a(k),zq=[0,a(o),dB,11,dB,55,[0,a(n),0]],zn=a(U),zo=a(lA),zp=a(k),zh=[0,a(v),lr,5,lr,69,[0,a(M),[0,a(J),[0,a(K),[0,a(t),0]]]]],zi=a(ax),zj=a("0.143"),zk=a(k),zd=[0,a(v),ko,5,ko,69,[0,a(M),[0,a(J),[0,a(K),[0,a(t),0]]]]],ze=a(ax),zf=a("0.1259"),zg=a(k),y$=[0,a(v),kj,5,kj,69,[0,a(M),[0,a(J),[0,a(K),[0,a(t),0]]]]],za=a(ax),zb=a("0.1089"),zc=a(k),y7=[0,a(v),iD,5,iD,69,[0,a(M),[0,a(J),[0,a(K),[0,a(t),0]]]]],y8=a(ax),y9=a("0.0918"),y_=a(k),y3=[0,a(v),lI,5,lI,69,[0,a(M),[0,a(J),[0,a(K),[0,a(t),0]]]]],y4=a(ax),y5=a("0.0842"),y6=a(k),yZ=[0,a(v),lP,5,lP,69,[0,a(M),[0,a(J),[0,a(K),[0,a(t),0]]]]],y0=a(ax),y1=a("0.0766"),y2=a(k),yV=[0,a(v),lE,5,lE,69,[0,a(M),[0,a(J),[0,a(K),[0,a(t),0]]]]],yW=a(ax),yX=a("0.069"),yY=a(k),yR=[0,a(v),jd,5,jd,69,[0,a(M),[0,a(J),[0,a(K),[0,a(t),0]]]]],yS=a(ax),yT=a("0.075"),yU=a(k),yN=[0,a(v),ky,5,ky,69,[0,a(M),[0,a(J),[0,a(K),[0,a(t),0]]]]],yO=a(ax),yP=a("0.0539"),yQ=a(k),yJ=[0,a(v),jF,5,jF,69,[0,a(M),[0,a(J),[0,a(K),[0,a(t),0]]]]],yK=a(ax),yL=a(jB),yM=a(k),yI=[0,a(o),eK,11,eK,56,[0,a(n),0]],yF=a(ax),yG=a(f_),yH=a(k),yw=a(U),yx=[0,a(ah),420,6,421,72,[0,a(go),[0,a(bZ),[0,a(eJ),[0,a(bG),[0,a(ag),[0,a(B),0]]]]]]],yr=[0,a(an),[0,a(dn),[0,a(aw),0]]],ys=[0,a(an),[0,a(dn),0]],yt=[0,a(an),[0,a(dn),[0,a(ay),0]]],yu=[0,a(an),[0,a(dn),0]],yv=[0,a(ah),jM,5,125,59,[0,a(l0),[0,a(L),[0,a(N),[0,a(H),[0,a(ag),[0,a(B),0]]]]]]],yq=[0,a(o),bB,11,bB,35,[0,a(n),0]],yk=[0,a(v),lK,5,lK,69,[0,a(b0),[0,a(jY),[0,a(bW),[0,a(t),0]]]]],yl=a(jk),ym=a("5827900"),yh=[0,a(v),bm,5,bm,69,[0,a(jE),[0,a(bW),[0,a(t),0]]]],yi=a(k_),yj=a("5775900"),ye=[0,a(v),bT,5,bT,69,[0,a(iG),[0,a(bW),[0,a(t),0]]]],yf=a(lB),yg=a("5684900"),yb=[0,a(v),87,5,87,69,[0,a(lL),[0,a(bW),[0,a(t),0]]]],yc=a(k1),yd=a("5628600"),ya=[0,a(o),es,11,es,27,[0,a(n),0]],x_=a(lX),x$=a("5595000"),x5=[0,a(v),jW,5,jW,69,[0,a(b0),[0,a(jY),[0,a(bW),[0,a(t),0]]]]],x6=a(jk),x7=a("8155800"),x2=[0,a(v),jC,5,jC,69,[0,a(jE),[0,a(bW),[0,a(t),0]]]],x3=a(k_),x4=a("8083100"),xZ=[0,a(v),bB,5,bB,69,[0,a(iG),[0,a(bW),[0,a(t),0]]]],x0=a(lB),x1=a("7955800"),xW=[0,a(v),94,5,94,69,[0,a(lL),[0,a(bW),[0,a(t),0]]]],xX=a(k1),xY=a("7877000"),xV=[0,a(o),ez,11,ez,28,[0,a(n),0]],xT=a(lX),xU=a("7830000"),xM=[0,a(an),[0,a(dj),[0,a(aw),0]]],xN=[0,a(an),[0,a(dj),0]],xO=[0,a(an),[0,a(dj),[0,a(ay),0]]],xP=[0,a(an),[0,a(dj),0]],xJ=[0,a(jb),83,19,83,69,[0,a("Article R521-1"),[0,a(L),[0,a(N),[0,a(H),[0,a(kI),[0,a(B),0]]]]]]],xI=a("14"),xH=[0,a(o),kn,11,kn,38,[0,a(n),0]],xj=[0,a(ah),269,5,270,48,[0,a(bk),[0,a(L),[0,a(N),[0,a(H),[0,a(ag),[0,a(B),0]]]]]]],xk=[0,0],xh=[0,a(ah),kr,5,259,56,[0,a(bk),[0,a(L),[0,a(N),[0,a(H),[0,a(ag),[0,a(B),0]]]]]]],xi=[1,0],xf=[0,a(ah),kG,5,kG,70,[0,a(bk),[0,a(L),[0,a(N),[0,a(H),[0,a(ag),[0,a(B),0]]]]]]],xg=[0,0],xd=[0,a(ah),kV,5,kV,69,[0,a(bk),[0,a(L),[0,a(N),[0,a(H),[0,a(ag),[0,a(B),0]]]]]]],xe=[0,0],xb=[0,a(ah),jD,5,jD,60,[0,a(bk),[0,a(L),[0,a(N),[0,a(H),[0,a(ag),[0,a(B),0]]]]]]],xc=[0,0],xa=[0,a(o),ca,11,ca,20,[0,a(n),0]],w$=[0,a(o),ca,11,ca,20,[0,a(n),0]],w8=[0,a(ah),263,5,kb,48,[0,a(bk),[0,a(L),[0,a(N),[0,a(H),[0,a(ag),[0,a(B),0]]]]]]],w9=[0,0],w6=[0,a(ah),lg,5,dk,56,[0,a(bk),[0,a(L),[0,a(N),[0,a(H),[0,a(ag),[0,a(B),0]]]]]]],w7=[2,0],w4=[0,a(ah),jo,5,jo,70,[0,a(bk),[0,a(L),[0,a(N),[0,a(H),[0,a(ag),[0,a(B),0]]]]]]],w5=[1,0],w2=[0,a(ah),jS,5,jS,69,[0,a(bk),[0,a(L),[0,a(N),[0,a(H),[0,a(ag),[0,a(B),0]]]]]]],w3=[0,0],w0=[0,a(ah),kX,5,kX,60,[0,a(bk),[0,a(L),[0,a(N),[0,a(H),[0,a(ag),[0,a(B),0]]]]]]],w1=[0,0],wZ=[0,a(o),cB,11,cB,26,[0,a(n),0]],wY=[0,a(o),cB,11,cB,26,[0,a(n),0]],w_=[0,a(f),[0,a(bE),0]],xl=[0,a(f),[0,a("versement"),0]],xn=a(eS),xm=[0,a(o),f$,11,f$,32,[0,a(n),0]],xo=[0,a(f),[0,a("nombre_enfants_l521_1"),0]],xq=a(eS),xp=[0,a(o),bm,11,bm,41,[0,a(n),0]],xr=[0,a(f),[0,a("nombre_enfants_alin\xc3\xa9a_2_l521_3"),0]],xs=[0,a(f),[0,a(jL),[0,a(gy),0]]],xt=[0,a(f),[0,a(jL),[0,a(gy),0]]],xv=[0,a(f),[0,a("prestations_familiales.date_courante"),0]],xu=[0,a(o),70,10,70,23,[0,a(n),0]],xx=[1,0],xy=[0,a(f),[0,a("prestations_familiales.prestation_courante"),0]],xw=[0,a(o),71,10,71,29,[0,a(n),0]],xA=[0,a(f),[0,a("prestations_familiales.r\xc3\xa9sidence"),0]],xz=[0,a(o),72,10,72,19,[0,a(n),0]],xB=[0,a(f),[0,a(lk),[0,a(an),0]]],xC=[0,a(f),[0,a(lk),[0,a(an),0]]],xE=[0,a(f),[0,a("enfant_le_plus_\xc3\xa2g\xc3\xa9.enfants"),0]],xD=[0,a(o),84,10,84,17,[0,a(n),0]],xF=[0,a(f),[0,a(j$),[0,a(gH),0]]],xG=[0,a(f),[0,a(j$),[0,a(gH),0]]],xK=[0,a(f),[0,a(bg),0]],xL=[0,a(o),aR,11,aR,61,[0,a(n),0]],xQ=[0,a(f),[0,a("enfants_\xc3\xa0_charge_droit_ouvert_prestation_familiale"),0]],xR=[0,a(f),[0,a(dw),0]],xS=[0,a(o),ez,11,ez,28,[0,a(n),0]],x8=[0,a(f),[0,a("plafond_II_d521_3"),0]],x9=[0,a(o),es,11,es,27,[0,a(n),0]],yn=[0,a(f),[0,a("plafond_I_d521_3"),0]],El=a(U),Em=[0,a(ah),jp,5,427,71,[0,a(go),[0,a(bZ),[0,a(eJ),[0,a(bG),[0,a(ag),[0,a(B),0]]]]]]],yo=[0,a(o),km,11,km,34,[0,a(n),0]],yp=[0,a(f),[0,a("droit_ouvert_compl\xc3\xa9ment"),0]],yy=[0,a(f),[0,a(dr),0]],yA=a(eS),yB=a(eS),yC=a(jB),Ek=a(k),yz=[0,a(o),dq,11,dq,64,[0,a(n),0]],yD=[0,a(f),[0,a("montant_initial_base_quatri\xc3\xa8me_enfant_et_plus_mayotte"),0]],yE=[0,a(o),eK,11,eK,56,[0,a(n),0]],zl=[0,a(f),[0,a("montant_initial_base_troisi\xc3\xa8me_enfant_mayotte"),0]],zm=[0,a(o),dB,11,dB,55,[0,a(n),0]],z5=[0,a(f),[0,a("montant_initial_base_deuxi\xc3\xa8me_enfant_mayotte"),0]],z6=[0,a(o),em,11,em,54,[0,a(n),0]],AR=[0,a(f),[0,a("montant_initial_base_premier_enfant_mayotte"),0]],AS=[0,a(o),iR,11,iR,31,[0,a(n),0]],AT=[0,a(f),[0,a("nombre_total_enfants"),0]],AV=a(du),AU=[0,a(o),gA,11,gA,31,[0,a(n),0]],A3=[0,a(f),[0,a("nombre_moyen_enfants"),0]],Eh=a(U),Ei=[0,a(ao),ks,5,360,71,[0,a(eT),[0,a(bZ),[0,a(df),[0,a(bG),[0,a(am),[0,a(B),0]]]]]]],Ej=a(jh),A5=a(k),A4=[0,a(o),gJ,11,gJ,46,[0,a(n),0]],A6=[0,a(f),[0,a("montant_initial_base_premier_enfant"),0]],A7=[0,a(o),eI,11,eI,28,[0,a(n),0]],A8=[0,a(f),[0,a("droit_ouvert_base"),0]],Bm=[0,a(f),[0,a(V),0]],BA=[0,a(f),[0,a(dy),0]],BB=[0,a(o),bH,11,bH,47,[0,a(n),0]],BJ=[0,a(f),[0,a("montant_vers\xc3\xa9_forfaitaire_par_enfant"),0]],BK=[0,a(o),dz,11,dz,56,[0,a(n),0]],B1=[0,a(f),[0,a("montant_initial_base_troisi\xc3\xa8me_enfant_et_plus"),0]],B2=[0,a(o),dA,11,dA,47,[0,a(n),0]],Ce=[0,a(f),[0,a("montant_initial_base_deuxi\xc3\xa8me_enfant"),0]],Cg=a(du),Ch=a(du),Cf=[0,a(o),cH,11,cH,38,[0,a(n),0]],Ci=[0,a(f),[0,a("rapport_enfants_total_moyen"),0]],CJ=[0,a(f),[0,a(dm),0]],CL=a(k),CK=[0,a(o),iP,11,iP,36,[0,a(n),0]],CR=[0,a(f),[0,a("montant_vers\xc3\xa9_forfaitaire"),0]],CS=[0,a(o),ew,11,ew,31,[0,a(n),0]],CY=[0,a(f),[0,a("montant_initial_base"),0]],Dk=[0,a(f),[0,a(dg),0]],Dl=[0,a(o),eD,11,eD,52,[0,a(n),0]],Dy=[0,a(f),[0,a("montant_vers\xc3\xa9_compl\xc3\xa9ment_pour_forfaitaire"),0]],Dz=[0,a(o),gp,11,gp,43,[0,a(n),0]],DA=[0,a(f),[0,a("montant_avec_garde_altern\xc3\xa9e_base"),0]],DN=[0,a(f),[0,a(dl),0]],D_=a(k),DO=[0,a(o),lD,11,lD,29,[0,a(n),0]],DP=[0,a(f),[0,a("montant_vers\xc3\xa9_base"),0]],DR=a(k),D9=a(k),DQ=[0,a(o),kx,11,kx,35,[0,a(n),0]],DW=[0,a(f),[0,a("montant_vers\xc3\xa9_majoration"),0]],DX=[0,a(o),kR,11,kR,58,[0,a(n),0]],DY=[0,a(f),[0,a("montant_base_compl\xc3\xa9ment_pour_base_et_majoration"),0]],D0=[0,a(f),[0,a(dy),[0,a(aw),0]]],D1=[0,a(f),[0,a(dy),0]],D2=[0,a(f),[0,a(dy),[0,a(ay),0]]],D3=[0,a(f),[0,a(dy),0]],D8=a(k),DZ=[0,a(o),kc,11,kc,59,[0,a(n),0]],D4=[0,a(f),[0,a("montant_vers\xc3\xa9_compl\xc3\xa9ment_pour_base_et_majoration"),0]],D7=a(k),D5=[0,a(o),iH,10,iH,23,[0,a(n),0]],D6=[0,a(f),[0,a("montant_vers\xc3\xa9"),0]],wL=[0,a(ah),60,5,62,32,[0,a(gq),[0,a(gj),[0,a(ge),[0,a(H),[0,a(ag),[0,a(B),0]]]]]]],wK=[0,a(ah),49,5,50,50,[0,a(gq),[0,a(gj),[0,a(ge),[0,a(H),[0,a(ag),[0,a(B),0]]]]]]],wJ=[0,a(o),65,10,65,22,[0,a(n),0]],wI=[0,a(o),65,10,65,22,[0,a(n),0]],wG=[0,a(ah),68,5,71,57,[0,a(gq),[0,a(gj),[0,a(ge),[0,a(H),[0,a(ag),[0,a(B),0]]]]]]],wF=[0,a(o),66,10,66,29,[0,a(n),0]],wq=[0,a(v),60,5,61,34,[0,a("Instruction interminist\xc3\xa9rielle n\xc2\xb0DSS/2B/2021/65 du 19 mars 2021 relative \xc3\xa0 la revalorisation au 1er avril 2021 des prestations familiales servies en m\xc3\xa9tropole, en Guadeloupe, en Guyane, en Martinique, \xc3\xa0 la R\xc3\xa9union, \xc3\xa0 Saint-Barth\xc3\xa9lemy, \xc3\xa0 Saint-Martin et dans le d\xc3\xa9partement de Mayotte"),[0,a(gi),[0,a(t),0]]]],wr=a("41481"),wo=[0,a(v),44,5,45,34,[0,a("Instruction interminist\xc3\xa9rielle no DSS/SD2B/2020/33 du 18 f\xc3\xa9vrier 2020 relative \xc3\xa0 la revalorisation au 1er avril 2020 des prestations familiales servies en m\xc3\xa9tropole, en Guadeloupe, en Guyane, en Martinique, \xc3\xa0 La R\xc3\xa9union, \xc3\xa0 Saint-Barth\xc3\xa9lemy, \xc3\xa0 Saint-Martin et dans le d\xc3\xa9partement de Mayotte"),[0,a(gi),[0,a(t),0]]]],wp=a("41404"),wm=[0,a(v),24,5,25,34,[0,a("Instruction minist\xc3\xa9rielle N\xc2\xb0DSS/SD2B/2019/65 du 25 mars 2019 relative \xc3\xa0 la revalorisation au 1er avril 2019 des prestations familiales servies en m\xc3\xa9tropole"),[0,a(gi),[0,a(t),0]]]],wn=a("41316"),wl=[0,a(o),74,10,74,24,[0,a(n),0]],wi=a("20"),wh=[0,a(o),68,10,68,22,[0,a(n),0]],wj=[0,a(an),[0,a("\xc3\xa2ge_l512_3_2"),0]],wk=[0,a(o),74,10,74,24,[0,a(n),0]],ws=[0,a(an),[0,a("base_mensuelle"),0]],wu=[0,a(an),[0,a("smic.date_courante"),0]],wt=[0,a(o),41,10,41,23,[0,a(n),0]],ww=[0,a(an),[0,a("smic.r\xc3\xa9sidence"),0]],wv=[0,a(o),42,10,42,19,[0,a(n),0]],wx=[0,a(an),[0,a(lR),[0,a(gh),0]]],wy=[0,a(an),[0,a(lR),[0,a(gh),0]]],wQ=[0,0],wS=[1,0],wT=[2,0],wU=[3,0],wV=[4,0],wW=[5,0],wR=[0,a(ah),354,5,ks,30,[0,a("Article L751-1"),[0,a("Chapitre 1er : G\xc3\xa9n\xc3\xa9ralit\xc3\xa9s"),[0,a(eJ),[0,a(bG),[0,a(ag),[0,a(B),0]]]]]]],wz=[0,a(o),69,10,69,33,[0,a(n),0]],wA=[0,a(an),[0,a("r\xc3\xa9gime_outre_mer_l751_1"),0]],wN=[0,a(jb),i8,18,i8,41,[0,a("Article R755-0-2"),[0,a(bZ),[0,a(df),[0,a(bG),[0,a(kI),[0,a(B),0]]]]]]],wO=a(ll),wP=a(jz),wC=a(ll),wD=a(jz),wB=[0,a(o),67,11,67,27,[0,a(n),0]],wE=[0,a(an),[0,a("plafond_l512_3_2"),0]],wH=[0,a(an),[0,a(dn),0]],wM=[0,a(an),[0,a(dj),0]],wa=[2,0],wb=a(k),wc=a(k),wd=[1,0],we=a(U),v$=[0,a(o),85,10,85,21,[0,a(n),0]],wf=[0,a(gH),[0,a("le_plus_\xc3\xa2g\xc3\xa9"),0]],v8=a(gc),v7=[0,a(o),81,10,81,37,[0,a(n),0]],v9=[0,a(gy),[0,a(bg),0]],v2=[8,0],v3=[0,a(v),lu,5,317,6,[0,a(b0),[0,a(iI),[0,a(cy),[0,a(t),0]]]]],v4=a("774"),vS=[6,0],vV=[0,0],vW=[1,0],vX=[2,0],vY=[3,0],vZ=[4,0],v0=[5,0],v1=[7,0],vT=[0,a(v),297,5,306,6,[0,a(b0),[0,a(iI),[0,a(cy),[0,a(t),0]]]]],vU=a("1025"),vP=[8,0],vQ=[0,a(v),276,5,278,6,[0,a(b0),[0,a(i_),[0,a(cy),[0,a(t),0]]]]],vR=a("766"),vF=[6,0],vI=[0,0],vJ=[1,0],vK=[2,0],vL=[3,0],vM=[4,0],vN=[5,0],vO=[7,0],vG=[0,a(v),kr,5,267,6,[0,a(b0),[0,a(i_),[0,a(cy),[0,a(t),0]]]]],vH=a("1015"),vC=[8,0],vD=[0,a(v),237,5,239,6,[0,a(b0),[0,a(iE),[0,a(cy),[0,a(t),0]]]]],vE=a("757"),vs=[6,0],vv=[0,0],vw=[1,0],vx=[2,0],vy=[3,0],vz=[4,0],vA=[5,0],vB=[7,0],vt=[0,a(v),219,5,228,6,[0,a(b0),[0,a(iE),[0,a(cy),[0,a(t),0]]]]],vu=a("1003"),vr=[0,a(o),43,10,43,22,[0,a(n),0]],vq=[0,a(o),43,10,43,22,[0,a(n),0]],v5=[0,a(gh),[0,a("brut_horaire"),0]],vh=a("a_d\xc3\xa9j\xc3\xa0_ouvert_droit_aux_allocations_familiales"),vi=a("prise_en_charge"),vj=a("\xc3\xa2ge"),vk=a("date_de_naissance"),vl=a("r\xc3\xa9muneration_mensuelle"),vm=a("obligation_scolaire"),vn=a("identifiant"),vo=[0,a("Enfant"),0],u_=a("PrestationAccueilJeuneEnfant"),va=a(f),vb=a("Compl\xc3\xa9mentFamilial"),vc=a("AllocationLogement"),vd=a("Allocation\xc3\x89ducationEnfantHandicap\xc3\xa9"),ve=a("AllocationSoutienFamilial"),vf=a("AllocationRentr\xc3\xa9eScolaire"),vg=a("AllocationJournali\xc3\xa8rePresenceParentale"),u$=[0,a("\xc3\x89l\xc3\xa9mentPrestationsFamiliales"),0],uZ=a(j7),u1=a(kJ),u2=a(i6),u3=a("LaR\xc3\xa9union"),u4=a("SaintBarth\xc3\xa9lemy"),u5=a("SaintMartin"),u6=a(jT),u7=a("SaintPierreEtMiquelon"),u8=a(le),u0=[0,a("Collectivit\xc3\xa9"),0],uV=a("Avant"),uX=a("Pendant"),uY=a("Apr\xc3\xa8s"),uW=[0,a("SituationObligationScolaire"),0],uP=a("GardeAltern\xc3\xa9ePartageAllocations"),uR=a("GardeAltern\xc3\xa9eAllocataireUnique"),uS=a("EffectiveEtPermanente"),uT=a("ServicesSociauxAllocationVers\xc3\xa9e\xc3\x80LaFamille"),uU=a("ServicesSociauxAllocationVers\xc3\xa9eAuxServicesSociaux"),uQ=[0,a("PriseEnCharge"),0],EN=a("Jsoo_runtime.Error.Exn"),EO=a(gf),Fs=a("Begin call"),Ft=a("End call"),Fu=a("Variable definition"),Fv=a("Decision taken"),E9=a("Confi\xc3\xa9 aux service sociaux, allocation vers\xc3\xa9e aux services sociaux"),E_=a("Confi\xc3\xa9 aux service sociaux, allocation vers\xc3\xa9e \xc3\xa0 la famille"),E$=a("Effective et permanente"),Fa=a("Garde altern\xc3\xa9e, allocataire unique"),Fb=a("Garde altern\xc3\xa9e, partage des allocations"),Fd=[0,0],Fe=[1,0],Ff=[2,0],Fg=[3,0],Fh=[4,0],Fc=a("Unknown prise en charge"),EZ=a(j7),E0=a(kJ),E1=a("La R\xc3\xa9union"),E2=a(i6),E3=a(le),E4=a(jT),E5=a("Saint Barth\xc3\xa9lemy"),E6=a("Saint Martin"),E7=a("Saint Pierre et Miquelon"),Fi=[7,0],Fj=[5,0],Fk=[4,0],Fl=[6,0],Fm=[8,0],Fn=[2,0],Fo=[3,0],Fp=[1,0],Fq=[0,0],E8=a("unknown collectivite!"),EX=a(p),EV=[0,[4,0,0,0,[12,68,[4,0,0,0,[12,77,[4,0,0,0,[12,89,0]]]]]],a("%dD%dM%dY")],EU=[0,a(kS),a(kZ),a(lj)];function -Y(a){if(typeof +Date(a.getFullYear(),6,1),g=Math.max(d.getTimezoneOffset(),f.getTimezoneOffset());return[0,a.getSeconds(),a.getMinutes(),a.getHours(),a.getDate(),a.getMonth(),a.getFullYear()-bU,a.getDay(),c,a.getTimezoneOffset()>>0){if(!(25>>0))c=1}else +a=d;continue}return 0}}return a(DX(0))}];function +k7(b){var +a=[0,0],c=eW[1];eW[1]=function(e){if(1-a[1]){a[1]=1;d(b,0)}return d(c,0)};return 0}function +k8(a){return d(eW[1],0)}function +cb(a){if(0<=a&&!(cw>>0){if(!(25<(b+bt|0)>>>0))c=1}else if(23!==b)c=1;return c?a+32|0:a}var -hf=Gv(0),cV=(4*hf|0)-1|0;function -hg(c){var +gF=Ea(0)[1],gG=D$(0),cL=(4*gG|0)-1|0;aj(0);var +le=D_(0);function +gH(c){var b=0,a=c;for(;;){if(a){var b=b+1|0,a=a[2];continue}return b}}function -hh(a){return a?a[1]:bs(m2)}function -dO(d){var +gI(a){return a?a[1]:bl(lf)}function +dD(d){var a=d,b=0;for(;;){if(a){var -c=[0,a[1],b],a=a[2],b=c;continue}return b}}function -b7(b,a){if(a){var -c=a[2],e=d(b,a[1]);return[0,e,b7(b,c)]}return 0}function -a$(a,c){var -b=ac(a);FR(b,0,a,c);return b}function -hi(a){var -b=aW(a),c=ac(b);b2(a,0,c,0,b);return c}function -dP(a){return aB(hi(a))}function -hj(c,b,a){if(0<=b&&0<=a&&!((aW(c)-a|0)>>0))e=1}else +f=0;if(1>>0))e=1}else if(65<=d)e=1}else{var -f=0;if(32!==d)if(43<=d)switch(d+lO|0){case +f=0;if(32!==d)if(43<=d)switch(d+ka|0){case 5:if(a<(c+2|0)&&1>>0){if(33>>0)p=1}else +n=cJ(k,j)+gd|0,p=0;if(59>>0){if(33<(n-61|0)>>>0)p=1}else if(2===n)p=1;if(!p){var j=j+1|0;continue}var -e=bI(k),a=[0,0],r=aW(e)-1|0,w=0;if(!(r<0)){var +e=bD(k),a=[0,0],r=aS(e)-1|0,w=0;if(!(r<0)){var i=w;for(;;){var -f=dD(e,i),g=0;if(32<=f){var +f=ds(e,i),g=0;if(32<=f){var l=f-34|0,q=0;if(58>>0){if(93<=l)q=1}else -if(56>>0){g=1;q=1}if(!q){var +if(56<(l-1|0)>>>0){g=1;q=1}if(!q){var m=1;g=2}}else if(11<=f){if(13===f)g=1}else if(8<=f)g=1;switch(g){case @@ -2081,40 +1978,40 @@ m=4;break;case 1:var m=2;break}a[1]=a[1]+m|0;var z=i+1|0;if(r!==i){var -i=z;continue}break}}if(a[1]===aW(e))var -t=hi(e);else{var -b=ac(a[1]);a[1]=0;var -s=aW(e)-1|0,x=0;if(!(s<0)){var +i=z;continue}break}}if(a[1]===aS(e))var +t=gJ(e);else{var +b=aa(a[1]);a[1]=0;var +s=aS(e)-1|0,x=0;if(!(s<0)){var h=x;for(;;){var -c=dD(e,h),d=0;if(35<=c)if(92===c)d=2;else -if(bB<=c)d=1;else +c=ds(e,h),d=0;if(35<=c)if(92===c)d=2;else +if(bt<=c)d=1;else d=3;else if(32<=c)if(34<=c)d=2;else d=3;else if(14<=c)d=1;else switch(c){case -8:aa(b,a[1],92);a[1]++;aa(b,a[1],98);break;case -9:aa(b,a[1],92);a[1]++;aa(b,a[1],gp);break;case -10:aa(b,a[1],92);a[1]++;aa(b,a[1],gJ);break;case -13:aa(b,a[1],92);a[1]++;aa(b,a[1],gA);break;default:d=1}switch(d){case -1:aa(b,a[1],92);a[1]++;aa(b,a[1],48+(c/aR|0)|0);a[1]++;aa(b,a[1],48+((c/10|0)%10|0)|0);a[1]++;aa(b,a[1],48+(c%10|0)|0);break;case -2:aa(b,a[1],92);a[1]++;aa(b,a[1],c);break;case -3:aa(b,a[1],c);break}a[1]++;var +8:$(b,a[1],92);a[1]++;$(b,a[1],98);break;case +9:$(b,a[1],92);a[1]++;$(b,a[1],f2);break;case +10:$(b,a[1],92);a[1]++;$(b,a[1],ge);break;case +13:$(b,a[1],92);a[1]++;$(b,a[1],f$);break;default:d=1}switch(d){case +1:$(b,a[1],92);a[1]++;$(b,a[1],48+(c/aO|0)|0);a[1]++;$(b,a[1],48+((c/10|0)%10|0)|0);a[1]++;$(b,a[1],48+(c%10|0)|0);break;case +2:$(b,a[1],92);a[1]++;$(b,a[1],c);break;case +3:$(b,a[1],c);break}a[1]++;var y=h+1|0;if(s!==h){var h=y;continue}break}}var t=b}var o=aB(t)}var -u=E(o),v=a$(u+2|0,34);b3(o,0,v,1,u);return aB(v)}}function -hx(d,f){var -g=cT(f),e=oW[1];switch(d[2]){case +u=E(o),v=a7(u+2|0,34);bZ(o,0,v,1,u);return aB(v)}}function +gX(d,f){var +g=dC(f),e=gY?gY[1]:70;switch(d[2]){case 0:var -b=cB;break;case +b=ct;break;case 1:var -b=ex;break;case +b=ek;break;case 2:var b=69;break;case 3:var -b=ca;break;case +b=b7;break;case 4:var b=71;break;case 5:var @@ -2124,210 +2021,210 @@ b=104;break;case 7:var b=72;break;default:var b=70}var -c=ht(16);co(c,37);switch(d[1]){case +c=gU(16);cg(c,37);switch(d[1]){case 0:break;case -1:co(c,43);break;default:co(c,32)}if(8<=d[2])co(c,35);co(c,46);au(c,a(p+g));co(c,b);return hv(c)}function -dT(m,a){if(13<=m){var +1:cg(c,43);break;default:cg(c,32)}if(8<=d[2])cg(c,35);cg(c,46);au(c,a(t+g));cg(c,b);return gW(c)}function +dI(m,a){if(13<=m){var g=[0,0],h=E(a)-1|0,n=0;if(!(h<0)){var -c=n;for(;;){if(!(9>>0))g[1]++;var +c=n;for(;;){if(!(9<(cJ(a,c)+ea|0)>>>0))g[1]++;var q=c+1|0;if(h!==c){var c=q;continue}break}}var -i=g[1],j=ac(E(a)+((i-1|0)/3|0)|0),k=[0,0],d=function(a){a3(j,k[1],a);k[1]++;return 0},e=[0,((i-1|0)%3|0)+1|0],l=E(a)-1|0,o=0;if(!(l<0)){var +i=g[1],j=aa(E(a)+((i-1|0)/3|0)|0),k=[0,0],d=function(a){a0(j,k[1],a);k[1]++;return 0},e=[0,((i-1|0)%3|0)+1|0],l=E(a)-1|0,o=0;if(!(l<0)){var b=o;for(;;){var -f=cQ(a,b);if(9>>0)d(f);else{if(0===e[1]){d(95);e[1]=3}e[1]+=-1;d(f)}var +f=cJ(a,b);if(9<(f+ea|0)>>>0)d(f);else{if(0===e[1]){d(95);e[1]=3}e[1]+=-1;d(f)}var p=b+1|0;if(l!==b){var b=p;continue}break}}return aB(j)}return a}function -oX(b,c){switch(b){case +m$(b,c){switch(b){case 1:var -a=n9;break;case +a=mm;break;case 2:var -a=n_;break;case +a=mn;break;case 4:var -a=oa;break;case +a=mp;break;case 5:var -a=ob;break;case +a=mq;break;case 6:var -a=oc;break;case +a=mr;break;case 7:var -a=od;break;case +a=ms;break;case 8:var -a=oe;break;case +a=mt;break;case 9:var -a=of;break;case +a=mu;break;case 10:var -a=og;break;case +a=mv;break;case 11:var -a=oh;break;case +a=mw;break;case 0:case 13:var -a=n8;break;case +a=ml;break;case 3:case 14:var -a=n$;break;default:var -a=oi}return dT(b,eY(a,c))}function -oY(b,c){switch(b){case +a=mo;break;default:var +a=mx}return dI(b,eG(a,c))}function +na(b,c){switch(b){case 1:var -a=ox;break;case +a=mM;break;case 2:var -a=oy;break;case +a=mN;break;case 4:var -a=oA;break;case +a=mP;break;case 5:var -a=oB;break;case +a=mQ;break;case 6:var -a=oC;break;case +a=mR;break;case 7:var -a=oD;break;case +a=mS;break;case 8:var -a=oE;break;case +a=mT;break;case 9:var -a=oF;break;case +a=mU;break;case 10:var -a=oG;break;case +a=mV;break;case 11:var -a=oH;break;case +a=mW;break;case 0:case 13:var -a=ow;break;case +a=mL;break;case 3:case 14:var -a=oz;break;default:var -a=oI}return dT(b,eY(a,c))}function -oZ(b,c){switch(b){case +a=mO;break;default:var +a=mX}return dI(b,eG(a,c))}function +nb(b,c){switch(b){case 1:var -a=oK;break;case +a=mZ;break;case 2:var -a=oL;break;case +a=m0;break;case 4:var -a=oN;break;case +a=m2;break;case 5:var -a=oO;break;case +a=m3;break;case 6:var -a=oP;break;case +a=m4;break;case 7:var -a=oQ;break;case +a=m5;break;case 8:var -a=oR;break;case +a=m6;break;case 9:var -a=oS;break;case +a=m7;break;case 10:var -a=oT;break;case +a=m8;break;case 11:var -a=oU;break;case +a=m9;break;case 0:case 13:var -a=oJ;break;case +a=mY;break;case 3:case 14:var -a=oM;break;default:var -a=oV}return dT(b,eY(a,c))}function -o0(b,c){switch(b){case +a=m1;break;default:var +a=m_}return dI(b,eG(a,c))}function +nc(b,c){switch(b){case 1:var -a=ok;break;case +a=mz;break;case 2:var -a=ol;break;case +a=mA;break;case 4:var -a=on;break;case +a=mC;break;case 5:var -a=oo;break;case +a=mD;break;case 6:var -a=op;break;case +a=mE;break;case 7:var -a=oq;break;case +a=mF;break;case 8:var -a=or;break;case +a=mG;break;case 9:var -a=os;break;case +a=mH;break;case 10:var -a=ot;break;case +a=mI;break;case 11:var -a=ou;break;case +a=mJ;break;case 0:case 13:var -a=oj;break;case +a=my;break;case 3:case 14:var -a=om;break;default:var -a=ov}return dT(b,F3(a,c))}function -bu(c,i,b){function +a=mB;break;default:var +a=mK}return dI(b,DG(a,c))}function +bn(c,i,b){function j(d){switch(c[1]){case 0:var a=45;break;case 1:var a=43;break;default:var -a=32}return F0(b,i,a)}function +a=32}return DD(b,i,a)}function q(c){var -a=FO(b);return 3===a?b<0.?o2:o3:4<=a?o4:c}switch(c[2]){case +a=Du(b);return 3===a?b<0.?ne:nf:4<=a?ng:c}switch(c[2]){case 5:var -e=gO(hx(c,i),b),d=0,u=E(e);for(;;){if(d===u)var +e=ky(gX(c,i),b),d=0,u=E(e);for(;;){if(d===u)var p=0;else{var -k=D(e,d)+i1|0,l=0;if(23>>0){if(55===k)l=1}else -if(21>>0)l=1;if(!l){var +k=C(e,d)+ib|0,l=0;if(23>>0){if(55===k)l=1}else +if(21<(k-1|0)>>>0)l=1;if(!l){var d=d+1|0;continue}var p=1}var -v=p?e:a5(e,o1);return q(v)}case +v=p?e:bG(e,nd);return q(v)}case 6:return j(0);case 7:var -h=bI(j(0)),f=aW(h);if(0===f)var +h=bD(j(0)),f=aS(h);if(0===f)var o=h;else{var -m=ac(f),n=f-1|0,r=0;if(!(n<0)){var +m=aa(f),n=f-1|0,r=0;if(!(n<0)){var a=r;for(;;){var -g=dD(h,a),s=25>>0?g:g+gI|0;aa(m,a,s);var +g=ds(h,a),s=25<(g+iz|0)>>>0?g:g+gd|0;$(m,a,s);var t=a+1|0;if(n!==a){var a=t;continue}break}}var o=m}return aB(o);case -8:return q(j(0));default:return gO(hx(c,i),b)}}function -dd(e,y,x,w){var +8:return q(j(0));default:return ky(gX(c,i),b)}}function +c5(e,y,x,w){var b=y,a=x,c=w;for(;;)if(typeof c==="number")return d(b,a);else switch(c[0]){case 0:var -z=c[1];return function(c){return G(b,[5,a,c],z)};case +z=c[1];return function(c){return H(b,[5,a,c],z)};case 1:var A=c[1];return function(c){var e=0;if(40<=c)if(92===c)var -d=mW;else -if(bB<=c)e=1;else +d=k_;else +if(bt<=c)e=1;else e=2;else if(32<=c)if(39<=c)var -d=mX;else +d=k$;else e=2;else if(14<=c)e=1;else switch(c){case 8:var -d=mY;break;case +d=la;break;case 9:var -d=mZ;break;case +d=lb;break;case 10:var -d=m0;break;case +d=lc;break;case 13:var -d=m1;break;default:e=1}switch(e){case +d=ld;break;default:e=1}switch(e){case 1:var -f=ac(4);aa(f,0,92);aa(f,1,48+(c/aR|0)|0);aa(f,2,48+((c/10|0)%10|0)|0);aa(f,3,48+(c%10|0)|0);var +f=aa(4);$(f,0,92);$(f,1,48+(c/aO|0)|0);$(f,2,48+((c/10|0)%10|0)|0);$(f,3,48+(c%10|0)|0);var d=aB(f);break;case 2:var -g=ac(1);aa(g,0,c);var +g=aa(1);$(g,0,c);var d=aB(g);break}var -h=E(d),i=a$(h+2|0,39);b3(d,0,i,1,h);return G(b,[4,a,aB(i)],A)};case +h=E(d),i=a7(h+2|0,39);bZ(d,0,i,1,h);return H(b,[4,a,aB(i)],A)};case 2:var -B=c[2],C=c[1];return fk(b,a,B,C,function(a){return a});case -3:return fk(b,a,c[2],c[1],n7);case -4:return dU(b,a,c[4],c[2],c[3],oX,c[1]);case -5:return dU(b,a,c[4],c[2],c[3],oY,c[1]);case -6:return dU(b,a,c[4],c[2],c[3],oZ,c[1]);case -7:return dU(b,a,c[4],c[2],c[3],o0,c[1]);case +B=c[2],C=c[1];return e2(b,a,B,C,function(a){return a});case +3:return e2(b,a,c[2],c[1],mk);case +4:return dJ(b,a,c[4],c[2],c[3],m$,c[1]);case +5:return dJ(b,a,c[4],c[2],c[3],na,c[1]);case +6:return dJ(b,a,c[4],c[2],c[3],nb,c[1]);case +7:return dJ(b,a,c[4],c[2],c[3],nc,c[1]);case 8:var i=c[4],j=c[3],k=c[2],h=c[1];if(typeof k==="number"){if(typeof -j==="number")return j?function(d,c){return G(b,[4,a,bu(h,d,c)],i)}:function(c){return G(b,[4,a,bu(h,fi(h),c)],i)};var -_=j[1];return function(c){return G(b,[4,a,bu(h,_,c)],i)}}else{if(0===k[0]){var +j==="number")return j?function(d,c){return H(b,[4,a,bn(h,d,c)],i)}:function(c){return H(b,[4,a,bn(h,e0(h),c)],i)};var +_=j[1];return function(c){return H(b,[4,a,bn(h,_,c)],i)}}else{if(0===k[0]){var n=k[2],o=k[1];if(typeof -j==="number")return j?function(d,c){return G(b,[4,a,aN(o,n,bu(h,d,c))],i)}:function(c){return G(b,[4,a,aN(o,n,bu(h,fi(h),c))],i)};var -$=j[1];return function(c){return G(b,[4,a,aN(o,n,bu(h,$,c))],i)}}var +j==="number")return j?function(d,c){return H(b,[4,a,aK(o,n,bn(h,d,c))],i)}:function(c){return H(b,[4,a,aK(o,n,bn(h,e0(h),c))],i)};var +ab=j[1];return function(c){return H(b,[4,a,aK(o,n,bn(h,ab,c))],i)}}var p=k[1];if(typeof -j==="number")return j?function(e,d,c){return G(b,[4,a,aN(p,e,bu(h,d,c))],i)}:function(d,c){return G(b,[4,a,aN(p,d,bu(h,fi(h),c))],i)};var -ab=j[1];return function(d,c){return G(b,[4,a,aN(p,d,bu(h,ab,c))],i)}}case -9:return fk(b,a,c[2],c[1],mM);case +j==="number")return j?function(e,d,c){return H(b,[4,a,aK(p,e,bn(h,d,c))],i)}:function(d,c){return H(b,[4,a,aK(p,d,bn(h,e0(h),c))],i)};var +ac=j[1];return function(d,c){return H(b,[4,a,aK(p,d,bn(h,ac,c))],i)}}case +9:return e2(b,a,c[2],c[1],k1);case 10:var a=[7,a],c=c[1];continue;case 11:var @@ -2335,578 +2232,522 @@ a=[2,a,c[1]],c=c[2];continue;case 12:var a=[3,a,c[1]],c=c[2];continue;case 13:var -D=c[3],H=c[2],q=ht(16);fj(q,H);var -v=hv(q);return function(c){return G(b,[4,a,v],D)};case +D=c[3],G=c[2],q=gU(16);e1(q,G);var +v=gW(q);return function(c){return H(b,[4,a,v],D)};case 14:var I=c[3],J=c[2];return function(d){var -e=d[1],c=R(e,Y(af(J)));if(typeof -c[2]==="number")return G(b,a,T(c[1],I));throw ap};case +e=d[1],c=Q(e,X(af(J)));if(typeof +c[2]==="number")return H(b,a,S(c[1],I));throw aq};case 15:var -K=c[1];return function(d,c){return G(b,[6,a,function(a){return g(d,a,c)}],K)};case +K=c[1];return function(d,c){return H(b,[6,a,function(a){return g(d,a,c)}],K)};case 16:var -L=c[1];return function(c){return G(b,[6,a,c],L)};case +L=c[1];return function(c){return H(b,[6,a,c],L)};case 17:var a=[0,a,c[1]],c=c[2];continue;case 18:var m=c[1];if(0===m[0]){var -M=c[2],N=m[1][1],P=0,b=function(b,c,d){return function(a){return G(c,[1,b,[0,a]],d)}}(a,b,M),a=P,c=N;continue}var -Q=c[2],S=m[1][1],U=0,b=function(b,c,d){return function(a){return G(c,[1,b,[1,a]],d)}}(a,b,Q),a=U,c=S;continue;case -19:throw[0,F,o6];case +M=c[2],O=m[1][1],P=0,b=function(b,c,d){return function(a){return H(c,[1,b,[0,a]],d)}}(a,b,M),a=P,c=O;continue}var +R=c[2],T=m[1][1],U=0,b=function(b,c,d){return function(a){return H(c,[1,b,[1,a]],d)}}(a,b,R),a=U,c=T;continue;case +19:throw[0,F,ni];case 20:var -V=c[3],W=[8,a,o7];return function(a){return G(b,W,V)};case +V=c[3],W=[8,a,nj];return function(a){return H(b,W,V)};case 21:var -X=c[2];return function(c){return G(b,[4,a,eY(o8,c)],X)};case +Y=c[2];return function(c){return H(b,[4,a,eG(nk,c)],Y)};case 22:var -Z=c[1];return function(c){return G(b,[5,a,c],Z)};case +Z=c[1];return function(c){return H(b,[5,a,c],Z)};case 23:var f=c[2],l=c[1];if(typeof l==="number")switch(l){case -0:return e<50?O(e+1|0,b,a,f):aj(O,[0,b,a,f]);case -1:return e<50?O(e+1|0,b,a,f):aj(O,[0,b,a,f]);case -2:throw[0,F,o9];default:return e<50?O(e+1|0,b,a,f):aj(O,[0,b,a,f])}else +0:return e<50?N(e+1|0,b,a,f):ak(N,[0,b,a,f]);case +1:return e<50?N(e+1|0,b,a,f):ak(N,[0,b,a,f]);case +2:throw[0,F,nl];default:return e<50?N(e+1|0,b,a,f):ak(N,[0,b,a,f])}else switch(l[0]){case -0:return e<50?O(e+1|0,b,a,f):aj(O,[0,b,a,f]);case -1:return e<50?O(e+1|0,b,a,f):aj(O,[0,b,a,f]);case -2:return e<50?O(e+1|0,b,a,f):aj(O,[0,b,a,f]);case -3:return e<50?O(e+1|0,b,a,f):aj(O,[0,b,a,f]);case -4:return e<50?O(e+1|0,b,a,f):aj(O,[0,b,a,f]);case -5:return e<50?O(e+1|0,b,a,f):aj(O,[0,b,a,f]);case -6:return e<50?O(e+1|0,b,a,f):aj(O,[0,b,a,f]);case -7:return e<50?O(e+1|0,b,a,f):aj(O,[0,b,a,f]);case -8:return e<50?O(e+1|0,b,a,f):aj(O,[0,b,a,f]);case +0:return e<50?N(e+1|0,b,a,f):ak(N,[0,b,a,f]);case +1:return e<50?N(e+1|0,b,a,f):ak(N,[0,b,a,f]);case +2:return e<50?N(e+1|0,b,a,f):ak(N,[0,b,a,f]);case +3:return e<50?N(e+1|0,b,a,f):ak(N,[0,b,a,f]);case +4:return e<50?N(e+1|0,b,a,f):ak(N,[0,b,a,f]);case +5:return e<50?N(e+1|0,b,a,f):ak(N,[0,b,a,f]);case +6:return e<50?N(e+1|0,b,a,f):ak(N,[0,b,a,f]);case +7:return e<50?N(e+1|0,b,a,f):ak(N,[0,b,a,f]);case +8:return e<50?N(e+1|0,b,a,f):ak(N,[0,b,a,f]);case 9:var -u=l[2];return e<50?f6(e+1|0,b,a,u,f):aj(f6,[0,b,a,u,f]);case -10:return e<50?O(e+1|0,b,a,f):aj(O,[0,b,a,f]);default:return e<50?O(e+1|0,b,a,f):aj(O,[0,b,a,f])}default:var -r=c[3],s=c[1],t=d(c[2],0);return e<50?f5(e+1|0,b,a,r,s,t):aj(f5,[0,b,a,r,s,t])}}function -f6(e,d,c,a,b){if(typeof -a==="number")return e<50?O(e+1|0,d,c,b):aj(O,[0,d,c,b]);else +u=l[2];return e<50?fJ(e+1|0,b,a,u,f):ak(fJ,[0,b,a,u,f]);case +10:return e<50?N(e+1|0,b,a,f):ak(N,[0,b,a,f]);default:return e<50?N(e+1|0,b,a,f):ak(N,[0,b,a,f])}default:var +r=c[3],s=c[1],t=d(c[2],0);return e<50?fI(e+1|0,b,a,r,s,t):ak(fI,[0,b,a,r,s,t])}}function +fJ(e,d,c,a,b){if(typeof +a==="number")return e<50?N(e+1|0,d,c,b):ak(N,[0,d,c,b]);else switch(a[0]){case 0:var -f=a[1];return function(a){return aS(d,c,f,b)};case +f=a[1];return function(a){return aP(d,c,f,b)};case 1:var -g=a[1];return function(a){return aS(d,c,g,b)};case +g=a[1];return function(a){return aP(d,c,g,b)};case 2:var -h=a[1];return function(a){return aS(d,c,h,b)};case +h=a[1];return function(a){return aP(d,c,h,b)};case 3:var -i=a[1];return function(a){return aS(d,c,i,b)};case +i=a[1];return function(a){return aP(d,c,i,b)};case 4:var -j=a[1];return function(a){return aS(d,c,j,b)};case +j=a[1];return function(a){return aP(d,c,j,b)};case 5:var -k=a[1];return function(a){return aS(d,c,k,b)};case +k=a[1];return function(a){return aP(d,c,k,b)};case 6:var -l=a[1];return function(a){return aS(d,c,l,b)};case +l=a[1];return function(a){return aP(d,c,l,b)};case 7:var -m=a[1];return function(a){return aS(d,c,m,b)};case +m=a[1];return function(a){return aP(d,c,m,b)};case 8:var -n=a[2];return function(a){return aS(d,c,n,b)};case +n=a[2];return function(a){return aP(d,c,n,b)};case 9:var -o=a[3],p=a[2],q=ak(af(a[1]),p);return function(a){return aS(d,c,aC(q,o),b)};case +o=a[3],p=a[2],q=al(af(a[1]),p);return function(a){return aP(d,c,aC(q,o),b)};case 10:var -r=a[1];return function(e,a){return aS(d,c,r,b)};case +r=a[1];return function(e,a){return aP(d,c,r,b)};case 11:var -s=a[1];return function(a){return aS(d,c,s,b)};case +s=a[1];return function(a){return aP(d,c,s,b)};case 12:var -t=a[1];return function(a){return aS(d,c,t,b)};case -13:throw[0,F,o_];default:throw[0,F,o$]}}function -O(d,b,e,a){var -c=[8,e,pa];return d<50?dd(d+1|0,b,c,a):aj(dd,[0,b,c,a])}function -f5(h,b,f,a,e,c){if(e){var -i=e[1];return function(e){return o5(b,f,a,i,d(c,e))}}var -g=[4,f,c];return h<50?dd(h+1|0,b,g,a):aj(dd,[0,b,g,a])}function -G(a,b,c){return dK(dd(0,a,b,c))}function -aS(a,b,c,d){return dK(f6(0,a,b,c,d))}function -o5(a,b,c,d,e){return dK(f5(0,a,b,c,d,e))}function -fk(f,e,c,a,b){if(typeof -a==="number")return function(a){return G(f,[4,e,d(b,a)],c)};else{if(0===a[0]){var -g=a[2],h=a[1];return function(a){return G(f,[4,e,aN(h,g,d(b,a))],c)}}var -i=a[1];return function(g,a){return G(f,[4,e,aN(i,g,d(b,a))],c)}}}function -dU(f,e,d,h,c,b,a){if(typeof +t=a[1];return function(a){return aP(d,c,t,b)};case +13:throw[0,F,nm];default:throw[0,F,nn]}}function +N(d,b,e,a){var +c=[8,e,no];return d<50?c5(d+1|0,b,c,a):ak(c5,[0,b,c,a])}function +fI(h,b,f,a,e,c){if(e){var +i=e[1];return function(e){return nh(b,f,a,i,d(c,e))}}var +g=[4,f,c];return h<50?c5(h+1|0,b,g,a):ak(c5,[0,b,g,a])}function +H(a,b,c){return dy(c5(0,a,b,c))}function +aP(a,b,c,d){return dy(fJ(0,a,b,c,d))}function +nh(a,b,c,d,e){return dy(fI(0,a,b,c,d,e))}function +e2(f,e,c,a,b){if(typeof +a==="number")return function(a){return H(f,[4,e,d(b,a)],c)};else{if(0===a[0]){var +g=a[2],h=a[1];return function(a){return H(f,[4,e,aK(h,g,d(b,a))],c)}}var +i=a[1];return function(g,a){return H(f,[4,e,aK(i,g,d(b,a))],c)}}}function +dJ(f,e,d,h,c,b,a){if(typeof h==="number"){if(typeof -c==="number")return c?function(h,c){return G(f,[4,e,cp(h,g(b,a,c))],d)}:function(c){return G(f,[4,e,g(b,a,c)],d)};var -l=c[1];return function(c){return G(f,[4,e,cp(l,g(b,a,c))],d)}}else{if(0===h[0]){var +c==="number")return c?function(h,c){return H(f,[4,e,ch(h,g(b,a,c))],d)}:function(c){return H(f,[4,e,g(b,a,c)],d)};var +l=c[1];return function(c){return H(f,[4,e,ch(l,g(b,a,c))],d)}}else{if(0===h[0]){var i=h[2],j=h[1];if(typeof -c==="number")return c?function(h,c){return G(f,[4,e,aN(j,i,cp(h,g(b,a,c)))],d)}:function(c){return G(f,[4,e,aN(j,i,g(b,a,c))],d)};var -m=c[1];return function(c){return G(f,[4,e,aN(j,i,cp(m,g(b,a,c)))],d)}}var +c==="number")return c?function(h,c){return H(f,[4,e,aK(j,i,ch(h,g(b,a,c)))],d)}:function(c){return H(f,[4,e,aK(j,i,g(b,a,c))],d)};var +m=c[1];return function(c){return H(f,[4,e,aK(j,i,ch(m,g(b,a,c)))],d)}}var k=h[1];if(typeof -c==="number")return c?function(i,h,c){return G(f,[4,e,aN(k,i,cp(h,g(b,a,c)))],d)}:function(h,c){return G(f,[4,e,aN(k,h,g(b,a,c))],d)};var -n=c[1];return function(h,c){return G(f,[4,e,aN(k,h,cp(n,g(b,a,c)))],d)}}}function -bv(b,f){var -a=f;for(;;)if(typeof +c==="number")return c?function(i,h,c){return H(f,[4,e,aK(k,i,ch(h,g(b,a,c)))],d)}:function(h,c){return H(f,[4,e,aK(k,h,g(b,a,c))],d)};var +n=c[1];return function(h,c){return H(f,[4,e,aK(k,h,ch(n,g(b,a,c)))],d)}}}function +bH(b,h){var +a=h;for(;;)if(typeof a==="number")return 0;else switch(a[0]){case 0:var -g=a[1],h=hw(a[2]);bv(b,g);return cU(b,h);case +e=a[2],i=a[1];if(typeof +e==="number")switch(e){case +0:var +c=lG;break;case 1:var -c=a[2],e=a[1];if(0===c[0]){var -i=c[1];bv(b,e);cU(b,pb);var -a=i;continue}var -j=c[1];bv(b,e);cU(b,pc);var -a=j;continue;case -6:var -m=a[2];bv(b,a[1]);return d(m,b);case -7:bv(b,a[1]);return cd(b);case -8:var -n=a[2];bv(b,a[1]);return ae(n);case -2:case +c=lH;break;case +2:var +c=lI;break;case +3:var +c=lJ;break;case 4:var -k=a[2];bv(b,a[1]);return cU(b,k);default:var -l=a[2];bv(b,a[1]);return ml(b,l)}}function -bL(b,f){var -a=f;for(;;)if(typeof -a==="number")return 0;else -switch(a[0]){case +c=lK;break;case +5:var +c=lL;break;default:var +c=lM}else +switch(e[0]){case 0:var -g=a[1],h=hw(a[2]);bL(b,g);return cZ(b,h);case +c=e[1];break;case 1:var -c=a[2],e=a[1];if(0===c[0]){var -i=c[1];bL(b,e);cZ(b,pd);var -a=i;continue}var -j=c[1];bL(b,e);cZ(b,pe);var -a=j;continue;case +c=e[1];break;default:var +c=bG(lN,gN(1,e[1]))}bH(b,i);return cP(b,c);case +1:var +f=a[2],g=a[1];if(0===f[0]){var +j=f[1];bH(b,g);cP(b,np);var +a=j;continue}var +k=f[1];bH(b,g);cP(b,nq);var +a=k;continue;case 6:var -m=a[2];bL(b,a[1]);return cZ(b,d(m,0));case +n=a[2];bH(b,a[1]);return cP(b,d(n,0));case 7:var a=a[1];continue;case 8:var -n=a[2];bL(b,a[1]);return ae(n);case +o=a[2];bH(b,a[1]);return ae(o);case 2:case 4:var -k=a[2];bL(b,a[1]);return cZ(b,k);default:var -l=a[2];bL(b,a[1]);return hs(b,l)}}function -hy(d,c){var -a=c[1],b=0;return G(function(a){bv(d,a);return 0},b,a)}function -fl(a){return hy(a_,a)}function -aT(b){var -a=b[1];return G(function(b){var -a=fg(64);bL(a,b);return hr(a)},0,a)}var -fm=[0,0];function -fo(i,h){var -a=i[1+h];if(1-(typeof -a==="number"?1:0)){if(dJ(a)===eC)return d(aT(pf),a);if(dJ(a)===lg){var -c=gO(mQ,a),b=0,g=E(c);for(;;){if(g<=b)return a5(c,mP);var -e=D(c,b),f=0;if(48<=e){if(!(58<=e))f=1}else -if(45===e)f=1;if(f){var -b=b+1|0;continue}return c}}return pg}return d(aT(ph),a)}function -hz(b,a){if(b.length-1<=a)return pi;var -c=hz(b,a+1|0),d=fo(b,a);return g(aT(pj),d,c)}function -dV(a){function -p(f){var -b=f;for(;;){if(b){var -g=b[2],h=b[1];try{var -e=0,c=d(h,a);e=1}catch(a){}if(e&&c)return[0,c[1]];var -b=g;continue}return 0}}var -i=p(fm[1]);if(i)return i[1];if(a===fc)return po;if(a===g$)return pp;if(a[1]===g_){var -c=a[2],j=c[3],q=c[2],r=c[1];return f9(aT(fn),r,q,j,j+5|0,pq)}if(a[1]===F){var -e=a[2],k=e[3],s=e[2],t=e[1];return f9(aT(fn),t,s,k,k+6|0,pr)}if(a[1]===hc){var -f=a[2],l=f[3],u=f[2],v=f[1];return f9(aT(fn),v,u,l,l+6|0,ps)}if(0===dJ(a)){var -h=a.length-1,w=a[1][1];if(2>>0)var -m=hz(a,2),n=fo(a,1),b=g(aT(pk),n,m);else -switch(h){case -0:var -b=pl;break;case -1:var -b=pm;break;default:var -o=fo(a,1),b=d(aT(pn),o)}return a5(w,b)}return a[1]}function -fp(t,s){var -e=FP(s),g=e.length-1-1|0,p=0;if(!(g<0)){var -b=p;for(;;){var -a=ab(e,b)[1+b],f=function(a){return function(b){return b?0===a?pt:pu:0===a?pv:pw}}(b);if(0===a[0])var -h=a[5],i=a[4],j=a[3],k=a[6]?px:pz,l=a[2],m=a[7],n=f(a[1]),c=[0,FF(aT(py),n,m,l,k,j,i,h)];else -if(a[1])var -c=0;else -var -o=f(0),c=[0,d(aT(pA),o)];if(c){var -q=c[1];d(hy(t,pB),q)}var -r=b+1|0;if(g!==b){var -b=r;continue}break}}return 0}function -dW(c){for(;;){var -a=fm[1],b=1-fb(fm,a,[0,c,a]);if(b)continue;return b}}var -pD=pC.slice();function -pE(e,c){var -f=dV(e);d(fl(pF),f);fp(a_,c);var -a=Gh(0);if(a<0){var -b=cT(a);hd(ab(pD,b)[1+b])}return cd(a_)}var -pG=[0];g1(a(kC),function(f,j){try{try{var -b=j?pG:me(0);try{fe(0)}catch(a){}try{var -a=pE(f,b),e=a}catch(a){a=c(a);var -h=dV(f);d(fl(pI),h);fp(a_,b);var -i=dV(a);d(fl(pJ),i);fp(a_,me(0));var -e=cd(a_)}var -g=e}catch(a){a=c(a);if(a!==fc)throw a;var -g=hd(pH)}return g}catch(a){return 0}});var -pL=[I,pK,aA(0)];dW(function(a){return a[1]===pL?[0,a5(pM,dV(a[2]))]:0});try{var -FD=mr(FC),hB=FD}catch(a){a=c(a);if(a!==aH)throw a;try{var -FB=mr(FA),hA=FB}catch(a){a=c(a);if(a!==aH)throw a;var -hA=pO}var -hB=hA}var -pP=m8(hB,82),dX=[jf,function(x){var -m=Gw(0),c=[0,bJ(55,0),0],i=0===m.length-1?[0,0]:m,j=i.length-1,b=0;for(;;){ab(c[1],b)[1+b]=b;var +l=a[2];bH(b,a[1]);return cP(b,l);default:var +m=a[2];bH(b,a[1]);return gT(b,m)}}function +e3(b){var +a=b[1];return H(function(b){var +a=eY(64);bH(a,b);return gS(a)},0,a)}var +gZ=[0,0];function +e4(a){gZ[1]=[0,a,gZ[1]];return 0}try{var +Dl=eR(Dk),g1=Dl}catch(a){a=c(a);if(a!==az)throw a;try{var +Dj=eR(Di),g0=Dj}catch(a){a=c(a);if(a!==az)throw a;var +g0=ns}var +g1=g0}var +nt=ll(g1,82),dK=[im,function(x){var +m=Eb(0),c=[0,bF(55,0),0],i=0===m.length-1?[0,0]:m,j=i.length-1,b=0;for(;;){ai(c[1],b)[1+b]=b;var w=b+1|0;if(54!==b){var b=w;continue}var -g=[0,pN],k=54+dN(55,j)|0,s=0;if(!(k<0)){var -d=s;for(;;){var -e=d%55|0,l=Gl(d,j),t=ab(i,l)[1+l],h=a5(g[1],a(p+t));g[1]=Gg(h,0,E(h));var -f=g[1],n=D(f,3)<<24,o=D(f,2)<<16,q=D(f,1)<<8,r=((D(f,0)+q|0)+o|0)+n|0,u=(ab(c[1],e)[1+e]^r)&gw;ab(c[1],e)[1+e]=u;var +g=[0,nr],k=54+dB(55,j)|0,r=0;if(!(k<0)){var +d=r;for(;;){var +e=d%55|0,l=D0(d,j),s=ai(i,l)[1+l],h=bG(g[1],a(t+s));g[1]=DV(h,0,E(h));var +f=g[1],n=C(f,3)<<24,o=C(f,2)<<16,p=C(f,1)<<8,q=((C(f,0)+p|0)+o|0)+n|0,u=(ai(c[1],e)[1+e]^q)&f7;ai(c[1],e)[1+e]=u;var v=d+1|0;if(k!==d){var d=v;continue}break}}c[2]=0;return c}}];function -pQ(h,k){var -l=h?h[1]:pP,b=16;for(;;){if(!(k<=b)&&!(hf<(b*2|0))){var +nu(h,k){var +l=h?h[1]:nt,b=16;for(;;){if(!(k<=b)&&!(gG<(b*2|0))){var b=b*2|0;continue}if(l){var -i=dJ(dX),a=eo===i?dX[1]:jf===i?nm(dX):dX;a[2]=(a[2]+1|0)%55|0;var -c=a[2],d=ab(a[1],c)[1+c],e=(a[2]+24|0)%55|0,f=(ab(a[1],e)[1+e]+(d^(d>>>25|0)&31)|0)&gw,g=a[2];ab(a[1],g)[1+g]=f;var +i=kF(dK),a=eb===i?dK[1]:im===i?lB(dK):dK;a[2]=(a[2]+1|0)%55|0;var +c=a[2],d=ai(a[1],c)[1+c],e=(a[2]+24|0)%55|0,f=(ai(a[1],e)[1+e]+(d^(d>>>25|0)&31)|0)&f7,g=a[2];ai(a[1],g)[1+g]=f;var j=f}else var -j=0;return[0,0,bJ(b,0),j,b]}}function -ba(a){return FU(10,aR,0,a)}var -hE=[I,pR,aA(0)],hC=0,hD=-1;function -dY(a,b){a[13]=a[13]+b[3]|0;return hq(b,a[28])}var -hF=1000000010;function -fq(b,a){return P(b[17],a,0,E(a))}function -fr(a){return d(a[19],0)}function -hG(a,c,b){a[9]=a[9]-c|0;fq(a,b);a[11]=0;return 0}function -dZ(c,a){var -b=ai(a,pS);return b?hG(c,E(a),a):b}function -b9(a,b,f){var -g=b[3],h=b[2];dZ(a,b[1]);fr(a);a[11]=1;var -c=(a[6]-f|0)+h|0,e=a[8],i=Gd(e,c)?e:c;a[10]=i;a[9]=a[6]-a[10]|0;d(a[21],a[10]);return dZ(a,g)}function -hH(b,a){return b9(b,pT,a)}function -cq(a,b){var -c=b[2],e=b[3];dZ(a,b[1]);a[9]=a[9]-c|0;d(a[20],c);return dZ(a,e)}function -pU(a,j,b){if(typeof +j=0;return[0,0,bF(b,0),j,b]}}function +a8(a){return Dx(10,aO,0,a)}var +g4=[P,nv,aj(0)],g2=0,g3=-1;function +dL(a,b){a[13]=a[13]+b[3]|0;return gR(b,a[28])}var +g5=1000000010;function +e5(b,a){return O(b[17],a,0,E(a))}function +e6(a){return d(a[19],0)}function +g6(a,c,b){a[9]=a[9]-c|0;e5(a,b);a[11]=0;return 0}function +dM(c,a){var +b=ad(a,nw);return b?g6(c,E(a),a):b}function +ci(a,b,f){var +g=b[3],h=b[2];dM(a,b[1]);e6(a);a[11]=1;var +c=(a[6]-f|0)+h|0,e=a[8],i=DS(e,c)?e:c;a[10]=i;a[9]=a[6]-a[10]|0;d(a[21],a[10]);return dM(a,g)}function +g7(b,a){return ci(b,nx,a)}function +cR(a,b){var +c=b[2],e=b[3];dM(a,b[1]);a[9]=a[9]-c|0;d(a[20],c);return dM(a,e)}function +g8(a){for(;;){var +r=a[28][2],O=r?[0,r[1]]:0;if(O){var +p=O[1],q=p[1],b=p[2],ac=0<=q?1:0,aa=p[3],ab=a[13]-a[12]|0,P=ac||(a[9]<=ab?1:0);if(P){var +g=a[28],m=g[2];if(m){if(m[2]){var +Q=m[2];g[1]=g[1]-1|0;g[2]=Q}else +eX(g);var +l=0<=q?q:g5;if(typeof b==="number")switch(b){case 0:var -s=cn(a[3]);if(s){var -t=s[1][1],u=function(b,a){if(a){var -c=a[1],d=a[2];return gX(b,c)?[0,b,a]:[0,c,u(b,d)]}return[0,b,0]};t[1]=u(a[6]-a[9]|0,t[1]);return 0}return 0;case -1:cm(a[2]);return 0;case -2:cm(a[3]);return 0;case +x=cf(a[3]);if(x){var +y=x[1][1],z=function(b,a){if(a){var +c=a[1],d=a[2];return gr(b,c)?[0,b,a]:[0,c,z(b,d)]}return[0,b,0]};y[1]=z(a[6]-a[9]|0,y[1])}break;case +1:ce(a[2]);break;case +2:ce(a[3]);break;case 3:var -v=cn(a[2]);return v?hH(a,v[1][2]):fr(a);case -4:var -w=a[10]!==(a[6]-a[9]|0)?1:0;if(w){var -f=a[28],h=f[2];if(h){var -n=h[1];if(h[2]){var -K=h[2];f[1]=f[1]-1|0;f[2]=K;var -i=[0,n]}else{ff(f);var -i=[0,n]}}else +A=cf(a[2]);if(A)g7(a,A[1][2]);else +e6(a);break;case +4:if(a[10]!==(a[6]-a[9]|0)){var +e=a[28],h=e[2];if(h){var +s=h[1];if(h[2]){var +R=h[2];e[1]=e[1]-1|0;e[2]=R;var +i=[0,s]}else{eX(e);var +i=[0,s]}}else var i=0;if(i){var -r=i[1],M=r[1];a[12]=a[12]-r[3]|0;a[9]=a[9]+M|0;return 0}return 0}return w;default:var -x=cm(a[5]);return x?fq(a,d(a[25],x[1])):0}else +w=i[1],T=w[1];a[12]=a[12]-w[3]|0;a[9]=a[9]+T|0}}break;default:var +B=ce(a[5]);if(B)e5(a,d(a[25],B[1]))}else switch(b[0]){case -0:return hG(a,j,b[1]);case +0:g6(a,l,b[1]);break;case 1:var -c=b[2],g=b[1],y=c[1],N=c[2],z=cn(a[2]);if(z){var -A=z[1],e=A[2];switch(A[1]){case -0:return cq(a,g);case -1:return b9(a,c,e);case -2:return b9(a,c,e);case -3:return a[9]<(j+E(y)|0)?b9(a,c,e):cq(a,g);case -4:return a[11]?cq(a,g):a[9]<(j+E(y)|0)?b9(a,c,e):((a[6]-e|0)+N|0)>>0))hH(a,q)}else -fr(a)}var -T=a[9]-S|0,U=1===I?1:a[9]>>0))g7(a,v)}else +e6(a)}var +_=a[9]-Z|0,$=1===M?1:a[9]>>3|0,cj(b4(b,a>>>3|0)|1<<(a&7)))}function -d3(b){var -a=fx(0);c1(a,b);return a}function -d4(c){var -b=ac(32),a=0;for(;;){a3(b,a,cj(b4(c,a)^cE));var +h=c[1],a=d(e3(pc),h);return[0,O(e3(n_),a,g,f)]}return 0});eV(pd);eV(pe);try{eV(Df)}catch(a){a=c(a);if(a[1]!==dA)throw a}try{eV(De)}catch(a){a=c(a);if(a[1]!==dA)throw a}nu(0,7);function +pf(b,a){return dF(b,0,a)}function +pg(b,a){return dF(b,a,E(b)-a|0)}var +bo=a7(32,cw);function +fa(a){return a7(32,0)}function +cS(b,a){return a0(b,a>>>3|0,cb(b0(b,a>>>3|0)|1<<(a&7)))}function +dQ(b){var +a=fa(0);cS(a,b);return a}function +dR(c){var +b=aa(32),a=0;for(;;){a0(b,a,cb(b0(c,a)^cw));var d=a+1|0;if(31!==a){var a=d;continue}return b}}function -fy(d,c){var -b=ac(32),a=0;for(;;){var -e=b4(c,a);a3(b,a,cj(b4(d,a)|e));var +fb(d,c){var +b=aa(32),a=0;for(;;){var +e=b0(c,a);a0(b,a,cb(b0(d,a)|e));var f=a+1|0;if(31!==a){var a=f;continue}return b}}function -rC(d,b){try{var +ph(d,b){try{var a=0;for(;;){var -f=b4(b,a);if(0!==(b4(d,a)&f))throw g9;var +f=b0(b,a);if(0!==(b0(d,a)&f))throw gB;var g=a+1|0;if(31!==a){var a=g;continue}var -e=1;return e}}catch(a){a=c(a);if(a===g9)return 0;throw a}}function -hU(f,e){var +e=1;return e}}catch(a){a=c(a);if(a===gB)return 0;throw a}}function +hi(f,e){var a=0;for(;;){var -c=b4(e,a);if(0!==c){var -b=0;for(;;){if(0!==(c&1<>>0){if(!(25>>0))d=1}else +c=fa(0);hi(function(a){cS(c,gE(a));var +b=a-224|0,d=0;if(30>>0){if(!(25<(b+bt|0)>>>0))d=1}else if(23!==b)d=1;var -e=d?a+gI|0:a;return c1(c,e)},b);var +e=d?a+gd|0:a;return cS(c,e)},b);var d=c}else var d=b;var -h=f?d4(d):d;return dP(h)}throw[0,F,rR]}var -hY=ac(cI),dc=0;for(;;){a3(hY,dc,he(cj(dc)));var -Fx=dc+1|0;if(cE!==dc){var -dc=Fx;continue}dP(hY);var -d7=dR([0,g2]),hZ=function(a){var -b=hr(a[1]);a[1][2]=0;var +h=f?dR(d):d;return dE(h)}throw[0,F,pw]}var +hm=aa(cA),c4=0;for(;;){a0(hm,c4,gE(cb(c4)));var +Dd=c4+1|0;if(cw!==c4){var +c4=Dd;continue}dE(hm);var +dU=dG([0,gv]),hn=function(a){var +b=gS(a[1]);a[1][2]=0;var c=E(b);if(0===c)return 0;if(1===c){var -d=a[2];a[2]=[0,[0,D(b,0)],d];return 0}a[2]=[0,[1,b],a[2]];return 0},rV=d4(d3(10)),fD=z,fE=ma,r1=function(b){var +d=a[2];a[2]=[0,[0,C(b,0)],d];return 0}a[2]=[0,[1,b],a[2]];return 0},pA=dR(dQ(10)),fg=y,fh=ku,pG=function(b){var f=E(b),z=[0,1];function -C(g){var -d=fx(0),a=g;for(;;){if(f<=a)bs(rZ);if(93===D(b,a)&&g>>0)if(9<=r)var -j=[0,[9,k+en|0],g+1|0];else +j=[0,[9,k+ea|0],g+1|0];else l=1;else if(r)l=2;else{var I=z[1];z[1]++;var -t=A(g+1|0),o=t[2],y=0,J=t[1];if((o+1|0)>>0)){if(q){var +q=C(b,d)-42|0;if(!(1>>0)){if(q){var c=[6,c],d=d+1|0;continue}var c=[5,c],d=d+1|0;continue}if(21===q){var c=[7,c],d=d+1|0;continue}}var B=0;if(typeof -c!=="number"&&0===c[0]){hs(h[1],c[1]);B=1}if(!B){hZ(h);h[2]=[0,c,h[2]]}var -a=d;continue a}}}hZ(h);return[0,[3,dO(h[2])],a]}}function +c!=="number"&&0===c[0]){gT(h[1],c[1]);B=1}if(!B){hn(h);h[2]=[0,c,h[2]]}var +a=d;continue a}}}hn(h);return[0,[3,dD(h[2])],a]}}function A(g){var -d=B(g),c=d[1],a=d[2];for(;;){if((a+2|0)<=f&&92===D(b,a)&&dq===D(b,a+1|0)){var +d=B(g),c=d[1],a=d[2];for(;;){if((a+2|0)<=f&&92===C(b,a)&&df===C(b,a+1|0)){var e=B(a+2|0),c=[4,c,e[1]],a=e[2];continue}return[0,c,a]}}var -G=A(0),O=G[1],H=G[2]===f?O:bs(r0),h=[0,bJ(32,0)],d=[0,0],m=[0,d7[1]],n=[0,0],j=[0,1],o=[0,0],r=0;function +G=A(0),P=G[1],H=G[2]===f?P:bl(pF),h=[0,bF(32,0)],d=[0,0],m=[0,dU[1]],n=[0,0],j=[0,1],o=[0,0],r=0;function a(f,e){if(h[1].length-1<=d[1]){var a=[0,h[1].length-1];for(;;){if(a[1]<=d[1]){a[1]=a[1]*2|0;continue}var -b=bJ(a[1],0);hp(h[1],0,b,0,h[1].length-1);h[1]=b;break}}var -g=hX(f,e),c=d[1];ab(h[1],c)[1+c]=g;d[1]++;return 0}function +b=bF(a[1],0);gQ(h[1],0,b,0,h[1].length-1);h[1]=b;break}}var +g=hl(f,e),c=d[1];ai(h[1],c)[1+c]=g;d[1]++;return 0}function k(c){var -b=d[1];a(d5,0);return b}function +b=d[1];a(dS,0);return b}function l(a,c,b){var -d=hX(c,fA(b,a));ab(h[1],a)[1+a]=d;return 0}function +d=hl(c,fd(b,a));ai(h[1],a)[1+a]=d;return 0}function i(b){try{var -a=g(d7[28],b,m[1]);return a}catch(a){a=c(a);if(a===aH){var -d=n[1];m[1]=P(d7[4],b,d,m[1]);n[1]++;return d}throw a}}function -t(b){if(fB(b)){var -a=o[1];if(64<=a)bs(rS);o[1]++;return a}return-1}function -p(b,a){return rC(b,a)}function +a=g(dU[28],b,m[1]);return a}catch(a){a=c(a);if(a===az){var +d=n[1];m[1]=O(dU[4],b,d,m[1]);n[1]++;return d}throw a}}function +t(b){if(fe(b)){var +a=o[1];if(64<=a)bl(px);o[1]++;return a}return-1}function +p(b,a){return ph(b,a)}function e(b){if(typeof b==="number")switch(b){case -0:return a(rF,0);case -1:return a(rG,0);default:return a(rH,0)}else +0:return a(pk,0);case +1:return a(pl,0);default:return a(pm,0)}else switch(b[0]){case -0:return a(d5,b[1]);case +0:return a(dS,b[1]);case 1:var -f=b[1],n=E(f);if(0===n)return 0;if(1===n)return a(d5,D(f,0));try{var -o=ho(f,0);e([1,rA(f,o)]);a(d5,0);var -v=e([1,rB(f,o+1|0)]);return v}catch(b){b=c(b);if(b===aH)return a(rD,i(f));throw b}case +f=b[1],n=E(f);if(0===n)return 0;if(1===n)return a(dS,C(f,0));try{var +o=gP(f,0);e([1,pf(f,o)]);a(dS,0);var +v=e([1,pg(f,o+1|0)]);return v}catch(b){b=c(b);if(b===az)return a(pi,i(f));throw b}case 2:var -p=b[1],w=b[2]?d4(p):p;return a(rE,i(dP(w)));case +p=b[1],w=b[2]?dR(p):p;return a(pj,i(dE(w)));case 3:return J(b[1]);case 4:var x=b[2],y=b[1],z=k(0);e(y);var A=k(0),B=d[1];e(x);var -C=d[1];l(z,d6,B);return l(A,fz,C);case +D=d[1];l(z,dT,B);return l(A,fc,D);case 5:var -q=b[1],g=t(q),r=k(0);if(0<=g)a(hV,g);e(q);if(0<=g)a(hW,g);a(fz,fA(r,d[1]));return l(r,d6,d[1]);case +q=b[1],g=t(q),r=k(0);if(0<=g)a(hj,g);e(q);if(0<=g)a(hk,g);a(fc,fd(r,d[1]));return l(r,dT,d[1]);case 6:var -s=b[1],h=t(s),F=d[1];e(s);if(0<=h)a(hW,h);var -G=k(0);if(0<=h)a(hV,h);a(fz,fA(F,d[1]));return l(G,d6,d[1]);case +s=b[1],h=t(s),F=d[1];e(s);if(0<=h)a(hk,h);var +G=k(0);if(0<=h)a(hj,h);a(fc,fd(F,d[1]));return l(G,dT,d[1]);case 7:var -H=b[1],I=k(0);e(H);return l(I,d6,d[1]);case +H=b[1],I=k(0);e(H);return l(I,dT,d[1]);case 8:var -m=b[1],K=b[2];a(rI,m);e(K);a(rJ,m);j[1]=dN(j[1],m+1|0);return 0;default:var -u=b[1];a(rK,u);j[1]=dN(j[1],u+1|0);return 0}}function +m=b[1],K=b[2];a(pn,m);e(K);a(po,m);j[1]=dB(j[1],m+1|0);return 0;default:var +u=b[1];a(pp,u);j[1]=dB(j[1],u+1|0);return 0}}function J(o){var b=o;for(;;){if(b){var c=b[1];if(typeof @@ -3080,7 +2921,7 @@ d==="number")l=1;else switch(d[0]){case 0:case 2:var -h=b[2],s=c2(h);if(p(bM(d),s)){a(rN,i(fC(r,d)));var +h=b[2],s=cT(h);if(p(bI(d),s)){a(ps,i(ff(r,d)));var b=h;continue}break;default:l=1}break;case 6:var f=c[1],m=0;if(typeof @@ -3088,7 +2929,7 @@ f==="number")m=1;else switch(f[0]){case 0:case 2:var -j=b[2],t=c2(j);if(p(bM(f),t)){a(rO,i(fC(r,f)));var +j=b[2],t=cT(j);if(p(bI(f),t)){a(pt,i(ff(r,f)));var b=j;continue}break;default:m=1}break;case 7:var g=c[1],n=0;if(typeof @@ -3096,118 +2937,118 @@ g==="number")n=1;else switch(g[0]){case 0:case 2:var -k=b[2],u=c2(k);if(p(bM(g),u)){a(rM,i(fC(r,g)));var +k=b[2],u=cT(k);if(p(bI(g),u)){a(pr,i(ff(r,g)));var b=k;continue}break;default:n=1}break}var q=b[2];e(c);var -b=q;continue}return 0}}e(H);a(rL,0);var -u=bM(H);if(l_(u,bw))var +b=q;continue}return 0}}e(H);a(pq,0);var +u=bI(H);if(ks(u,bo))var v=-1;else{var -s=a$(cI,0);hU(function(a){return a3(s,a,1)},u);var -v=i(dP(s))}var -w=bJ(n[1],rT),K=m[1];function -L(b,a){ab(w,a)[1+a]=b;return 0}g(d7[12],L,K);var +s=a7(cA,0);hi(function(a){return a0(s,a,1)},u);var +v=i(dE(s))}var +w=bF(n[1],py),K=m[1];function +L(b,a){ai(w,a)[1+a]=b;return 0}g(dU[12],L,K);var q=d[1],x=h[1],I=0,M=o[1],N=j[1];if(0<=q&&!((x.length-1-q|0)<0)){var -y=FJ(x,0,q);I=1}if(!I)var -y=ae(m9);return[0,y,w,rU,N,M,v]},d8=function(b,a){return Math.abs(b-a)<0.001?1:0},fF=function(b,a){return d8(b,a)?0:b>a===b?c:mB(b,a)}return mB(b,a)},io=function(a){return typeof -a==="number"?a:GW(a)},by=0,fQ=1,ur=-1,ip=function(a){return ci(0,a,0,E(a))},us=function(b,a){return ci(b,a,0,E(a))},fR=function(a){if(typeof +c=b<>a===b?c:kQ(b,a)}return kQ(b,a)},hM=function(a){return typeof +a==="number"?a:Ey(a)},bq=0,ft=1,r9=-1,hN=function(a){return ca(0,a,0,E(a))},r_=function(b,a){return ca(b,a,0,E(a))},fu=function(a){if(typeof a==="number")return a;var -e=g5(a);if(63>g;f=1}if(!f)var -c=GU(a,b);var -i=GJ(a,ct(c,b)),d=e_(c),h=i?d:F_(d,ut);return gW(e1(h),b)}return e1(e_(a))},c_=function(a,b){if(a!==0&&b!==1){var -c=GL(a,b);if(c===1)return[0,a,b];var -d=im(b,c);return[0,im(a,c),d]}return[0,a,fQ]},iq=function(b,a){var -c=br(a);if(0===c)return[0,br(b),by];if(0>>0))switch(b){case +c=Ew(a,b);var +i=El(a,cl(c,b)),d=eT(c),h=i?d:DN(d,r$);return gq(eJ(h),b)}return eJ(eT(a))},c1=function(a,b){if(a!==0&&b!==1){var +c=En(a,b);if(c===1)return[0,a,b];var +d=hL(b,c);return[0,hL(a,c),d]}return[0,a,ft]},hO=function(b,a){var +c=bk(a);if(0===c)return[0,bk(b),bq];if(0>>0))switch(b){case 0:return 2;case -1:break;default:return 1}return 3}return a[1]===0?0:4},uu=function(a){var -b=a[2];return[0,cs(a[1]),b]},fU=function(b,a){if(b[2]!==0&&a[2]!==0){var -c=bS(b[2],a[2]);return c_(bS(b[1],a[1]),c)}return[0,a9(br(b[1]),br(a[1])),by]},fV=function(a){switch(a){case +1:break;default:return 1}return 3}return a[1]===0?0:4},sa=function(a){var +b=a[2];return[0,ck(a[1]),b]},fx=function(b,a){if(b[2]!==0&&a[2]!==0){var +c=bO(b[2],a[2]);return c1(bO(b[1],a[1]),c)}return[0,a5(bk(b[1]),bk(a[1])),bq]},fy=function(a){switch(a){case 0:return 2;case 1:return 8;case -2:return 10;default:return 16}},fW=function(f,e,c,b){var -a=e;for(;;){if(c<=a)return 0;if(d(b,D(f,a)))return[0,a];var -a=a+1|0;continue}},b=[I,uE,aA(0)],s=[I,uL,aA(0)],uw=function(a){if(ai(a,ux)){if(ai(a,uy)){if(!ai(a,uz))return it;if(ai(a,uA)){if(ai(a,uB))try{var -l=ho(a,47),Z=ci(0,a,l+1|0,(E(a)-l|0)-1|0),_=iq(ci(0,a,0,l),Z);return _}catch(l){l=c(l);if(l===aH){var +2:return 10;default:return 16}},fz=function(f,e,c,b){var +a=e;for(;;){if(c<=a)return 0;if(d(b,C(f,a)))return[0,a];var +a=a+1|0;continue}},sc=function(a){if(ad(a,sd)){if(ad(a,se)){if(!ad(a,sf))return hR;if(ad(a,sg)){if(ad(a,sh))try{var +l=gP(a,47),Z=ca(0,a,l+1|0,(E(a)-l|0)-1|0),_=hO(ca(0,a,0,l),Z);return _}catch(l){l=c(l);if(l===az){var j=E(a),x=0;if(j<1)var s=[0,0,x];else{var -P=D(a,0)+lO|0,S=0;if(!(2

>>0)){var +P=C(a,0)+ka|0,S=0;if(!(2

>>0)){var T=0;switch(P){case 0:var R=[0,0,1];break;case @@ -3511,10 +3353,10 @@ Q=[0,0,x];var s=Q}var d=s[2];if(j<(d+2|0))var t=[0,2,d];else{var -Y=D(a,d),h=D(a,d+1|0),r=0;if(48===Y){var +Y=C(a,d),h=C(a,d+1|0),r=0;if(48===Y){var i=0;if(89<=h){if(98===h)i=2;else -if(dA===h)i=1;else -if(bT!==h){r=1;i=3}}else +if(dp===h)i=1;else +if(bP!==h){r=1;i=3}}else if(66===h)i=2;else if(79===h)i=1;else if(!(88<=h)){r=1;i=3}switch(i){case @@ -3527,212 +3369,213 @@ q=[0,0,d+2|0]}}else r=1;if(r)var q=[0,2,d];var t=q}var -e=t[2],b=t[1],U=2===b?function(a){if(69!==a&&ex!==a)return 0;return 1}:3<=b?function(a){if(80!==a&&dz!==a)return 0;return 1}:function(a){return 0},y=fW(a,e,j,U);if(y)var -z=y[1],A=z+1|0,f=z,B=io(ci(10,a,A,j-A|0));else +e=t[2],b=t[1],U=2===b?function(a){if(69!==a&&ek!==a)return 0;return 1}:3<=b?function(a){if(80!==a&&dn!==a)return 0;return 1}:function(a){return 0},y=fz(a,e,j,U);if(y)var +z=y[1],A=z+1|0,f=z,B=hM(ca(10,a,A,j-A|0));else var f=j,B=0;if(2<=b){var -C=fW(a,e,f,function(a){return 46===a?1:0});if(C){var -u=C[1];if(2===b)var -G=1;else{if(!(3<=b))throw[0,F,uD];var +D=fz(a,e,f,function(a){return 46===a?1:0});if(D){var +u=D[1];if(2===b)var +G=1;else{if(!(3<=b))throw[0,F,sj];var G=4}var I=u+1|0,J=f-1|0,H=0;if(J Date: Tue, 8 Mar 2022 14:49:11 +0100 Subject: [PATCH 2/4] Change settings --- .ocamlformat | 5 +++-- CONTRIBUTING.md | 2 +- catala.opam | 2 +- dune-project | 2 +- 4 files changed, 6 insertions(+), 5 deletions(-) diff --git a/.ocamlformat b/.ocamlformat index cf8f21af..484d5d0d 100644 --- a/.ocamlformat +++ b/.ocamlformat @@ -1,6 +1,7 @@ profile = default -margin = 100 +margin = 80 exp-grouping = preserve +break-fun-decl = smart wrap-comments parse-docstrings -version=0.19.0 +version=0.20.1 diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index f56ebf0d..d5fd3af5 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -89,7 +89,7 @@ You can look at the [online OCaml documentation](https://catala-lang.org/ocaml_docs/) for the different modules' interfaces as well as high-level architecture documentation. -Please note that the `ocamlformat` version this project uses is `0.19.0`. +Please note that the `ocamlformat` version this project uses is `0.20.1`. Using another version may cause spurious diffs to appear in your pull requests. ### Example: adding a builtin function diff --git a/catala.opam b/catala.opam index 9e1f1152..bcb16cf0 100644 --- a/catala.opam +++ b/catala.opam @@ -40,7 +40,7 @@ depends: [ "cppo" {>= "1"} "obelisk" {dev} "alcotest" {with-test & >= "1.5.0"} - "ocamlformat" {dev & = "0.19.0"} + "ocamlformat" {dev & = "0.20.1"} "odoc" {with-doc} ] build: [ diff --git a/dune-project b/dune-project index 5c01f455..4facb1cb 100644 --- a/dune-project +++ b/dune-project @@ -80,7 +80,7 @@ (ocamlformat (and :dev - (= 0.19.0))))) + (= 0.20.1))))) (package (name french_law) From 729fb7e55106fbb3e6d7a246c2eaa156a1f8d7cf Mon Sep 17 00:00:00 2001 From: Louis Gesbert Date: Tue, 8 Mar 2022 16:12:25 +0100 Subject: [PATCH 3/4] reformat (sync with master) --- build_system/clerk.ml | 19 +- build_system/clerk_driver.ml | 383 +++-- build_system/ninja_utils.ml | 48 +- build_system/tests/test_clerk_driver.ml | 69 +- compiler/catala.ml | 18 +- compiler/catala_web_interpreter.ml | 7 +- compiler/dcalc/ast.ml | 144 +- compiler/dcalc/ast.mli | 93 +- compiler/dcalc/binded_representation.ml | 66 +- compiler/dcalc/binded_representation.mli | 47 +- compiler/dcalc/interpreter.ml | 307 ++-- compiler/dcalc/interpreter.mli | 29 +- compiler/dcalc/optimizations.ml | 140 +- compiler/dcalc/optimizations.mli | 21 +- compiler/dcalc/print.ml | 209 ++- compiler/dcalc/print.mli | 33 +- compiler/dcalc/typing.ml | 305 ++-- compiler/dcalc/typing.mli | 28 +- compiler/desugared/ast.ml | 134 +- compiler/desugared/ast.mli | 66 +- compiler/desugared/dependency.ml | 172 +- compiler/desugared/dependency.mli | 43 +- compiler/desugared/desugared_to_scope.ml | 429 +++-- compiler/desugared/desugared_to_scope.mli | 18 +- compiler/driver.ml | 148 +- compiler/driver.mli | 22 +- compiler/lcalc/ast.ml | 91 +- compiler/lcalc/ast.mli | 49 +- compiler/lcalc/backends.ml | 32 +- compiler/lcalc/backends.mli | 22 +- compiler/lcalc/compile_with_exceptions.ml | 62 +- compiler/lcalc/compile_with_exceptions.mli | 22 +- compiler/lcalc/compile_without_exceptions.ml | 342 ++-- compiler/lcalc/compile_without_exceptions.mli | 25 +- compiler/lcalc/optimizations.ml | 79 +- compiler/lcalc/optimizations.mli | 18 +- compiler/lcalc/print.ml | 143 +- compiler/lcalc/print.mli | 34 +- compiler/lcalc/to_ocaml.ml | 315 ++-- compiler/lcalc/to_ocaml.mli | 21 +- compiler/literate/html.ml | 109 +- compiler/literate/html.mli | 31 +- compiler/literate/latex.ml | 82 +- compiler/literate/latex.mli | 31 +- compiler/literate/literate_common.ml | 22 +- compiler/literate/literate_common.mli | 32 +- compiler/runtime.ml | 142 +- compiler/runtime.mli | 94 +- compiler/scalc/ast.ml | 25 +- compiler/scalc/compile_from_lambda.ml | 146 +- compiler/scalc/print.ml | 183 +- compiler/scalc/print.mli | 25 +- compiler/scalc/to_python.ml | 278 +-- compiler/scalc/to_python.mli | 21 +- compiler/scopelang/ast.ml | 85 +- compiler/scopelang/ast.mli | 68 +- compiler/scopelang/dependency.ml | 133 +- compiler/scopelang/dependency.mli | 39 +- compiler/scopelang/print.ml | 204 ++- compiler/scopelang/print.mli | 23 +- compiler/scopelang/scope_to_dcalc.ml | 352 ++-- compiler/scopelang/scope_to_dcalc.mli | 28 +- compiler/surface/ast.ml | 412 ++++- compiler/surface/desugaring.ml | 859 +++++++--- compiler/surface/desugaring.mli | 22 +- compiler/surface/fill_positions.ml | 25 +- compiler/surface/fill_positions.mli | 22 +- compiler/surface/lexer_common.ml | 75 +- compiler/surface/lexer_common.mli | 43 +- compiler/surface/lexer_en.mli | 19 +- compiler/surface/lexer_fr.mli | 19 +- compiler/surface/lexer_pl.mli | 19 +- compiler/surface/name_resolution.ml | 373 +++-- compiler/surface/name_resolution.mli | 93 +- compiler/surface/parse_utils.ml | 18 +- compiler/surface/parse_utils.mli | 18 +- compiler/surface/parser_driver.ml | 189 ++- compiler/surface/parser_driver.mli | 18 +- compiler/surface/parser_errors.mli | 18 +- compiler/surface/print.ml | 18 +- compiler/surface/print.mli | 18 +- compiler/utils/cli.ml | 180 +- compiler/utils/cli.mli | 45 +- compiler/utils/errors.ml | 38 +- compiler/utils/errors.mli | 27 +- compiler/utils/pos.ml | 111 +- compiler/utils/pos.mli | 52 +- compiler/utils/uid.ml | 25 +- compiler/utils/uid.mli | 39 +- compiler/verification/conditions.ml | 159 +- compiler/verification/conditions.mli | 36 +- compiler/verification/io.ml | 85 +- compiler/verification/io.mli | 51 +- compiler/verification/solver.ml | 41 +- compiler/verification/solver.mli | 23 +- compiler/verification/z3backend.ml | 527 +++--- compiler/verification/z3backend.mli | 19 +- french_law/ocaml/api.ml | 35 +- french_law/ocaml/api.mli | 18 +- french_law/ocaml/api_web.ml | 99 +- french_law/ocaml/bench.ml | 64 +- .../law_source/allocations_familiales.ml | 1490 ++++++++++++----- .../law_source/allocations_familiales.mli | 23 +- 103 files changed, 7592 insertions(+), 4279 deletions(-) diff --git a/build_system/clerk.ml b/build_system/clerk.ml index f0991b63..a27c2303 100644 --- a/build_system/clerk.ml +++ b/build_system/clerk.ml @@ -1,15 +1,18 @@ -(* This file is part of the Catala build system, a specification language for tax and social - benefits computation rules. Copyright (C) 2020 Inria, contributors: Denis Merigoux - , Emile Rolley +(* This file is part of the Catala build system, a specification language for + tax and social benefits computation rules. Copyright (C) 2020 Inria, + contributors: Denis Merigoux , Emile Rolley + - 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 + 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 + 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. *) let () = Clerk_driver.main () diff --git a/build_system/clerk_driver.ml b/build_system/clerk_driver.ml index 6c010d24..c0d5fe7e 100644 --- a/build_system/clerk_driver.ml +++ b/build_system/clerk_driver.ml @@ -1,15 +1,18 @@ -(* This file is part of the Catala build system, a specification language for tax and social - benefits computation rules. Copyright (C) 2020 Inria, contributors: Denis Merigoux - , Emile Rolley +(* This file is part of the Catala build system, a specification language for + tax and social benefits computation rules. Copyright (C) 2020 Inria, + contributors: Denis Merigoux , Emile Rolley + - 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 + 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 + 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. *) open Cmdliner @@ -21,7 +24,8 @@ module Nj = Ninja_utils let files_or_folders = Arg.( - non_empty & pos_right 0 file [] & info [] ~docv:"FILE(S)" ~doc:"File(s) or folder(s) to process") + non_empty & pos_right 0 file [] + & info [] ~docv:"FILE(S)" ~doc:"File(s) or folder(s) to process") let command = Arg.( @@ -29,21 +33,23 @@ let command = & pos 0 (some string) None & info [] ~docv:"COMMAND" ~doc:"Command selection among: test, run") -let debug = Arg.(value & flag & info [ "debug"; "d" ] ~doc:"Prints debug information") +let debug = + Arg.(value & flag & info [ "debug"; "d" ] ~doc:"Prints debug information") let reset_test_outputs = Arg.( value & flag & info [ "r"; "reset" ] ~doc: - "Used with the `test` command, resets the test output to whatever is output by the \ - Catala compiler.") + "Used with the `test` command, resets the test output to whatever is \ + output by the Catala compiler.") let catalac = Arg.( value & opt (some string) None - & info [ "e"; "exe" ] ~docv:"EXE" ~doc:"Catala compiler executable, defaults to `catala`") + & info [ "e"; "exe" ] ~docv:"EXE" + ~doc:"Catala compiler executable, defaults to `catala`") let ninja_output = Arg.( @@ -51,22 +57,25 @@ let ninja_output = & opt (some string) None & info [ "o"; "output" ] ~docv:"OUTPUT" ~doc: - "$(i, OUTPUT) is the file that will contain the build.ninja file output. If not \ - specified, the build.ninja file will be outputed in the temporary directory of the \ - system.") + "$(i, OUTPUT) is the file that will contain the build.ninja file \ + output. If not specified, the build.ninja file will be outputed in \ + the temporary directory of the system.") let scope = Arg.( value & opt (some string) None & info [ "s"; "scope" ] ~docv:"SCOPE" - ~doc:"Used with the `run` command, selects which scope of a given Catala file to run.") + ~doc: + "Used with the `run` command, selects which scope of a given Catala \ + file to run.") let catala_opts = Arg.( value & opt (some string) None - & info [ "c"; "catala-opts" ] ~docv:"LANG" ~doc:"Options to pass to the Catala compiler") + & info [ "c"; "catala-opts" ] ~docv:"LANG" + ~doc:"Options to pass to the Catala compiler") let clerk_t f = Term.( @@ -77,29 +86,34 @@ let version = "0.5.0" let info = let doc = - "Build system for Catala, a specification language for tax and social benefits computation \ - rules." + "Build system for Catala, a specification language for tax and social \ + benefits computation rules." in let man = [ `S Manpage.s_description; `P - "$(b,clerk) is a build system for Catala, a specification language for tax and social \ - benefits computation rules"; + "$(b,clerk) is a build system for Catala, a specification language for \ + tax and social benefits computation rules"; `S Manpage.s_commands; `I ( "test", - "Tests a Catala source file given expected outputs provided in a directory called \ - `output` at the same level that the tested file. If the tested file is `foo.catala_en`, \ - then `output` should contain expected output files like `foo.catala_en.$(i,BACKEND)` \ - where $(i,BACKEND) is chosen among: `Interpret`, `Dcalc`, `Scalc`, `Lcalc`, \ - `Typecheck, `Scopelang`, `html`, `tex`, `py`, `ml` and `d` (for Makefile dependencies). \ - For the `Interpret` backend, the scope to test is selected by naming the expected \ - output file `foo.catala_en.$(i,SCOPE).interpret`. When the argument of $(b,clerk) is a \ - folder, it recursively looks for Catala files coupled with `output` directories and \ - matching expected output on which to perform tests." ); + "Tests a Catala source file given expected outputs provided in a \ + directory called `output` at the same level that the tested file. \ + If the tested file is `foo.catala_en`, then `output` should contain \ + expected output files like `foo.catala_en.$(i,BACKEND)` where \ + $(i,BACKEND) is chosen among: `Interpret`, `Dcalc`, `Scalc`, \ + `Lcalc`, `Typecheck, `Scopelang`, `html`, `tex`, `py`, `ml` and `d` \ + (for Makefile dependencies). For the `Interpret` backend, the scope \ + to test is selected by naming the expected output file \ + `foo.catala_en.$(i,SCOPE).interpret`. When the argument of \ + $(b,clerk) is a folder, it recursively looks for Catala files \ + coupled with `output` directories and matching expected output on \ + which to perform tests." ); `I - ("run", "Runs the Catala interpreter on a given scope of a given file. See the `-s` option."); + ( "run", + "Runs the Catala interpreter on a given scope of a given file. See \ + the `-s` option." ); `S Manpage.s_authors; `P "Denis Merigoux "; `P "Emile Rolley "; @@ -107,7 +121,8 @@ let info = `P "Typical usage:"; `Pre "clerk test file.catala_en"; `S Manpage.s_bugs; - `P "Please file bug reports at https://github.com/CatalaLang/catala/issues"; + `P + "Please file bug reports at https://github.com/CatalaLang/catala/issues"; ] in let exits = Term.default_exits @ [ Term.exit_info ~doc:"on error." 1 ] in @@ -140,8 +155,8 @@ type expected_output_descr = { let catala_suffix_regex = Re.Pcre.regexp "\\.catala_(\\w){2}" -let filename_to_expected_output_descr (output_dir : string) (filename : string) : - expected_output_descr option = +let filename_to_expected_output_descr (output_dir : string) (filename : string) + : expected_output_descr option = let complete_filename = filename in let first_extension = Filename.extension filename in let filename = Filename.remove_extension filename in @@ -166,16 +181,19 @@ let filename_to_expected_output_descr (output_dir : string) (filename : string) | Some backend -> let second_extension = Filename.extension filename in let base_filename, scope = - if Re.Pcre.pmatch ~rex:catala_suffix_regex second_extension then (filename, None) + if Re.Pcre.pmatch ~rex:catala_suffix_regex second_extension then + (filename, None) else let scope_name_regex = Re.Pcre.regexp "\\.(.+)" in - let scope_name = (Re.Pcre.extract ~rex:scope_name_regex second_extension).(1) in + let scope_name = + (Re.Pcre.extract ~rex:scope_name_regex second_extension).(1) + in (Filename.remove_extension filename, Some scope_name) in Some { output_dir; complete_filename; base_filename; backend; scope } -(** [readdir_sort dirname] returns the sorted subdirectories of [dirname] in an array or an empty - array if the [dirname] doesn't exist. *) +(** [readdir_sort dirname] returns the sorted subdirectories of [dirname] in an + array or an empty array if the [dirname] doesn't exist. *) let readdir_sort (dirname : string) : string array = try let dirs = Sys.readdir dirname in @@ -183,8 +201,8 @@ let readdir_sort (dirname : string) : string array = dirs with Sys_error _ -> Array.make 0 "" -(** Given a file, looks in the relative [output] directory if there are files with the same base - name that contain expected outputs for different *) +(** Given a file, looks in the relative [output] directory if there are files + with the same base name that contain expected outputs for different *) let search_for_expected_outputs (file : string) : expected_output_descr list = let output_dir = Filename.dirname file ^ Filename.dir_sep ^ "output/" in let output_files = readdir_sort output_dir in @@ -193,13 +211,17 @@ let search_for_expected_outputs (file : string) : expected_output_descr list = match filename_to_expected_output_descr output_dir output_file with | None -> None | Some expected_output -> - if expected_output.base_filename = Filename.basename file then Some expected_output + if expected_output.base_filename = Filename.basename file then + Some expected_output else None) (Array.to_list output_files) -let add_reset_rules_aux ~(redirect : string) ~(with_scope_output_rule : string) - ~(without_scope_output_rule : string) (catala_exe_opts : string) (rules : Rule.t Nj.RuleMap.t) : - Rule.t Nj.RuleMap.t = +let add_reset_rules_aux + ~(redirect : string) + ~(with_scope_output_rule : string) + ~(without_scope_output_rule : string) + (catala_exe_opts : string) + (rules : Rule.t Nj.RuleMap.t) : Rule.t Nj.RuleMap.t = let reset_common_cmd_exprs = Nj.Expr. [ @@ -215,7 +237,10 @@ let add_reset_rules_aux ~(redirect : string) ~(with_scope_output_rule : string) let reset_with_scope_rule = Nj.Rule.make with_scope_output_rule ~command: - Nj.Expr.(Seq ([ Lit catala_exe_opts; Lit "-s"; Var "scope" ] @ reset_common_cmd_exprs)) + Nj.Expr.( + Seq + ([ Lit catala_exe_opts; Lit "-s"; Var "scope" ] + @ reset_common_cmd_exprs)) ~description: Nj.Expr.( Seq @@ -249,13 +274,19 @@ let add_reset_rules_aux ~(redirect : string) ~(with_scope_output_rule : string) |> add reset_with_scope_rule.name reset_with_scope_rule |> add reset_without_scope_rule.name reset_without_scope_rule) -let add_test_rules_aux ~(test_common_cmd_exprs : Expr.t list) ~(with_scope_output_rule : string) - ~(without_scope_output_rule : string) (catala_exe_opts : string) (rules : Rule.t Nj.RuleMap.t) : - Rule.t Nj.RuleMap.t = +let add_test_rules_aux + ~(test_common_cmd_exprs : Expr.t list) + ~(with_scope_output_rule : string) + ~(without_scope_output_rule : string) + (catala_exe_opts : string) + (rules : Rule.t Nj.RuleMap.t) : Rule.t Nj.RuleMap.t = let test_with_scope_rule = Nj.Rule.make with_scope_output_rule ~command: - Nj.Expr.(Seq ([ Lit catala_exe_opts; Lit "-s"; Var "scope" ] @ test_common_cmd_exprs)) + Nj.Expr.( + Seq + ([ Lit catala_exe_opts; Lit "-s"; Var "scope" ] + @ test_common_cmd_exprs)) ~description: Nj.Expr.( Seq @@ -276,7 +307,11 @@ let add_test_rules_aux ~(test_common_cmd_exprs : Expr.t list) ~(with_scope_outpu Nj.Expr.( Seq [ - Lit "TEST on file"; Var "tested_file"; Lit "with the"; Var "catala_cmd"; Lit "command"; + Lit "TEST on file"; + Var "tested_file"; + Lit "with the"; + Var "catala_cmd"; + Lit "command"; ]) in Nj.RuleMap.( @@ -284,15 +319,18 @@ let add_test_rules_aux ~(test_common_cmd_exprs : Expr.t list) ~(with_scope_outpu |> add test_with_scope_rule.name test_with_scope_rule |> add test_without_scope_rule.name test_without_scope_rule) -(** [add_reset_rules catala_exe_opts rules] adds ninja rules used to reset test files into [rules] - and returns it.*) -let add_reset_rules (catala_exe_opts : string) (rules : Rule.t Nj.RuleMap.t) : Rule.t Nj.RuleMap.t = +(** [add_reset_rules catala_exe_opts rules] adds ninja rules used to reset test + files into [rules] and returns it.*) +let add_reset_rules (catala_exe_opts : string) (rules : Rule.t Nj.RuleMap.t) : + Rule.t Nj.RuleMap.t = add_reset_rules_aux ~with_scope_output_rule:"reset_with_scope" - ~without_scope_output_rule:"reset_without_scope" ~redirect:">" catala_exe_opts rules + ~without_scope_output_rule:"reset_without_scope" ~redirect:">" + catala_exe_opts rules -(** [add_test_rules catala_exe_opts rules] adds ninja rules used to test files into [rules] and - returns it.*) -let add_test_rules (catala_exe_opts : string) (rules : Rule.t Nj.RuleMap.t) : Rule.t Nj.RuleMap.t = +(** [add_test_rules catala_exe_opts rules] adds ninja rules used to test files + into [rules] and returns it.*) +let add_test_rules (catala_exe_opts : string) (rules : Rule.t Nj.RuleMap.t) : + Rule.t Nj.RuleMap.t = let test_common_cmd_exprs = Nj.Expr. [ @@ -305,19 +343,23 @@ let add_test_rules (catala_exe_opts : string) (rules : Rule.t Nj.RuleMap.t) : Ru Lit "-"; ] in - add_test_rules_aux ~test_common_cmd_exprs ~with_scope_output_rule:"test_with_scope" + add_test_rules_aux ~test_common_cmd_exprs + ~with_scope_output_rule:"test_with_scope" ~without_scope_output_rule:"test_without_scope" catala_exe_opts rules -(** [add_reset_with_ouput_rules catala_exe_opts rules] adds ninja rules used to reset test files - using an output flag into [rules] and returns it.*) -let add_reset_with_output_rules (catala_exe_opts : string) (rules : Rule.t Nj.RuleMap.t) : +(** [add_reset_with_ouput_rules catala_exe_opts rules] adds ninja rules used to + reset test files using an output flag into [rules] and returns it.*) +let add_reset_with_output_rules + (catala_exe_opts : string) (rules : Rule.t Nj.RuleMap.t) : Rule.t Nj.RuleMap.t = add_reset_rules_aux ~with_scope_output_rule:"reset_with_scope_and_output" - ~without_scope_output_rule:"reset_without_scope_and_output" ~redirect:"-o" catala_exe_opts rules + ~without_scope_output_rule:"reset_without_scope_and_output" ~redirect:"-o" + catala_exe_opts rules -(** [add_test_with_output_rules catala_exe_opts rules] adds ninja rules used to test files using an - output flag into [rules] and returns it.*) -let add_test_with_output_rules (catala_exe_opts : string) (rules : Rule.t Nj.RuleMap.t) : +(** [add_test_with_output_rules catala_exe_opts rules] adds ninja rules used to + test files using an output flag into [rules] and returns it.*) +let add_test_with_output_rules + (catala_exe_opts : string) (rules : Rule.t Nj.RuleMap.t) : Rule.t Nj.RuleMap.t = let test_common_cmd_exprs = Nj.Expr. @@ -333,35 +375,44 @@ let add_test_with_output_rules (catala_exe_opts : string) (rules : Rule.t Nj.Rul Var "tmp_file"; ] in - add_test_rules_aux ~test_common_cmd_exprs ~with_scope_output_rule:"test_with_scope_and_output" - ~without_scope_output_rule:"test_without_scope_and_output" catala_exe_opts rules + add_test_rules_aux ~test_common_cmd_exprs + ~with_scope_output_rule:"test_with_scope_and_output" + ~without_scope_output_rule:"test_without_scope_and_output" catala_exe_opts + rules -(** [ninja_start catala_exe] returns the inital [ninja] data structure with rules needed to reset - and test files. *) +(** [ninja_start catala_exe] returns the inital [ninja] data structure with + rules needed to reset and test files. *) let ninja_start (catala_exe : string) (catala_opts : string) : ninja = let catala_exe_opts = catala_exe ^ " " ^ catala_opts in let run_and_display_final_message = Nj.Rule.make "run_and_display_final_message" ~command:Nj.Expr.(Seq [ Lit ":" ]) - ~description:Nj.Expr.(Seq [ Lit "All tests"; Var "test_file_or_folder"; Lit "passed!" ]) + ~description: + Nj.Expr.( + Seq [ Lit "All tests"; Var "test_file_or_folder"; Lit "passed!" ]) in { rules = Nj.RuleMap.( - empty |> add_reset_rules catala_exe_opts |> add_test_rules catala_exe_opts + empty + |> add_reset_rules catala_exe_opts + |> add_test_rules catala_exe_opts |> add_test_with_output_rules catala_exe_opts |> add_reset_with_output_rules catala_exe_opts |> add run_and_display_final_message.name run_and_display_final_message); builds = Nj.BuildMap.empty; } -(** [collect_all_ninja_build ninja tested_file catala_exe catala_opts reset_test_outputs] creates - and returns all ninja build statements needed to test the [tested_file]. *) -let collect_all_ninja_build (ninja : ninja) (tested_file : string) (reset_test_outputs : bool) : +(** [collect_all_ninja_build ninja tested_file catala_exe catala_opts reset_test_outputs] + creates and returns all ninja build statements needed to test the + [tested_file]. *) +let collect_all_ninja_build + (ninja : ninja) (tested_file : string) (reset_test_outputs : bool) : (string * ninja) option = let expected_outputs = search_for_expected_outputs tested_file in if List.length expected_outputs = 0 then ( - Cli.debug_print "No expected outputs were found for test file %s" tested_file; + Cli.debug_print "No expected outputs were found for test file %s" + tested_file; None) else let ninja, test_names = @@ -369,58 +420,80 @@ let collect_all_ninja_build (ninja : ninja) (tested_file : string) (reset_test_o (fun (ninja, test_names) expected_output -> let vars = [ - ("catala_cmd", Nj.Expr.Lit (catala_backend_to_string expected_output.backend)); + ( "catala_cmd", + Nj.Expr.Lit (catala_backend_to_string expected_output.backend) + ); ("tested_file", Nj.Expr.Lit tested_file); ( "expected_output", - Nj.Expr.Lit (expected_output.output_dir ^ expected_output.complete_filename) ); + Nj.Expr.Lit + (expected_output.output_dir + ^ expected_output.complete_filename) ); ] in - let output_build_kind = if reset_test_outputs then "reset" else "test" in - let catala_backend = catala_backend_to_string expected_output.backend in + let output_build_kind = + if reset_test_outputs then "reset" else "test" + in + let catala_backend = + catala_backend_to_string expected_output.backend + in let get_rule_infos ?(rule_postfix = "") : - string option -> string * string * (string * Nj.Expr.t) list = function + string option -> string * string * (string * Nj.Expr.t) list = + function | Some scope -> - ( Printf.sprintf "%s_%s_%s_%s" output_build_kind scope catala_backend tested_file + ( Printf.sprintf "%s_%s_%s_%s" output_build_kind scope + catala_backend tested_file |> Nj.Build.unpath, output_build_kind ^ "_with_scope" ^ rule_postfix, ("scope", Nj.Expr.Lit scope) :: vars ) | None -> - ( Printf.sprintf "%s_%s_%s" output_build_kind catala_backend tested_file + ( Printf.sprintf "%s_%s_%s" output_build_kind catala_backend + tested_file |> Nj.Build.unpath, output_build_kind ^ "_without_scope" ^ rule_postfix, vars ) in - let ninja_add_new_rule (rule_output : string) (rule : string) - (vars : (string * Nj.Expr.t) list) (ninja : ninja) : ninja = + let ninja_add_new_rule + (rule_output : string) + (rule : string) + (vars : (string * Nj.Expr.t) list) + (ninja : ninja) : ninja = { ninja with builds = Nj.BuildMap.add rule_output - (Nj.Build.make_with_vars ~outputs:[ Nj.Expr.Lit rule_output ] ~rule ~vars) + (Nj.Build.make_with_vars + ~outputs:[ Nj.Expr.Lit rule_output ] + ~rule ~vars) ninja.builds; } in match expected_output.backend with - | Cli.Interpret | Cli.Proof | Cli.Typecheck | Cli.Dcalc | Cli.Scopelang | Cli.Scalc - | Cli.Lcalc -> - let rule_output, rule_name, rule_vars = get_rule_infos expected_output.scope in + | Cli.Interpret | Cli.Proof | Cli.Typecheck | Cli.Dcalc + | Cli.Scopelang | Cli.Scalc | Cli.Lcalc -> + let rule_output, rule_name, rule_vars = + get_rule_infos expected_output.scope + in let rule_vars = match expected_output.backend with | Cli.Proof -> - ("extra_flags", Nj.Expr.Lit "--disable_counterexamples") :: rule_vars - (* Counterexamples can be different at each call because of the randomness - inside SMT solver, so we can't expect their value to remain constant. Hence - we disable the counterexamples when testing the replication of failed + ("extra_flags", Nj.Expr.Lit "--disable_counterexamples") + :: rule_vars + (* Counterexamples can be different at each call because of + the randomness inside SMT solver, so we can't expect + their value to remain constant. Hence we disable the + counterexamples when testing the replication of failed proofs. *) | _ -> rule_vars in ( ninja_add_new_rule rule_output rule_name rule_vars ninja, test_names ^ " $\n " ^ rule_output ) | Cli.Python | Cli.OCaml | Cli.Latex | Cli.Html | Cli.Makefile -> - let tmp_file = Filename.temp_file "clerk_" ("_" ^ catala_backend) in + let tmp_file = + Filename.temp_file "clerk_" ("_" ^ catala_backend) + in let rule_output, rule_name, rule_vars = get_rule_infos ~rule_postfix:"_and_output" expected_output.scope in @@ -441,36 +514,50 @@ let collect_all_ninja_build (ninja : ninja) (tested_file : string) (reset_test_o ninja with builds = Nj.BuildMap.add test_name - (Nj.Build.make_with_inputs ~outputs:[ Nj.Expr.Lit test_name ] ~rule:"phony" - ~inputs:[ Nj.Expr.Lit test_names ]) + (Nj.Build.make_with_inputs ~outputs:[ Nj.Expr.Lit test_name ] + ~rule:"phony" ~inputs:[ Nj.Expr.Lit test_names ]) ninja.builds; } ) -(** [add_root_test_build ninja all_file_names all_test_builds] add the 'test' ninja build - declaration calling the rule 'run_and_display_final_message' for [all_test_builds] which - correspond to [all_file_names]. *) -let add_root_test_build (ninja : ninja) (all_file_names : string list) (all_test_builds : string) : +(** [add_root_test_build ninja all_file_names all_test_builds] add the 'test' + ninja build declaration calling the rule 'run_and_display_final_message' for + [all_test_builds] which correspond to [all_file_names]. *) +let add_root_test_build + (ninja : ninja) (all_file_names : string list) (all_test_builds : string) : ninja = let file_names_str = List.hd all_file_names ^ "" - ^ List.fold_left (fun acc name -> acc ^ "; " ^ name) "" (List.tl all_file_names) + ^ List.fold_left + (fun acc name -> acc ^ "; " ^ name) + "" (List.tl all_file_names) in { ninja with builds = Nj.BuildMap.add "test" (Nj.Build.make_with_vars_and_inputs ~outputs:[ Nj.Expr.Lit "test" ] - ~rule:"run_and_display_final_message" ~inputs:[ Nj.Expr.Lit all_test_builds ] - ~vars:[ ("test_file_or_folder", Nj.Expr.Lit ("in [ " ^ file_names_str ^ " ]")) ]) + ~rule:"run_and_display_final_message" + ~inputs:[ Nj.Expr.Lit all_test_builds ] + ~vars: + [ + ( "test_file_or_folder", + Nj.Expr.Lit ("in [ " ^ file_names_str ^ " ]") ); + ]) ninja.builds; } (**{1 Running}*) -let run_file (file : string) (catala_exe : string) (catala_opts : string) (scope : string) : int = +let run_file + (file : string) + (catala_exe : string) + (catala_opts : string) + (scope : string) : int = let command = String.concat " " - (List.filter (fun s -> s <> "") [ catala_exe; catala_opts; "-s " ^ scope; "Interpret"; file ]) + (List.filter + (fun s -> s <> "") + [ catala_exe; catala_opts; "-s " ^ scope; "Interpret"; file ]) in Cli.debug_print "Running: %s" command; Sys.command command @@ -503,11 +590,13 @@ type ninja_building_context = { all_test_builds : string; all_failed_names : string list; } -(** Record used to keep tracks of the current context while building the [Ninja_utils.ninja].*) +(** Record used to keep tracks of the current context while building the + [Ninja_utils.ninja].*) -(** [ninja_building_context_init ninja_init] returns the empty context corresponding to - [ninja_init]. *) -let ninja_building_context_init (ninja_init : Nj.ninja) : ninja_building_context = +(** [ninja_building_context_init ninja_init] returns the empty context + corresponding to [ninja_init]. *) +let ninja_building_context_init (ninja_init : Nj.ninja) : ninja_building_context + = { last_valid_ninja = ninja_init; curr_ninja = Some ninja_init; @@ -516,9 +605,13 @@ let ninja_building_context_init (ninja_init : Nj.ninja) : ninja_building_context all_failed_names = []; } -(** [collect_in_directory ctx file_or_folder ninja_start reset_test_outputs] updates the building - context [ctx] by adding new ninja build statements needed to test files in [folder].*) -let collect_in_folder (ctx : ninja_building_context) (folder : string) (ninja_start : Nj.ninja) +(** [collect_in_directory ctx file_or_folder ninja_start reset_test_outputs] + updates the building context [ctx] by adding new ninja build statements + needed to test files in [folder].*) +let collect_in_folder + (ctx : ninja_building_context) + (folder : string) + (ninja_start : Nj.ninja) (reset_test_outputs : bool) : ninja_building_context = let ninja, test_file_names = List.fold_left @@ -527,11 +620,14 @@ let collect_in_folder (ctx : ninja_building_context) (folder : string) (ninja_st | None -> (* Skips none Catala file. *) (ninja, test_file_names) - | Some (test_file_name, ninja) -> (ninja, test_file_names ^ " $\n " ^ test_file_name)) + | Some (test_file_name, ninja) -> + (ninja, test_file_names ^ " $\n " ^ test_file_name)) (ninja_start, "") (get_catala_files_in_folder folder) in - let test_dir_name = Printf.sprintf "test_dir_%s" (folder |> Nj.Build.unpath) in + let test_dir_name = + Printf.sprintf "test_dir_%s" (folder |> Nj.Build.unpath) + in let curr_ninja = if 0 = String.length test_file_names then None else @@ -540,9 +636,15 @@ let collect_in_folder (ctx : ninja_building_context) (folder : string) (ninja_st ninja with builds = Nj.BuildMap.add test_dir_name - (Nj.Build.make_with_vars_and_inputs ~outputs:[ Nj.Expr.Lit test_dir_name ] - ~rule:"run_and_display_final_message" ~inputs:[ Nj.Expr.Lit test_file_names ] - ~vars:[ ("test_file_or_folder", Nj.Expr.Lit ("in folder '" ^ folder ^ "'")) ]) + (Nj.Build.make_with_vars_and_inputs + ~outputs:[ Nj.Expr.Lit test_dir_name ] + ~rule:"run_and_display_final_message" + ~inputs:[ Nj.Expr.Lit test_file_names ] + ~vars: + [ + ( "test_file_or_folder", + Nj.Expr.Lit ("in folder '" ^ folder ^ "'") ); + ]) ninja.builds; } in @@ -562,9 +664,13 @@ let collect_in_folder (ctx : ninja_building_context) (folder : string) (ninja_st all_failed_names = folder :: ctx.all_failed_names; } -(** [collect_in_file ctx file_or_folder ninja_start reset_test_outputs] updates the building context - [ctx] by adding new ninja build statements needed to test the [tested_file].*) -let collect_in_file (ctx : ninja_building_context) (tested_file : string) (ninja_start : Nj.ninja) +(** [collect_in_file ctx file_or_folder ninja_start reset_test_outputs] updates + the building context [ctx] by adding new ninja build statements needed to + test the [tested_file].*) +let collect_in_file + (ctx : ninja_building_context) + (tested_file : string) + (ninja_start : Nj.ninja) (reset_test_outputs : bool) : ninja_building_context = match collect_all_ninja_build ninja_start tested_file reset_test_outputs with | Some (test_file_name, ninja) -> @@ -586,35 +692,47 @@ let collect_in_file (ctx : ninja_building_context) (tested_file : string) (ninja (** {1 Return code values} *) let return_ok = 0 - let return_err = 1 (** {1 Driver} *) -(** [add_root_test_build ctx files_or_folders reset_test_outputs] updates the [ctx] by adding ninja - build statements needed to test or [reset_test_outputs] [files_or_folders]. *) -let add_test_builds (ctx : ninja_building_context) (files_or_folders : string list) +(** [add_root_test_build ctx files_or_folders reset_test_outputs] updates the + [ctx] by adding ninja build statements needed to test or + [reset_test_outputs] [files_or_folders]. *) +let add_test_builds + (ctx : ninja_building_context) + (files_or_folders : string list) (reset_test_outputs : bool) : ninja_building_context = files_or_folders |> List.fold_left (fun ctx file_or_folder -> let curr_ninja = - match ctx.curr_ninja with Some ninja -> ninja | None -> ctx.last_valid_ninja + match ctx.curr_ninja with + | Some ninja -> ninja + | None -> ctx.last_valid_ninja in if Sys.is_directory file_or_folder then collect_in_folder ctx file_or_folder curr_ninja reset_test_outputs else collect_in_file ctx file_or_folder curr_ninja reset_test_outputs) ctx -let driver (files_or_folders : string list) (command : string) (catala_exe : string option) - (catala_opts : string option) (debug : bool) (scope : string option) (reset_test_outputs : bool) +let driver + (files_or_folders : string list) + (command : string) + (catala_exe : string option) + (catala_opts : string option) + (debug : bool) + (scope : string option) + (reset_test_outputs : bool) (ninja_output : string option) : int = if debug then Cli.debug_flag := true; let files_or_folders = List.sort_uniq String.compare files_or_folders and catala_exe = Option.fold ~none:"catala" ~some:Fun.id catala_exe and catala_opts = Option.fold ~none:"" ~some:Fun.id catala_opts and ninja_output = - Option.fold ~none:(Filename.temp_file "clerk_build" ".ninja") ~some:Fun.id ninja_output + Option.fold + ~none:(Filename.temp_file "clerk_build" ".ninja") + ~some:Fun.id ninja_output in match String.lowercase_ascii command with | "test" -> ( @@ -625,7 +743,11 @@ let driver (files_or_folders : string list) (command : string) (catala_exe : str files_or_folders reset_test_outputs in let there_is_some_fails = 0 <> List.length ctx.all_failed_names in - let ninja = match ctx.curr_ninja with Some ninja -> ninja | None -> ctx.last_valid_ninja in + let ninja = + match ctx.curr_ninja with + | Some ninja -> ninja + | None -> ctx.last_valid_ninja + in if there_is_some_fails then List.iter (fun f -> @@ -633,7 +755,8 @@ let driver (files_or_folders : string list) (command : string) (catala_exe : str |> Cli.with_style [ ANSITerminal.magenta ] "%s" |> Cli.warning_print "No test case found for %s") ctx.all_failed_names; - if 0 = List.compare_lengths ctx.all_failed_names files_or_folders then return_ok + if 0 = List.compare_lengths ctx.all_failed_names files_or_folders then + return_ok else try let out = open_out ninja_output in diff --git a/build_system/ninja_utils.ml b/build_system/ninja_utils.ml index 2bd64a66..83d2f365 100644 --- a/build_system/ninja_utils.ml +++ b/build_system/ninja_utils.ml @@ -1,15 +1,17 @@ -(* This file is part of the Catala build system, a specification language for tax and social - benefits computation rules. Copyright (C) 2020 Inria, contributor: Emile Rolley - +(* This file is part of the Catala build system, a specification language for + tax and social benefits computation rules. Copyright (C) 2020 Inria, + contributor: Emile Rolley - 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 + 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 + 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. *) module Expr = struct @@ -23,7 +25,8 @@ module Expr = struct and format_list fmt = function | hd :: tl -> Format.fprintf fmt "%a%a" format hd - (fun fmt tl -> tl |> List.iter (fun s -> Format.fprintf fmt " %a" format s)) + (fun fmt tl -> + tl |> List.iter (fun s -> Format.fprintf fmt " %a" format s)) tl | [] -> () end @@ -31,15 +34,16 @@ end module Rule = struct type t = { name : string; command : Expr.t; description : Expr.t option } - let make name ~command ~description = { name; command; description = Option.some description } + let make name ~command ~description = + { name; command; description = Option.some description } let format fmt rule = let format_description fmt = function | Some e -> Format.fprintf fmt " description = %a\n" Expr.format e | None -> Format.fprintf fmt "\n" in - Format.fprintf fmt "rule %s\n command = %a\n%a" rule.name Expr.format rule.command - format_description rule.description + Format.fprintf fmt "rule %s\n command = %a\n%a" rule.name Expr.format + rule.command format_description rule.description end module Build = struct @@ -52,7 +56,8 @@ module Build = struct let make ~outputs ~rule = { outputs; rule; inputs = Option.none; vars = [] } - let make_with_vars ~outputs ~rule ~vars = { outputs; rule; inputs = Option.none; vars } + let make_with_vars ~outputs ~rule ~vars = + { outputs; rule; inputs = Option.none; vars } let make_with_inputs ~outputs ~rule ~inputs = { outputs; rule; inputs = Option.some inputs; vars = [] } @@ -62,21 +67,24 @@ module Build = struct let empty = make ~outputs:[ Expr.Lit "empty" ] ~rule:"phony" - let unpath ?(sep = "-") path = Re.Pcre.(substitute ~rex:(regexp "/") ~subst:(fun _ -> sep)) path + let unpath ?(sep = "-") path = + Re.Pcre.(substitute ~rex:(regexp "/") ~subst:(fun _ -> sep)) path let format fmt build = let format_inputs fmt = function | Some exs -> Format.fprintf fmt " %a" Expr.format_list exs | None -> () and format_vars fmt vars = - List.iter (fun (name, exp) -> Format.fprintf fmt " %s = %a\n" name Expr.format exp) vars + List.iter + (fun (name, exp) -> + Format.fprintf fmt " %s = %a\n" name Expr.format exp) + vars in - Format.fprintf fmt "build %a: %s%a\n%a" Expr.format_list build.outputs build.rule format_inputs - build.inputs format_vars build.vars + Format.fprintf fmt "build %a: %s%a\n%a" Expr.format_list build.outputs + build.rule format_inputs build.inputs format_vars build.vars end module RuleMap : Map.S with type key = String.t = Map.Make (String) - module BuildMap : Map.S with type key = String.t = Map.Make (String) type ninja = { rules : Rule.t RuleMap.t; builds : Build.t BuildMap.t } @@ -84,6 +92,8 @@ type ninja = { rules : Rule.t RuleMap.t; builds : Build.t BuildMap.t } let empty = { rules = RuleMap.empty; builds = BuildMap.empty } let format fmt ninja = - let format_for_all iter format = iter (fun _name rule -> Format.fprintf fmt "%a\n" format rule) in + let format_for_all iter format = + iter (fun _name rule -> Format.fprintf fmt "%a\n" format rule) + in format_for_all RuleMap.iter Rule.format ninja.rules; format_for_all BuildMap.iter Build.format ninja.builds diff --git a/build_system/tests/test_clerk_driver.ml b/build_system/tests/test_clerk_driver.ml index 24db8893..c413ef5c 100644 --- a/build_system/tests/test_clerk_driver.ml +++ b/build_system/tests/test_clerk_driver.ml @@ -4,15 +4,12 @@ module Nj = Ninja_utils module To_test = struct let ninja_start = D.ninja_start - let add_test_builds = D.add_test_builds end (* cwd: _build/default/build_system/tests/ *) let test_files_dir = "../../../../build_system/tests/catala_files/" - let ninja_start = To_test.ninja_start "catala" "" - let al_assert msg = Al.(check bool) msg true let test_ninja_start () = @@ -22,12 +19,16 @@ let test_ninja_start () = "rule reset_with_scope\n command = catala -s $scope $catala_cmd $tested_file $extra_flags --unstyled > $expected_output 2>&1\n description = RESET scope $scope of file $tested_file with the $catala_cmd command\n\nrule reset_with_scope_and_output\n command = catala -s $scope $catala_cmd $tested_file $extra_flags --unstyled -o $expected_output 2>&1\n description = RESET scope $scope of file $tested_file with the $catala_cmd command\n\nrule reset_without_scope\n command = catala $catala_cmd $tested_file $extra_flags --unstyled > $expected_output 2>&1\n description = RESET file $tested_file with the $catala_cmd command\n\nrule reset_without_scope_and_output\n command = catala $catala_cmd $tested_file $extra_flags --unstyled -o $expected_output 2>&1\n description = RESET file $tested_file with the $catala_cmd command\n\nrule run_and_display_final_message\n command = :\n description = All tests $test_file_or_folder passed!\n\nrule test_with_scope\n command = catala -s $scope $catala_cmd $tested_file $extra_flags --unstyled 2>&1 | colordiff -u -b $expected_output -\n description = TEST scope $scope of file $tested_file with the $catala_cmd command\n\nrule test_with_scope_and_output\n command = catala -s $scope $catala_cmd $tested_file $extra_flags --unstyled -o $tmp_file ; colordiff -u -b $expected_output $tmp_file\n description = TEST scope $scope of file $tested_file with the $catala_cmd command\n\nrule test_without_scope\n command = catala $catala_cmd $tested_file $extra_flags --unstyled 2>&1 | colordiff -u -b $expected_output -\n description = TEST on file $tested_file with the $catala_cmd command\n\nrule test_without_scope_and_output\n command = catala $catala_cmd $tested_file $extra_flags --unstyled -o $tmp_file ; colordiff -u -b $expected_output $tmp_file\n description = TEST on file $tested_file with the $catala_cmd command\n\n"[@ocamlformat "disable"] in let actual_format = Buffer.contents Format.stdbuf in - Al.(check string) "both formated strings should equal" expected_format actual_format + Al.(check string) + "both formated strings should equal" expected_format actual_format let test_add_test_builds_for_folder () = let ctx = D.ninja_building_context_init ninja_start in - let nj_building_ctx = To_test.add_test_builds ctx [ test_files_dir ^ "folder" ] false in - al_assert "a test case should be found" (Option.is_some nj_building_ctx.curr_ninja); + let nj_building_ctx = + To_test.add_test_builds ctx [ test_files_dir ^ "folder" ] false + in + al_assert "a test case should be found" + (Option.is_some nj_building_ctx.curr_ninja); let expected_format = "build test_A_Interpret_..-..-..-..-build_system-tests-catala_files-folder-file1.catala_en: test_with_scope\n scope = A\n catala_cmd = Interpret\n tested_file = ../../../../build_system/tests/catala_files/folder/file1.catala_en\n expected_output = ../../../../build_system/tests/catala_files/folder/output/file1.catala_en.A.Interpret\nbuild test_B_Interpret_..-..-..-..-build_system-tests-catala_files-folder-file1.catala_en: test_with_scope\n scope = B\n catala_cmd = Interpret\n tested_file = ../../../../build_system/tests/catala_files/folder/file1.catala_en\n expected_output = ../../../../build_system/tests/catala_files/folder/output/file1.catala_en.B.Interpret\nbuild test_Proof_..-..-..-..-build_system-tests-catala_files-folder-file3.catala_en: test_without_scope\n extra_flags = --disable_counterexamples\n catala_cmd = Proof\n tested_file = ../../../../build_system/tests/catala_files/folder/file3.catala_en\n expected_output = ../../../../build_system/tests/catala_files/folder/output/file3.catala_en.Proof\nbuild test_Typecheck_..-..-..-..-build_system-tests-catala_files-folder-file2.catala_en: test_without_scope\n catala_cmd = Typecheck\n tested_file = ../../../../build_system/tests/catala_files/folder/file2.catala_en\n expected_output = ../../../../build_system/tests/catala_files/folder/output/file2.catala_en.Typecheck\nbuild test_dir_..-..-..-..-build_system-tests-catala_files-folder: run_and_display_final_message $\n test_file_..-..-..-..-build_system-tests-catala_files-folder-file3.catala_en $\n test_file_..-..-..-..-build_system-tests-catala_files-folder-file2.catala_en $\n test_file_..-..-..-..-build_system-tests-catala_files-folder-file1.catala_en\n test_file_or_folder = in folder '../../../../build_system/tests/catala_files/folder'\nbuild test_file_..-..-..-..-build_system-tests-catala_files-folder-file1.catala_en: phony $\n test_A_Interpret_..-..-..-..-build_system-tests-catala_files-folder-file1.catala_en $\n test_B_Interpret_..-..-..-..-build_system-tests-catala_files-folder-file1.catala_en\nbuild test_file_..-..-..-..-build_system-tests-catala_files-folder-file2.catala_en: phony $\n test_Typecheck_..-..-..-..-build_system-tests-catala_files-folder-file2.catala_en\nbuild test_file_..-..-..-..-build_system-tests-catala_files-folder-file3.catala_en: phony $\n test_Proof_..-..-..-..-build_system-tests-catala_files-folder-file3.catala_en\n"[@ocamlformat "disable"] @@ -35,44 +36,63 @@ let test_add_test_builds_for_folder () = let actual_format = let ninja = Option.get nj_building_ctx.curr_ninja in Buffer.clear Format.stdbuf; - Nj.BuildMap.iter (fun _ b -> Nj.Build.format Format.str_formatter b) ninja.builds; + Nj.BuildMap.iter + (fun _ b -> Nj.Build.format Format.str_formatter b) + ninja.builds; Buffer.contents Format.stdbuf in - Al.(check string) "both formated strings should equal" expected_format actual_format + Al.(check string) + "both formated strings should equal" expected_format actual_format let test_add_test_builds_for_untested_file () = let untested_file = test_files_dir ^ "untested_file.catala_en" in let ctx = D.ninja_building_context_init Nj.empty in let nj_building_ctx = To_test.add_test_builds ctx [ untested_file ] false in - al_assert "no test cases should be found" (Option.is_none nj_building_ctx.curr_ninja); + al_assert "no test cases should be found" + (Option.is_none nj_building_ctx.curr_ninja); al_assert "ninja_start should be the last valid ninja" (Nj.empty = nj_building_ctx.last_valid_ninja) (* Test without comparing formated ninja. *) let test_add_test_builds_for_simple_interpret_scope_file () = - let simple_interpret_scope_file = test_files_dir ^ "simple_interpret_scope_file.catala_en" in + let simple_interpret_scope_file = + test_files_dir ^ "simple_interpret_scope_file.catala_en" + in let ctx = D.ninja_building_context_init ninja_start in - let nj_building_ctx = To_test.add_test_builds ctx [ simple_interpret_scope_file ] false in - al_assert "a test case should be found" (Option.is_some nj_building_ctx.curr_ninja); + let nj_building_ctx = + To_test.add_test_builds ctx [ simple_interpret_scope_file ] false + in + al_assert "a test case should be found" + (Option.is_some nj_building_ctx.curr_ninja); let expected_format = let open Nj in - let test_file_output = "test_file_" ^ Nj.Build.unpath simple_interpret_scope_file in - let test_A_file_output = "test_A_Interpret_" ^ Nj.Build.unpath simple_interpret_scope_file in + let test_file_output = + "test_file_" ^ Nj.Build.unpath simple_interpret_scope_file + in + let test_A_file_output = + "test_A_Interpret_" ^ Nj.Build.unpath simple_interpret_scope_file + in let test_A_file = - Build.make_with_vars ~outputs:[ Expr.Lit test_A_file_output ] ~rule:"test_with_scope" + Build.make_with_vars + ~outputs:[ Expr.Lit test_A_file_output ] + ~rule:"test_with_scope" ~vars: [ ("scope", Lit "A"); ("catala_cmd", Lit "Interpret"); ("tested_file", Lit simple_interpret_scope_file); ( "expected_output", - Lit (test_files_dir ^ "output/simple_interpret_scope_file.catala_en.A.Interpret") ); + Lit + (test_files_dir + ^ "output/simple_interpret_scope_file.catala_en.A.Interpret") ); ] in let test_file = - Build.make_with_inputs ~outputs:[ Expr.Lit test_file_output ] ~rule:"phony" + Build.make_with_inputs + ~outputs:[ Expr.Lit test_file_output ] + ~rule:"phony" ~inputs:[ Expr.Lit (" $\n " ^ test_A_file_output) ] in BuildMap.empty @@ -85,21 +105,28 @@ let test_add_test_builds_for_simple_interpret_scope_file () = let actual_format = let ninja = Option.get nj_building_ctx.curr_ninja in Buffer.clear Format.stdbuf; - Nj.BuildMap.iter (fun _ b -> Nj.Build.format Format.str_formatter b) ninja.builds; + Nj.BuildMap.iter + (fun _ b -> Nj.Build.format Format.str_formatter b) + ninja.builds; Buffer.contents Format.stdbuf in - Al.(check string) "both formated strings should equal" expected_format actual_format + Al.(check string) + "both formated strings should equal" expected_format actual_format let () = Al.run "Clerk_driver" Al. [ ( "Test ninja_start", - [ test_case "initial ninja rules should be present" `Quick test_ninja_start ] ); + [ + test_case "initial ninja rules should be present" `Quick + test_ninja_start; + ] ); ( "Test add_test_builds", [ - test_case "an untested file" `Quick test_add_test_builds_for_untested_file; + test_case "an untested file" `Quick + test_add_test_builds_for_untested_file; test_case "a simple Interpret scope" `Quick test_add_test_builds_for_simple_interpret_scope_file; test_case "a simple folder" `Quick test_add_test_builds_for_folder; diff --git a/compiler/catala.ml b/compiler/catala.ml index 02a21bb8..cf22a6e7 100644 --- a/compiler/catala.ml +++ b/compiler/catala.ml @@ -1,15 +1,17 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux - +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, contributor: + Denis Merigoux - 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 + 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 + 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. *) let _ = Driver.main () diff --git a/compiler/catala_web_interpreter.ml b/compiler/catala_web_interpreter.ml index 26327eb7..16128c59 100644 --- a/compiler/catala_web_interpreter.ml +++ b/compiler/catala_web_interpreter.ml @@ -4,8 +4,11 @@ open Js_of_ocaml let _ = Js.export_all (object%js - method interpret (contents : Js.js_string Js.t) (scope : Js.js_string Js.t) - (language : Js.js_string Js.t) (trace : bool) = + method interpret + (contents : Js.js_string Js.t) + (scope : Js.js_string Js.t) + (language : Js.js_string Js.t) + (trace : bool) = driver (Contents (Js.to_string contents)) { diff --git a/compiler/dcalc/ast.ml b/compiler/dcalc/ast.ml index 6441ffc6..6c4afac5 100644 --- a/compiler/dcalc/ast.ml +++ b/compiler/dcalc/ast.ml @@ -1,31 +1,36 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux - +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, contributor: + Denis Merigoux - 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 + 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 + 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. *) [@@@ocaml.warning "-7-34"] open Utils -module ScopeName : Uid.Id with type info = Uid.MarkedString.info = Uid.Make (Uid.MarkedString) () +module ScopeName : Uid.Id with type info = Uid.MarkedString.info = + Uid.Make (Uid.MarkedString) () -module StructName : Uid.Id with type info = Uid.MarkedString.info = Uid.Make (Uid.MarkedString) () +module StructName : Uid.Id with type info = Uid.MarkedString.info = + Uid.Make (Uid.MarkedString) () module StructFieldName : Uid.Id with type info = Uid.MarkedString.info = Uid.Make (Uid.MarkedString) () module StructMap : Map.S with type key = StructName.t = Map.Make (StructName) -module EnumName : Uid.Id with type info = Uid.MarkedString.info = Uid.Make (Uid.MarkedString) () +module EnumName : Uid.Id with type info = Uid.MarkedString.info = + Uid.Make (Uid.MarkedString) () module EnumConstructor : Uid.Id with type info = Uid.MarkedString.info = Uid.Make (Uid.MarkedString) () @@ -33,9 +38,7 @@ module EnumConstructor : Uid.Id with type info = Uid.MarkedString.info = module EnumMap : Map.S with type key = EnumName.t = Map.Make (EnumName) type typ_lit = TBool | TUnit | TInt | TRat | TMoney | TDate | TDuration - type struct_name = StructName.t - type enum_name = EnumName.t type typ = @@ -47,13 +50,9 @@ type typ = | TAny type date = Runtime.date - type duration = Runtime.duration - type integer = Runtime.integer - type decimal = Runtime.decimal - type money = Runtime.money type lit = @@ -67,7 +66,6 @@ type lit = | LDuration of duration type op_kind = KInt | KRat | KMoney | KDate | KDuration - type ternop = Fold type binop = @@ -105,12 +103,14 @@ type operator = Ternop of ternop | Binop of binop | Unop of unop type expr = | EVar of expr Bindlib.var Pos.marked | ETuple of expr Pos.marked list * struct_name option - | ETupleAccess of expr Pos.marked * int * struct_name option * typ Pos.marked list + | ETupleAccess of + expr Pos.marked * int * struct_name option * typ Pos.marked list | EInj of expr Pos.marked * int * enum_name * typ Pos.marked list | EMatch of expr Pos.marked * expr Pos.marked list * enum_name | EArray of expr Pos.marked list | ELit of lit - | EAbs of (expr, expr Pos.marked) Bindlib.mbinder Pos.marked * typ Pos.marked list + | EAbs of + (expr, expr Pos.marked) Bindlib.mbinder Pos.marked * typ Pos.marked list | EApp of expr Pos.marked * expr Pos.marked list | EAssert of expr Pos.marked | EOp of operator @@ -119,11 +119,8 @@ type expr = | ErrorOnEmpty of expr Pos.marked type struct_ctx = (StructFieldName.t * typ Pos.marked) list StructMap.t - type enum_ctx = (EnumConstructor.t * typ Pos.marked) list EnumMap.t - type decl_ctx = { ctx_enums : enum_ctx; ctx_structs : struct_ctx } - type binder = (expr, expr Pos.marked) Bindlib.binder type scope_let_kind = @@ -143,13 +140,17 @@ type scope_let = { type scope_body = { scope_body_lets : scope_let list; - scope_body_result : expr Pos.marked Bindlib.box; (** {x1 = x1; x2 = x2; x3 = x3; ... } *) + scope_body_result : expr Pos.marked Bindlib.box; + (** {x1 = x1; x2 = x2; x3 = x3; ... } *) scope_body_arg : expr Bindlib.var; (** x: input_struct *) scope_body_input_struct : StructName.t; scope_body_output_struct : StructName.t; } -type program = { decl_ctx : decl_ctx; scopes : (ScopeName.t * expr Bindlib.var * scope_body) list } +type program = { + decl_ctx : decl_ctx; + scopes : (ScopeName.t * expr Bindlib.var * scope_body) list; +} module Var = struct type t = expr Bindlib.var @@ -164,21 +165,28 @@ end module VarMap = Map.Make (Var) -let union : unit VarMap.t -> unit VarMap.t -> unit VarMap.t = VarMap.union (fun _ _ _ -> Some ()) +let union : unit VarMap.t -> unit VarMap.t -> unit VarMap.t = + VarMap.union (fun _ _ _ -> Some ()) let rec free_vars_set (e : expr Pos.marked) : unit VarMap.t = match Pos.unmark e with | EVar (v, _) -> VarMap.singleton v () - | ETuple (es, _) | EArray es -> es |> List.map free_vars_set |> List.fold_left union VarMap.empty - | ETupleAccess (e1, _, _, _) | EAssert e1 | ErrorOnEmpty e1 | EInj (e1, _, _, _) -> + | ETuple (es, _) | EArray es -> + es |> List.map free_vars_set |> List.fold_left union VarMap.empty + | ETupleAccess (e1, _, _, _) + | EAssert e1 + | ErrorOnEmpty e1 + | EInj (e1, _, _, _) -> free_vars_set e1 | EApp (e1, es) | EMatch (e1, es, _) -> e1 :: es |> List.map free_vars_set |> List.fold_left union VarMap.empty | EDefault (es, ejust, econs) -> - ejust :: econs :: es |> List.map free_vars_set |> List.fold_left union VarMap.empty + ejust :: econs :: es |> List.map free_vars_set + |> List.fold_left union VarMap.empty | EOp _ | ELit _ -> VarMap.empty | EIfThenElse (e1, e2, e3) -> - [ e1; e2; e3 ] |> List.map free_vars_set |> List.fold_left union VarMap.empty + [ e1; e2; e3 ] |> List.map free_vars_set + |> List.fold_left union VarMap.empty | EAbs ((binder, _), _) -> let vs, body = Bindlib.unmbind binder in Array.fold_right VarMap.remove vs (free_vars_set body) @@ -191,16 +199,28 @@ type vars = expr Bindlib.mvar let make_var ((x, pos) : Var.t Pos.marked) : expr Pos.marked Bindlib.box = Bindlib.box_apply (fun x -> (x, pos)) (Bindlib.box_var x) -let make_abs (xs : vars) (e : expr Pos.marked Bindlib.box) (pos_binder : Pos.t) - (taus : typ Pos.marked list) (pos : Pos.t) : expr Pos.marked Bindlib.box = - Bindlib.box_apply (fun b -> (EAbs ((b, pos_binder), taus), pos)) (Bindlib.bind_mvar xs e) +let make_abs + (xs : vars) + (e : expr Pos.marked Bindlib.box) + (pos_binder : Pos.t) + (taus : typ Pos.marked list) + (pos : Pos.t) : expr Pos.marked Bindlib.box = + Bindlib.box_apply + (fun b -> (EAbs ((b, pos_binder), taus), pos)) + (Bindlib.bind_mvar xs e) -let make_app (e : expr Pos.marked Bindlib.box) (u : expr Pos.marked Bindlib.box list) (pos : Pos.t) - : expr Pos.marked Bindlib.box = +let make_app + (e : expr Pos.marked Bindlib.box) + (u : expr Pos.marked Bindlib.box list) + (pos : Pos.t) : expr Pos.marked Bindlib.box = Bindlib.box_apply2 (fun e u -> (EApp (e, u), pos)) e (Bindlib.box_list u) -let make_let_in (x : Var.t) (tau : typ Pos.marked) (e1 : expr Pos.marked Bindlib.box) - (e2 : expr Pos.marked Bindlib.box) (pos : Pos.t) : expr Pos.marked Bindlib.box = +let make_let_in + (x : Var.t) + (tau : typ Pos.marked) + (e1 : expr Pos.marked Bindlib.box) + (e2 : expr Pos.marked Bindlib.box) + (pos : Pos.t) : expr Pos.marked Bindlib.box = make_app (make_abs (Array.of_list [ x ]) e2 pos [ tau ] pos) [ e1 ] pos let empty_thunked_term : expr Pos.marked = @@ -209,12 +229,15 @@ let empty_thunked_term : expr Pos.marked = (make_abs (Array.of_list [ silent ]) (Bindlib.box (ELit LEmptyError, Pos.no_pos)) - Pos.no_pos [ (TLit TUnit, Pos.no_pos) ] Pos.no_pos) + Pos.no_pos + [ (TLit TUnit, Pos.no_pos) ] + Pos.no_pos) let is_value (e : expr Pos.marked) : bool = match Pos.unmark e with ELit _ | EAbs _ | EOp _ -> true | _ -> false -let build_whole_scope_expr (ctx : decl_ctx) (body : scope_body) (pos_scope : Pos.t) = +let build_whole_scope_expr + (ctx : decl_ctx) (body : scope_body) (pos_scope : Pos.t) = let body_expr = List.fold_right (fun scope_let acc -> @@ -229,25 +252,37 @@ let build_whole_scope_expr (ctx : decl_ctx) (body : scope_body) (pos_scope : Pos body_expr pos_scope [ ( TTuple - ( List.map snd (StructMap.find body.scope_body_input_struct ctx.ctx_structs), + ( List.map snd + (StructMap.find body.scope_body_input_struct ctx.ctx_structs), Some body.scope_body_input_struct ), pos_scope ); ] pos_scope -let build_scope_typ_from_sig (ctx : decl_ctx) (scope_input_struct_name : StructName.t) - (scope_return_struct_name : StructName.t) (pos : Pos.t) : typ Pos.marked = +let build_scope_typ_from_sig + (ctx : decl_ctx) + (scope_input_struct_name : StructName.t) + (scope_return_struct_name : StructName.t) + (pos : Pos.t) : typ Pos.marked = let scope_sig = StructMap.find scope_input_struct_name ctx.ctx_structs in - let scope_return_typ = StructMap.find scope_return_struct_name ctx.ctx_structs in - let result_typ = (TTuple (List.map snd scope_return_typ, Some scope_return_struct_name), pos) in - let input_typ = (TTuple (List.map snd scope_sig, Some scope_input_struct_name), pos) in + let scope_return_typ = + StructMap.find scope_return_struct_name ctx.ctx_structs + in + let result_typ = + (TTuple (List.map snd scope_return_typ, Some scope_return_struct_name), pos) + in + let input_typ = + (TTuple (List.map snd scope_sig, Some scope_input_struct_name), pos) + in (TArrow (input_typ, result_typ), pos) let build_whole_program_expr (p : program) (main_scope : ScopeName.t) = let end_result = make_var (let _, x, _ = - List.find (fun (s_name, _, _) -> ScopeName.compare main_scope s_name = 0) p.scopes + List.find + (fun (s_name, _, _) -> ScopeName.compare main_scope s_name = 0) + p.scopes in (x, Pos.no_pos)) in @@ -264,11 +299,18 @@ let build_whole_program_expr (p : program) (main_scope : ScopeName.t) = let rec expr_size (e : expr Pos.marked) : int = match Pos.unmark e with | EVar _ | ELit _ | EOp _ -> 1 - | ETuple (args, _) | EArray args -> List.fold_left (fun acc arg -> acc + expr_size arg) 1 args - | ETupleAccess (e1, _, _, _) | EInj (e1, _, _, _) | EAssert e1 | ErrorOnEmpty e1 -> + | ETuple (args, _) | EArray args -> + List.fold_left (fun acc arg -> acc + expr_size arg) 1 args + | ETupleAccess (e1, _, _, _) + | EInj (e1, _, _, _) + | EAssert e1 + | ErrorOnEmpty e1 -> expr_size e1 + 1 | EMatch (arg, args, _) | EApp (arg, args) -> - List.fold_left (fun acc arg -> acc + expr_size arg) (1 + expr_size arg) args + List.fold_left + (fun acc arg -> acc + expr_size arg) + (1 + expr_size arg) + args | EAbs ((binder, _), _) -> let _, body = Bindlib.unmbind binder in 1 + expr_size body @@ -284,6 +326,8 @@ let variable_types (p : program) : typ Pos.marked VarMap.t = (fun acc (_, _, scope) -> List.fold_left (fun acc scope_let -> - VarMap.add (Pos.unmark scope_let.scope_let_var) scope_let.scope_let_typ acc) + VarMap.add + (Pos.unmark scope_let.scope_let_var) + scope_let.scope_let_typ acc) acc scope.scope_body_lets) VarMap.empty p.scopes diff --git a/compiler/dcalc/ast.mli b/compiler/dcalc/ast.mli index 453d22fa..1aa36607 100644 --- a/compiler/dcalc/ast.mli +++ b/compiler/dcalc/ast.mli @@ -1,33 +1,28 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux - +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, contributor: + Denis Merigoux - 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 + 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 + 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. *) (** Abstract syntax tree of the default calculus intermediate representation *) open Utils - module ScopeName : Uid.Id with type info = Uid.MarkedString.info - module StructName : Uid.Id with type info = Uid.MarkedString.info - module StructFieldName : Uid.Id with type info = Uid.MarkedString.info - module StructMap : Map.S with type key = StructName.t - module EnumName : Uid.Id with type info = Uid.MarkedString.info - module EnumConstructor : Uid.Id with type info = Uid.MarkedString.info - module EnumMap : Map.S with type key = EnumName.t (** Abstract syntax tree for the default calculus *) @@ -45,7 +40,6 @@ type typ = | TAny type date = Runtime.date - type duration = Runtime.duration type lit = @@ -87,8 +81,8 @@ type binop = type log_entry = | VarDef of typ - (** During code generation, we need to know the type of the variable being logged for - embedding *) + (** During code generation, we need to know the type of the variable being + logged for embedding *) | BeginCall | EndCall | PosRecordIfTrueBool @@ -105,13 +99,14 @@ type unop = type operator = Ternop of ternop | Binop of binop | Unop of unop -(** The expressions use the {{:https://lepigre.fr/ocaml-bindlib/} Bindlib} library, based on - higher-order abstract syntax*) +(** The expressions use the {{:https://lepigre.fr/ocaml-bindlib/} Bindlib} + library, based on higher-order abstract syntax*) type expr = | EVar of expr Bindlib.var Pos.marked | ETuple of expr Pos.marked list * StructName.t option (** The [MarkedString.info] is the former struct field name*) - | ETupleAccess of expr Pos.marked * int * StructName.t option * typ Pos.marked list + | ETupleAccess of + expr Pos.marked * int * StructName.t option * typ Pos.marked list (** The [MarkedString.info] is the former struct field name *) | EInj of expr Pos.marked * int * EnumName.t * typ Pos.marked list (** The [MarkedString.info] is the former enum case name *) @@ -119,7 +114,9 @@ type expr = (** The [MarkedString.info] is the former enum case name *) | EArray of expr Pos.marked list | ELit of lit - | EAbs of ((expr, expr Pos.marked) Bindlib.mbinder[@opaque]) Pos.marked * typ Pos.marked list + | EAbs of + ((expr, expr Pos.marked) Bindlib.mbinder[@opaque]) Pos.marked + * typ Pos.marked list | EApp of expr Pos.marked * expr Pos.marked list | EAssert of expr Pos.marked | EOp of operator @@ -128,20 +125,19 @@ type expr = | ErrorOnEmpty of expr Pos.marked type struct_ctx = (StructFieldName.t * typ Pos.marked) list StructMap.t - type enum_ctx = (EnumConstructor.t * typ Pos.marked) list EnumMap.t - type decl_ctx = { ctx_enums : enum_ctx; ctx_structs : struct_ctx } - type binder = (expr, expr Pos.marked) Bindlib.binder -(** This kind annotation signals that the let-binding respects a structural invariant. These - invariants concern the shape of the expression in the let-binding, and are documented below. *) +(** This kind annotation signals that the let-binding respects a structural + invariant. These invariants concern the shape of the expression in the + let-binding, and are documented below. *) type scope_let_kind = | DestructuringInputStruct (** [let x = input.field]*) | ScopeVarDefinition (** [let x = error_on_empty e]*) | SubScopeVarDefinition - (** [let s.x = fun _ -> e] or [let s.x = error_on_empty e] for input-only subscope variables. *) + (** [let s.x = fun _ -> e] or [let s.x = error_on_empty e] for input-only + subscope variables. *) | CallingSubScope (** [let result = s ({ x = s.x; y = s.x; ...}) ]*) | DestructuringSubScopeResults (** [let s.x = result.x ]**) | Assertion (** [let _ = assert e]*) @@ -152,9 +148,9 @@ type scope_let = { scope_let_typ : typ Pos.marked; scope_let_expr : expr Pos.marked Bindlib.box; } -(** A scope let-binding has all the information necessary to make a proper let-binding expression, - plus an annotation for the kind of the let-binding that comes from the compilation of a - {!module: Scopelang.Ast} statement. *) +(** A scope let-binding has all the information necessary to make a proper + let-binding expression, plus an annotation for the kind of the let-binding + that comes from the compilation of a {!module: Scopelang.Ast} statement. *) type scope_body = { scope_body_lets : scope_let list; @@ -163,11 +159,14 @@ type scope_body = { scope_body_input_struct : StructName.t; scope_body_output_struct : StructName.t; } -(** Instead of being a single expression, we give a little more ad-hoc structure to the scope body - by decomposing it in an ordered list of let-bindings, and a result expression that uses the - let-binded variables. *) +(** Instead of being a single expression, we give a little more ad-hoc structure + to the scope body by decomposing it in an ordered list of let-bindings, and + a result expression that uses the let-binded variables. *) -type program = { decl_ctx : decl_ctx; scopes : (ScopeName.t * expr Bindlib.var * scope_body) list } +type program = { + decl_ctx : decl_ctx; + scopes : (ScopeName.t * expr Bindlib.var * scope_body) list; +} (** {1 Helpers} *) @@ -177,14 +176,12 @@ module Var : sig type t = expr Bindlib.var val make : string Pos.marked -> t - val compare : t -> t -> int end module VarMap : Map.S with type key = Var.t val free_vars_set : expr Pos.marked -> unit VarMap.t - val free_vars_list : expr Pos.marked -> Var.t list type vars = expr Bindlib.mvar @@ -216,22 +213,26 @@ val make_let_in : (**{2 Other}*) val empty_thunked_term : expr Pos.marked - val is_value : expr Pos.marked -> bool (** {1 AST manipulation helpers}*) -val build_whole_scope_expr : decl_ctx -> scope_body -> Pos.t -> expr Pos.marked Bindlib.box -(** Usage: [build_whole_scope_expr ctx body scope_position] where [scope_position] corresponds to - the line of the scope declaration for instance. *) +val build_whole_scope_expr : + decl_ctx -> scope_body -> Pos.t -> expr Pos.marked Bindlib.box +(** Usage: [build_whole_scope_expr ctx body scope_position] where + [scope_position] corresponds to the line of the scope declaration for + instance. *) -val build_whole_program_expr : program -> ScopeName.t -> expr Pos.marked Bindlib.box -(** Usage: [build_whole_program_expr program main_scope] builds an expression corresponding to the - main program and returning the main scope as a function. *) +val build_whole_program_expr : + program -> ScopeName.t -> expr Pos.marked Bindlib.box +(** Usage: [build_whole_program_expr program main_scope] builds an expression + corresponding to the main program and returning the main scope as a + function. *) val expr_size : expr Pos.marked -> int (** Used by the optimizer to know when to stop *) val variable_types : program -> typ Pos.marked VarMap.t -(** Traverses all the scopes and retrieves all the types for the variables that may appear in scope - or subscope variable definitions, giving them as a big map. *) +(** Traverses all the scopes and retrieves all the types for the variables that + may appear in scope or subscope variable definitions, giving them as a big + map. *) diff --git a/compiler/dcalc/binded_representation.ml b/compiler/dcalc/binded_representation.ml index f254e50e..90ea6cef 100644 --- a/compiler/dcalc/binded_representation.ml +++ b/compiler/dcalc/binded_representation.ml @@ -1,15 +1,17 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020-2022 Inria, contributor: Alain Delaët-Tixeuil - +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020-2022 Inria, + contributor: Alain Delaët-Tixeuil - 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 + 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 + 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. *) open Utils @@ -47,7 +49,8 @@ let rec free_vars_set_scope_lets (scope_lets : scope_lets) : unit D.VarMap.t = | Result e -> D.free_vars_set e | ScopeLet { scope_let_expr = e; scope_let_next = next; _ } -> let v, body = Bindlib.unbind next in - union (D.free_vars_set e) (D.VarMap.remove v (free_vars_set_scope_lets body)) + union (D.free_vars_set e) + (D.VarMap.remove v (free_vars_set_scope_lets body)) let free_vars_set_scope_body (scope_body : scope_body) : unit D.VarMap.t = let { scope_body_result = binder; _ } = scope_body in @@ -60,7 +63,9 @@ let rec free_vars_set_scopes (scopes : scopes) : unit D.VarMap.t = | ScopeDef { scope_body = body; scope_next = next; _ } -> let v, next = Bindlib.unbind next in - union (D.VarMap.remove v (free_vars_set_scopes next)) (free_vars_set_scope_body body) + union + (D.VarMap.remove v (free_vars_set_scopes next)) + (free_vars_set_scope_body body) let free_vars_list_scope_lets (scope_lets : scope_lets) : D.Var.t list = free_vars_set_scope_lets scope_lets |> D.VarMap.bindings |> List.map fst @@ -76,13 +81,14 @@ let bind_scope_lets (acc : scope_lets Bindlib.box) (scope_let : D.scope_let) : scope_lets Bindlib.box = let pos = snd scope_let.D.scope_let_var in - (* Cli.debug_print @@ Format.asprintf "binding let %a. Variable occurs = %b" Print.format_var (fst - scope_let.D.scope_let_var) (Bindlib.occur (fst scope_let.D.scope_let_var) acc); *) + (* Cli.debug_print @@ Format.asprintf "binding let %a. Variable occurs = %b" + Print.format_var (fst scope_let.D.scope_let_var) (Bindlib.occur (fst + scope_let.D.scope_let_var) acc); *) let binder = Bindlib.bind_var (fst scope_let.D.scope_let_var) acc in Bindlib.box_apply2 (fun expr binder -> - (* Cli.debug_print @@ Format.asprintf "free variables in expression: %a" (Format.pp_print_list - Print.format_var) (D.free_vars_list expr); *) + (* Cli.debug_print @@ Format.asprintf "free variables in expression: %a" + (Format.pp_print_list Print.format_var) (D.free_vars_list expr); *) ScopeLet { scope_let_kind = scope_let.D.scope_let_kind; @@ -101,15 +107,16 @@ let bind_scope_body (body : D.scope_body) : scope_body Bindlib.box = ~f:(Fun.flip bind_scope_lets) in - (* Cli.debug_print @@ Format.asprintf "binding arg %a" Print.format_var body.D.scope_body_arg; *) + (* Cli.debug_print @@ Format.asprintf "binding arg %a" Print.format_var + body.D.scope_body_arg; *) let scope_body_result = Bindlib.bind_var body.D.scope_body_arg body_result in - (* Cli.debug_print @@ Format.asprintf "isfinal term is closed: %b" (Bindlib.is_closed - scope_body_result); *) + (* Cli.debug_print @@ Format.asprintf "isfinal term is closed: %b" + (Bindlib.is_closed scope_body_result); *) Bindlib.box_apply (fun scope_body_result -> - (* Cli.debug_print @@ Format.asprintf "rank of the final term: %i" (Bindlib.binder_rank - scope_body_result); *) + (* Cli.debug_print @@ Format.asprintf "rank of the final term: %i" + (Bindlib.binder_rank scope_body_result); *) { scope_body_output_struct = body.D.scope_body_output_struct; scope_body_input_struct = body.D.scope_body_input_struct; @@ -118,15 +125,22 @@ let bind_scope_body (body : D.scope_body) : scope_body Bindlib.box = scope_body_result let bind_scope - ((scope_name, scope_var, scope_body) : D.ScopeName.t * D.expr Bindlib.var * D.scope_body) + ((scope_name, scope_var, scope_body) : + D.ScopeName.t * D.expr Bindlib.var * D.scope_body) (acc : scopes Bindlib.box) : scopes Bindlib.box = Bindlib.box_apply2 - (fun scope_body scope_next -> ScopeDef { scope_name; scope_body; scope_next }) - (bind_scope_body scope_body) (Bindlib.bind_var scope_var acc) + (fun scope_body scope_next -> + ScopeDef { scope_name; scope_body; scope_next }) + (bind_scope_body scope_body) + (Bindlib.bind_var scope_var acc) -let bind_scopes (scopes : (D.ScopeName.t * D.expr Bindlib.var * D.scope_body) list) : +let bind_scopes + (scopes : (D.ScopeName.t * D.expr Bindlib.var * D.scope_body) list) : scopes Bindlib.box = - let result = ListLabels.fold_right scopes ~init:(Bindlib.box Nil) ~f:bind_scope in - (* Cli.debug_print @@ Format.asprintf "free variable in the program : [%a]" (Format.pp_print_list - Print.format_var) (free_vars_list_scopes (Bindlib.unbox result)); *) + let result = + ListLabels.fold_right scopes ~init:(Bindlib.box Nil) ~f:bind_scope + in + (* Cli.debug_print @@ Format.asprintf "free variable in the program : [%a]" + (Format.pp_print_list Print.format_var) (free_vars_list_scopes + (Bindlib.unbox result)); *) result diff --git a/compiler/dcalc/binded_representation.mli b/compiler/dcalc/binded_representation.mli index 352028a9..ef81fa69 100644 --- a/compiler/dcalc/binded_representation.mli +++ b/compiler/dcalc/binded_representation.mli @@ -1,25 +1,28 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020-2022 Inria, contributor: Alain Delaët-Tixeuil - +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020-2022 Inria, + contributor: Alain Delaët-Tixeuil - 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 + 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 + 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. *) module D = Ast -(** Alternative representation of the Dcalc Ast. It is currently used in the transformation without - exceptions. We make heavy use of bindlib, binding each scope-let-variable and each scope - explicitly. *) +(** Alternative representation of the Dcalc Ast. It is currently used in the + transformation without exceptions. We make heavy use of bindlib, binding + each scope-let-variable and each scope explicitly. *) -(** In [Ast], [Ast.scope_lets] is defined as a list of kind, var, and boxed expression. This - representation binds using bindlib the tail of the list with the variable defined in the let. *) +(** In [Ast], [Ast.scope_lets] is defined as a list of kind, var, and boxed + expression. This representation binds using bindlib the tail of the list + with the variable defined in the let. *) type scope_lets = | Result of D.expr Utils.Pos.marked | ScopeLet of { @@ -35,12 +38,12 @@ type scope_body = { scope_body_output_struct : D.StructName.t; scope_body_result : (D.expr, scope_lets) Bindlib.binder; } -(** As a consequence, the scope_body contains only a result and input/output signature, as the other - elements are stored inside the scope_let. The binder present is the argument of type - [scope_body_input_struct]. *) +(** As a consequence, the scope_body contains only a result and input/output + signature, as the other elements are stored inside the scope_let. The binder + present is the argument of type [scope_body_input_struct]. *) -(** Finally, we do the same transformation for the whole program for the kinded lets. This permit us - to use bindlib variables for scopes names. *) +(** Finally, we do the same transformation for the whole program for the kinded + lets. This permit us to use bindlib variables for scopes names. *) type scopes = | Nil | ScopeDef of { @@ -58,6 +61,8 @@ val free_vars_list_scope_body : scope_body -> D.Var.t list val free_vars_list_scopes : scopes -> D.Var.t list (** List of variables not binded inside scopes*) -val bind_scopes : (D.ScopeName.t * D.expr Bindlib.var * D.scope_body) list -> scopes Bindlib.box -(** Transform a list of scopes into our representation of scopes. It requires that scopes are - topologically-well-ordered, and ensure there is no free variables in the returned [scopes] *) +val bind_scopes : + (D.ScopeName.t * D.expr Bindlib.var * D.scope_body) list -> scopes Bindlib.box +(** Transform a list of scopes into our representation of scopes. It requires + that scopes are topologically-well-ordered, and ensure there is no free + variables in the returned [scopes] *) diff --git a/compiler/dcalc/interpreter.ml b/compiler/dcalc/interpreter.ml index 6bb0b8c1..2e2f7862 100644 --- a/compiler/dcalc/interpreter.ml +++ b/compiler/dcalc/interpreter.ml @@ -1,15 +1,17 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux - , Emile Rolley +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, contributor: + Denis Merigoux , Emile Rolley - 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 + 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 + 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. *) (** Reference interpreter for the default calculus *) @@ -26,11 +28,14 @@ let log_indent = ref 0 (** {1 Evaluation} *) -let rec evaluate_operator (ctx : Ast.decl_ctx) (op : A.operator Pos.marked) +let rec evaluate_operator + (ctx : Ast.decl_ctx) + (op : A.operator Pos.marked) (args : A.expr Pos.marked list) : A.expr Pos.marked = - (* Try to apply [div] and if a [Division_by_zero] exceptions is catched, use [op] to raise - multispanned errors. *) - let apply_div_or_raise_err (div : unit -> A.expr) (op : A.operator Pos.marked) : A.expr = + (* Try to apply [div] and if a [Division_by_zero] exceptions is catched, use + [op] to raise multispanned errors. *) + let apply_div_or_raise_err (div : unit -> A.expr) (op : A.operator Pos.marked) + : A.expr = try div () with Division_by_zero -> Errors.raise_multispanned_error @@ -40,16 +45,22 @@ let rec evaluate_operator (ctx : Ast.decl_ctx) (op : A.operator Pos.marked) ] "division by zero at runtime" in - let get_binop_args_pos (args : (A.expr * Pos.t) list) : (string option * Pos.t) list = - [ (None, Pos.get_position (List.nth args 0)); (None, Pos.get_position (List.nth args 1)) ] + let get_binop_args_pos (args : (A.expr * Pos.t) list) : + (string option * Pos.t) list = + [ + (None, Pos.get_position (List.nth args 0)); + (None, Pos.get_position (List.nth args 1)); + ] in - (* Try to apply [cmp] and if a [UncomparableDurations] exceptions is catched, use [args] to raise - multispanned errors. *) - let apply_cmp_or_raise_err (cmp : unit -> A.expr) (args : (A.expr * Pos.t) list) : A.expr = + (* Try to apply [cmp] and if a [UncomparableDurations] exceptions is catched, + use [args] to raise multispanned errors. *) + let apply_cmp_or_raise_err + (cmp : unit -> A.expr) (args : (A.expr * Pos.t) list) : A.expr = try cmp () with Runtime.UncomparableDurations -> Errors.raise_multispanned_error (get_binop_args_pos args) - "Cannot compare together durations that cannot be converted to a precise number of days" + "Cannot compare together durations that cannot be converted to a \ + precise number of days" in Pos.same_pos_as (match (Pos.unmark op, List.map Pos.unmark args) with @@ -57,19 +68,29 @@ let rec evaluate_operator (ctx : Ast.decl_ctx) (op : A.operator Pos.marked) Pos.unmark (List.fold_left (fun acc e' -> - evaluate_expr ctx (Pos.same_pos_as (A.EApp (List.nth args 0, [ acc; e' ])) e')) + evaluate_expr ctx + (Pos.same_pos_as (A.EApp (List.nth args 0, [ acc; e' ])) e')) (List.nth args 1) es) - | A.Binop A.And, [ ELit (LBool b1); ELit (LBool b2) ] -> A.ELit (LBool (b1 && b2)) - | A.Binop A.Or, [ ELit (LBool b1); ELit (LBool b2) ] -> A.ELit (LBool (b1 || b2)) - | A.Binop A.Xor, [ ELit (LBool b1); ELit (LBool b2) ] -> A.ELit (LBool (b1 <> b2)) - | A.Binop (A.Add KInt), [ ELit (LInt i1); ELit (LInt i2) ] -> A.ELit (LInt Runtime.(i1 +! i2)) - | A.Binop (A.Sub KInt), [ ELit (LInt i1); ELit (LInt i2) ] -> A.ELit (LInt Runtime.(i1 -! i2)) - | A.Binop (A.Mult KInt), [ ELit (LInt i1); ELit (LInt i2) ] -> A.ELit (LInt Runtime.(i1 *! i2)) + | A.Binop A.And, [ ELit (LBool b1); ELit (LBool b2) ] -> + A.ELit (LBool (b1 && b2)) + | A.Binop A.Or, [ ELit (LBool b1); ELit (LBool b2) ] -> + A.ELit (LBool (b1 || b2)) + | A.Binop A.Xor, [ ELit (LBool b1); ELit (LBool b2) ] -> + A.ELit (LBool (b1 <> b2)) + | A.Binop (A.Add KInt), [ ELit (LInt i1); ELit (LInt i2) ] -> + A.ELit (LInt Runtime.(i1 +! i2)) + | A.Binop (A.Sub KInt), [ ELit (LInt i1); ELit (LInt i2) ] -> + A.ELit (LInt Runtime.(i1 -! i2)) + | A.Binop (A.Mult KInt), [ ELit (LInt i1); ELit (LInt i2) ] -> + A.ELit (LInt Runtime.(i1 *! i2)) | A.Binop (A.Div KInt), [ ELit (LInt i1); ELit (LInt i2) ] -> apply_div_or_raise_err (fun _ -> A.ELit (LInt Runtime.(i1 /! i2))) op - | A.Binop (A.Add KRat), [ ELit (LRat i1); ELit (LRat i2) ] -> A.ELit (LRat Runtime.(i1 +& i2)) - | A.Binop (A.Sub KRat), [ ELit (LRat i1); ELit (LRat i2) ] -> A.ELit (LRat Runtime.(i1 -& i2)) - | A.Binop (A.Mult KRat), [ ELit (LRat i1); ELit (LRat i2) ] -> A.ELit (LRat Runtime.(i1 *& i2)) + | A.Binop (A.Add KRat), [ ELit (LRat i1); ELit (LRat i2) ] -> + A.ELit (LRat Runtime.(i1 +& i2)) + | A.Binop (A.Sub KRat), [ ELit (LRat i1); ELit (LRat i2) ] -> + A.ELit (LRat Runtime.(i1 -& i2)) + | A.Binop (A.Mult KRat), [ ELit (LRat i1); ELit (LRat i2) ] -> + A.ELit (LRat Runtime.(i1 *& i2)) | A.Binop (A.Div KRat), [ ELit (LRat i1); ELit (LRat i2) ] -> apply_div_or_raise_err (fun _ -> A.ELit (LRat Runtime.(i1 /& i2))) op | A.Binop (A.Add KMoney), [ ELit (LMoney m1); ELit (LMoney m2) ] -> @@ -94,16 +115,25 @@ let rec evaluate_operator (ctx : Ast.decl_ctx) (op : A.operator Pos.marked) try A.ELit (LRat Runtime.(d1 /^ d2)) with Runtime.IndivisableDurations -> Errors.raise_multispanned_error (get_binop_args_pos args) - "Cannot divide durations that cannot be converted to a precise number of days") + "Cannot divide durations that cannot be converted to a precise \ + number of days") op - | A.Binop (A.Lt KInt), [ ELit (LInt i1); ELit (LInt i2) ] -> A.ELit (LBool Runtime.(i1 A.ELit (LBool Runtime.(i1 <=! i2)) - | A.Binop (A.Gt KInt), [ ELit (LInt i1); ELit (LInt i2) ] -> A.ELit (LBool Runtime.(i1 >! i2)) - | A.Binop (A.Gte KInt), [ ELit (LInt i1); ELit (LInt i2) ] -> A.ELit (LBool Runtime.(i1 >=! i2)) - | A.Binop (A.Lt KRat), [ ELit (LRat i1); ELit (LRat i2) ] -> A.ELit (LBool Runtime.(i1 <& i2)) - | A.Binop (A.Lte KRat), [ ELit (LRat i1); ELit (LRat i2) ] -> A.ELit (LBool Runtime.(i1 <=& i2)) - | A.Binop (A.Gt KRat), [ ELit (LRat i1); ELit (LRat i2) ] -> A.ELit (LBool Runtime.(i1 >& i2)) - | A.Binop (A.Gte KRat), [ ELit (LRat i1); ELit (LRat i2) ] -> A.ELit (LBool Runtime.(i1 >=& i2)) + | A.Binop (A.Lt KInt), [ ELit (LInt i1); ELit (LInt i2) ] -> + A.ELit (LBool Runtime.(i1 + A.ELit (LBool Runtime.(i1 <=! i2)) + | A.Binop (A.Gt KInt), [ ELit (LInt i1); ELit (LInt i2) ] -> + A.ELit (LBool Runtime.(i1 >! i2)) + | A.Binop (A.Gte KInt), [ ELit (LInt i1); ELit (LInt i2) ] -> + A.ELit (LBool Runtime.(i1 >=! i2)) + | A.Binop (A.Lt KRat), [ ELit (LRat i1); ELit (LRat i2) ] -> + A.ELit (LBool Runtime.(i1 <& i2)) + | A.Binop (A.Lte KRat), [ ELit (LRat i1); ELit (LRat i2) ] -> + A.ELit (LBool Runtime.(i1 <=& i2)) + | A.Binop (A.Gt KRat), [ ELit (LRat i1); ELit (LRat i2) ] -> + A.ELit (LBool Runtime.(i1 >& i2)) + | A.Binop (A.Gte KRat), [ ELit (LRat i1); ELit (LRat i2) ] -> + A.ELit (LBool Runtime.(i1 >=& i2)) | A.Binop (A.Lt KMoney), [ ELit (LMoney m1); ELit (LMoney m2) ] -> A.ELit (LBool Runtime.(m1 <$ m2)) | A.Binop (A.Lte KMoney), [ ELit (LMoney m1); ELit (LMoney m2) ] -> @@ -115,11 +145,15 @@ let rec evaluate_operator (ctx : Ast.decl_ctx) (op : A.operator Pos.marked) | A.Binop (A.Lt KDuration), [ ELit (LDuration d1); ELit (LDuration d2) ] -> apply_cmp_or_raise_err (fun _ -> A.ELit (LBool Runtime.(d1 <^ d2))) args | A.Binop (A.Lte KDuration), [ ELit (LDuration d1); ELit (LDuration d2) ] -> - apply_cmp_or_raise_err (fun _ -> A.ELit (LBool Runtime.(d1 <=^ d2))) args + apply_cmp_or_raise_err + (fun _ -> A.ELit (LBool Runtime.(d1 <=^ d2))) + args | A.Binop (A.Gt KDuration), [ ELit (LDuration d1); ELit (LDuration d2) ] -> apply_cmp_or_raise_err (fun _ -> A.ELit (LBool Runtime.(d1 >^ d2))) args | A.Binop (A.Gte KDuration), [ ELit (LDuration d1); ELit (LDuration d2) ] -> - apply_cmp_or_raise_err (fun _ -> A.ELit (LBool Runtime.(d1 >=^ d2))) args + apply_cmp_or_raise_err + (fun _ -> A.ELit (LBool Runtime.(d1 >=^ d2))) + args | A.Binop (A.Lt KDate), [ ELit (LDate d1); ELit (LDate d2) ] -> A.ELit (LBool Runtime.(d1 <@ d2)) | A.Binop (A.Lte KDate), [ ELit (LDate d1); ELit (LDate d2) ] -> @@ -131,11 +165,16 @@ let rec evaluate_operator (ctx : Ast.decl_ctx) (op : A.operator Pos.marked) | A.Binop A.Eq, [ ELit LUnit; ELit LUnit ] -> A.ELit (LBool true) | A.Binop A.Eq, [ ELit (LDuration d1); ELit (LDuration d2) ] -> A.ELit (LBool Runtime.(d1 =^ d2)) - | A.Binop A.Eq, [ ELit (LDate d1); ELit (LDate d2) ] -> A.ELit (LBool Runtime.(d1 =@ d2)) - | A.Binop A.Eq, [ ELit (LMoney m1); ELit (LMoney m2) ] -> A.ELit (LBool Runtime.(m1 =$ m2)) - | A.Binop A.Eq, [ ELit (LRat i1); ELit (LRat i2) ] -> A.ELit (LBool Runtime.(i1 =& i2)) - | A.Binop A.Eq, [ ELit (LInt i1); ELit (LInt i2) ] -> A.ELit (LBool Runtime.(i1 =! i2)) - | A.Binop A.Eq, [ ELit (LBool b1); ELit (LBool b2) ] -> A.ELit (LBool (b1 = b2)) + | A.Binop A.Eq, [ ELit (LDate d1); ELit (LDate d2) ] -> + A.ELit (LBool Runtime.(d1 =@ d2)) + | A.Binop A.Eq, [ ELit (LMoney m1); ELit (LMoney m2) ] -> + A.ELit (LBool Runtime.(m1 =$ m2)) + | A.Binop A.Eq, [ ELit (LRat i1); ELit (LRat i2) ] -> + A.ELit (LBool Runtime.(i1 =& i2)) + | A.Binop A.Eq, [ ELit (LInt i1); ELit (LInt i2) ] -> + A.ELit (LBool Runtime.(i1 =! i2)) + | A.Binop A.Eq, [ ELit (LBool b1); ELit (LBool b2) ] -> + A.ELit (LBool (b1 = b2)) | A.Binop A.Eq, [ EArray es1; EArray es2 ] -> A.ELit (LBool @@ -155,7 +194,9 @@ let rec evaluate_operator (ctx : Ast.decl_ctx) (op : A.operator Pos.marked) s1 = s2 && List.for_all2 (fun e1 e2 -> - match Pos.unmark (evaluate_operator ctx op [ e1; e2 ]) with + match + Pos.unmark (evaluate_operator ctx op [ e1; e2 ]) + with | A.ELit (LBool b) -> b | _ -> assert false (* should not happen *)) @@ -172,54 +213,76 @@ let rec evaluate_operator (ctx : Ast.decl_ctx) (op : A.operator Pos.marked) | _ -> assert false (* should not happen *) with Invalid_argument _ -> false)) - | A.Binop A.Eq, [ _; _ ] -> A.ELit (LBool false) (* comparing anything else return false *) + | A.Binop A.Eq, [ _; _ ] -> + A.ELit (LBool false) (* comparing anything else return false *) | A.Binop A.Neq, [ _; _ ] -> ( - match Pos.unmark (evaluate_operator ctx (Pos.same_pos_as (A.Binop A.Eq) op) args) with + match + Pos.unmark + (evaluate_operator ctx (Pos.same_pos_as (A.Binop A.Eq) op) args) + with | A.ELit (A.LBool b) -> A.ELit (A.LBool (not b)) | _ -> assert false (*should not happen *)) | A.Binop A.Concat, [ A.EArray es1; A.EArray es2 ] -> A.EArray (es1 @ es2) | A.Binop A.Map, [ _; A.EArray es ] -> A.EArray (List.map - (fun e' -> evaluate_expr ctx (Pos.same_pos_as (A.EApp (List.nth args 0, [ e' ])) e')) + (fun e' -> + evaluate_expr ctx + (Pos.same_pos_as (A.EApp (List.nth args 0, [ e' ])) e')) es) | A.Binop A.Filter, [ _; A.EArray es ] -> A.EArray (List.filter (fun e' -> - match evaluate_expr ctx (Pos.same_pos_as (A.EApp (List.nth args 0, [ e' ])) e') with + match + evaluate_expr ctx + (Pos.same_pos_as (A.EApp (List.nth args 0, [ e' ])) e') + with | A.ELit (A.LBool b), _ -> b | _ -> Errors.raise_spanned_error (Pos.get_position (List.nth args 0)) - "This predicate evaluated to something else than a boolean (should not happen \ - if the term was well-typed)") + "This predicate evaluated to something else than a \ + boolean (should not happen if the term was well-typed)") es) - | A.Binop _, ([ ELit LEmptyError; _ ] | [ _; ELit LEmptyError ]) -> A.ELit LEmptyError - | A.Unop (A.Minus KInt), [ ELit (LInt i) ] -> A.ELit (LInt Runtime.(integer_of_int 0 -! i)) - | A.Unop (A.Minus KRat), [ ELit (LRat i) ] -> A.ELit (LRat Runtime.(decimal_of_string "0" -& i)) + | A.Binop _, ([ ELit LEmptyError; _ ] | [ _; ELit LEmptyError ]) -> + A.ELit LEmptyError + | A.Unop (A.Minus KInt), [ ELit (LInt i) ] -> + A.ELit (LInt Runtime.(integer_of_int 0 -! i)) + | A.Unop (A.Minus KRat), [ ELit (LRat i) ] -> + A.ELit (LRat Runtime.(decimal_of_string "0" -& i)) | A.Unop (A.Minus KMoney), [ ELit (LMoney i) ] -> A.ELit (LMoney Runtime.(money_of_units_int 0 -$ i)) - | A.Unop (A.Minus KDuration), [ ELit (LDuration i) ] -> A.ELit (LDuration Runtime.(~-^i)) + | A.Unop (A.Minus KDuration), [ ELit (LDuration i) ] -> + A.ELit (LDuration Runtime.(~-^i)) | A.Unop A.Not, [ ELit (LBool b) ] -> A.ELit (LBool (not b)) - | A.Unop A.Length, [ EArray es ] -> A.ELit (LInt (Runtime.integer_of_int (List.length es))) - | A.Unop A.GetDay, [ ELit (LDate d) ] -> A.ELit (LInt Runtime.(day_of_month_of_date d)) - | A.Unop A.GetMonth, [ ELit (LDate d) ] -> A.ELit (LInt Runtime.(month_number_of_date d)) - | A.Unop A.GetYear, [ ELit (LDate d) ] -> A.ELit (LInt Runtime.(year_of_date d)) - | A.Unop A.IntToRat, [ ELit (LInt i) ] -> A.ELit (LRat Runtime.(decimal_of_integer i)) + | A.Unop A.Length, [ EArray es ] -> + A.ELit (LInt (Runtime.integer_of_int (List.length es))) + | A.Unop A.GetDay, [ ELit (LDate d) ] -> + A.ELit (LInt Runtime.(day_of_month_of_date d)) + | A.Unop A.GetMonth, [ ELit (LDate d) ] -> + A.ELit (LInt Runtime.(month_number_of_date d)) + | A.Unop A.GetYear, [ ELit (LDate d) ] -> + A.ELit (LInt Runtime.(year_of_date d)) + | A.Unop A.IntToRat, [ ELit (LInt i) ] -> + A.ELit (LRat Runtime.(decimal_of_integer i)) | A.Unop (A.Log (entry, infos)), [ e' ] -> if !Cli.trace_flag then ( match entry with | VarDef _ -> - (* TODO: this usage of Format is broken, Formatting requires that all is formatted in - one pass, without going through intermediate "%s" *) - Cli.log_format "%*s%a %a: %s" (!log_indent * 2) "" Print.format_log_entry entry - Print.format_uid_list infos + (* TODO: this usage of Format is broken, Formatting requires that + all is formatted in one pass, without going through + intermediate "%s" *) + Cli.log_format "%*s%a %a: %s" (!log_indent * 2) "" + Print.format_log_entry entry Print.format_uid_list infos (match e' with - (* | Ast.EAbs _ -> Cli.with_style [ ANSITerminal.green ] "" *) + (* | Ast.EAbs _ -> Cli.with_style [ ANSITerminal.green ] + "" *) | _ -> let expr_str = - Format.asprintf "%a" (Print.format_expr ctx ~debug:false) (e', Pos.no_pos) + Format.asprintf "%a" + (Print.format_expr ctx ~debug:false) + (e', Pos.no_pos) in let expr_str = Re.Pcre.substitute ~rex:(Re.Pcre.regexp "\n\\s*") @@ -231,19 +294,20 @@ let rec evaluate_operator (ctx : Ast.decl_ctx) (op : A.operator Pos.marked) let pos = Pos.get_position op in match (pos <> Pos.no_pos, e') with | true, ELit (LBool true) -> - Cli.log_format "%*s%a%s:\n%s" (!log_indent * 2) "" Print.format_log_entry entry + Cli.log_format "%*s%a%s:\n%s" (!log_indent * 2) "" + Print.format_log_entry entry (Cli.with_style [ ANSITerminal.green ] "Definition applied") - (Cli.add_prefix_to_each_line (Pos.retrieve_loc_text pos) (fun _ -> - Format.asprintf "%*s" (!log_indent * 2) "")) + (Cli.add_prefix_to_each_line (Pos.retrieve_loc_text pos) + (fun _ -> Format.asprintf "%*s" (!log_indent * 2) "")) | _ -> ()) | BeginCall -> - Cli.log_format "%*s%a %a" (!log_indent * 2) "" Print.format_log_entry entry - Print.format_uid_list infos; + Cli.log_format "%*s%a %a" (!log_indent * 2) "" + Print.format_log_entry entry Print.format_uid_list infos; log_indent := !log_indent + 1 | EndCall -> log_indent := !log_indent - 1; - Cli.log_format "%*s%a %a" (!log_indent * 2) "" Print.format_log_entry entry - Print.format_uid_list infos) + Cli.log_format "%*s%a %a" (!log_indent * 2) "" + Print.format_log_entry entry Print.format_uid_list infos) else (); e' | A.Unop _, [ ELit LEmptyError ] -> A.ELit LEmptyError @@ -258,36 +322,44 @@ let rec evaluate_operator (ctx : Ast.decl_ctx) (op : A.operator Pos.marked) arg), Pos.get_position arg )) args) - "Operator applied to the wrong arguments\n(should not happen if the term was well-typed)") + "Operator applied to the wrong arguments\n\ + (should not happen if the term was well-typed)") op -and evaluate_expr (ctx : Ast.decl_ctx) (e : A.expr Pos.marked) : A.expr Pos.marked = +and evaluate_expr (ctx : Ast.decl_ctx) (e : A.expr Pos.marked) : + A.expr Pos.marked = match Pos.unmark e with | EVar _ -> Errors.raise_spanned_error (Pos.get_position e) - "free variable found at evaluation (should not happen if term was well-typed" + "free variable found at evaluation (should not happen if term was \ + well-typed" | EApp (e1, args) -> ( let e1 = evaluate_expr ctx e1 in let args = List.map (evaluate_expr ctx) args in match Pos.unmark e1 with | EAbs ((binder, _), _) -> if Bindlib.mbinder_arity binder = List.length args then - evaluate_expr ctx (Bindlib.msubst binder (Array.of_list (List.map Pos.unmark args))) + evaluate_expr ctx + (Bindlib.msubst binder (Array.of_list (List.map Pos.unmark args))) else Errors.raise_spanned_error (Pos.get_position e) - "wrong function call, expected %d arguments, got %d" (Bindlib.mbinder_arity binder) + "wrong function call, expected %d arguments, got %d" + (Bindlib.mbinder_arity binder) (List.length args) | EOp op -> - Pos.same_pos_as (Pos.unmark (evaluate_operator ctx (Pos.same_pos_as op e1) args)) e + Pos.same_pos_as + (Pos.unmark (evaluate_operator ctx (Pos.same_pos_as op e1) args)) + e | ELit LEmptyError -> Pos.same_pos_as (A.ELit LEmptyError) e | _ -> Errors.raise_spanned_error (Pos.get_position e) - "function has not been reduced to a lambda at evaluation (should not happen if the \ - term was well-typed") + "function has not been reduced to a lambda at evaluation (should \ + not happen if the term was well-typed") | EAbs _ | ELit _ | EOp _ -> e (* these are values *) | ETuple (es, s) -> let new_es = List.map (evaluate_expr ctx) es in - if List.exists is_empty_error new_es then Pos.same_pos_as (A.ELit LEmptyError) e + if List.exists is_empty_error new_es then + Pos.same_pos_as (A.ELit LEmptyError) e else Pos.same_pos_as (A.ETuple (new_es, s)) e | ETupleAccess (e1, n, s, _) -> ( let e1 = evaluate_expr ctx e1 in @@ -299,20 +371,20 @@ and evaluate_expr (ctx : Ast.decl_ctx) (e : A.expr Pos.marked) : A.expr Pos.mark | _ -> Errors.raise_multispanned_error [ (None, Pos.get_position e); (None, Pos.get_position e1) ] - "Error during tuple access: not the same structs (should not happen if the term \ - was well-typed)"); + "Error during tuple access: not the same structs (should not \ + happen if the term was well-typed)"); match List.nth_opt es n with | Some e' -> e' | None -> Errors.raise_spanned_error (Pos.get_position e1) - "The tuple has %d components but the %i-th element was requested (should not \ - happen if the term was well-type)" + "The tuple has %d components but the %i-th element was \ + requested (should not happen if the term was well-type)" (List.length es) n) | ELit LEmptyError -> Pos.same_pos_as (A.ELit LEmptyError) e | _ -> Errors.raise_spanned_error (Pos.get_position e1) - "The expression %a should be a tuple with %d components but is not (should not happen \ - if the term was well-typed)" + "The expression %a should be a tuple with %d components but is not \ + (should not happen if the term was well-typed)" (Print.format_expr ctx ~debug:true) e n) | EInj (e1, n, en, ts) -> @@ -326,22 +398,23 @@ and evaluate_expr (ctx : Ast.decl_ctx) (e : A.expr Pos.marked) : A.expr Pos.mark if e_name <> e_name' then Errors.raise_multispanned_error [ (None, Pos.get_position e); (None, Pos.get_position e1) ] - "Error during match: two different enums found (should not happend if the term was \ - well-typed)"; + "Error during match: two different enums found (should not \ + happend if the term was well-typed)"; let es_n = match List.nth_opt es n with | Some es_n -> es_n | None -> Errors.raise_spanned_error (Pos.get_position e) - "sum type index error (should not happend if the term was well-typed)" + "sum type index error (should not happend if the term was \ + well-typed)" in let new_e = Pos.same_pos_as (A.EApp (es_n, [ e1 ])) e in evaluate_expr ctx new_e | A.ELit A.LEmptyError -> Pos.same_pos_as (A.ELit A.LEmptyError) e | _ -> Errors.raise_spanned_error (Pos.get_position e1) - "Expected a term having a sum type as an argument to a match (should not happend if \ - the term was well-typed") + "Expected a term having a sum type as an argument to a match \ + (should not happend if the term was well-typed") | EDefault (exceptions, just, cons) -> ( let exceptions = List.map (evaluate_expr ctx) exceptions in let empty_count = List.length (List.filter is_empty_error exceptions) in @@ -354,17 +427,18 @@ and evaluate_expr (ctx : Ast.decl_ctx) (e : A.expr Pos.marked) : A.expr Pos.mark | ELit (LBool false) -> Pos.same_pos_as (A.ELit LEmptyError) e | _ -> Errors.raise_spanned_error (Pos.get_position e) - "Default justification has not been reduced to a boolean at evaluation (should not \ - happen if the term was well-typed") + "Default justification has not been reduced to a boolean at \ + evaluation (should not happen if the term was well-typed") | 1 -> List.find (fun sub -> not (is_empty_error sub)) exceptions | _ -> Errors.raise_multispanned_error (List.map (fun except -> - (Some "This consequence has a valid justification:", Pos.get_position except)) + ( Some "This consequence has a valid justification:", + Pos.get_position except )) (List.filter (fun sub -> not (is_empty_error sub)) exceptions)) - "There is a conflict between multiple validd consequences for assigning the same \ - variable.") + "There is a conflict between multiple validd consequences for \ + assigning the same variable.") | EIfThenElse (cond, et, ef) -> ( match Pos.unmark (evaluate_expr ctx cond) with | ELit (LBool true) -> evaluate_expr ctx et @@ -372,36 +446,42 @@ and evaluate_expr (ctx : Ast.decl_ctx) (e : A.expr Pos.marked) : A.expr Pos.mark | ELit LEmptyError -> Pos.same_pos_as (A.ELit LEmptyError) e | _ -> Errors.raise_spanned_error (Pos.get_position cond) - "Expected a boolean literal for the result of this condition (should not happen if the \ - term was well-typed)") + "Expected a boolean literal for the result of this condition \ + (should not happen if the term was well-typed)") | EArray es -> let new_es = List.map (evaluate_expr ctx) es in - if List.exists is_empty_error new_es then Pos.same_pos_as (A.ELit LEmptyError) e + if List.exists is_empty_error new_es then + Pos.same_pos_as (A.ELit LEmptyError) e else Pos.same_pos_as (A.EArray new_es) e | ErrorOnEmpty e' -> let e' = evaluate_expr ctx e' in if Pos.unmark e' = A.ELit LEmptyError then Errors.raise_spanned_error (Pos.get_position e) - "This variable evaluated to an empty term (no rule that defined it applied in this \ - situation)" + "This variable evaluated to an empty term (no rule that defined it \ + applied in this situation)" else e' | EAssert e' -> ( match Pos.unmark (evaluate_expr ctx e') with | ELit (LBool true) -> Pos.same_pos_as (Ast.ELit LUnit) e' | ELit (LBool false) -> ( match Pos.unmark e' with - | EApp ((Ast.EOp (Binop op), pos_op), [ ((ELit _, _) as e1); ((ELit _, _) as e2) ]) -> - Errors.raise_spanned_error (Pos.get_position e') "Assertion failed: %a %a %a" + | EApp + ( (Ast.EOp (Binop op), pos_op), + [ ((ELit _, _) as e1); ((ELit _, _) as e2) ] ) -> + Errors.raise_spanned_error (Pos.get_position e') + "Assertion failed: %a %a %a" (Print.format_expr ctx ~debug:false) e1 Print.format_binop (op, pos_op) (Print.format_expr ctx ~debug:false) e2 - | _ -> Errors.raise_spanned_error (Pos.get_position e') "Assertion failed") + | _ -> + Errors.raise_spanned_error (Pos.get_position e') + "Assertion failed") | ELit LEmptyError -> Pos.same_pos_as (A.ELit LEmptyError) e | _ -> Errors.raise_spanned_error (Pos.get_position e') - "Expected a boolean literal for the result of this assertion (should not happen if the \ - term was well-typed)") + "Expected a boolean literal for the result of this assertion \ + (should not happen if the term was well-typed)") (** {1 API} *) @@ -411,7 +491,9 @@ let interpret_program (ctx : Ast.decl_ctx) (e : Ast.expr Pos.marked) : | Ast.EAbs (_, [ (Ast.TTuple (taus, Some s_in), _) ]) -> ( let application_term = List.map (fun _ -> Ast.empty_thunked_term) taus in let to_interpret = - (Ast.EApp (e, [ (Ast.ETuple (application_term, Some s_in), Pos.no_pos) ]), Pos.no_pos) + ( Ast.EApp + (e, [ (Ast.ETuple (application_term, Some s_in), Pos.no_pos) ]), + Pos.no_pos ) in match Pos.unmark (evaluate_expr ctx to_interpret) with | Ast.ETuple (args, Some s_out) -> @@ -423,8 +505,9 @@ let interpret_program (ctx : Ast.decl_ctx) (e : Ast.expr Pos.marked) : List.map2 (fun arg var -> (var, arg)) args s_out_fields | _ -> Errors.raise_spanned_error (Pos.get_position e) - "The interpretation of a program should always yield a struct corresponding to the \ - scope variables") + "The interpretation of a program should always yield a struct \ + corresponding to the scope variables") | _ -> Errors.raise_spanned_error (Pos.get_position e) - "The interpreter can only interpret terms starting with functions having thunked arguments" + "The interpreter can only interpret terms starting with functions \ + having thunked arguments" diff --git a/compiler/dcalc/interpreter.mli b/compiler/dcalc/interpreter.mli index 922564b3..0e6a95a5 100644 --- a/compiler/dcalc/interpreter.mli +++ b/compiler/dcalc/interpreter.mli @@ -1,15 +1,17 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux - +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, contributor: + Denis Merigoux - 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 + 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 + 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. *) (** Reference interpreter for the default calculus *) @@ -20,7 +22,10 @@ val evaluate_expr : Ast.decl_ctx -> Ast.expr Pos.marked -> Ast.expr Pos.marked (** Evaluates an expression according to the semantics of the default calculus. *) val interpret_program : - Ast.decl_ctx -> Ast.expr Pos.marked -> (Uid.MarkedString.info * Ast.expr Pos.marked) list -(** Interprets a program. This function expects an expression typed as a function whose argument are - all thunked. The function is executed by providing for each argument a thunked empty default. - Returns a list of all the computed values for the scope variables of the executed scope. *) + Ast.decl_ctx -> + Ast.expr Pos.marked -> + (Uid.MarkedString.info * Ast.expr Pos.marked) list +(** Interprets a program. This function expects an expression typed as a + function whose argument are all thunked. The function is executed by + providing for each argument a thunked empty default. Returns a list of all + the computed values for the scope variables of the executed scope. *) diff --git a/compiler/dcalc/optimizations.ml b/compiler/dcalc/optimizations.ml index c762762b..9a31dc20 100644 --- a/compiler/dcalc/optimizations.ml +++ b/compiler/dcalc/optimizations.ml @@ -1,28 +1,35 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2022 Inria, contributors: Alain Delaët - , Denis Merigoux +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2022 Inria, + contributors: Alain Delaët , Denis Merigoux + - 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 + 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 + 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. *) open Utils open Ast -type partial_evaluation_ctx = { var_values : expr Pos.marked Ast.VarMap.t; decl_ctx : decl_ctx } +type partial_evaluation_ctx = { + var_values : expr Pos.marked Ast.VarMap.t; + decl_ctx : decl_ctx; +} -let rec partial_evaluation (ctx : partial_evaluation_ctx) (e : expr Pos.marked) : - expr Pos.marked Bindlib.box = +let rec partial_evaluation (ctx : partial_evaluation_ctx) (e : expr Pos.marked) + : expr Pos.marked Bindlib.box = let pos = Pos.get_position e in let rec_helper = partial_evaluation ctx in match Pos.unmark e with | EApp - ( ((EOp (Unop Not), _ | EApp ((EOp (Unop (Log _)), _), [ (EOp (Unop Not), _) ]), _) as op), + ( (( EOp (Unop Not), _ + | EApp ((EOp (Unop (Log _)), _), [ (EOp (Unop Not), _) ]), _ ) as op), [ e1 ] ) -> (* reduction of logical not *) (Bindlib.box_apply (fun e1 -> @@ -32,23 +39,29 @@ let rec partial_evaluation (ctx : partial_evaluation_ctx) (e : expr Pos.marked) | _ -> (EApp (op, [ e1 ]), pos))) (rec_helper e1) | EApp - ( ((EOp (Binop Or), _ | EApp ((EOp (Unop (Log _)), _), [ (EOp (Binop Or), _) ]), _) as op), + ( (( EOp (Binop Or), _ + | EApp ((EOp (Unop (Log _)), _), [ (EOp (Binop Or), _) ]), _ ) as op), [ e1; e2 ] ) -> (* reduction of logical or *) (Bindlib.box_apply2 (fun e1 e2 -> match (e1, e2) with - | (ELit (LBool false), _), new_e | new_e, (ELit (LBool false), _) -> new_e - | (ELit (LBool true), _), _ | _, (ELit (LBool true), _) -> (ELit (LBool true), pos) + | (ELit (LBool false), _), new_e | new_e, (ELit (LBool false), _) -> + new_e + | (ELit (LBool true), _), _ | _, (ELit (LBool true), _) -> + (ELit (LBool true), pos) | _ -> (EApp (op, [ e1; e2 ]), pos))) (rec_helper e1) (rec_helper e2) | EApp - ( ((EOp (Binop And), _ | EApp ((EOp (Unop (Log _)), _), [ (EOp (Binop And), _) ]), _) as op), + ( (( EOp (Binop And), _ + | EApp ((EOp (Unop (Log _)), _), [ (EOp (Binop And), _) ]), _ ) as op), [ e1; e2 ] ) -> (* reduction of logical and *) (Bindlib.box_apply2 (fun e1 e2 -> match (e1, e2) with - | (ELit (LBool true), _), new_e | new_e, (ELit (LBool true), _) -> new_e - | (ELit (LBool false), _), _ | _, (ELit (LBool false), _) -> (ELit (LBool false), pos) + | (ELit (LBool true), _), new_e | new_e, (ELit (LBool true), _) -> + new_e + | (ELit (LBool false), _), _ | _, (ELit (LBool false), _) -> + (ELit (LBool false), pos) | _ -> (EApp (op, [ e1; e2 ]), pos))) (rec_helper e1) (rec_helper e2) | EVar (x, _) -> Bindlib.box_apply (fun x -> (x, pos)) (Bindlib.box_var x) @@ -57,14 +70,19 @@ let rec partial_evaluation (ctx : partial_evaluation_ctx) (e : expr Pos.marked) (fun args -> (ETuple (args, s_name), pos)) (List.map rec_helper args |> Bindlib.box_list) | ETupleAccess (arg, i, s_name, typs) -> - Bindlib.box_apply (fun arg -> (ETupleAccess (arg, i, s_name, typs), pos)) (rec_helper arg) + Bindlib.box_apply + (fun arg -> (ETupleAccess (arg, i, s_name, typs), pos)) + (rec_helper arg) | EInj (arg, i, e_name, typs) -> - Bindlib.box_apply (fun arg -> (EInj (arg, i, e_name, typs), pos)) (rec_helper arg) + Bindlib.box_apply + (fun arg -> (EInj (arg, i, e_name, typs), pos)) + (rec_helper arg) | EMatch (arg, arms, e_name) -> Bindlib.box_apply2 (fun arg arms -> match (arg, arms) with - | (EInj (e1, i, e_name', _ts), _), _ when Ast.EnumName.compare e_name e_name' = 0 -> + | (EInj (e1, i, e_name', _ts), _), _ + when Ast.EnumName.compare e_name e_name' = 0 -> (* iota reduction *) (EApp (List.nth arms i, [ e1 ]), pos) | _ -> (EMatch (arg, arms, e_name), pos)) @@ -79,7 +97,9 @@ let rec partial_evaluation (ctx : partial_evaluation_ctx) (e : expr Pos.marked) let vars, body = Bindlib.unmbind binder in let new_body = rec_helper body in let new_binder = Bindlib.bind_mvar vars new_body in - Bindlib.box_apply (fun binder -> (EAbs ((binder, binder_pos), typs), pos)) new_binder + Bindlib.box_apply + (fun binder -> (EAbs ((binder, binder_pos), typs), pos)) + new_binder | EApp (f, args) -> Bindlib.box_apply2 (fun f args -> @@ -90,7 +110,8 @@ let rec partial_evaluation (ctx : partial_evaluation_ctx) (e : expr Pos.marked) | _ -> (EApp (f, args), pos)) (rec_helper f) (List.map rec_helper args |> Bindlib.box_list) - | EAssert e1 -> Bindlib.box_apply (fun e1 -> (EAssert e1, pos)) (rec_helper e1) + | EAssert e1 -> + Bindlib.box_apply (fun e1 -> (EAssert e1, pos)) (rec_helper e1) | EOp op -> Bindlib.box (EOp op, pos) | EDefault (exceptions, just, cons) -> Bindlib.box_apply3 @@ -98,7 +119,10 @@ let rec partial_evaluation (ctx : partial_evaluation_ctx) (e : expr Pos.marked) (* TODO: mechanically prove each of these optimizations correct :) *) match ( List.filter - (fun except -> match Pos.unmark except with ELit LEmptyError -> false | _ -> true) + (fun except -> + match Pos.unmark except with + | ELit LEmptyError -> false + | _ -> true) exceptions (* we can discard the exceptions that are always empty error *), just, @@ -109,25 +133,33 @@ let rec partial_evaluation (ctx : partial_evaluation_ctx) (e : expr Pos.marked) (fun nb except -> if is_value except then nb + 1 else nb) 0 exceptions > 1 -> - (* at this point we know a conflict error will be triggered so we just feed the - expression to the interpreter that will print the beautiful right error message *) - Interpreter.evaluate_expr ctx.decl_ctx (EDefault (exceptions, just, cons), pos) + (* at this point we know a conflict error will be triggered so we + just feed the expression to the interpreter that will print the + beautiful right error message *) + Interpreter.evaluate_expr ctx.decl_ctx + (EDefault (exceptions, just, cons), pos) | [ except ], _, _ when is_value except -> - (* if there is only one exception and it is a non-empty value it is always chosen *) + (* if there is only one exception and it is a non-empty value it + is always chosen *) except | ( [], - ((ELit (LBool true) | EApp ((EOp (Unop (Log _)), _), [ (ELit (LBool true), _) ])), _), + ( ( ELit (LBool true) + | EApp ((EOp (Unop (Log _)), _), [ (ELit (LBool true), _) ]) ), + _ ), cons ) -> cons | ( [], - ((ELit (LBool false) | EApp ((EOp (Unop (Log _)), _), [ (ELit (LBool false), _) ])), _), + ( ( ELit (LBool false) + | EApp ((EOp (Unop (Log _)), _), [ (ELit (LBool false), _) ]) ), + _ ), _ ) -> (ELit LEmptyError, pos) | [], just, cons when not !Cli.avoid_exceptions_flag -> - (* without exceptions, a default is just an [if then else] raising an error in the - else case. This exception is only valid in the context of - compilation_with_exceptions, so we desactivate with a global flag to know if we - will be compiling using exceptions or the option monad. *) + (* without exceptions, a default is just an [if then else] raising + an error in the else case. This exception is only valid in the + context of compilation_with_exceptions, so we desactivate with + a global flag to know if we will be compiling using exceptions + or the option monad. *) (EIfThenElse (just, cons, (ELit LEmptyError, pos)), pos) | exceptions, just, cons -> (EDefault (exceptions, just, cons), pos)) (List.map rec_helper exceptions |> Bindlib.box_list) @@ -143,19 +175,24 @@ let rec partial_evaluation (ctx : partial_evaluation_ctx) (e : expr Pos.marked) | EApp ((EOp (Unop (Log _)), _), [ (ELit (LBool false), _) ]), _, _ -> e3 | ( _, - (ELit (LBool true) | EApp ((EOp (Unop (Log _)), _), [ (ELit (LBool true), _) ])), - (ELit (LBool false) | EApp ((EOp (Unop (Log _)), _), [ (ELit (LBool false), _) ])) ) + ( ELit (LBool true) + | EApp ((EOp (Unop (Log _)), _), [ (ELit (LBool true), _) ]) ), + ( ELit (LBool false) + | EApp ((EOp (Unop (Log _)), _), [ (ELit (LBool false), _) ]) ) ) -> e1 | _ -> (EIfThenElse (e1, e2, e3), pos)) (rec_helper e1) (rec_helper e2) (rec_helper e3) - | ErrorOnEmpty e1 -> Bindlib.box_apply (fun e1 -> (ErrorOnEmpty e1, pos)) (rec_helper e1) + | ErrorOnEmpty e1 -> + Bindlib.box_apply (fun e1 -> (ErrorOnEmpty e1, pos)) (rec_helper e1) let optimize_expr (decl_ctx : decl_ctx) (e : expr Pos.marked) = partial_evaluation { var_values = VarMap.empty; decl_ctx } e -let program_map (t : 'a -> expr Pos.marked -> expr Pos.marked Bindlib.box) (ctx : 'a) (p : program) - : program = +let program_map + (t : 'a -> expr Pos.marked -> expr Pos.marked Bindlib.box) + (ctx : 'a) + (p : program) : program = { p with scopes = @@ -170,7 +207,8 @@ let program_map (t : 'a -> expr Pos.marked -> expr Pos.marked Bindlib.box) (ctx { scope_let with scope_let_expr = - Bindlib.unbox (Bindlib.box_apply (t ctx) scope_let.scope_let_expr); + Bindlib.unbox + (Bindlib.box_apply (t ctx) scope_let.scope_let_expr); }) s_body.scope_body_lets; } @@ -180,7 +218,9 @@ let program_map (t : 'a -> expr Pos.marked -> expr Pos.marked Bindlib.box) (ctx } let optimize_program (p : program) : program = - program_map partial_evaluation { var_values = VarMap.empty; decl_ctx = p.decl_ctx } p + program_map partial_evaluation + { var_values = VarMap.empty; decl_ctx = p.decl_ctx } + p let rec remove_all_logs (e : expr Pos.marked) : expr Pos.marked Bindlib.box = let pos = Pos.get_position e in @@ -192,9 +232,13 @@ let rec remove_all_logs (e : expr Pos.marked) : expr Pos.marked Bindlib.box = (fun args -> (ETuple (args, s_name), pos)) (List.map rec_helper args |> Bindlib.box_list) | ETupleAccess (arg, i, s_name, typs) -> - Bindlib.box_apply (fun arg -> (ETupleAccess (arg, i, s_name, typs), pos)) (rec_helper arg) + Bindlib.box_apply + (fun arg -> (ETupleAccess (arg, i, s_name, typs), pos)) + (rec_helper arg) | EInj (arg, i, e_name, typs) -> - Bindlib.box_apply (fun arg -> (EInj (arg, i, e_name, typs), pos)) (rec_helper arg) + Bindlib.box_apply + (fun arg -> (EInj (arg, i, e_name, typs), pos)) + (rec_helper arg) | EMatch (arg, arms, e_name) -> Bindlib.box_apply2 (fun arg arms -> (EMatch (arg, arms, e_name), pos)) @@ -209,7 +253,9 @@ let rec remove_all_logs (e : expr Pos.marked) : expr Pos.marked Bindlib.box = let vars, body = Bindlib.unmbind binder in let new_body = rec_helper body in let new_binder = Bindlib.bind_mvar vars new_body in - Bindlib.box_apply (fun binder -> (EAbs ((binder, binder_pos), typs), pos)) new_binder + Bindlib.box_apply + (fun binder -> (EAbs ((binder, binder_pos), typs), pos)) + new_binder | EApp (f, args) -> Bindlib.box_apply2 (fun f args -> @@ -218,7 +264,8 @@ let rec remove_all_logs (e : expr Pos.marked) : expr Pos.marked Bindlib.box = | _ -> (EApp (f, args), pos)) (rec_helper f) (List.map rec_helper args |> Bindlib.box_list) - | EAssert e1 -> Bindlib.box_apply (fun e1 -> (EAssert e1, pos)) (rec_helper e1) + | EAssert e1 -> + Bindlib.box_apply (fun e1 -> (EAssert e1, pos)) (rec_helper e1) | EOp op -> Bindlib.box (EOp op, pos) | EDefault (exceptions, just, cons) -> Bindlib.box_apply3 @@ -229,4 +276,5 @@ let rec remove_all_logs (e : expr Pos.marked) : expr Pos.marked Bindlib.box = Bindlib.box_apply3 (fun e1 e2 e3 -> (EIfThenElse (e1, e2, e3), pos)) (rec_helper e1) (rec_helper e2) (rec_helper e3) - | ErrorOnEmpty e1 -> Bindlib.box_apply (fun e1 -> (ErrorOnEmpty e1, pos)) (rec_helper e1) + | ErrorOnEmpty e1 -> + Bindlib.box_apply (fun e1 -> (ErrorOnEmpty e1, pos)) (rec_helper e1) diff --git a/compiler/dcalc/optimizations.mli b/compiler/dcalc/optimizations.mli index 973f906a..0827b091 100644 --- a/compiler/dcalc/optimizations.mli +++ b/compiler/dcalc/optimizations.mli @@ -1,15 +1,18 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2022 Inria, contributors: Alain Delaët - , Denis Merigoux +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2022 Inria, + contributors: Alain Delaët , Denis Merigoux + - 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 + 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 + 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. *) (** Optimization passes for default calculus programs and expressions *) @@ -18,7 +21,5 @@ open Utils open Ast val optimize_expr : decl_ctx -> expr Pos.marked -> expr Pos.marked Bindlib.box - val optimize_program : program -> program - val remove_all_logs : expr Pos.marked -> expr Pos.marked Bindlib.box diff --git a/compiler/dcalc/print.ml b/compiler/dcalc/print.ml index c9476374..98bd2427 100644 --- a/compiler/dcalc/print.ml +++ b/compiler/dcalc/print.ml @@ -1,15 +1,17 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux - +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, contributor: + Denis Merigoux - 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 + 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 + 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. *) open Utils @@ -30,14 +32,17 @@ let begins_with_uppercase (s : string) : bool = let first_letter = CamomileLibraryDefault.Camomile.UTF8.get s 0 in is_uppercase first_letter -let format_uid_list (fmt : Format.formatter) (infos : Uid.MarkedString.info list) : unit = +let format_uid_list + (fmt : Format.formatter) (infos : Uid.MarkedString.info list) : unit = Format.fprintf fmt "%a" (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt ".") (fun fmt info -> Format.fprintf fmt "%a" (Utils.Cli.format_with_style - (if begins_with_uppercase (Pos.unmark info) then [ ANSITerminal.red ] else [])) + (if begins_with_uppercase (Pos.unmark info) then + [ ANSITerminal.red ] + else [])) (Format.asprintf "%a" Utils.Uid.MarkedString.format_info info))) infos @@ -45,7 +50,9 @@ let format_keyword (fmt : Format.formatter) (s : string) : unit = Format.fprintf fmt "%a" (Utils.Cli.format_with_style [ ANSITerminal.red ]) s let format_base_type (fmt : Format.formatter) (s : string) : unit = - Format.fprintf fmt "%a" (Utils.Cli.format_with_style [ ANSITerminal.yellow ]) s + Format.fprintf fmt "%a" + (Utils.Cli.format_with_style [ ANSITerminal.yellow ]) + s let format_punctuation (fmt : Format.formatter) (s : string) : unit = Format.fprintf fmt "%a" (Utils.Cli.format_with_style [ ANSITerminal.cyan ]) s @@ -54,7 +61,9 @@ let format_operator (fmt : Format.formatter) (s : string) : unit = Format.fprintf fmt "%a" (Utils.Cli.format_with_style [ ANSITerminal.green ]) s let format_lit_style (fmt : Format.formatter) (s : string) : unit = - Format.fprintf fmt "%a" (Utils.Cli.format_with_style [ ANSITerminal.yellow ]) s + Format.fprintf fmt "%a" + (Utils.Cli.format_with_style [ ANSITerminal.yellow ]) + s let format_tlit (fmt : Format.formatter) (l : typ_lit) : unit = format_base_type fmt @@ -67,12 +76,15 @@ let format_tlit (fmt : Format.formatter) (l : typ_lit) : unit = | TDuration -> "duration" | TDate -> "date") -let format_enum_constructor (fmt : Format.formatter) (c : EnumConstructor.t) : unit = +let format_enum_constructor (fmt : Format.formatter) (c : EnumConstructor.t) : + unit = Format.fprintf fmt "%a" (Utils.Cli.format_with_style [ ANSITerminal.magenta ]) (Format.asprintf "%a" EnumConstructor.format_t c) -let rec format_typ (ctx : Ast.decl_ctx) (fmt : Format.formatter) (typ : typ Pos.marked) : unit = +let rec format_typ + (ctx : Ast.decl_ctx) (fmt : Format.formatter) (typ : typ Pos.marked) : unit + = let format_typ = format_typ ctx in let format_typ_with_parens (fmt : Format.formatter) (t : typ Pos.marked) = if typ_needs_parens t then Format.fprintf fmt "(%a)" format_typ t @@ -83,30 +95,39 @@ let rec format_typ (ctx : Ast.decl_ctx) (fmt : Format.formatter) (typ : typ Pos. | TTuple (ts, None) -> Format.fprintf fmt "@[(%a)@]" (Format.pp_print_list - ~pp_sep:(fun fmt () -> Format.fprintf fmt "@ %a@ " format_operator "*") + ~pp_sep:(fun fmt () -> + Format.fprintf fmt "@ %a@ " format_operator "*") (fun fmt t -> Format.fprintf fmt "%a" format_typ t)) ts | TTuple (_args, Some s) -> - Format.fprintf fmt "@[%a%a%a%a@]" Ast.StructName.format_t s format_punctuation "{" + Format.fprintf fmt "@[%a%a%a%a@]" Ast.StructName.format_t s + format_punctuation "{" (Format.pp_print_list - ~pp_sep:(fun fmt () -> Format.fprintf fmt "%a@ " format_punctuation ";") + ~pp_sep:(fun fmt () -> + Format.fprintf fmt "%a@ " format_punctuation ";") (fun fmt (field, typ) -> - Format.fprintf fmt "%a%a%a%a@ %a" format_punctuation "\"" StructFieldName.format_t - field format_punctuation "\"" format_punctuation ":" format_typ typ)) + Format.fprintf fmt "%a%a%a%a@ %a" format_punctuation "\"" + StructFieldName.format_t field format_punctuation "\"" + format_punctuation ":" format_typ typ)) (StructMap.find s ctx.ctx_structs) format_punctuation "}" | TEnum (_, e) -> - Format.fprintf fmt "@[%a%a%a%a@]" Ast.EnumName.format_t e format_punctuation "[" + Format.fprintf fmt "@[%a%a%a%a@]" Ast.EnumName.format_t e + format_punctuation "[" (Format.pp_print_list - ~pp_sep:(fun fmt () -> Format.fprintf fmt "@ %a@ " format_punctuation "|") + ~pp_sep:(fun fmt () -> + Format.fprintf fmt "@ %a@ " format_punctuation "|") (fun fmt (case, typ) -> - Format.fprintf fmt "%a%a@ %a" format_enum_constructor case format_punctuation ":" - format_typ typ)) - (EnumMap.find e ctx.ctx_enums) format_punctuation "]" + Format.fprintf fmt "%a%a@ %a" format_enum_constructor case + format_punctuation ":" format_typ typ)) + (EnumMap.find e ctx.ctx_enums) + format_punctuation "]" | TArrow (t1, t2) -> - Format.fprintf fmt "@[%a %a@ %a@]" format_typ_with_parens t1 format_operator "→" - format_typ t2 - | TArray t1 -> Format.fprintf fmt "@[%a@ %a@]" format_base_type "array" format_typ t1 + Format.fprintf fmt "@[%a %a@ %a@]" format_typ_with_parens t1 + format_operator "→" format_typ t2 + | TArray t1 -> + Format.fprintf fmt "@[%a@ %a@]" format_base_type "array" format_typ + t1 | TAny -> format_base_type fmt "any" (* (EmileRolley) NOTE: seems to be factorizable with Lcalc.Print.format_lit. *) @@ -117,18 +138,30 @@ let format_lit (fmt : Format.formatter) (l : lit Pos.marked) : unit = | LEmptyError -> format_lit_style fmt "∅ " | LUnit -> format_lit_style fmt "()" | LRat i -> - format_lit_style fmt (Runtime.decimal_to_string ~max_prec_digits:!Utils.Cli.max_prec_digits i) + format_lit_style fmt + (Runtime.decimal_to_string ~max_prec_digits:!Utils.Cli.max_prec_digits i) | LMoney e -> ( match !Utils.Cli.locale_lang with - | En -> format_lit_style fmt (Format.asprintf "$%s" (Runtime.money_to_string e)) - | Fr -> format_lit_style fmt (Format.asprintf "%s €" (Runtime.money_to_string e)) - | Pl -> format_lit_style fmt (Format.asprintf "%s PLN" (Runtime.money_to_string e))) + | En -> + format_lit_style fmt + (Format.asprintf "$%s" (Runtime.money_to_string e)) + | Fr -> + format_lit_style fmt + (Format.asprintf "%s €" (Runtime.money_to_string e)) + | Pl -> + format_lit_style fmt + (Format.asprintf "%s PLN" (Runtime.money_to_string e))) | LDate d -> format_lit_style fmt (Runtime.date_to_string d) | LDuration d -> format_lit_style fmt (Runtime.duration_to_string d) let format_op_kind (fmt : Format.formatter) (k : op_kind) = Format.fprintf fmt "%s" - (match k with KInt -> "" | KRat -> "." | KMoney -> "$" | KDate -> "@" | KDuration -> "^") + (match k with + | KInt -> "" + | KRat -> "." + | KMoney -> "$" + | KDate -> "@" + | KDuration -> "^") let format_binop (fmt : Format.formatter) (op : binop Pos.marked) : unit = format_operator fmt @@ -184,12 +217,16 @@ let needs_parens (e : expr Pos.marked) : bool = let format_var (fmt : Format.formatter) (v : Var.t) : unit = Format.fprintf fmt "%s_%d" (Bindlib.name_of v) (Bindlib.uid_of v) -let rec format_expr ?(debug : bool = false) (ctx : Ast.decl_ctx) (fmt : Format.formatter) +let rec format_expr + ?(debug : bool = false) + (ctx : Ast.decl_ctx) + (fmt : Format.formatter) (e : expr Pos.marked) : unit = let format_expr = format_expr ~debug ctx in let format_with_parens (fmt : Format.formatter) (e : expr Pos.marked) = if needs_parens e then - Format.fprintf fmt "%a%a%a" format_punctuation "(" format_expr e format_punctuation ")" + Format.fprintf fmt "%a%a%a" format_punctuation "(" format_expr e + format_punctuation ")" else Format.fprintf fmt "%a" format_expr e in match Pos.unmark e with @@ -201,13 +238,15 @@ let rec format_expr ?(debug : bool = false) (ctx : Ast.decl_ctx) (fmt : Format.f (fun fmt e -> Format.fprintf fmt "%a" format_expr e)) es format_punctuation ")" | ETuple (es, Some s) -> - Format.fprintf fmt "@[%a@ @[%a%a%a@]@]" Ast.StructName.format_t s - format_punctuation "{" + Format.fprintf fmt "@[%a@ @[%a%a%a@]@]" + Ast.StructName.format_t s format_punctuation "{" (Format.pp_print_list - ~pp_sep:(fun fmt () -> Format.fprintf fmt "%a@ " format_punctuation ";") + ~pp_sep:(fun fmt () -> + Format.fprintf fmt "%a@ " format_punctuation ";") (fun fmt (e, struct_field) -> - Format.fprintf fmt "%a%a%a%a@ %a" format_punctuation "\"" Ast.StructFieldName.format_t - struct_field format_punctuation "\"" format_punctuation "=" format_expr e)) + Format.fprintf fmt "%a%a%a%a@ %a" format_punctuation "\"" + Ast.StructFieldName.format_t struct_field format_punctuation "\"" + format_punctuation "=" format_expr e)) (List.combine es (List.map fst (Ast.StructMap.find s ctx.ctx_structs))) format_punctuation "}" | EArray es -> @@ -218,10 +257,11 @@ let rec format_expr ?(debug : bool = false) (ctx : Ast.decl_ctx) (fmt : Format.f es format_punctuation "]" | ETupleAccess (e1, n, s, _ts) -> ( match s with - | None -> Format.fprintf fmt "%a%a%d" format_expr e1 format_punctuation "." n + | None -> + Format.fprintf fmt "%a%a%d" format_expr e1 format_punctuation "." n | Some s -> - Format.fprintf fmt "%a%a%a%a%a" format_expr e1 format_operator "." format_punctuation "\"" - Ast.StructFieldName.format_t + Format.fprintf fmt "%a%a%a%a%a" format_expr e1 format_operator "." + format_punctuation "\"" Ast.StructFieldName.format_t (fst (List.nth (Ast.StructMap.find s ctx.ctx_structs) n)) format_punctuation "\"") | EInj (e, n, en, _ts) -> @@ -229,8 +269,8 @@ let rec format_expr ?(debug : bool = false) (ctx : Ast.decl_ctx) (fmt : Format.f (fst (List.nth (Ast.EnumMap.find en ctx.ctx_enums) n)) format_expr e | EMatch (e, es, e_name) -> - Format.fprintf fmt "@[%a@ @[%a@]@ %a@ %a@]" format_keyword "match" format_expr e - format_keyword "with" + Format.fprintf fmt "@[%a@ @[%a@]@ %a@ %a@]" format_keyword + "match" format_expr e format_keyword "with" (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n") (fun fmt (e, c) -> @@ -241,63 +281,82 @@ let rec format_expr ?(debug : bool = false) (ctx : Ast.decl_ctx) (fmt : Format.f | EApp ((EAbs ((binder, _), taus), _), args) -> let xs, body = Bindlib.unmbind binder in let xs_tau = List.map2 (fun x tau -> (x, tau)) (Array.to_list xs) taus in - let xs_tau_arg = List.map2 (fun (x, tau) arg -> (x, tau, arg)) xs_tau args in + let xs_tau_arg = + List.map2 (fun (x, tau) arg -> (x, tau, arg)) xs_tau args + in Format.fprintf fmt "%a%a" (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "") (fun fmt (x, tau, arg) -> - Format.fprintf fmt "@[%a@ %a@ %a@ %a@ %a@ %a@ %a@]@\n" format_keyword "let" - format_var x format_punctuation ":" (format_typ ctx) tau format_punctuation "=" - format_expr arg format_keyword "in")) + Format.fprintf fmt "@[%a@ %a@ %a@ %a@ %a@ %a@ %a@]@\n" + format_keyword "let" format_var x format_punctuation ":" + (format_typ ctx) tau format_punctuation "=" format_expr arg + format_keyword "in")) xs_tau_arg format_expr body | EAbs ((binder, _), taus) -> let xs, body = Bindlib.unmbind binder in let xs_tau = List.map2 (fun x tau -> (x, tau)) (Array.to_list xs) taus in - Format.fprintf fmt "@[%a @[%a@] %a@ %a@]" format_punctuation "λ" + Format.fprintf fmt "@[%a @[%a@] %a@ %a@]" format_punctuation + "λ" (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ") (fun fmt (x, tau) -> - Format.fprintf fmt "%a%a%a %a%a" format_punctuation "(" format_var x format_punctuation - ":" (format_typ ctx) tau format_punctuation ")")) + Format.fprintf fmt "%a%a%a %a%a" format_punctuation "(" format_var + x format_punctuation ":" (format_typ ctx) tau format_punctuation + ")")) xs_tau format_punctuation "→" format_expr body | EApp ((EOp (Binop ((Ast.Map | Ast.Filter) as op)), _), [ arg1; arg2 ]) -> - Format.fprintf fmt "@[%a@ %a@ %a@]" format_binop (op, Pos.no_pos) format_with_parens - arg1 format_with_parens arg2 + Format.fprintf fmt "@[%a@ %a@ %a@]" format_binop (op, Pos.no_pos) + format_with_parens arg1 format_with_parens arg2 | EApp ((EOp (Binop op), _), [ arg1; arg2 ]) -> - Format.fprintf fmt "@[%a@ %a@ %a@]" format_with_parens arg1 format_binop - (op, Pos.no_pos) format_with_parens arg2 - | EApp ((EOp (Unop (Log _)), _), [ arg1 ]) when not debug -> format_expr fmt arg1 + Format.fprintf fmt "@[%a@ %a@ %a@]" format_with_parens arg1 + format_binop (op, Pos.no_pos) format_with_parens arg2 + | EApp ((EOp (Unop (Log _)), _), [ arg1 ]) when not debug -> + format_expr fmt arg1 | EApp ((EOp (Unop op), _), [ arg1 ]) -> - Format.fprintf fmt "@[%a@ %a@]" format_unop (op, Pos.no_pos) format_with_parens arg1 + Format.fprintf fmt "@[%a@ %a@]" format_unop (op, Pos.no_pos) + format_with_parens arg1 | EApp (f, args) -> Format.fprintf fmt "@[%a@ %a@]" format_expr f - (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ") format_with_parens) + (Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ") + format_with_parens) args | EIfThenElse (e1, e2, e3) -> - Format.fprintf fmt "@[%a@ %a@ %a@ %a@ %a@ %a@]" format_keyword "if" format_expr e1 - format_keyword "then" format_expr e2 format_keyword "else" format_expr e3 + Format.fprintf fmt "@[%a@ %a@ %a@ %a@ %a@ %a@]" format_keyword "if" + format_expr e1 format_keyword "then" format_expr e2 format_keyword + "else" format_expr e3 | EOp (Ternop op) -> Format.fprintf fmt "%a" format_ternop (op, Pos.no_pos) | EOp (Binop op) -> Format.fprintf fmt "%a" format_binop (op, Pos.no_pos) | EOp (Unop op) -> Format.fprintf fmt "%a" format_unop (op, Pos.no_pos) | EDefault (exceptions, just, cons) -> if List.length exceptions = 0 then - Format.fprintf fmt "@[%a%a@ %a@ %a%a@]" format_punctuation "⟨" format_expr just - format_punctuation "⊢" format_expr cons format_punctuation "⟩" - else - Format.fprintf fmt "@[%a%a@ %a@ %a@ %a@ %a%a@]" format_punctuation "⟨" - (Format.pp_print_list - ~pp_sep:(fun fmt () -> Format.fprintf fmt "%a@ " format_punctuation ",") - format_expr) - exceptions format_punctuation "|" format_expr just format_punctuation "⊢" format_expr cons + Format.fprintf fmt "@[%a%a@ %a@ %a%a@]" format_punctuation "⟨" + format_expr just format_punctuation "⊢" format_expr cons format_punctuation "⟩" + else + Format.fprintf fmt "@[%a%a@ %a@ %a@ %a@ %a%a@]" + format_punctuation "⟨" + (Format.pp_print_list + ~pp_sep:(fun fmt () -> + Format.fprintf fmt "%a@ " format_punctuation ",") + format_expr) + exceptions format_punctuation "|" format_expr just format_punctuation + "⊢" format_expr cons format_punctuation "⟩" | ErrorOnEmpty e' -> - Format.fprintf fmt "%a@ %a" format_operator "error_empty" format_with_parens e' + Format.fprintf fmt "%a@ %a" format_operator "error_empty" + format_with_parens e' | EAssert e' -> - Format.fprintf fmt "@[%a@ %a%a%a@]" format_keyword "assert" format_punctuation "(" - format_expr e' format_punctuation ")" + Format.fprintf fmt "@[%a@ %a%a%a@]" format_keyword "assert" + format_punctuation "(" format_expr e' format_punctuation ")" -let format_scope ?(debug : bool = false) (ctx : decl_ctx) (fmt : Format.formatter) +let format_scope + ?(debug : bool = false) + (ctx : decl_ctx) + (fmt : Format.formatter) ((n, s) : Ast.ScopeName.t * scope_body) = - Format.fprintf fmt "@[%a %a =@ %a@]" format_keyword "let" Ast.ScopeName.format_t n - (format_expr ctx ~debug) - (Bindlib.unbox (Ast.build_whole_scope_expr ctx s (Pos.get_position (Ast.ScopeName.get_info n)))) + Format.fprintf fmt "@[%a %a =@ %a@]" format_keyword "let" + Ast.ScopeName.format_t n (format_expr ctx ~debug) + (Bindlib.unbox + (Ast.build_whole_scope_expr ctx s + (Pos.get_position (Ast.ScopeName.get_info n)))) diff --git a/compiler/dcalc/print.mli b/compiler/dcalc/print.mli index 179a56d1..78329751 100644 --- a/compiler/dcalc/print.mli +++ b/compiler/dcalc/print.mli @@ -1,15 +1,17 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux - +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, contributor: + Denis Merigoux - 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 + 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 + 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. *) (** Printing functions for the default calculus AST *) @@ -19,43 +21,28 @@ open Utils (** {1 Helpers} *) val is_uppercase : CamomileLibraryDefault.Camomile.UChar.t -> bool - val begins_with_uppercase : string -> bool (** {1 Common syntax highlighting helpers}*) val format_base_type : Format.formatter -> string -> unit - val format_keyword : Format.formatter -> string -> unit - val format_punctuation : Format.formatter -> string -> unit - val format_operator : Format.formatter -> string -> unit - val format_lit_style : Format.formatter -> string -> unit (** {1 Formatters} *) val format_uid_list : Format.formatter -> Uid.MarkedString.info list -> unit - val format_enum_constructor : Format.formatter -> Ast.EnumConstructor.t -> unit - val format_tlit : Format.formatter -> Ast.typ_lit -> unit - val format_typ : Ast.decl_ctx -> Format.formatter -> Ast.typ Pos.marked -> unit - val format_lit : Format.formatter -> Ast.lit Pos.marked -> unit - val format_op_kind : Format.formatter -> Ast.op_kind -> unit - val format_binop : Format.formatter -> Ast.binop Pos.marked -> unit - val format_ternop : Format.formatter -> Ast.ternop Pos.marked -> unit - val format_log_entry : Format.formatter -> Ast.log_entry -> unit - val format_unop : Format.formatter -> Ast.unop Pos.marked -> unit - val format_var : Format.formatter -> Ast.Var.t -> unit val format_expr : diff --git a/compiler/dcalc/typing.ml b/compiler/dcalc/typing.ml index 8f19db37..44067beb 100644 --- a/compiler/dcalc/typing.ml +++ b/compiler/dcalc/typing.ml @@ -1,19 +1,21 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux - +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, contributor: + Denis Merigoux - 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 + 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 + 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. *) -(** Typing for the default calculus. Because of the error terms, we perform type inference using the - classical W algorithm with union-find unification. *) +(** Typing for the default calculus. Because of the error terms, we perform type + inference using the classical W algorithm with union-find unification. *) open Utils module A = Ast @@ -29,8 +31,9 @@ module Any = end) () -(** We do not reuse {!type: Dcalc.Ast.typ} because we have to include a new [TAny] variant. Indeed, - error terms can have any type and this has to be captured by the type sytem. *) +(** We do not reuse {!type: Dcalc.Ast.typ} because we have to include a new + [TAny] variant. Indeed, error terms can have any type and this has to be + captured by the type sytem. *) type typ = | TLit of A.typ_lit | TArrow of typ Pos.marked UnionFind.elem * typ Pos.marked UnionFind.elem @@ -43,10 +46,13 @@ let typ_needs_parens (t : typ Pos.marked UnionFind.elem) : bool = let t = UnionFind.get (UnionFind.find t) in match Pos.unmark t with TArrow _ | TArray _ -> true | _ -> false -let rec format_typ (ctx : Ast.decl_ctx) (fmt : Format.formatter) +let rec format_typ + (ctx : Ast.decl_ctx) + (fmt : Format.formatter) (typ : typ Pos.marked UnionFind.elem) : unit = let format_typ = format_typ ctx in - let format_typ_with_parens (fmt : Format.formatter) (t : typ Pos.marked UnionFind.elem) = + let format_typ_with_parens + (fmt : Format.formatter) (t : typ Pos.marked UnionFind.elem) = if typ_needs_parens t then Format.fprintf fmt "(%a)" format_typ t else Format.fprintf fmt "%a" format_typ t in @@ -62,21 +68,24 @@ let rec format_typ (ctx : Ast.decl_ctx) (fmt : Format.formatter) | TTuple (_ts, Some s) -> Format.fprintf fmt "%a" Ast.StructName.format_t s | TEnum (_ts, e) -> Format.fprintf fmt "%a" Ast.EnumName.format_t e | TArrow (t1, t2) -> - Format.fprintf fmt "@[%a →@ %a@]" format_typ_with_parens t1 format_typ t2 + Format.fprintf fmt "@[%a →@ %a@]" format_typ_with_parens t1 + format_typ t2 | TArray t1 -> Format.fprintf fmt "@[%a@ array@]" format_typ t1 | TAny d -> Format.fprintf fmt "any[%d]" (Any.hash d) (** Raises an error if unification cannot be performed *) -let rec unify (ctx : Ast.decl_ctx) (t1 : typ Pos.marked UnionFind.elem) +let rec unify + (ctx : Ast.decl_ctx) + (t1 : typ Pos.marked UnionFind.elem) (t2 : typ Pos.marked UnionFind.elem) : unit = let unify = unify ctx in - (* Cli.debug_print (Format.asprintf "Unifying %a and %a" (format_typ ctx) t1 (format_typ ctx) - t2); *) + (* Cli.debug_print (Format.asprintf "Unifying %a and %a" (format_typ ctx) t1 + (format_typ ctx) t2); *) let t1_repr = UnionFind.get (UnionFind.find t1) in let t2_repr = UnionFind.get (UnionFind.find t2) in let raise_type_error (t1_pos : Pos.t) (t2_pos : Pos.t) : 'a = - (* TODO: if we get weird error messages, then it means that we should use the persistent version - of the union-find data structure. *) + (* TODO: if we get weird error messages, then it means that we should use + the persistent version of the union-find data structure. *) let t1_s = Cli.with_style [ ANSITerminal.yellow ] "%s" (Re.Pcre.substitute ~rex:(Re.Pcre.regexp "\n\\s*") @@ -129,9 +138,10 @@ let rec unify (ctx : Ast.decl_ctx) (t1 : typ Pos.marked UnionFind.elem) let t_union = UnionFind.union t1 t2 in match repr with None -> () | Some t_repr -> UnionFind.set t_union t_repr -(** Operators have a single type, instead of being polymorphic with constraints. This allows us to - have a simpler type system, while we argue the syntactic burden of operator annotations helps - the programmer visualize the type flow in the code. *) +(** Operators have a single type, instead of being polymorphic with constraints. + This allows us to have a simpler type system, while we argue the syntactic + burden of operator annotations helps the programmer visualize the type flow + in the code. *) let op_type (op : A.operator Pos.marked) : typ Pos.marked UnionFind.elem = let pos = Pos.get_position op in let bt = UnionFind.make (TLit TBool, pos) in @@ -146,10 +156,13 @@ let op_type (op : A.operator Pos.marked) : typ Pos.marked UnionFind.elem = let array_any2 = UnionFind.make (TArray any2, pos) in let arr x y = UnionFind.make (TArrow (x, y), pos) in match Pos.unmark op with - | A.Ternop A.Fold -> arr (arr any2 (arr any any2)) (arr any2 (arr array_any any2)) + | A.Ternop A.Fold -> + arr (arr any2 (arr any any2)) (arr any2 (arr array_any any2)) | A.Binop (A.And | A.Or | A.Xor) -> arr bt (arr bt bt) - | A.Binop (A.Add KInt | A.Sub KInt | A.Mult KInt | A.Div KInt) -> arr it (arr it it) - | A.Binop (A.Add KRat | A.Sub KRat | A.Mult KRat | A.Div KRat) -> arr rt (arr rt rt) + | A.Binop (A.Add KInt | A.Sub KInt | A.Mult KInt | A.Div KInt) -> + arr it (arr it it) + | A.Binop (A.Add KRat | A.Sub KRat | A.Mult KRat | A.Div KRat) -> + arr rt (arr rt rt) | A.Binop (A.Add KMoney | A.Sub KMoney) -> arr mt (arr mt mt) | A.Binop (A.Add KDuration | A.Sub KDuration) -> arr dut (arr dut dut) | A.Binop (A.Sub KDate) -> arr dat (arr dat dut) @@ -157,11 +170,16 @@ let op_type (op : A.operator Pos.marked) : typ Pos.marked UnionFind.elem = | A.Binop (A.Div KDuration) -> arr dut (arr dut rt) | A.Binop (A.Div KMoney) -> arr mt (arr mt rt) | A.Binop (A.Mult KMoney) -> arr mt (arr rt mt) - | A.Binop (A.Lt KInt | A.Lte KInt | A.Gt KInt | A.Gte KInt) -> arr it (arr it bt) - | A.Binop (A.Lt KRat | A.Lte KRat | A.Gt KRat | A.Gte KRat) -> arr rt (arr rt bt) - | A.Binop (A.Lt KMoney | A.Lte KMoney | A.Gt KMoney | A.Gte KMoney) -> arr mt (arr mt bt) - | A.Binop (A.Lt KDate | A.Lte KDate | A.Gt KDate | A.Gte KDate) -> arr dat (arr dat bt) - | A.Binop (A.Lt KDuration | A.Lte KDuration | A.Gt KDuration | A.Gte KDuration) -> + | A.Binop (A.Lt KInt | A.Lte KInt | A.Gt KInt | A.Gte KInt) -> + arr it (arr it bt) + | A.Binop (A.Lt KRat | A.Lte KRat | A.Gt KRat | A.Gte KRat) -> + arr rt (arr rt bt) + | A.Binop (A.Lt KMoney | A.Lte KMoney | A.Gt KMoney | A.Gte KMoney) -> + arr mt (arr mt bt) + | A.Binop (A.Lt KDate | A.Lte KDate | A.Gt KDate | A.Gte KDate) -> + arr dat (arr dat bt) + | A.Binop (A.Lt KDuration | A.Lte KDuration | A.Gt KDuration | A.Gte KDuration) + -> arr dut (arr dut bt) | A.Binop (A.Eq | A.Neq) -> arr any (arr any bt) | A.Binop A.Map -> arr (arr any any2) (arr array_any array_any2) @@ -190,9 +208,13 @@ let rec ast_to_typ (ty : A.typ) : typ = ( UnionFind.make (Pos.map_under_mark ast_to_typ t1), UnionFind.make (Pos.map_under_mark ast_to_typ t2) ) | A.TTuple (ts, s) -> - TTuple (List.map (fun t -> UnionFind.make (Pos.map_under_mark ast_to_typ t)) ts, s) + TTuple + ( List.map (fun t -> UnionFind.make (Pos.map_under_mark ast_to_typ t)) ts, + s ) | A.TEnum (ts, e) -> - TEnum (List.map (fun t -> UnionFind.make (Pos.map_under_mark ast_to_typ t)) ts, e) + TEnum + ( List.map (fun t -> UnionFind.make (Pos.map_under_mark ast_to_typ t)) ts, + e ) | A.TArray t -> TArray (UnionFind.make (Pos.map_under_mark ast_to_typ t)) | A.TAny -> TAny (Any.fresh ()) @@ -213,9 +235,11 @@ let rec typ_to_ast (ty : typ Pos.marked UnionFind.elem) : A.typ Pos.marked = type env = typ Pos.marked UnionFind.elem A.VarMap.t (** Infers the most permissive type from an expression *) -let rec typecheck_expr_bottom_up (ctx : Ast.decl_ctx) (env : env) (e : A.expr Pos.marked) : +let rec typecheck_expr_bottom_up + (ctx : Ast.decl_ctx) (env : env) (e : A.expr Pos.marked) : typ Pos.marked UnionFind.elem = - (* Cli.debug_print (Format.asprintf "Looking for type of %a" (Print.format_expr ctx) e); *) + (* Cli.debug_print (Format.asprintf "Looking for type of %a" + (Print.format_expr ctx) e); *) try let out = match Pos.unmark e with @@ -230,46 +254,66 @@ let rec typecheck_expr_bottom_up (ctx : Ast.decl_ctx) (env : env) (e : A.expr Po | ELit (LRat _) -> UnionFind.make (Pos.same_pos_as (TLit TRat) e) | ELit (LMoney _) -> UnionFind.make (Pos.same_pos_as (TLit TMoney) e) | ELit (LDate _) -> UnionFind.make (Pos.same_pos_as (TLit TDate) e) - | ELit (LDuration _) -> UnionFind.make (Pos.same_pos_as (TLit TDuration) e) + | ELit (LDuration _) -> + UnionFind.make (Pos.same_pos_as (TLit TDuration) e) | ELit LUnit -> UnionFind.make (Pos.same_pos_as (TLit TUnit) e) - | ELit LEmptyError -> UnionFind.make (Pos.same_pos_as (TAny (Any.fresh ())) e) + | ELit LEmptyError -> + UnionFind.make (Pos.same_pos_as (TAny (Any.fresh ())) e) | ETuple (es, s) -> let ts = List.map (typecheck_expr_bottom_up ctx env) es in UnionFind.make (Pos.same_pos_as (TTuple (ts, s)) e) | ETupleAccess (e1, n, s, typs) -> ( let typs = - List.map (fun typ -> UnionFind.make (Pos.map_under_mark ast_to_typ typ)) typs + List.map + (fun typ -> UnionFind.make (Pos.map_under_mark ast_to_typ typ)) + typs in - typecheck_expr_top_down ctx env e1 (UnionFind.make (TTuple (typs, s), Pos.get_position e)); + typecheck_expr_top_down ctx env e1 + (UnionFind.make (TTuple (typs, s), Pos.get_position e)); match List.nth_opt typs n with | Some t' -> t' | None -> Errors.raise_spanned_error (Pos.get_position e1) - "Expression should have a tuple type with at least %d elements but only has %d" n - (List.length typs)) + "Expression should have a tuple type with at least %d elements \ + but only has %d" + n (List.length typs)) | EInj (e1, n, e_name, ts) -> - let ts = List.map (fun t -> UnionFind.make (Pos.map_under_mark ast_to_typ t)) ts in + let ts = + List.map + (fun t -> UnionFind.make (Pos.map_under_mark ast_to_typ t)) + ts + in let ts_n = match List.nth_opt ts n with | Some ts_n -> ts_n | None -> Errors.raise_spanned_error (Pos.get_position e) - "Expression should have a sum type with at least %d cases but only has %d" n - (List.length ts) + "Expression should have a sum type with at least %d cases \ + but only has %d" + n (List.length ts) in typecheck_expr_top_down ctx env e1 ts_n; UnionFind.make (Pos.same_pos_as (TEnum (ts, e_name)) e) | EMatch (e1, es, e_name) -> let enum_cases = - List.map (fun e' -> UnionFind.make (Pos.same_pos_as (TAny (Any.fresh ())) e')) es + List.map + (fun e' -> + UnionFind.make (Pos.same_pos_as (TAny (Any.fresh ())) e')) + es + in + let t_e1 = + UnionFind.make (Pos.same_pos_as (TEnum (enum_cases, e_name)) e1) in - let t_e1 = UnionFind.make (Pos.same_pos_as (TEnum (enum_cases, e_name)) e1) in typecheck_expr_top_down ctx env e1 t_e1; - let t_ret = UnionFind.make (Pos.same_pos_as (TAny (Any.fresh ())) e) in + let t_ret = + UnionFind.make (Pos.same_pos_as (TAny (Any.fresh ())) e) + in List.iteri (fun i es' -> let enum_t = List.nth enum_cases i in - let t_es' = UnionFind.make (Pos.same_pos_as (TArrow (enum_t, t_ret)) es') in + let t_es' = + UnionFind.make (Pos.same_pos_as (TArrow (enum_t, t_ret)) es') + in typecheck_expr_top_down ctx env es' t_es') es; t_ret @@ -279,10 +323,16 @@ let rec typecheck_expr_bottom_up (ctx : Ast.decl_ctx) (env : env) (e : A.expr Po let xstaus = List.map2 (fun x tau -> - (x, UnionFind.make (ast_to_typ (Pos.unmark tau), Pos.get_position tau))) + ( x, + UnionFind.make + (ast_to_typ (Pos.unmark tau), Pos.get_position tau) )) (Array.to_list xs) taus in - let env = List.fold_left (fun env (x, tau) -> A.VarMap.add x tau env) env xstaus in + let env = + List.fold_left + (fun env (x, tau) -> A.VarMap.add x tau env) + env xstaus + in List.fold_right (fun (_, t_arg) (acc : typ Pos.marked UnionFind.elem) -> UnionFind.make (TArrow (t_arg, acc), pos_binder)) @@ -290,35 +340,45 @@ let rec typecheck_expr_bottom_up (ctx : Ast.decl_ctx) (env : env) (e : A.expr Po (typecheck_expr_bottom_up ctx env body) else Errors.raise_spanned_error pos_binder - "function has %d variables but was supplied %d types" (Array.length xs) - (List.length taus) + "function has %d variables but was supplied %d types" + (Array.length xs) (List.length taus) | EApp (e1, args) -> let t_args = List.map (typecheck_expr_bottom_up ctx env) args in - let t_ret = UnionFind.make (Pos.same_pos_as (TAny (Any.fresh ())) e) in + let t_ret = + UnionFind.make (Pos.same_pos_as (TAny (Any.fresh ())) e) + in let t_app = List.fold_right - (fun t_arg acc -> UnionFind.make (Pos.same_pos_as (TArrow (t_arg, acc)) e)) + (fun t_arg acc -> + UnionFind.make (Pos.same_pos_as (TArrow (t_arg, acc)) e)) t_args t_ret in typecheck_expr_top_down ctx env e1 t_app; t_ret | EOp op -> op_type (Pos.same_pos_as op e) | EDefault (excepts, just, cons) -> - typecheck_expr_top_down ctx env just (UnionFind.make (Pos.same_pos_as (TLit TBool) just)); + typecheck_expr_top_down ctx env just + (UnionFind.make (Pos.same_pos_as (TLit TBool) just)); let tcons = typecheck_expr_bottom_up ctx env cons in - List.iter (fun except -> typecheck_expr_top_down ctx env except tcons) excepts; + List.iter + (fun except -> typecheck_expr_top_down ctx env except tcons) + excepts; tcons | EIfThenElse (cond, et, ef) -> - typecheck_expr_top_down ctx env cond (UnionFind.make (Pos.same_pos_as (TLit TBool) cond)); + typecheck_expr_top_down ctx env cond + (UnionFind.make (Pos.same_pos_as (TLit TBool) cond)); let tt = typecheck_expr_bottom_up ctx env et in typecheck_expr_top_down ctx env ef tt; tt | EAssert e' -> - typecheck_expr_top_down ctx env e' (UnionFind.make (Pos.same_pos_as (TLit TBool) e')); + typecheck_expr_top_down ctx env e' + (UnionFind.make (Pos.same_pos_as (TLit TBool) e')); UnionFind.make (Pos.same_pos_as (TLit TUnit) e') | ErrorOnEmpty e' -> typecheck_expr_bottom_up ctx env e' | EArray es -> - let cell_type = UnionFind.make (Pos.same_pos_as (TAny (Any.fresh ())) e) in + let cell_type = + UnionFind.make (Pos.same_pos_as (TAny (Any.fresh ())) e) + in List.iter (fun e' -> let t_e' = typecheck_expr_bottom_up ctx env e' in @@ -326,21 +386,25 @@ let rec typecheck_expr_bottom_up (ctx : Ast.decl_ctx) (env : env) (e : A.expr Po es; UnionFind.make (Pos.same_pos_as (TArray cell_type) e) in - (* Cli.debug_print (Format.asprintf "Found type of %a: %a" (Print.format_expr ctx) e (format_typ - ctx) out); *) + (* Cli.debug_print (Format.asprintf "Found type of %a: %a" + (Print.format_expr ctx) e (format_typ ctx) out); *) out with Errors.StructuredError (msg, err_pos) when List.length err_pos = 2 -> raise (Errors.StructuredError ( msg, - (Some "Error coming from typechecking the following expression:", Pos.get_position e) + ( Some "Error coming from typechecking the following expression:", + Pos.get_position e ) :: err_pos )) (** Checks whether the expression can be typed with the provided type *) -and typecheck_expr_top_down (ctx : Ast.decl_ctx) (env : env) (e : A.expr Pos.marked) +and typecheck_expr_top_down + (ctx : Ast.decl_ctx) + (env : env) + (e : A.expr Pos.marked) (tau : typ Pos.marked UnionFind.elem) : unit = - (* Cli.debug_print (Format.asprintf "Typechecking %a : %a" (Print.format_expr ctx) e (format_typ - ctx) tau); *) + (* Cli.debug_print (Format.asprintf "Typechecking %a : %a" (Print.format_expr + ctx) e (format_typ ctx) tau); *) try match Pos.unmark e with | EVar v -> ( @@ -349,52 +413,80 @@ and typecheck_expr_top_down (ctx : Ast.decl_ctx) (env : env) (e : A.expr Pos.mar | None -> Errors.raise_spanned_error (Pos.get_position e) "Variable not found in the current context") - | ELit (LBool _) -> unify ctx tau (UnionFind.make (Pos.same_pos_as (TLit TBool) e)) - | ELit (LInt _) -> unify ctx tau (UnionFind.make (Pos.same_pos_as (TLit TInt) e)) - | ELit (LRat _) -> unify ctx tau (UnionFind.make (Pos.same_pos_as (TLit TRat) e)) - | ELit (LMoney _) -> unify ctx tau (UnionFind.make (Pos.same_pos_as (TLit TMoney) e)) - | ELit (LDate _) -> unify ctx tau (UnionFind.make (Pos.same_pos_as (TLit TDate) e)) - | ELit (LDuration _) -> unify ctx tau (UnionFind.make (Pos.same_pos_as (TLit TDuration) e)) - | ELit LUnit -> unify ctx tau (UnionFind.make (Pos.same_pos_as (TLit TUnit) e)) - | ELit LEmptyError -> unify ctx tau (UnionFind.make (Pos.same_pos_as (TAny (Any.fresh ())) e)) + | ELit (LBool _) -> + unify ctx tau (UnionFind.make (Pos.same_pos_as (TLit TBool) e)) + | ELit (LInt _) -> + unify ctx tau (UnionFind.make (Pos.same_pos_as (TLit TInt) e)) + | ELit (LRat _) -> + unify ctx tau (UnionFind.make (Pos.same_pos_as (TLit TRat) e)) + | ELit (LMoney _) -> + unify ctx tau (UnionFind.make (Pos.same_pos_as (TLit TMoney) e)) + | ELit (LDate _) -> + unify ctx tau (UnionFind.make (Pos.same_pos_as (TLit TDate) e)) + | ELit (LDuration _) -> + unify ctx tau (UnionFind.make (Pos.same_pos_as (TLit TDuration) e)) + | ELit LUnit -> + unify ctx tau (UnionFind.make (Pos.same_pos_as (TLit TUnit) e)) + | ELit LEmptyError -> + unify ctx tau (UnionFind.make (Pos.same_pos_as (TAny (Any.fresh ())) e)) | ETuple (es, s) -> let t_es = UnionFind.make - (Pos.same_pos_as (TTuple (List.map (typecheck_expr_bottom_up ctx env) es, s)) e) + (Pos.same_pos_as + (TTuple (List.map (typecheck_expr_bottom_up ctx env) es, s)) + e) in unify ctx tau t_es | ETupleAccess (e1, n, s, typs) -> ( - let typs = List.map (fun typ -> UnionFind.make (Pos.map_under_mark ast_to_typ typ)) typs in - typecheck_expr_top_down ctx env e1 (UnionFind.make (TTuple (typs, s), Pos.get_position e)); + let typs = + List.map + (fun typ -> UnionFind.make (Pos.map_under_mark ast_to_typ typ)) + typs + in + typecheck_expr_top_down ctx env e1 + (UnionFind.make (TTuple (typs, s), Pos.get_position e)); match List.nth_opt typs n with | Some t1n -> unify ctx t1n tau | None -> Errors.raise_spanned_error (Pos.get_position e1) - "Expression should have a tuple type with at least %d elements but only has %d" n - (List.length typs)) + "Expression should have a tuple type with at least %d elements \ + but only has %d" + n (List.length typs)) | EInj (e1, n, e_name, ts) -> - let ts = List.map (fun t -> UnionFind.make (Pos.map_under_mark ast_to_typ t)) ts in + let ts = + List.map + (fun t -> UnionFind.make (Pos.map_under_mark ast_to_typ t)) + ts + in let ts_n = match List.nth_opt ts n with | Some ts_n -> ts_n | None -> Errors.raise_spanned_error (Pos.get_position e) - "Expression should have a sum type with at least %d cases but only has %d" n - (List.length ts) + "Expression should have a sum type with at least %d cases but \ + only has %d" + n (List.length ts) in typecheck_expr_top_down ctx env e1 ts_n; unify ctx (UnionFind.make (Pos.same_pos_as (TEnum (ts, e_name)) e)) tau | EMatch (e1, es, e_name) -> let enum_cases = - List.map (fun e' -> UnionFind.make (Pos.same_pos_as (TAny (Any.fresh ())) e')) es + List.map + (fun e' -> + UnionFind.make (Pos.same_pos_as (TAny (Any.fresh ())) e')) + es + in + let t_e1 = + UnionFind.make (Pos.same_pos_as (TEnum (enum_cases, e_name)) e1) in - let t_e1 = UnionFind.make (Pos.same_pos_as (TEnum (enum_cases, e_name)) e1) in typecheck_expr_top_down ctx env e1 t_e1; let t_ret = UnionFind.make (Pos.same_pos_as (TAny (Any.fresh ())) e) in List.iteri (fun i es' -> let enum_t = List.nth enum_cases i in - let t_es' = UnionFind.make (Pos.same_pos_as (TArrow (enum_t, t_ret)) es') in + let t_es' = + UnionFind.make (Pos.same_pos_as (TArrow (enum_t, t_ret)) es') + in typecheck_expr_top_down ctx env es' t_es') es; unify ctx tau t_ret @@ -403,27 +495,34 @@ and typecheck_expr_top_down (ctx : Ast.decl_ctx) (env : env) (e : A.expr Pos.mar if Array.length xs = List.length t_args then let xstaus = List.map2 - (fun x t_arg -> (x, UnionFind.make (Pos.map_under_mark ast_to_typ t_arg))) + (fun x t_arg -> + (x, UnionFind.make (Pos.map_under_mark ast_to_typ t_arg))) (Array.to_list xs) t_args in - let env = List.fold_left (fun env (x, t_arg) -> A.VarMap.add x t_arg env) env xstaus in + let env = + List.fold_left + (fun env (x, t_arg) -> A.VarMap.add x t_arg env) + env xstaus + in let t_out = typecheck_expr_bottom_up ctx env body in let t_func = List.fold_right - (fun (_, t_arg) acc -> UnionFind.make (Pos.same_pos_as (TArrow (t_arg, acc)) e)) + (fun (_, t_arg) acc -> + UnionFind.make (Pos.same_pos_as (TArrow (t_arg, acc)) e)) xstaus t_out in unify ctx t_func tau else Errors.raise_spanned_error pos_binder - "function has %d variables but was supplied %d types" (Array.length xs) - (List.length t_args) + "function has %d variables but was supplied %d types" + (Array.length xs) (List.length t_args) | EApp (e1, args) -> let t_args = List.map (typecheck_expr_bottom_up ctx env) args in let te1 = typecheck_expr_bottom_up ctx env e1 in let t_func = List.fold_right - (fun t_arg acc -> UnionFind.make (Pos.same_pos_as (TArrow (t_arg, acc)) e)) + (fun t_arg acc -> + UnionFind.make (Pos.same_pos_as (TArrow (t_arg, acc)) e)) t_args tau in unify ctx te1 t_func @@ -431,19 +530,26 @@ and typecheck_expr_top_down (ctx : Ast.decl_ctx) (env : env) (e : A.expr Pos.mar let op_typ = op_type (Pos.same_pos_as op e) in unify ctx op_typ tau | EDefault (excepts, just, cons) -> - typecheck_expr_top_down ctx env just (UnionFind.make (Pos.same_pos_as (TLit TBool) just)); + typecheck_expr_top_down ctx env just + (UnionFind.make (Pos.same_pos_as (TLit TBool) just)); typecheck_expr_top_down ctx env cons tau; - List.iter (fun except -> typecheck_expr_top_down ctx env except tau) excepts + List.iter + (fun except -> typecheck_expr_top_down ctx env except tau) + excepts | EIfThenElse (cond, et, ef) -> - typecheck_expr_top_down ctx env cond (UnionFind.make (Pos.same_pos_as (TLit TBool) cond)); + typecheck_expr_top_down ctx env cond + (UnionFind.make (Pos.same_pos_as (TLit TBool) cond)); typecheck_expr_top_down ctx env et tau; typecheck_expr_top_down ctx env ef tau | EAssert e' -> - typecheck_expr_top_down ctx env e' (UnionFind.make (Pos.same_pos_as (TLit TBool) e')); + typecheck_expr_top_down ctx env e' + (UnionFind.make (Pos.same_pos_as (TLit TBool) e')); unify ctx tau (UnionFind.make (Pos.same_pos_as (TLit TUnit) e')) | ErrorOnEmpty e' -> typecheck_expr_top_down ctx env e' tau | EArray es -> - let cell_type = UnionFind.make (Pos.same_pos_as (TAny (Any.fresh ())) e) in + let cell_type = + UnionFind.make (Pos.same_pos_as (TAny (Any.fresh ())) e) + in List.iter (fun e' -> let t_e' = typecheck_expr_bottom_up ctx env e' in @@ -454,7 +560,8 @@ and typecheck_expr_top_down (ctx : Ast.decl_ctx) (env : env) (e : A.expr Pos.mar raise (Errors.StructuredError ( msg, - (Some "Error coming from typechecking the following expression:", Pos.get_position e) + ( Some "Error coming from typechecking the following expression:", + Pos.get_position e ) :: err_pos )) (** {1 API} *) @@ -465,5 +572,7 @@ let infer_type (ctx : Ast.decl_ctx) (e : A.expr Pos.marked) : A.typ Pos.marked = typ_to_ast ty (** Typechecks an expression given an expected type *) -let check_type (ctx : Ast.decl_ctx) (e : A.expr Pos.marked) (tau : A.typ Pos.marked) = - typecheck_expr_top_down ctx A.VarMap.empty e (UnionFind.make (Pos.map_under_mark ast_to_typ tau)) +let check_type + (ctx : Ast.decl_ctx) (e : A.expr Pos.marked) (tau : A.typ Pos.marked) = + typecheck_expr_top_down ctx A.VarMap.empty e + (UnionFind.make (Pos.map_under_mark ast_to_typ tau)) diff --git a/compiler/dcalc/typing.mli b/compiler/dcalc/typing.mli index 672c6a76..a95bf4bc 100644 --- a/compiler/dcalc/typing.mli +++ b/compiler/dcalc/typing.mli @@ -1,20 +1,24 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux - +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, contributor: + Denis Merigoux - 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 + 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 + 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. *) -(** Typing for the default calculus. Because of the error terms, we perform type inference using the - classical W algorithm with union-find unification. *) +(** Typing for the default calculus. Because of the error terms, we perform type + inference using the classical W algorithm with union-find unification. *) -val infer_type : Ast.decl_ctx -> Ast.expr Utils.Pos.marked -> Ast.typ Utils.Pos.marked +val infer_type : + Ast.decl_ctx -> Ast.expr Utils.Pos.marked -> Ast.typ Utils.Pos.marked -val check_type : Ast.decl_ctx -> Ast.expr Utils.Pos.marked -> Ast.typ Utils.Pos.marked -> unit +val check_type : + Ast.decl_ctx -> Ast.expr Utils.Pos.marked -> Ast.typ Utils.Pos.marked -> unit diff --git a/compiler/desugared/ast.ml b/compiler/desugared/ast.ml index baea0879..3e0398e7 100644 --- a/compiler/desugared/ast.ml +++ b/compiler/desugared/ast.ml @@ -1,15 +1,17 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020 Inria, contributor: Nicolas Chataing - +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, contributor: + Nicolas Chataing - 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 + 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 + 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. *) (** Abstract syntax tree of the desugared representation *) @@ -20,33 +22,35 @@ open Utils module IdentMap : Map.S with type key = String.t = Map.Make (String) -module RuleName : Uid.Id with type info = Uid.MarkedString.info = Uid.Make (Uid.MarkedString) () +module RuleName : Uid.Id with type info = Uid.MarkedString.info = + Uid.Make (Uid.MarkedString) () module RuleMap : Map.S with type key = RuleName.t = Map.Make (RuleName) - module RuleSet : Set.S with type elt = RuleName.t = Set.Make (RuleName) -module LabelName : Uid.Id with type info = Uid.MarkedString.info = Uid.Make (Uid.MarkedString) () +module LabelName : Uid.Id with type info = Uid.MarkedString.info = + Uid.Make (Uid.MarkedString) () module LabelMap : Map.S with type key = LabelName.t = Map.Make (LabelName) - module LabelSet : Set.S with type elt = LabelName.t = Set.Make (LabelName) -module StateName : Uid.Id with type info = Uid.MarkedString.info = Uid.Make (Uid.MarkedString) () +module StateName : Uid.Id with type info = Uid.MarkedString.info = + Uid.Make (Uid.MarkedString) () -module ScopeVar : Uid.Id with type info = Uid.MarkedString.info = Uid.Make (Uid.MarkedString) () +module ScopeVar : Uid.Id with type info = Uid.MarkedString.info = + Uid.Make (Uid.MarkedString) () module ScopeVarSet : Set.S with type elt = ScopeVar.t = Set.Make (ScopeVar) - module ScopeVarMap : Map.S with type key = ScopeVar.t = Map.Make (ScopeVar) -(** Inside a scope, a definition can refer either to a scope def, or a subscope def *) +(** Inside a scope, a definition can refer either to a scope def, or a subscope + def *) module ScopeDef = struct type t = | Var of ScopeVar.t * StateName.t option | SubScopeVar of Scopelang.Ast.SubScopeName.t * ScopeVar.t - (** In this case, the [ScopeVar.t] lives inside the context of the subscope's original - declaration *) + (** In this case, the [ScopeVar.t] lives inside the context of the + subscope's original declaration *) let compare x y = match (x, y) with @@ -67,24 +71,27 @@ module ScopeDef = struct match x with | Var (x, None) -> Pos.get_position (ScopeVar.get_info x) | Var (_, Some sx) -> Pos.get_position (StateName.get_info sx) - | SubScopeVar (x, _) -> Pos.get_position (Scopelang.Ast.SubScopeName.get_info x) + | SubScopeVar (x, _) -> + Pos.get_position (Scopelang.Ast.SubScopeName.get_info x) let format_t fmt x = match x with | Var (v, None) -> ScopeVar.format_t fmt v - | Var (v, Some sv) -> Format.fprintf fmt "%a.%a" ScopeVar.format_t v StateName.format_t sv + | Var (v, Some sv) -> + Format.fprintf fmt "%a.%a" ScopeVar.format_t v StateName.format_t sv | SubScopeVar (s, v) -> - Format.fprintf fmt "%a.%a" Scopelang.Ast.SubScopeName.format_t s ScopeVar.format_t v + Format.fprintf fmt "%a.%a" Scopelang.Ast.SubScopeName.format_t s + ScopeVar.format_t v let hash x = match x with | Var (v, None) -> ScopeVar.hash v | Var (v, Some sv) -> Int.logxor (ScopeVar.hash v) (StateName.hash sv) - | SubScopeVar (w, v) -> Int.logxor (Scopelang.Ast.SubScopeName.hash w) (ScopeVar.hash v) + | SubScopeVar (w, v) -> + Int.logxor (Scopelang.Ast.SubScopeName.hash w) (ScopeVar.hash v) end module ScopeDefMap : Map.S with type key = ScopeDef.t = Map.Make (ScopeDef) - module ScopeDefSet : Set.S with type elt = ScopeDef.t = Set.Make (ScopeDef) (** {1 AST} *) @@ -92,9 +99,12 @@ module ScopeDefSet : Set.S with type elt = ScopeDef.t = Set.Make (ScopeDef) type location = | ScopeVar of ScopeVar.t Pos.marked * StateName.t option | SubScopeVar of - Scopelang.Ast.ScopeName.t * Scopelang.Ast.SubScopeName.t Pos.marked * ScopeVar.t Pos.marked + Scopelang.Ast.ScopeName.t + * Scopelang.Ast.SubScopeName.t Pos.marked + * ScopeVar.t Pos.marked -module LocationSet : Set.S with type elt = location Pos.marked = Set.Make (struct +module LocationSet : Set.S with type elt = location Pos.marked = +Set.Make (struct type t = location Pos.marked let compare x y = @@ -106,28 +116,38 @@ module LocationSet : Set.S with type elt = location Pos.marked = Set.Make (struc | ScopeVar ((x, _), Some sx), ScopeVar ((y, _), Some sy) -> let cmp = ScopeVar.compare x y in if cmp = 0 then StateName.compare sx sy else cmp - | SubScopeVar (_, (xsubindex, _), (xsubvar, _)), SubScopeVar (_, (ysubindex, _), (ysubvar, _)) - -> + | ( SubScopeVar (_, (xsubindex, _), (xsubvar, _)), + SubScopeVar (_, (ysubindex, _), (ysubvar, _)) ) -> let c = Scopelang.Ast.SubScopeName.compare xsubindex ysubindex in if c = 0 then ScopeVar.compare xsubvar ysubvar else c | ScopeVar _, SubScopeVar _ -> -1 | SubScopeVar _, ScopeVar _ -> 1 end) -(** The expressions use the {{:https://lepigre.fr/ocaml-bindlib/} Bindlib} library, based on - higher-order abstract syntax*) +(** The expressions use the {{:https://lepigre.fr/ocaml-bindlib/} Bindlib} + library, based on higher-order abstract syntax*) type expr = | ELocation of location | EVar of expr Bindlib.var Pos.marked - | EStruct of Scopelang.Ast.StructName.t * expr Pos.marked Scopelang.Ast.StructFieldMap.t - | EStructAccess of expr Pos.marked * Scopelang.Ast.StructFieldName.t * Scopelang.Ast.StructName.t - | EEnumInj of expr Pos.marked * Scopelang.Ast.EnumConstructor.t * Scopelang.Ast.EnumName.t + | EStruct of + Scopelang.Ast.StructName.t + * expr Pos.marked Scopelang.Ast.StructFieldMap.t + | EStructAccess of + expr Pos.marked + * Scopelang.Ast.StructFieldName.t + * Scopelang.Ast.StructName.t + | EEnumInj of + expr Pos.marked + * Scopelang.Ast.EnumConstructor.t + * Scopelang.Ast.EnumName.t | EMatch of expr Pos.marked * Scopelang.Ast.EnumName.t * expr Pos.marked Scopelang.Ast.EnumConstructorMap.t | ELit of Dcalc.Ast.lit - | EAbs of (expr, expr Pos.marked) Bindlib.mbinder Pos.marked * Scopelang.Ast.typ Pos.marked list + | EAbs of + (expr, expr Pos.marked) Bindlib.mbinder Pos.marked + * Scopelang.Ast.typ Pos.marked list | EApp of expr Pos.marked * expr Pos.marked list | EOp of Dcalc.Ast.operator | EDefault of expr Pos.marked list * expr Pos.marked * expr Pos.marked @@ -156,30 +176,36 @@ type rule = { rule_exception_to_rules : RuleSet.t Pos.marked; } -let empty_rule (pos : Pos.t) (have_parameter : Scopelang.Ast.typ Pos.marked option) : rule = +let empty_rule + (pos : Pos.t) (have_parameter : Scopelang.Ast.typ Pos.marked option) : rule + = { rule_just = Bindlib.box (ELit (Dcalc.Ast.LBool false), pos); rule_cons = Bindlib.box (ELit Dcalc.Ast.LEmptyError, pos); rule_parameter = - (match have_parameter with Some typ -> Some (Var.make ("dummy", pos), typ) | None -> None); + (match have_parameter with + | Some typ -> Some (Var.make ("dummy", pos), typ) + | None -> None); rule_exception_to_rules = (RuleSet.empty, pos); rule_id = RuleName.fresh ("empty", pos); } -let always_false_rule (pos : Pos.t) (have_parameter : Scopelang.Ast.typ Pos.marked option) : rule = +let always_false_rule + (pos : Pos.t) (have_parameter : Scopelang.Ast.typ Pos.marked option) : rule + = { rule_just = Bindlib.box (ELit (Dcalc.Ast.LBool true), pos); rule_cons = Bindlib.box (ELit (Dcalc.Ast.LBool false), pos); rule_parameter = - (match have_parameter with Some typ -> Some (Var.make ("dummy", pos), typ) | None -> None); + (match have_parameter with + | Some typ -> Some (Var.make ("dummy", pos), typ) + | None -> None); rule_exception_to_rules = (RuleSet.empty, pos); rule_id = RuleName.fresh ("always_false", pos); } type assertion = expr Pos.marked Bindlib.box - type variation_typ = Increasing | Decreasing - type reference_typ = Decree | Law type meta_assertion = @@ -241,11 +267,14 @@ let rec locations_used (e : expr Pos.marked) : LocationSet.t = (LocationSet.union (locations_used just) (locations_used cons)) excepts | EArray es -> - List.fold_left (fun acc e' -> LocationSet.union acc (locations_used e')) LocationSet.empty es + List.fold_left + (fun acc e' -> LocationSet.union acc (locations_used e')) + LocationSet.empty es | ErrorOnEmpty e' -> locations_used e' let free_variables (def : rule RuleMap.t) : Pos.t ScopeDefMap.t = - let add_locs (acc : Pos.t ScopeDefMap.t) (locs : LocationSet.t) : Pos.t ScopeDefMap.t = + let add_locs (acc : Pos.t ScopeDefMap.t) (locs : LocationSet.t) : + Pos.t ScopeDefMap.t = LocationSet.fold (fun (loc, loc_pos) acc -> ScopeDefMap.add @@ -269,15 +298,26 @@ let free_variables (def : rule RuleMap.t) : Pos.t ScopeDefMap.t = let make_var ((x, pos) : Var.t Pos.marked) : expr Pos.marked Bindlib.box = Bindlib.box_apply (fun v -> (v, pos)) (Bindlib.box_var x) -let make_abs (xs : vars) (e : expr Pos.marked Bindlib.box) (pos_binder : Pos.t) - (taus : Scopelang.Ast.typ Pos.marked list) (pos : Pos.t) : expr Pos.marked Bindlib.box = - Bindlib.box_apply (fun b -> (EAbs ((b, pos_binder), taus), pos)) (Bindlib.bind_mvar xs e) +let make_abs + (xs : vars) + (e : expr Pos.marked Bindlib.box) + (pos_binder : Pos.t) + (taus : Scopelang.Ast.typ Pos.marked list) + (pos : Pos.t) : expr Pos.marked Bindlib.box = + Bindlib.box_apply + (fun b -> (EAbs ((b, pos_binder), taus), pos)) + (Bindlib.bind_mvar xs e) -let make_app (e : expr Pos.marked Bindlib.box) (u : expr Pos.marked Bindlib.box list) (pos : Pos.t) - : expr Pos.marked Bindlib.box = +let make_app + (e : expr Pos.marked Bindlib.box) + (u : expr Pos.marked Bindlib.box list) + (pos : Pos.t) : expr Pos.marked Bindlib.box = Bindlib.box_apply2 (fun e u -> (EApp (e, u), pos)) e (Bindlib.box_list u) -let make_let_in (x : Var.t) (tau : Scopelang.Ast.typ Pos.marked) (e1 : expr Pos.marked Bindlib.box) +let make_let_in + (x : Var.t) + (tau : Scopelang.Ast.typ Pos.marked) + (e1 : expr Pos.marked Bindlib.box) (e2 : expr Pos.marked Bindlib.box) : expr Pos.marked Bindlib.box = Bindlib.box_apply2 (fun e u -> (EApp (e, u), Pos.get_position (Bindlib.unbox e2))) diff --git a/compiler/desugared/ast.mli b/compiler/desugared/ast.mli index b543e4b5..be85be80 100644 --- a/compiler/desugared/ast.mli +++ b/compiler/desugared/ast.mli @@ -1,15 +1,17 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020 Inria, contributor: Nicolas Chataing - +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, contributor: + Nicolas Chataing - 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 + 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 + 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. *) (** Abstract syntax tree of the desugared representation *) @@ -19,44 +21,31 @@ open Utils (** {1 Names, Maps and Keys} *) module IdentMap : Map.S with type key = String.t - module RuleName : Uid.Id with type info = Uid.MarkedString.info - module RuleMap : Map.S with type key = RuleName.t - module RuleSet : Set.S with type elt = RuleName.t - module LabelName : Uid.Id with type info = Uid.MarkedString.info - module LabelMap : Map.S with type key = LabelName.t - module LabelSet : Set.S with type elt = LabelName.t - module StateName : Uid.Id with type info = Uid.MarkedString.info - module ScopeVar : Uid.Id with type info = Uid.MarkedString.info - module ScopeVarSet : Set.S with type elt = ScopeVar.t - module ScopeVarMap : Map.S with type key = ScopeVar.t -(** Inside a scope, a definition can refer either to a scope def, or a subscope def *) +(** Inside a scope, a definition can refer either to a scope def, or a subscope + def *) module ScopeDef : sig type t = | Var of ScopeVar.t * StateName.t option | SubScopeVar of Scopelang.Ast.SubScopeName.t * ScopeVar.t val compare : t -> t -> int - val get_position : t -> Pos.t - val format_t : Format.formatter -> t -> unit - val hash : t -> int end module ScopeDefMap : Map.S with type key = ScopeDef.t - module ScopeDefSet : Set.S with type elt = ScopeDef.t (** {1 AST} *) @@ -65,24 +54,36 @@ module ScopeDefSet : Set.S with type elt = ScopeDef.t type location = | ScopeVar of ScopeVar.t Pos.marked * StateName.t option | SubScopeVar of - Scopelang.Ast.ScopeName.t * Scopelang.Ast.SubScopeName.t Pos.marked * ScopeVar.t Pos.marked + Scopelang.Ast.ScopeName.t + * Scopelang.Ast.SubScopeName.t Pos.marked + * ScopeVar.t Pos.marked module LocationSet : Set.S with type elt = location Pos.marked -(** The expressions use the {{:https://lepigre.fr/ocaml-bindlib/} Bindlib} library, based on - higher-order abstract syntax*) +(** The expressions use the {{:https://lepigre.fr/ocaml-bindlib/} Bindlib} + library, based on higher-order abstract syntax*) type expr = | ELocation of location | EVar of expr Bindlib.var Pos.marked - | EStruct of Scopelang.Ast.StructName.t * expr Pos.marked Scopelang.Ast.StructFieldMap.t - | EStructAccess of expr Pos.marked * Scopelang.Ast.StructFieldName.t * Scopelang.Ast.StructName.t - | EEnumInj of expr Pos.marked * Scopelang.Ast.EnumConstructor.t * Scopelang.Ast.EnumName.t + | EStruct of + Scopelang.Ast.StructName.t + * expr Pos.marked Scopelang.Ast.StructFieldMap.t + | EStructAccess of + expr Pos.marked + * Scopelang.Ast.StructFieldName.t + * Scopelang.Ast.StructName.t + | EEnumInj of + expr Pos.marked + * Scopelang.Ast.EnumConstructor.t + * Scopelang.Ast.EnumName.t | EMatch of expr Pos.marked * Scopelang.Ast.EnumName.t * expr Pos.marked Scopelang.Ast.EnumConstructorMap.t | ELit of Dcalc.Ast.lit - | EAbs of (expr, expr Pos.marked) Bindlib.mbinder Pos.marked * Scopelang.Ast.typ Pos.marked list + | EAbs of + (expr, expr Pos.marked) Bindlib.mbinder Pos.marked + * Scopelang.Ast.typ Pos.marked list | EApp of expr Pos.marked * expr Pos.marked list | EOp of Dcalc.Ast.operator | EDefault of expr Pos.marked list * expr Pos.marked * expr Pos.marked @@ -96,7 +97,6 @@ module Var : sig type t = expr Bindlib.var val make : string Pos.marked -> t - val compare : t -> t -> int end @@ -138,13 +138,10 @@ type rule = { } val empty_rule : Pos.t -> Scopelang.Ast.typ Pos.marked option -> rule - val always_false_rule : Pos.t -> Scopelang.Ast.typ Pos.marked option -> rule type assertion = expr Pos.marked Bindlib.box - type variation_typ = Increasing | Decreasing - type reference_typ = Decree | Law type meta_assertion = @@ -179,5 +176,4 @@ type program = { (** {1 Helpers} *) val locations_used : expr Pos.marked -> LocationSet.t - val free_variables : rule RuleMap.t -> Pos.t ScopeDefMap.t diff --git a/compiler/desugared/dependency.ml b/compiler/desugared/dependency.ml index aec0150a..b6f5f905 100644 --- a/compiler/desugared/dependency.ml +++ b/compiler/desugared/dependency.ml @@ -1,18 +1,21 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020 Inria, contributor: Nicolas Chataing - +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, contributor: + Nicolas Chataing - 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 + 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 + 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. *) -(** Scope dependencies computations using {{:http://ocamlgraph.lri.fr/} OCamlgraph} *) +(** Scope dependencies computations using {{:http://ocamlgraph.lri.fr/} + OCamlgraph} *) open Utils @@ -36,7 +39,8 @@ module Vertex = struct let hash x = match x with | Var (x, None) -> Ast.ScopeVar.hash x - | Var (x, Some sx) -> Int.logxor (Ast.ScopeVar.hash x) (Ast.StateName.hash sx) + | Var (x, Some sx) -> + Int.logxor (Ast.ScopeVar.hash x) (Ast.StateName.hash sx) | SubScope x -> Scopelang.Ast.SubScopeName.hash x let compare = compare @@ -53,21 +57,23 @@ module Vertex = struct match x with | Var (v, None) -> Ast.ScopeVar.format_t fmt v | Var (v, Some sv) -> - Format.fprintf fmt "%a.%a" Ast.ScopeVar.format_t v Ast.StateName.format_t sv + Format.fprintf fmt "%a.%a" Ast.ScopeVar.format_t v + Ast.StateName.format_t sv | SubScope v -> Scopelang.Ast.SubScopeName.format_t fmt v end -(** On the edges, the label is the position of the expression responsible for the use of the - variable. In the graph, [x -> y] if [x] is used in the definition of [y].*) +(** On the edges, the label is the position of the expression responsible for + the use of the variable. In the graph, [x -> y] if [x] is used in the + definition of [y].*) module Edge = struct type t = Pos.t let compare = compare - let default = Pos.no_pos end -module ScopeDependencies = Graph.Persistent.Digraph.ConcreteBidirectionalLabeled (Vertex) (Edge) +module ScopeDependencies = + Graph.Persistent.Digraph.ConcreteBidirectionalLabeled (Vertex) (Edge) (** Module of the graph, provided by OCamlGraph *) module TopologicalTraversal = Graph.Topological.Make (ScopeDependencies) @@ -78,14 +84,15 @@ module SCC = Graph.Components.Make (ScopeDependencies) (** {2 Graph computations} *) -(** Returns an ordering of the scope variables and subscope compatible with the dependencies of the - computation *) +(** Returns an ordering of the scope variables and subscope compatible with the + dependencies of the computation *) let correct_computation_ordering (g : ScopeDependencies.t) : Vertex.t list = List.rev (TopologicalTraversal.fold (fun sd acc -> sd :: acc) g []) (** Outputs an error in case of cycles. *) let check_for_cycle (scope : Ast.scope) (g : ScopeDependencies.t) : unit = - (* if there is a cycle, there will be an strongly connected component of cardinality > 1 *) + (* if there is a cycle, there will be an strongly connected component of + cardinality > 1 *) let sccs = SCC.scc_list g in if List.length sccs < ScopeDependencies.nb_vertex g then let scc = List.find (fun scc -> List.length scc > 1) sccs in @@ -96,33 +103,43 @@ let check_for_cycle (scope : Ast.scope) (g : ScopeDependencies.t) : unit = let var_str, var_info = match v with | Vertex.Var (v, None) -> - (Format.asprintf "%a" Ast.ScopeVar.format_t v, Ast.ScopeVar.get_info v) + ( Format.asprintf "%a" Ast.ScopeVar.format_t v, + Ast.ScopeVar.get_info v ) | Vertex.Var (v, Some sv) -> - ( Format.asprintf "%a.%a" Ast.ScopeVar.format_t v Ast.StateName.format_t sv, + ( Format.asprintf "%a.%a" Ast.ScopeVar.format_t v + Ast.StateName.format_t sv, Ast.StateName.get_info sv ) | Vertex.SubScope v -> ( Format.asprintf "%a" Scopelang.Ast.SubScopeName.format_t v, Scopelang.Ast.SubScopeName.get_info v ) in let succs = ScopeDependencies.succ_e g v in - let _, edge_pos, succ = List.find (fun (_, _, succ) -> List.mem succ scc) succs in + let _, edge_pos, succ = + List.find (fun (_, _, succ) -> List.mem succ scc) succs + in let succ_str = match succ with - | Vertex.Var (v, None) -> Format.asprintf "%a" Ast.ScopeVar.format_t v + | Vertex.Var (v, None) -> + Format.asprintf "%a" Ast.ScopeVar.format_t v | Vertex.Var (v, Some sv) -> - Format.asprintf "%a.%a" Ast.ScopeVar.format_t v Ast.StateName.format_t sv - | Vertex.SubScope v -> Format.asprintf "%a" Scopelang.Ast.SubScopeName.format_t v + Format.asprintf "%a.%a" Ast.ScopeVar.format_t v + Ast.StateName.format_t sv + | Vertex.SubScope v -> + Format.asprintf "%a" Scopelang.Ast.SubScopeName.format_t v in [ - (Some ("Cycle variable " ^ var_str ^ ", declared:"), Pos.get_position var_info); - ( Some ("Used here in the definition of another cycle variable " ^ succ_str ^ ":"), + ( Some ("Cycle variable " ^ var_str ^ ", declared:"), + Pos.get_position var_info ); + ( Some + ("Used here in the definition of another cycle variable " + ^ succ_str ^ ":"), edge_pos ); ]) scc) in Errors.raise_multispanned_error spans - "Cyclic dependency detected between variables of scope %a!" Scopelang.Ast.ScopeName.format_t - scope.scope_uid + "Cyclic dependency detected between variables of scope %a!" + Scopelang.Ast.ScopeName.format_t scope.scope_uid (** Builds the dependency graph of a particular scope *) let build_scope_dependencies (scope : Ast.scope) : ScopeDependencies.t = @@ -135,7 +152,8 @@ let build_scope_dependencies (scope : Ast.scope) : ScopeDependencies.t = | Ast.WholeVar -> ScopeDependencies.add_vertex g (Vertex.Var (v, None)) | Ast.States states -> List.fold_left - (fun g state -> ScopeDependencies.add_vertex g (Vertex.Var (v, Some state))) + (fun g state -> + ScopeDependencies.add_vertex g (Vertex.Var (v, Some state))) g states) scope.scope_vars g in @@ -153,13 +171,14 @@ let build_scope_dependencies (scope : Ast.scope) : ScopeDependencies.t = Ast.ScopeDefMap.fold (fun fv_def fv_def_pos g -> match (def_key, fv_def) with - | Ast.ScopeDef.Var (v_defined, s_defined), Ast.ScopeDef.Var (v_used, s_used) -> + | ( Ast.ScopeDef.Var (v_defined, s_defined), + Ast.ScopeDef.Var (v_used, s_used) ) -> (* simple case *) if v_used = v_defined && s_used = s_defined then (* variable definitions cannot be recursive *) Errors.raise_spanned_error fv_def_pos - "The variable %a is used in one of its definitions, but recursion is forbidden \ - in Catala" + "The variable %a is used in one of its definitions, but \ + recursion is forbidden in Catala" Ast.ScopeDef.format_t def_key else let edge = @@ -169,21 +188,25 @@ let build_scope_dependencies (scope : Ast.scope) : ScopeDependencies.t = (Vertex.Var (v_defined, s_defined)) in ScopeDependencies.add_edge_e g edge - | Ast.ScopeDef.SubScopeVar (defined, _), Ast.ScopeDef.Var (v_used, s_used) -> - (* here we are defining the input of a subscope using a var of the scope *) + | ( Ast.ScopeDef.SubScopeVar (defined, _), + Ast.ScopeDef.Var (v_used, s_used) ) -> + (* here we are defining the input of a subscope using a var of + the scope *) let edge = ScopeDependencies.E.create (Vertex.Var (v_used, s_used)) fv_def_pos (Vertex.SubScope defined) in ScopeDependencies.add_edge_e g edge - | Ast.ScopeDef.SubScopeVar (defined, _), Ast.ScopeDef.SubScopeVar (used, _) -> - (* here we are defining the input of a scope with the output of another subscope *) + | ( Ast.ScopeDef.SubScopeVar (defined, _), + Ast.ScopeDef.SubScopeVar (used, _) ) -> + (* here we are defining the input of a scope with the output of + another subscope *) if used = defined then (* subscopes are not recursive functions *) Errors.raise_spanned_error fv_def_pos - "The subscope %a is used when defining one of its inputs, but recursion is \ - forbidden in Catala" + "The subscope %a is used when defining one of its inputs, \ + but recursion is forbidden in Catala" Scopelang.Ast.SubScopeName.format_t defined else let edge = @@ -191,8 +214,10 @@ let build_scope_dependencies (scope : Ast.scope) : ScopeDependencies.t = (Vertex.SubScope defined) in ScopeDependencies.add_edge_e g edge - | Ast.ScopeDef.Var (v_defined, s_defined), Ast.ScopeDef.SubScopeVar (used, _) -> - (* finally we define a scope var with the output of a subscope *) + | ( Ast.ScopeDef.Var (v_defined, s_defined), + Ast.ScopeDef.SubScopeVar (used, _) ) -> + (* finally we define a scope var with the output of a + subscope *) let edge = ScopeDependencies.E.create (Vertex.SubScope used) fv_def_pos (Vertex.Var (v_defined, s_defined)) @@ -210,33 +235,38 @@ let build_scope_dependencies (scope : Ast.scope) : ScopeDependencies.t = module ExceptionVertex = struct include Ast.RuleSet - let hash (x : t) : int = Ast.RuleSet.fold (fun r acc -> Int.logxor (Ast.RuleName.hash r) acc) x 0 + let hash (x : t) : int = + Ast.RuleSet.fold (fun r acc -> Int.logxor (Ast.RuleName.hash r) acc) x 0 let equal x y = compare x y = 0 end module ExceptionsDependencies = Graph.Persistent.Digraph.ConcreteBidirectionalLabeled (ExceptionVertex) (Edge) -(** Module of the graph, provided by OCamlGraph. [x -> y] if [y] is an exception to [x] *) +(** Module of the graph, provided by OCamlGraph. [x -> y] if [y] is an exception + to [x] *) module ExceptionsSCC = Graph.Components.Make (ExceptionsDependencies) (** Tarjan's stongly connected components algorithm, provided by OCamlGraph *) (** {2 Graph computations} *) -let build_exceptions_graph (def : Ast.rule Ast.RuleMap.t) (def_info : Ast.ScopeDef.t) : +let build_exceptions_graph + (def : Ast.rule Ast.RuleMap.t) (def_info : Ast.ScopeDef.t) : ExceptionsDependencies.t = (* first we collect all the rule sets referred by exceptions *) let all_rule_sets_pointed_to_by_exceptions : Ast.RuleSet.t list = Ast.RuleMap.fold (fun _rule_name rule acc -> - if Ast.RuleSet.is_empty (Pos.unmark rule.Ast.rule_exception_to_rules) then acc + if Ast.RuleSet.is_empty (Pos.unmark rule.Ast.rule_exception_to_rules) + then acc else Pos.unmark rule.Ast.rule_exception_to_rules :: acc) def [] in - (* we make sure these sets are either disjoint or equal ; should be a syntactic invariant since - you currently can't assign two labels to a single rule but an extra check is valuable since - this is a required invariant for the graph to be sound *) + (* we make sure these sets are either disjoint or equal ; should be a + syntactic invariant since you currently can't assign two labels to a single + rule but an extra check is valuable since this is a required invariant for + the graph to be sound *) List.iter (fun rule_set1 -> List.iter @@ -259,12 +289,13 @@ let build_exceptions_graph (def : Ast.rule Ast.RuleMap.t) (def_info : Ast.ScopeD (Ast.RuleSet.to_seq rule_set2)) in Errors.raise_multispanned_error spans - "Definitions or rules grouped by different labels overlap, whereas these groups \ - shoule be disjoint") + "Definitions or rules grouped by different labels overlap, \ + whereas these groups shoule be disjoint") all_rule_sets_pointed_to_by_exceptions) all_rule_sets_pointed_to_by_exceptions; - (* Then we add the exception graph vertices by taking all those sets of rules pointed to by - exceptions, and adding the remaining rules not pointed as separate singleton set vertices *) + (* Then we add the exception graph vertices by taking all those sets of rules + pointed to by exceptions, and adding the remaining rules not pointed as + separate singleton set vertices *) let g = List.fold_left (fun g rule_set -> ExceptionsDependencies.add_vertex g rule_set) @@ -279,30 +310,34 @@ let build_exceptions_graph (def : Ast.rule Ast.RuleMap.t) (def_info : Ast.ScopeD Ast.RuleSet.mem rule_name rule_set_pointed_to_by_exceptions) all_rule_sets_pointed_to_by_exceptions then g - else ExceptionsDependencies.add_vertex g (Ast.RuleSet.singleton rule_name)) + else + ExceptionsDependencies.add_vertex g (Ast.RuleSet.singleton rule_name)) def g in (* then we add the edges *) let g = Ast.RuleMap.fold (fun rule_name rule g -> - (* Right now, exceptions can only consist of one rule, we may want to relax that constraint - later in the development of Catala. *) + (* Right now, exceptions can only consist of one rule, we may want to + relax that constraint later in the development of Catala. *) let exception_to_ruleset, pos = rule.Ast.rule_exception_to_rules in - if Ast.RuleSet.is_empty exception_to_ruleset then g (* we don't add an edge*) + if Ast.RuleSet.is_empty exception_to_ruleset then g + (* we don't add an edge*) else if ExceptionsDependencies.mem_vertex g exception_to_ruleset then if exception_to_ruleset = Ast.RuleSet.singleton rule_name then - Errors.raise_spanned_error pos "Cannot define rule as an exception to itself" + Errors.raise_spanned_error pos + "Cannot define rule as an exception to itself" else let edge = - ExceptionsDependencies.E.create (Ast.RuleSet.singleton rule_name) pos - exception_to_ruleset + ExceptionsDependencies.E.create + (Ast.RuleSet.singleton rule_name) + pos exception_to_ruleset in ExceptionsDependencies.add_edge_e g edge else Errors.raise_spanned_error pos - "This rule has been declared as an exception to an incorrect label: this label is not \ - attached to a definition of \"%a\"" + "This rule has been declared as an exception to an incorrect \ + label: this label is not attached to a definition of \"%a\"" Ast.ScopeDef.format_t def_info) def g in @@ -310,7 +345,8 @@ let build_exceptions_graph (def : Ast.rule Ast.RuleMap.t) (def_info : Ast.ScopeD (** Outputs an error in case of cycles. *) let check_for_exception_cycle (g : ExceptionsDependencies.t) : unit = - (* if there is a cycle, there will be an strongly connected component of cardinality > 1 *) + (* if there is a cycle, there will be an strongly connected component of + cardinality > 1 *) let sccs = ExceptionsSCC.scc_list g in if List.length sccs < ExceptionsDependencies.nb_vertex g then let scc = List.find (fun scc -> List.length scc > 1) sccs in @@ -320,20 +356,24 @@ let check_for_exception_cycle (g : ExceptionsDependencies.t) : unit = (fun (vs : Ast.RuleSet.t) -> let v = Ast.RuleSet.choose vs in let var_str, var_info = - (Format.asprintf "%a" Ast.RuleName.format_t v, Ast.RuleName.get_info v) + ( Format.asprintf "%a" Ast.RuleName.format_t v, + Ast.RuleName.get_info v ) in let succs = ExceptionsDependencies.succ_e g vs in - let _, edge_pos, _ = List.find (fun (_, _, succ) -> List.mem succ scc) succs in + let _, edge_pos, _ = + List.find (fun (_, _, succ) -> List.mem succ scc) succs + in [ ( Some ("Cyclic exception for definition of variable \"" ^ var_str ^ "\", declared here:"), Pos.get_position var_info ); ( Some - ("Used here in the definition of another cyclic exception for defining \"" - ^ var_str ^ "\":"), + ("Used here in the definition of another cyclic exception \ + for defining \"" ^ var_str ^ "\":"), edge_pos ); ]) scc) in - Errors.raise_multispanned_error spans "Cyclic dependency detected between exceptions!" + Errors.raise_multispanned_error spans + "Cyclic dependency detected between exceptions!" diff --git a/compiler/desugared/dependency.mli b/compiler/desugared/dependency.mli index a48b3a28..e0aea4bd 100644 --- a/compiler/desugared/dependency.mli +++ b/compiler/desugared/dependency.mli @@ -1,18 +1,21 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020 Inria, contributor: Nicolas Chataing - +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, contributor: + Nicolas Chataing - 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 + 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 + 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. *) -(** Scope dependencies computations using {{:http://ocamlgraph.lri.fr/} OCamlgraph} *) +(** Scope dependencies computations using {{:http://ocamlgraph.lri.fr/} + OCamlgraph} *) open Utils @@ -40,20 +43,22 @@ module Vertex : sig end module Edge : Graph.Sig.ORDERED_TYPE_DFT with type t = Pos.t -(** On the edges, the label is the position of the expression responsible for the use of the - variable. In the graph, [x -> y] if [x] is used in the definition of [y].*) +(** On the edges, the label is the position of the expression responsible for + the use of the variable. In the graph, [x -> y] if [x] is used in the + definition of [y].*) (** Module of the graph, provided by OCamlGraph *) -module ScopeDependencies : Graph.Sig.P with type V.t = Vertex.t and type E.label = Edge.t +module ScopeDependencies : + Graph.Sig.P with type V.t = Vertex.t and type E.label = Edge.t (** {2 Graph computations} *) -(** Returns an ordering of the scope variables and subscope compatible with the dependencies of the - computation *) +(** Returns an ordering of the scope variables and subscope compatible with the + dependencies of the computation *) val correct_computation_ordering : ScopeDependencies.t -> Vertex.t list -(** Returns an ordering of the scope variables and subscope compatible with the dependencies of the - computation *) +(** Returns an ordering of the scope variables and subscope compatible with the + dependencies of the computation *) val check_for_cycle : Ast.scope -> ScopeDependencies.t -> unit (** Outputs an error in case of cycles. *) @@ -63,8 +68,10 @@ val build_scope_dependencies : Ast.scope -> ScopeDependencies.t (** {1 Exceptions dependency graph} *) -module ExceptionsDependencies : Graph.Sig.P with type V.t = Ast.RuleSet.t and type E.label = Edge.t +module ExceptionsDependencies : + Graph.Sig.P with type V.t = Ast.RuleSet.t and type E.label = Edge.t -val build_exceptions_graph : Ast.rule Ast.RuleMap.t -> Ast.ScopeDef.t -> ExceptionsDependencies.t +val build_exceptions_graph : + Ast.rule Ast.RuleMap.t -> Ast.ScopeDef.t -> ExceptionsDependencies.t val check_for_exception_cycle : ExceptionsDependencies.t -> unit diff --git a/compiler/desugared/desugared_to_scope.ml b/compiler/desugared/desugared_to_scope.ml index e9415fca..8946e200 100644 --- a/compiler/desugared/desugared_to_scope.ml +++ b/compiler/desugared/desugared_to_scope.ml @@ -1,15 +1,17 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux - +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, contributor: + Denis Merigoux - 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 + 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 + 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. *) (** Translation from {!module: Desugared.Ast} to {!module: Scopelang.Ast} *) @@ -31,20 +33,24 @@ let rec translate_expr (ctx : ctx) (e : Ast.expr Pos.marked) : Scopelang.Ast.expr Pos.marked Bindlib.box = match Pos.unmark e with | Ast.ELocation (SubScopeVar (s_name, ss_name, s_var)) -> - (* When referring to a subscope variable in an expression, we are referring to the output, - hence we take the last state. *) + (* When referring to a subscope variable in an expression, we are + referring to the output, hence we take the last state. *) let new_s_var = match Ast.ScopeVarMap.find (Pos.unmark s_var) ctx.scope_var_mapping with | WholeVar new_s_var -> Pos.same_pos_as new_s_var s_var - | States states -> Pos.same_pos_as (snd (List.hd (List.rev states))) s_var + | States states -> + Pos.same_pos_as (snd (List.hd (List.rev states))) s_var in Bindlib.box - (Scopelang.Ast.ELocation (SubScopeVar (s_name, ss_name, new_s_var)), Pos.get_position e) + ( Scopelang.Ast.ELocation (SubScopeVar (s_name, ss_name, new_s_var)), + Pos.get_position e ) | Ast.ELocation (ScopeVar (s_var, None)) -> Bindlib.box ( Scopelang.Ast.ELocation (ScopeVar - (match Ast.ScopeVarMap.find (Pos.unmark s_var) ctx.scope_var_mapping with + (match + Ast.ScopeVarMap.find (Pos.unmark s_var) ctx.scope_var_mapping + with | WholeVar new_s_var -> Pos.same_pos_as new_s_var s_var | States _ -> failwith "should not happen")), Pos.get_position e ) @@ -52,9 +58,12 @@ let rec translate_expr (ctx : ctx) (e : Ast.expr Pos.marked) : Bindlib.box ( Scopelang.Ast.ELocation (ScopeVar - (match Ast.ScopeVarMap.find (Pos.unmark s_var) ctx.scope_var_mapping with + (match + Ast.ScopeVarMap.find (Pos.unmark s_var) ctx.scope_var_mapping + with | WholeVar _ -> failwith "should not happen" - | States states -> Pos.same_pos_as (List.assoc state states) s_var)), + | States states -> + Pos.same_pos_as (List.assoc state states) s_var)), Pos.get_position e ) | Ast.EVar v -> Bindlib.box_apply @@ -62,16 +71,20 @@ let rec translate_expr (ctx : ctx) (e : Ast.expr Pos.marked) : (Bindlib.box_var (Ast.VarMap.find (Pos.unmark v) ctx.var_mapping)) | EStruct (s_name, fields) -> Bindlib.box_apply - (fun new_fields -> (Scopelang.Ast.EStruct (s_name, new_fields), Pos.get_position e)) + (fun new_fields -> + (Scopelang.Ast.EStruct (s_name, new_fields), Pos.get_position e)) (Scopelang.Ast.StructFieldMapLift.lift_box (Scopelang.Ast.StructFieldMap.map (translate_expr ctx) fields)) | EStructAccess (e1, s_name, f_name) -> Bindlib.box_apply - (fun new_e1 -> (Scopelang.Ast.EStructAccess (new_e1, s_name, f_name), Pos.get_position e)) + (fun new_e1 -> + ( Scopelang.Ast.EStructAccess (new_e1, s_name, f_name), + Pos.get_position e )) (translate_expr ctx e1) | EEnumInj (e1, cons, e_name) -> Bindlib.box_apply - (fun new_e1 -> (Scopelang.Ast.EEnumInj (new_e1, cons, e_name), Pos.get_position e)) + (fun new_e1 -> + (Scopelang.Ast.EEnumInj (new_e1, cons, e_name), Pos.get_position e)) (translate_expr ctx e1) | EMatch (e1, e_name, arms) -> Bindlib.box_apply2 @@ -84,34 +97,43 @@ let rec translate_expr (ctx : ctx) (e : Ast.expr Pos.marked) : | EAbs ((binder, binder_pos), typs) -> let vars, body = Bindlib.unmbind binder in let new_vars = - Array.map (fun var -> Scopelang.Ast.Var.make (Bindlib.name_of var, binder_pos)) vars + Array.map + (fun var -> Scopelang.Ast.Var.make (Bindlib.name_of var, binder_pos)) + vars in let ctx = List.fold_left2 (fun ctx var new_var -> - { ctx with var_mapping = Ast.VarMap.add var new_var ctx.var_mapping }) + { + ctx with + var_mapping = Ast.VarMap.add var new_var ctx.var_mapping; + }) ctx (Array.to_list vars) (Array.to_list new_vars) in Bindlib.box_apply (fun new_binder -> - (Scopelang.Ast.EAbs ((new_binder, binder_pos), typs), Pos.get_position e)) + ( Scopelang.Ast.EAbs ((new_binder, binder_pos), typs), + Pos.get_position e )) (Bindlib.bind_mvar new_vars (translate_expr ctx body)) | EApp (e1, args) -> Bindlib.box_apply2 - (fun new_e1 new_args -> (Scopelang.Ast.EApp (new_e1, new_args), Pos.get_position e)) + (fun new_e1 new_args -> + (Scopelang.Ast.EApp (new_e1, new_args), Pos.get_position e)) (translate_expr ctx e1) (Bindlib.box_list (List.map (translate_expr ctx) args)) | EOp op -> Bindlib.box (Scopelang.Ast.EOp op, Pos.get_position e) | EDefault (excepts, just, cons) -> Bindlib.box_apply3 (fun new_excepts new_just new_cons -> - (Scopelang.Ast.EDefault (new_excepts, new_just, new_cons), Pos.get_position e)) + ( Scopelang.Ast.EDefault (new_excepts, new_just, new_cons), + Pos.get_position e )) (Bindlib.box_list (List.map (translate_expr ctx) excepts)) (translate_expr ctx just) (translate_expr ctx cons) | EIfThenElse (e1, e2, e3) -> Bindlib.box_apply3 (fun new_e1 new_e2 new_e3 -> - (Scopelang.Ast.EIfThenElse (new_e1, new_e2, new_e3), Pos.get_position e)) + ( Scopelang.Ast.EIfThenElse (new_e1, new_e2, new_e3), + Pos.get_position e )) (translate_expr ctx e1) (translate_expr ctx e2) (translate_expr ctx e3) | EArray args -> Bindlib.box_apply @@ -124,29 +146,39 @@ let rec translate_expr (ctx : ctx) (e : Ast.expr Pos.marked) : (** {1 Rule tree construction} *) -(** Intermediate representation for the exception tree of rules for a particular scope definition. *) +(** Intermediate representation for the exception tree of rules for a particular + scope definition. *) type rule_tree = - | Leaf of Ast.rule list (** Rules defining a base case piecewise. List is non-empty. *) + | Leaf of Ast.rule list + (** Rules defining a base case piecewise. List is non-empty. *) | Node of rule_tree list * Ast.rule list - (** A list of exceptions to a non-empty list of rules defining a base case piecewise. *) + (** A list of exceptions to a non-empty list of rules defining a base case + piecewise. *) -(** Transforms a flat list of rules into a tree, taking into account the priorities declared between - rules *) -let def_map_to_tree (def_info : Ast.ScopeDef.t) (def : Ast.rule Ast.RuleMap.t) : rule_tree list = +(** Transforms a flat list of rules into a tree, taking into account the + priorities declared between rules *) +let def_map_to_tree (def_info : Ast.ScopeDef.t) (def : Ast.rule Ast.RuleMap.t) : + rule_tree list = let exc_graph = Dependency.build_exceptions_graph def def_info in Dependency.check_for_exception_cycle exc_graph; - (* we start by the base cases: they are the vertices which have no successors *) + (* we start by the base cases: they are the vertices which have no + successors *) let base_cases = Dependency.ExceptionsDependencies.fold_vertex (fun v base_cases -> - if Dependency.ExceptionsDependencies.out_degree exc_graph v = 0 then v :: base_cases + if Dependency.ExceptionsDependencies.out_degree exc_graph v = 0 then + v :: base_cases else base_cases) exc_graph [] in let rec build_tree (base_cases : Ast.RuleSet.t) : rule_tree = - let exceptions = Dependency.ExceptionsDependencies.pred exc_graph base_cases in + let exceptions = + Dependency.ExceptionsDependencies.pred exc_graph base_cases + in let base_case_as_rule_list = - List.map (fun r -> Ast.RuleMap.find r def) (List.of_seq (Ast.RuleSet.to_seq base_cases)) + List.map + (fun r -> Ast.RuleMap.find r def) + (List.of_seq (Ast.RuleSet.to_seq base_cases)) in match exceptions with | [] -> Leaf base_case_as_rule_list @@ -154,24 +186,31 @@ let def_map_to_tree (def_info : Ast.ScopeDef.t) (def : Ast.rule Ast.RuleMap.t) : in List.map build_tree base_cases -(** From the {!type: rule_tree}, builds an {!constructor: Dcalc.Ast.EDefault} expression in the - scope language. The [~toplevel] parameter is used to know when to place the toplevel binding in - the case of functions. *) -let rec rule_tree_to_expr ~(toplevel : bool) (ctx : ctx) (def_pos : Pos.t) - (is_func : Ast.Var.t option) (tree : rule_tree) : Scopelang.Ast.expr Pos.marked Bindlib.box = +(** From the {!type: rule_tree}, builds an {!constructor: Dcalc.Ast.EDefault} + expression in the scope language. The [~toplevel] parameter is used to know + when to place the toplevel binding in the case of functions. *) +let rec rule_tree_to_expr + ~(toplevel : bool) + (ctx : ctx) + (def_pos : Pos.t) + (is_func : Ast.Var.t option) + (tree : rule_tree) : Scopelang.Ast.expr Pos.marked Bindlib.box = let exceptions, base_rules = match tree with Leaf r -> ([], r) | Node (exceptions, r) -> (exceptions, r) in - (* because each rule has its own variable parameter and we want to convert the whole rule tree - into a function, we need to perform some alpha-renaming of all the expressions *) - let substitute_parameter (e : Ast.expr Pos.marked Bindlib.box) (rule : Ast.rule) : + (* because each rule has its own variable parameter and we want to convert the + whole rule tree into a function, we need to perform some alpha-renaming of + all the expressions *) + let substitute_parameter + (e : Ast.expr Pos.marked Bindlib.box) (rule : Ast.rule) : Ast.expr Pos.marked Bindlib.box = match (is_func, rule.Ast.rule_parameter) with | Some new_param, Some (old_param, _) -> let binder = Bindlib.bind_var old_param e in Bindlib.box_apply2 (fun binder new_param -> Bindlib.subst binder new_param) - binder (Bindlib.box_var new_param) + binder + (Bindlib.box_var new_param) | None, None -> e | _ -> assert false (* should not happen *) @@ -182,27 +221,38 @@ let rec rule_tree_to_expr ~(toplevel : bool) (ctx : ctx) (def_pos : Pos.t) | Some new_param -> ( match Ast.VarMap.find_opt new_param ctx.var_mapping with | None -> - let new_param_scope = Scopelang.Ast.Var.make (Bindlib.name_of new_param, def_pos) in - { ctx with var_mapping = Ast.VarMap.add new_param new_param_scope ctx.var_mapping } + let new_param_scope = + Scopelang.Ast.Var.make (Bindlib.name_of new_param, def_pos) + in + { + ctx with + var_mapping = + Ast.VarMap.add new_param new_param_scope ctx.var_mapping; + } | Some _ -> - (* We only create a mapping if none exists because [rule_tree_to_expr] is called - recursively on the exceptions of the tree and we don't want to create a new Scopelang - variable for the parameter at each tree level. *) + (* We only create a mapping if none exists because + [rule_tree_to_expr] is called recursively on the exceptions of + the tree and we don't want to create a new Scopelang variable for + the parameter at each tree level. *) ctx) in let base_just_list = - List.map (fun rule -> substitute_parameter rule.Ast.rule_just rule) base_rules + List.map + (fun rule -> substitute_parameter rule.Ast.rule_just rule) + base_rules in let base_cons_list = - List.map (fun rule -> substitute_parameter rule.Ast.rule_cons rule) base_rules + List.map + (fun rule -> substitute_parameter rule.Ast.rule_cons rule) + base_rules in let translate_and_unbox_list (list : Ast.expr Pos.marked Bindlib.box list) : Scopelang.Ast.expr Pos.marked Bindlib.box list = List.map (fun e -> - (* There are two levels of boxing here, the outermost is introduced by the [translate_expr] - function for which all of the bindings should have been closed by now, so we can safely - unbox. *) + (* There are two levels of boxing here, the outermost is introduced by + the [translate_expr] function for which all of the bindings should + have been closed by now, so we can safely unbox. *) Bindlib.unbox (Bindlib.box_apply (translate_expr ctx) e)) list in @@ -212,7 +262,8 @@ let rec rule_tree_to_expr ~(toplevel : bool) (ctx : ctx) (def_pos : Pos.t) ( Scopelang.Ast.EDefault ( List.map2 (fun base_just base_cons -> - (Scopelang.Ast.EDefault ([], base_just, base_cons), Pos.get_position base_just)) + ( Scopelang.Ast.EDefault ([], base_just, base_cons), + Pos.get_position base_just )) base_just_list base_cons_list, (Scopelang.Ast.ELit (Dcalc.Ast.LBool false), def_pos), (Scopelang.Ast.ELit Dcalc.Ast.LEmptyError, def_pos) ), @@ -221,7 +272,10 @@ let rec rule_tree_to_expr ~(toplevel : bool) (ctx : ctx) (def_pos : Pos.t) (Bindlib.box_list (translate_and_unbox_list base_cons_list)) in let exceptions = - Bindlib.box_list (List.map (rule_tree_to_expr ~toplevel:false ctx def_pos is_func) exceptions) + Bindlib.box_list + (List.map + (rule_tree_to_expr ~toplevel:false ctx def_pos is_func) + exceptions) in let default = Bindlib.box_apply2 @@ -237,8 +291,8 @@ let rec rule_tree_to_expr ~(toplevel : bool) (ctx : ctx) (def_pos : Pos.t) | None, None -> default | Some new_param, Some (_, typ) -> if toplevel then - (* When we're creating a function from multiple defaults, we must check that the result - returned by the function is not empty *) + (* When we're creating a function from multiple defaults, we must check + that the result returned by the function is not empty *) let default = Bindlib.box_apply (fun (default : Scopelang.Ast.expr * Pos.t) -> @@ -253,74 +307,98 @@ let rec rule_tree_to_expr ~(toplevel : bool) (ctx : ctx) (def_pos : Pos.t) (** {1 AST translation} *) -(** Translates a definition inside a scope, the resulting expression should be an {!constructor: - Dcalc.Ast.EDefault} *) -let translate_def (ctx : ctx) (def_info : Ast.ScopeDef.t) (def : Ast.rule Ast.RuleMap.t) - (typ : Scopelang.Ast.typ Pos.marked) (io : Scopelang.Ast.io) ~(is_cond : bool) +(** Translates a definition inside a scope, the resulting expression should be + an {!constructor: Dcalc.Ast.EDefault} *) +let translate_def + (ctx : ctx) + (def_info : Ast.ScopeDef.t) + (def : Ast.rule Ast.RuleMap.t) + (typ : Scopelang.Ast.typ Pos.marked) + (io : Scopelang.Ast.io) + ~(is_cond : bool) ~(is_subscope_var : bool) : Scopelang.Ast.expr Pos.marked = (* Here, we have to transform this list of rules into a default tree. *) - let is_def_func = match Pos.unmark typ with Scopelang.Ast.TArrow (_, _) -> true | _ -> false in - let is_rule_func _ (r : Ast.rule) : bool = Option.is_some r.Ast.rule_parameter in + let is_def_func = + match Pos.unmark typ with Scopelang.Ast.TArrow (_, _) -> true | _ -> false + in + let is_rule_func _ (r : Ast.rule) : bool = + Option.is_some r.Ast.rule_parameter + in let all_rules_func = Ast.RuleMap.for_all is_rule_func def in - let all_rules_not_func = Ast.RuleMap.for_all (fun n r -> not (is_rule_func n r)) def in + let all_rules_not_func = + Ast.RuleMap.for_all (fun n r -> not (is_rule_func n r)) def + in let is_def_func_param_typ : Scopelang.Ast.typ Pos.marked option = if is_def_func && all_rules_func then match Pos.unmark typ with | Scopelang.Ast.TArrow (t_param, _) -> Some t_param | _ -> Errors.raise_spanned_error (Pos.get_position typ) - "The definitions of %a are function but its type, %a, is not a function type" + "The definitions of %a are function but its type, %a, is not a \ + function type" Ast.ScopeDef.format_t def_info Scopelang.Print.format_typ typ else if (not is_def_func) && all_rules_not_func then None else let spans = List.map (fun (_, r) -> - (Some "This definition is a function:", Pos.get_position (Bindlib.unbox r.Ast.rule_cons))) + ( Some "This definition is a function:", + Pos.get_position (Bindlib.unbox r.Ast.rule_cons) )) (Ast.RuleMap.bindings (Ast.RuleMap.filter is_rule_func def)) @ List.map (fun (_, r) -> ( Some "This definition is not a function:", Pos.get_position (Bindlib.unbox r.Ast.rule_cons) )) - (Ast.RuleMap.bindings (Ast.RuleMap.filter (fun n r -> not (is_rule_func n r)) def)) + (Ast.RuleMap.bindings + (Ast.RuleMap.filter (fun n r -> not (is_rule_func n r)) def)) in Errors.raise_multispanned_error spans - "some definitions of the same variable are functions while others aren't" + "some definitions of the same variable are functions while others \ + aren't" in let top_list = def_map_to_tree def_info def in let top_value = - (if is_cond then Ast.always_false_rule else Ast.empty_rule) Pos.no_pos is_def_func_param_typ + (if is_cond then Ast.always_false_rule else Ast.empty_rule) + Pos.no_pos is_def_func_param_typ in if Ast.RuleMap.cardinal def = 0 && is_subscope_var - (* Here we have a special case for the empty definitions. Indeed, we could use the code for the - regular case below that would create a convoluted default always returning empty error, and - this would be correct. But it gets more complicated with functions. Indeed, if we create an - empty definition for a subscope argument whose type is a function, we get something like [fun - () -> (fun real_param -> < ... >)] that is passed as an argument to the subscope. The - sub-scope de-thunks but the de-thunking does not return empty error, signalling there is not - reentrant variable, because functions are values! So the subscope does not see that there is - not reentrant variable and does not pick its internal definition instead. See - [test/test_scope/subscope_function_arg_not_defined.catala_en] for a test case exercising that - subtlety. + (* Here we have a special case for the empty definitions. Indeed, we could + use the code for the regular case below that would create a convoluted + default always returning empty error, and this would be correct. But it + gets more complicated with functions. Indeed, if we create an empty + definition for a subscope argument whose type is a function, we get + something like [fun () -> (fun real_param -> < ... >)] that is passed as + an argument to the subscope. The sub-scope de-thunks but the de-thunking + does not return empty error, signalling there is not reentrant variable, + because functions are values! So the subscope does not see that there is + not reentrant variable and does not pick its internal definition instead. + See [test/test_scope/subscope_function_arg_not_defined.catala_en] for a + test case exercising that subtlety. - To avoid this complication we special case here and put an empty error for all subscope - variables that are not defined. It covers the subtlety with functions described above but - also conditions with the false default value. *) + To avoid this complication we special case here and put an empty error + for all subscope variables that are not defined. It covers the subtlety + with functions described above but also conditions with the false default + value. *) && not (is_cond - && match Pos.unmark io.Scopelang.Ast.io_input with OnlyInput -> true | _ -> false) - (* However, this special case suffers from an exception: when a condition is defined as an - OnlyInput to a subscope, since the [false] default value will not be provided by the calee - scope, it has to be placed in the caller. *) + && + match Pos.unmark io.Scopelang.Ast.io_input with + | OnlyInput -> true + | _ -> false) + (* However, this special case suffers from an exception: when a condition is + defined as an OnlyInput to a subscope, since the [false] default value + will not be provided by the calee scope, it has to be placed in the + caller. *) then (ELit LEmptyError, Pos.no_pos) else Bindlib.unbox (rule_tree_to_expr ~toplevel:true ctx (Ast.ScopeDef.get_position def_info) (Option.map - (fun _ -> Ast.Var.make ("param", Ast.ScopeDef.get_position def_info)) + (fun _ -> + Ast.Var.make ("param", Ast.ScopeDef.get_position def_info)) is_def_func_param_typ) (match top_list with | [] -> @@ -332,7 +410,9 @@ let translate_def (ctx : ctx) (def_info : Ast.ScopeDef.t) (def : Ast.rule Ast.Ru let translate_scope (ctx : ctx) (scope : Ast.scope) : Scopelang.Ast.scope_decl = let scope_dependencies = Dependency.build_scope_dependencies scope in Dependency.check_for_cycle scope scope_dependencies; - let scope_ordering = Dependency.correct_computation_ordering scope_dependencies in + let scope_ordering = + Dependency.correct_computation_ordering scope_dependencies + in let scope_decl_rules = List.flatten (List.map @@ -340,31 +420,42 @@ let translate_scope (ctx : ctx) (scope : Ast.scope) : Scopelang.Ast.scope_decl = match vertex with | Dependency.Vertex.Var (var, state) -> ( let scope_def = - Ast.ScopeDefMap.find (Ast.ScopeDef.Var (var, state)) scope.scope_defs + Ast.ScopeDefMap.find + (Ast.ScopeDef.Var (var, state)) + scope.scope_defs in let var_def = scope_def.scope_def_rules in let var_typ = scope_def.scope_def_typ in let is_cond = scope_def.scope_def_is_condition in match Pos.unmark scope_def.Ast.scope_def_io.io_input with | OnlyInput when not (Ast.RuleMap.is_empty var_def) -> - (* If the variable is tagged as input, then it shall not be redefined. *) + (* If the variable is tagged as input, then it shall not be + redefined. *) Errors.raise_multispanned_error - ((Some "Incriminated variable:", Pos.get_position (Ast.ScopeVar.get_info var)) + (( Some "Incriminated variable:", + Pos.get_position (Ast.ScopeVar.get_info var) ) :: List.map (fun (rule, _) -> ( Some "Incriminated variable definition:", Pos.get_position (Ast.RuleName.get_info rule) )) (Ast.RuleMap.bindings var_def)) - "It is impossible to give a definition to a scope variable tagged as input." - | OnlyInput -> [] (* we do not provide any definition for an input-only variable *) + "It is impossible to give a definition to a scope \ + variable tagged as input." + | OnlyInput -> + [] + (* we do not provide any definition for an input-only + variable *) | _ -> let expr_def = translate_def ctx (Ast.ScopeDef.Var (var, state)) - var_def var_typ scope_def.Ast.scope_def_io ~is_cond ~is_subscope_var:false + var_def var_typ scope_def.Ast.scope_def_io ~is_cond + ~is_subscope_var:false in let scope_var = - match (Ast.ScopeVarMap.find var ctx.scope_var_mapping, state) with + match + (Ast.ScopeVarMap.find var ctx.scope_var_mapping, state) + with | WholeVar v, None -> v | States states, Some state -> List.assoc state states | _ -> failwith "should not happen" @@ -373,17 +464,20 @@ let translate_scope (ctx : ctx) (scope : Ast.scope) : Scopelang.Ast.scope_decl = Scopelang.Ast.Definition ( ( Scopelang.Ast.ScopeVar ( scope_var, - Pos.get_position (Scopelang.Ast.ScopeVar.get_info scope_var) ), - Pos.get_position (Scopelang.Ast.ScopeVar.get_info scope_var) ), + Pos.get_position + (Scopelang.Ast.ScopeVar.get_info scope_var) ), + Pos.get_position + (Scopelang.Ast.ScopeVar.get_info scope_var) ), var_typ, scope_def.Ast.scope_def_io, expr_def ); ]) | Dependency.Vertex.SubScope sub_scope_index -> - (* Before calling the sub_scope, we need to include all the re-definitions of - subscope parameters*) + (* Before calling the sub_scope, we need to include all the + re-definitions of subscope parameters*) let sub_scope = - Scopelang.Ast.SubScopeMap.find sub_scope_index scope.scope_sub_scopes + Scopelang.Ast.SubScopeMap.find sub_scope_index + scope.scope_sub_scopes in let sub_scope_vars_redefs_candidates = Ast.ScopeDefMap.filter @@ -392,13 +486,17 @@ let translate_scope (ctx : ctx) (scope : Ast.scope) : Scopelang.Ast.scope_decl = | Ast.ScopeDef.Var _ -> false | Ast.ScopeDef.SubScopeVar (sub_scope_index', _) -> sub_scope_index = sub_scope_index' - (* We exclude subscope variables that have 0 re-definitions and are not - visible in the input of the subscope *) + (* We exclude subscope variables that have 0 + re-definitions and are not visible in the input of + the subscope *) && not - ((match Pos.unmark scope_def.Ast.scope_def_io.io_input with + ((match + Pos.unmark scope_def.Ast.scope_def_io.io_input + with | Scopelang.Ast.NoInput -> true | _ -> false) - && Ast.RuleMap.is_empty scope_def.scope_def_rules)) + && Ast.RuleMap.is_empty scope_def.scope_def_rules + )) scope.scope_defs in let sub_scope_vars_redefs = @@ -408,57 +506,78 @@ let translate_scope (ctx : ctx) (scope : Ast.scope) : Scopelang.Ast.scope_decl = let def_typ = scope_def.scope_def_typ in let is_cond = scope_def.scope_def_is_condition in match def_key with - | Ast.ScopeDef.Var _ -> assert false (* should not happen *) + | Ast.ScopeDef.Var _ -> + assert false (* should not happen *) | Ast.ScopeDef.SubScopeVar (_, sub_scope_var) -> - (* This definition redefines a variable of the correct subscope. But we - have to check that this redefinition is allowed with respect to the io + (* This definition redefines a variable of the correct + subscope. But we have to check that this + redefinition is allowed with respect to the io parameters of that subscope variable. *) - (match Pos.unmark scope_def.Ast.scope_def_io.io_input with + (match + Pos.unmark scope_def.Ast.scope_def_io.io_input + with | Scopelang.Ast.NoInput -> Errors.raise_multispanned_error - ((Some "Incriminated subscope:", Ast.ScopeDef.get_position def_key) + (( Some "Incriminated subscope:", + Ast.ScopeDef.get_position def_key ) :: ( Some "Incriminated variable:", - Pos.get_position (Ast.ScopeVar.get_info sub_scope_var) ) + Pos.get_position + (Ast.ScopeVar.get_info sub_scope_var) ) :: List.map (fun (rule, _) -> - ( Some "Incriminated subscope variable definition:", - Pos.get_position (Ast.RuleName.get_info rule) )) + ( Some + "Incriminated subscope variable \ + definition:", + Pos.get_position + (Ast.RuleName.get_info rule) )) (Ast.RuleMap.bindings def)) - "It is impossible to give a definition to a subscope variable not \ - tagged as input or context." - | OnlyInput when Ast.RuleMap.is_empty def && not is_cond -> - (* If the subscope variable is tagged as input, then it shall be - defined. *) + "It is impossible to give a definition to a \ + subscope variable not tagged as input or \ + context." + | OnlyInput + when Ast.RuleMap.is_empty def && not is_cond -> + (* If the subscope variable is tagged as input, + then it shall be defined. *) Errors.raise_multispanned_error [ - (Some "Incriminated subscope:", Ast.ScopeDef.get_position def_key); + ( Some "Incriminated subscope:", + Ast.ScopeDef.get_position def_key ); ( Some "Incriminated variable:", - Pos.get_position (Ast.ScopeVar.get_info sub_scope_var) ); + Pos.get_position + (Ast.ScopeVar.get_info sub_scope_var) ); ] - "This subscope variable is a mandatory input but no definition was \ - provided." + "This subscope variable is a mandatory input \ + but no definition was provided." | _ -> ()); - (* Now that all is good, we can proceed with translating this redefinition - to a proper Scopelang term. *) + (* Now that all is good, we can proceed with + translating this redefinition to a proper Scopelang + term. *) let expr_def = - translate_def ctx def_key def def_typ scope_def.Ast.scope_def_io ~is_cond + translate_def ctx def_key def def_typ + scope_def.Ast.scope_def_io ~is_cond ~is_subscope_var:true in let subscop_real_name = - Scopelang.Ast.SubScopeMap.find sub_scope_index scope.scope_sub_scopes + Scopelang.Ast.SubScopeMap.find sub_scope_index + scope.scope_sub_scopes + in + let var_pos = + Pos.get_position + (Ast.ScopeVar.get_info sub_scope_var) in - let var_pos = Pos.get_position (Ast.ScopeVar.get_info sub_scope_var) in Scopelang.Ast.Definition ( ( Scopelang.Ast.SubScopeVar ( subscop_real_name, (sub_scope_index, var_pos), match - Ast.ScopeVarMap.find sub_scope_var ctx.scope_var_mapping + Ast.ScopeVarMap.find sub_scope_var + ctx.scope_var_mapping with | WholeVar v -> (v, var_pos) | States states -> - (* When defining a sub-scope variable, we always define its - first state in the sub-scope. *) + (* When defining a sub-scope variable, we + always define its first state in the + sub-scope. *) (snd (List.hd states), var_pos) ), var_pos ), def_typ, @@ -469,17 +588,22 @@ let translate_scope (ctx : ctx) (scope : Ast.scope) : Scopelang.Ast.scope_decl = let sub_scope_vars_redefs = List.map snd (Ast.ScopeDefMap.bindings sub_scope_vars_redefs) in - sub_scope_vars_redefs @ [ Scopelang.Ast.Call (sub_scope, sub_scope_index) ]) + sub_scope_vars_redefs + @ [ Scopelang.Ast.Call (sub_scope, sub_scope_index) ]) scope_ordering) in - (* Then, after having computed all the scopes variables, we add the assertions. TODO: the - assertions should be interleaved with the definitions! *) + (* Then, after having computed all the scopes variables, we add the + assertions. TODO: the assertions should be interleaved with the + definitions! *) let scope_decl_rules = scope_decl_rules @ List.map (fun e -> let scope_e = translate_expr ctx e in - Bindlib.unbox (Bindlib.box_apply (fun scope_e -> Scopelang.Ast.Assertion scope_e) scope_e)) + Bindlib.unbox + (Bindlib.box_apply + (fun scope_e -> Scopelang.Ast.Assertion scope_e) + scope_e)) (Bindlib.unbox (Bindlib.box_list scope.Ast.scope_assertions)) in let scope_sig = @@ -487,20 +611,28 @@ let translate_scope (ctx : ctx) (scope : Ast.scope) : Scopelang.Ast.scope_decl = (fun var (states : Ast.var_or_states) acc -> match states with | WholeVar -> - let scope_def = Ast.ScopeDefMap.find (Ast.ScopeDef.Var (var, None)) scope.scope_defs in + let scope_def = + Ast.ScopeDefMap.find + (Ast.ScopeDef.Var (var, None)) + scope.scope_defs + in let typ = scope_def.scope_def_typ in Scopelang.Ast.ScopeVarMap.add (match Ast.ScopeVarMap.find var ctx.scope_var_mapping with | WholeVar v -> v | States _ -> failwith "should not happen") - (typ, scope_def.scope_def_io) acc + (typ, scope_def.scope_def_io) + acc | States states -> - (* What happens in the case of variables with multiple states is interesting. We need to - create as many Scopelang.Var entries in the scope signature as there are states. *) + (* What happens in the case of variables with multiple states is + interesting. We need to create as many Scopelang.Var entries in + the scope signature as there are states. *) List.fold_left (fun acc (state : Ast.StateName.t) -> let scope_def = - Ast.ScopeDefMap.find (Ast.ScopeDef.Var (var, Some state)) scope.scope_defs + Ast.ScopeDefMap.find + (Ast.ScopeDef.Var (var, Some state)) + scope.scope_defs in Scopelang.Ast.ScopeVarMap.add (match Ast.ScopeVarMap.find var ctx.scope_var_mapping with @@ -520,8 +652,9 @@ let translate_scope (ctx : ctx) (scope : Ast.scope) : Scopelang.Ast.scope_decl = (** {1 API} *) let translate_program (pgrm : Ast.program) : Scopelang.Ast.program = - (* First we give mappings to all the locations between Desugared and Scopelang. This involves - creating a new Scopelang scope variable for every state of a Desugared variable. *) + (* First we give mappings to all the locations between Desugared and + Scopelang. This involves creating a new Scopelang scope variable for every + state of a Desugared variable. *) let ctx = Scopelang.Ast.ScopeMap.fold (fun _scope scope_decl ctx -> @@ -533,7 +666,9 @@ let translate_program (pgrm : Ast.program) : Scopelang.Ast.program = ctx with scope_var_mapping = Ast.ScopeVarMap.add scope_var - (WholeVar (Scopelang.Ast.ScopeVar.fresh (Ast.ScopeVar.get_info scope_var))) + (WholeVar + (Scopelang.Ast.ScopeVar.fresh + (Ast.ScopeVar.get_info scope_var))) ctx.scope_var_mapping; } | States states -> @@ -546,15 +681,21 @@ let translate_program (pgrm : Ast.program) : Scopelang.Ast.program = (fun state -> ( state, Scopelang.Ast.ScopeVar.fresh - (let state_name, state_pos = Ast.StateName.get_info state in - ( Pos.unmark (Ast.ScopeVar.get_info scope_var) ^ "_" ^ state_name, + (let state_name, state_pos = + Ast.StateName.get_info state + in + ( Pos.unmark (Ast.ScopeVar.get_info scope_var) + ^ "_" ^ state_name, state_pos )) )) states)) ctx.scope_var_mapping; }) scope_decl.Ast.scope_vars ctx) pgrm.Ast.program_scopes - { scope_var_mapping = Ast.ScopeVarMap.empty; var_mapping = Ast.VarMap.empty } + { + scope_var_mapping = Ast.ScopeVarMap.empty; + var_mapping = Ast.VarMap.empty; + } in { Scopelang.Ast.program_scopes = diff --git a/compiler/desugared/desugared_to_scope.mli b/compiler/desugared/desugared_to_scope.mli index 05bd5b5f..7b8d2c12 100644 --- a/compiler/desugared/desugared_to_scope.mli +++ b/compiler/desugared/desugared_to_scope.mli @@ -1,15 +1,17 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux - +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, contributor: + Denis Merigoux - 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 + 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 + 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. *) (** Translation from {!module: Desugared.Ast} to {!module: Scopelang.Ast} *) diff --git a/compiler/driver.ml b/compiler/driver.ml index 46375f2d..7e6ce0ac 100644 --- a/compiler/driver.ml +++ b/compiler/driver.ml @@ -1,15 +1,18 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020 Inria, contributors: Denis Merigoux - , Emile Rolley +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, + contributors: Denis Merigoux , Emile Rolley + - 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 + 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 + 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. *) module Cli = Utils.Cli @@ -19,19 +22,25 @@ module Pos = Utils.Pos (** Associates a {!type: Cli.backend_lang} with its string represtation. *) let languages = [ ("en", Cli.En); ("fr", Cli.Fr); ("pl", Cli.Pl) ] -(** Associates a file extension with its corresponding {!type: Cli.backend_lang} string - representation. *) -let extensions = [ (".catala_fr", "fr"); (".catala_en", "en"); (".catala_pl", "pl") ] +(** Associates a file extension with its corresponding {!type: Cli.backend_lang} + string representation. *) +let extensions = + [ (".catala_fr", "fr"); (".catala_en", "en"); (".catala_pl", "pl") ] -(** Entry function for the executable. Returns a negative number in case of error. Usage: +(** Entry function for the executable. Returns a negative number in case of + error. Usage: [driver source_file debug dcalc unstyled wrap_weaved_output backend plugins_dirs language max_prec_digits trace optimize scope_to_execute output_file]*) let driver source_file (options : Cli.options) : int = try Cli.set_option_globals options; Cli.debug_print "Reading files..."; let filename = ref "" in - (match source_file with Pos.FileName f -> filename := f | Contents c -> Cli.contents := c); - (match options.max_prec_digits with None -> () | Some i -> Cli.max_prec_digits := i); + (match source_file with + | Pos.FileName f -> filename := f + | Contents c -> Cli.contents := c); + (match options.max_prec_digits with + | None -> () + | Some i -> Cli.max_prec_digits := i); let l = match options.language with | Some l -> l @@ -40,15 +49,16 @@ let driver source_file (options : Cli.options) : int = let ext = Filename.extension !filename in if ext = "" then Errors.raise_error - "No file extension found for the file '%s'. (Try to add one or to specify the -l \ - flag)" + "No file extension found for the file '%s'. (Try to add one or \ + to specify the -l flag)" !filename; try List.assoc ext extensions with Not_found -> ext) in let language = try List.assoc l languages with Not_found -> - Errors.raise_error "The selected language (%s) is not supported by Catala" l + Errors.raise_error + "The selected language (%s) is not supported by Catala" l in Cli.locale_lang := language; let backend = options.backend in @@ -66,9 +76,13 @@ let driver source_file (options : Cli.options) : int = else if backend = "typecheck" then Cli.Typecheck else if backend = "lcalc" then Cli.Lcalc else if backend = "scalc" then Cli.Scalc - else Errors.raise_error "The selected backend (%s) is not supported by Catala" backend + else + Errors.raise_error + "The selected backend (%s) is not supported by Catala" backend + in + let prgm = + Surface.Parser_driver.parse_top_level_file source_file language in - let prgm = Surface.Parser_driver.parse_top_level_file source_file language in let prgm = Surface.Fill_positions.fill_pos_with_legislative_info prgm in match backend with | Cli.Makefile -> @@ -77,7 +91,8 @@ let driver source_file (options : Cli.options) : int = match source_file with | FileName f -> f | Contents _ -> - Errors.raise_error "The Makefile backend does not work if the input is not a file" + Errors.raise_error + "The Makefile backend does not work if the input is not a file" in let output_file = match options.output_file with @@ -101,7 +116,8 @@ let driver source_file (options : Cli.options) : int = | FileName f -> f | Contents _ -> Errors.raise_error - "The literate programming backends do not work if the input is not a file" + "The literate programming backends do not work if the input is \ + not a file" in Cli.debug_print "Weaving literate program into %s" (match backend with @@ -114,7 +130,10 @@ let driver source_file (options : Cli.options) : int = | None -> ( Filename.remove_extension source_file ^ - match backend with Cli.Latex -> ".tex" | Cli.Html -> ".html" | _ -> assert false + match backend with + | Cli.Latex -> ".tex" + | Cli.Html -> ".html" + | _ -> assert false (* should not happen *)) in let oc = open_out output_file in @@ -130,11 +149,11 @@ let driver source_file (options : Cli.options) : int = if options.wrap_weaved_output then match backend with | Cli.Latex -> - Literate.Latex.wrap_latex prgm.Surface.Ast.program_source_files language fmt - (fun fmt -> weave_output fmt prgm) + Literate.Latex.wrap_latex prgm.Surface.Ast.program_source_files + language fmt (fun fmt -> weave_output fmt prgm) | Cli.Html -> - Literate.Html.wrap_html prgm.Surface.Ast.program_source_files language fmt (fun fmt -> - weave_output fmt prgm) + Literate.Html.wrap_html prgm.Surface.Ast.program_source_files + language fmt (fun fmt -> weave_output fmt prgm) | _ -> assert false (* should not happen *) else weave_output fmt prgm; close_out oc; @@ -144,14 +163,19 @@ let driver source_file (options : Cli.options) : int = let ctxt = Surface.Name_resolution.form_context prgm in let scope_uid = match (options.ex_scope, backend) with - | None, Cli.Interpret -> Errors.raise_error "No scope was provided for execution." + | None, Cli.Interpret -> + Errors.raise_error "No scope was provided for execution." | None, _ -> snd (try Desugared.Ast.IdentMap.choose ctxt.scope_idmap - with Not_found -> Errors.raise_error "There isn't any scope inside the program.") + with Not_found -> + Errors.raise_error + "There isn't any scope inside the program.") | Some name, _ -> ( match Desugared.Ast.IdentMap.find_opt name ctxt.scope_idmap with - | None -> Errors.raise_error "There is no scope \"%s\" inside the program." name + | None -> + Errors.raise_error + "There is no scope \"%s\" inside the program." name | Some uid -> uid) in Cli.debug_print "Desugaring..."; @@ -168,13 +192,16 @@ let driver source_file (options : Cli.options) : int = in if Option.is_some options.ex_scope then Format.fprintf fmt "%a\n" Scopelang.Print.format_scope - (scope_uid, Scopelang.Ast.ScopeMap.find scope_uid prgm.program_scopes) + ( scope_uid, + Scopelang.Ast.ScopeMap.find scope_uid prgm.program_scopes ) else Format.fprintf fmt "%a\n" Scopelang.Print.format_program prgm; at_end (); exit 0 end; Cli.debug_print "Translating to default calculus..."; - let prgm, type_ordering = Scopelang.Scope_to_dcalc.translate_program prgm in + let prgm, type_ordering = + Scopelang.Scope_to_dcalc.translate_program prgm + in let prgm = if options.optimize then begin Cli.debug_print "Optimizing default calculus..."; @@ -182,7 +209,9 @@ let driver source_file (options : Cli.options) : int = end else prgm in - let prgrm_dcalc_expr = Bindlib.unbox (Dcalc.Ast.build_whole_program_expr prgm scope_uid) in + let prgrm_dcalc_expr = + Bindlib.unbox (Dcalc.Ast.build_whole_program_expr prgm scope_uid) + in if backend = Cli.Dcalc then begin let fmt, at_end = match options.output_file with @@ -194,38 +223,51 @@ let driver source_file (options : Cli.options) : int = if Option.is_some options.ex_scope then Format.fprintf fmt "%a\n" (Dcalc.Print.format_scope ~debug:options.debug prgm.decl_ctx) - (let _, _, s = List.find (fun (name, _, _) -> name = scope_uid) prgm.scopes in + (let _, _, s = + List.find (fun (name, _, _) -> name = scope_uid) prgm.scopes + in (scope_uid, s)) - else Format.fprintf fmt "%a\n" (Dcalc.Print.format_expr prgm.decl_ctx) prgrm_dcalc_expr; + else + Format.fprintf fmt "%a\n" + (Dcalc.Print.format_expr prgm.decl_ctx) + prgrm_dcalc_expr; at_end (); exit 0 end; Cli.debug_print "Typechecking..."; let _typ = Dcalc.Typing.infer_type prgm.decl_ctx prgrm_dcalc_expr in - (* Cli.debug_print (Format.asprintf "Typechecking results :@\n%a" (Dcalc.Print.format_typ - prgm.decl_ctx) typ); *) + (* Cli.debug_print (Format.asprintf "Typechecking results :@\n%a" + (Dcalc.Print.format_typ prgm.decl_ctx) typ); *) match backend with | Cli.Typecheck -> (* That's it! *) Cli.result_print "Typechecking successful!"; 0 | Cli.Proof -> - let vcs = Verification.Conditions.generate_verification_conditions prgm in + let vcs = + Verification.Conditions.generate_verification_conditions prgm + in Verification.Solver.solve_vc prgm prgm.decl_ctx vcs; 0 | Cli.Interpret -> Cli.debug_print "Starting interpretation..."; - let results = Dcalc.Interpreter.interpret_program prgm.decl_ctx prgrm_dcalc_expr in + let results = + Dcalc.Interpreter.interpret_program prgm.decl_ctx prgrm_dcalc_expr + in let out_regex = Re.Pcre.regexp "\\_out$" in let results = List.map (fun ((v1, v1_pos), e1) -> - let v1 = Re.Pcre.substitute ~rex:out_regex ~subst:(fun _ -> "") v1 in + let v1 = + Re.Pcre.substitute ~rex:out_regex ~subst:(fun _ -> "") v1 + in ((v1, v1_pos), e1)) results in let results = - List.sort (fun ((v1, _), _) ((v2, _), _) -> String.compare v1 v2) results + List.sort + (fun ((v1, _), _) ((v2, _), _) -> String.compare v1 v2) + results in Cli.debug_print "End of interpretation"; Cli.result_print "Computation successful!%s" @@ -263,14 +305,17 @@ let driver source_file (options : Cli.options) : int = Format.fprintf fmt "%a\n" (Lcalc.Print.format_scope ~debug:options.debug prgm.decl_ctx) (let body = - List.find (fun body -> body.Lcalc.Ast.scope_body_name = scope_uid) prgm.scopes + List.find + (fun body -> body.Lcalc.Ast.scope_body_name = scope_uid) + prgm.scopes in body) else Format.fprintf fmt "%a\n" (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "\n\n") - (fun fmt scope -> (Lcalc.Print.format_scope prgm.decl_ctx) fmt scope)) + (fun fmt scope -> + (Lcalc.Print.format_scope prgm.decl_ctx) fmt scope)) prgm.scopes; at_end (); exit 0 @@ -279,7 +324,8 @@ let driver source_file (options : Cli.options) : int = match source_file with | FileName f -> f | Contents _ -> - Errors.raise_error "This backend does not work if the input is not a file" + Errors.raise_error + "This backend does not work if the input is not a file" in let new_output_file (extension : string) : string = match options.output_file with @@ -302,15 +348,18 @@ let driver source_file (options : Cli.options) : int = match options.output_file with | Some f -> let oc = open_out f in - (Format.formatter_of_out_channel oc, fun _ -> close_out oc) + ( Format.formatter_of_out_channel oc, + fun _ -> close_out oc ) | None -> (Format.std_formatter, fun _ -> ()) in if Option.is_some options.ex_scope then Format.fprintf fmt "%a\n" - (Scalc.Print.format_scope ~debug:options.debug prgm.decl_ctx) + (Scalc.Print.format_scope ~debug:options.debug + prgm.decl_ctx) (let body = List.find - (fun body -> body.Scalc.Ast.scope_body_name = scope_uid) + (fun body -> + body.Scalc.Ast.scope_body_name = scope_uid) prgm.scopes in body) @@ -318,7 +367,8 @@ let driver source_file (options : Cli.options) : int = Format.fprintf fmt "%a\n" (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "\n\n") - (fun fmt scope -> (Scalc.Print.format_scope prgm.decl_ctx) fmt scope)) + (fun fmt scope -> + (Scalc.Print.format_scope prgm.decl_ctx) fmt scope)) prgm.scopes; at_end (); exit 0 @@ -343,7 +393,9 @@ let driver source_file (options : Cli.options) : int = -1 let main () = - let return_code = Cmdliner.Term.eval (Cli.catala_t (fun f -> driver (FileName f)), Cli.info) in + let return_code = + Cmdliner.Term.eval (Cli.catala_t (fun f -> driver (FileName f)), Cli.info) + in match return_code with | `Ok 0 -> Cmdliner.Term.exit (`Ok 0) | _ -> Cmdliner.Term.exit (`Error `Term) diff --git a/compiler/driver.mli b/compiler/driver.mli index d2157f5a..e3e7333f 100644 --- a/compiler/driver.mli +++ b/compiler/driver.mli @@ -1,19 +1,23 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020 Inria, contributors: Denis Merigoux - , Emile Rolley +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, + contributors: Denis Merigoux , Emile Rolley + - 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 + 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 + 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. *) val driver : Utils.Pos.input_file -> Utils.Cli.options -> int -(** Entry function for the executable. Returns a negative number in case of error. *) +(** Entry function for the executable. Returns a negative number in case of + error. *) val main : unit -> unit (** Main program entry point, including command-line parsing and return code *) diff --git a/compiler/lcalc/ast.ml b/compiler/lcalc/ast.ml index 489fea96..0d833598 100644 --- a/compiler/lcalc/ast.ml +++ b/compiler/lcalc/ast.ml @@ -1,15 +1,17 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux - +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, contributor: + Denis Merigoux - 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 + 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 + 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. *) open Utils @@ -30,7 +32,8 @@ type expr = | EVar of expr Bindlib.var Pos.marked | ETuple of expr Pos.marked list * D.StructName.t option (** The [MarkedString.info] is the former struct field name*) - | ETupleAccess of expr Pos.marked * int * D.StructName.t option * D.typ Pos.marked list + | ETupleAccess of + expr Pos.marked * int * D.StructName.t option * D.typ Pos.marked list (** The [MarkedString.info] is the former struct field name *) | EInj of expr Pos.marked * int * D.EnumName.t * D.typ Pos.marked list (** The [MarkedString.info] is the former enum case name *) @@ -38,7 +41,8 @@ type expr = (** The [MarkedString.info] is the former enum case name *) | EArray of expr Pos.marked list | ELit of lit - | EAbs of (expr, expr Pos.marked) Bindlib.mbinder Pos.marked * D.typ Pos.marked list + | EAbs of + (expr, expr Pos.marked) Bindlib.mbinder Pos.marked * D.typ Pos.marked list | EApp of expr Pos.marked * expr Pos.marked list | EAssert of expr Pos.marked | EOp of D.operator @@ -64,37 +68,55 @@ type vars = expr Bindlib.mvar let make_var ((x, pos) : Var.t Pos.marked) : expr Pos.marked Bindlib.box = Bindlib.box_apply (fun x -> (x, pos)) (Bindlib.box_var x) -let make_abs (xs : vars) (e : expr Pos.marked Bindlib.box) (pos_binder : Pos.t) - (taus : D.typ Pos.marked list) (pos : Pos.t) : expr Pos.marked Bindlib.box = - Bindlib.box_apply (fun b -> (EAbs ((b, pos_binder), taus), pos)) (Bindlib.bind_mvar xs e) +let make_abs + (xs : vars) + (e : expr Pos.marked Bindlib.box) + (pos_binder : Pos.t) + (taus : D.typ Pos.marked list) + (pos : Pos.t) : expr Pos.marked Bindlib.box = + Bindlib.box_apply + (fun b -> (EAbs ((b, pos_binder), taus), pos)) + (Bindlib.bind_mvar xs e) -let make_app (e : expr Pos.marked Bindlib.box) (u : expr Pos.marked Bindlib.box list) (pos : Pos.t) - : expr Pos.marked Bindlib.box = +let make_app + (e : expr Pos.marked Bindlib.box) + (u : expr Pos.marked Bindlib.box list) + (pos : Pos.t) : expr Pos.marked Bindlib.box = Bindlib.box_apply2 (fun e u -> (EApp (e, u), pos)) e (Bindlib.box_list u) -let make_let_in (x : Var.t) (tau : D.typ Pos.marked) (e1 : expr Pos.marked Bindlib.box) +let make_let_in + (x : Var.t) + (tau : D.typ Pos.marked) + (e1 : expr Pos.marked Bindlib.box) (e2 : expr Pos.marked Bindlib.box) : expr Pos.marked Bindlib.box = let pos = Pos.get_position (Bindlib.unbox e2) in make_app (make_abs (Array.of_list [ x ]) e2 pos [ tau ] pos) [ e1 ] pos let ( let+ ) x f = Bindlib.box_apply f x - let ( and+ ) x y = Bindlib.box_pair x y - let option_enum : D.EnumName.t = D.EnumName.fresh ("eoption", Pos.no_pos) -let none_constr : D.EnumConstructor.t = D.EnumConstructor.fresh ("ENone", Pos.no_pos) +let none_constr : D.EnumConstructor.t = + D.EnumConstructor.fresh ("ENone", Pos.no_pos) -let some_constr : D.EnumConstructor.t = D.EnumConstructor.fresh ("ESome", Pos.no_pos) +let some_constr : D.EnumConstructor.t = + D.EnumConstructor.fresh ("ESome", Pos.no_pos) let option_enum_config : (D.EnumConstructor.t * D.typ Pos.marked) list = - [ (none_constr, (D.TLit D.TUnit, Pos.no_pos)); (some_constr, (D.TAny, Pos.no_pos)) ] + [ + (none_constr, (D.TLit D.TUnit, Pos.no_pos)); + (some_constr, (D.TAny, Pos.no_pos)); + ] let make_none (pos : Pos.t) : expr Pos.marked Bindlib.box = let mark : 'a -> 'a Pos.marked = Pos.mark pos in Bindlib.box @@ mark - @@ EInj (mark @@ ELit LUnit, 0, option_enum, [ (D.TLit D.TUnit, pos); (D.TAny, pos) ]) + @@ EInj + ( mark @@ ELit LUnit, + 0, + option_enum, + [ (D.TLit D.TUnit, pos); (D.TAny, pos) ] ) let make_some (e : expr Pos.marked Bindlib.box) : expr Pos.marked Bindlib.box = let pos = Pos.get_position @@ Bindlib.unbox e in @@ -103,11 +125,12 @@ let make_some (e : expr Pos.marked Bindlib.box) : expr Pos.marked Bindlib.box = mark @@ EInj (e, 1, option_enum, [ (D.TLit D.TUnit, pos); (D.TAny, pos) ]) (** [make_matchopt_with_abs_arms arg e_none e_some] build an expression - [match arg with |None -> e_none | Some -> e_some] and requires e_some and e_none to be in the - form [EAbs ...].*) -let make_matchopt_with_abs_arms (arg : expr Pos.marked Bindlib.box) - (e_none : expr Pos.marked Bindlib.box) (e_some : expr Pos.marked Bindlib.box) : - expr Pos.marked Bindlib.box = + [match arg with |None -> e_none | Some -> e_some] and requires e_some and + e_none to be in the form [EAbs ...].*) +let make_matchopt_with_abs_arms + (arg : expr Pos.marked Bindlib.box) + (e_none : expr Pos.marked Bindlib.box) + (e_some : expr Pos.marked Bindlib.box) : expr Pos.marked Bindlib.box = let pos = Pos.get_position @@ Bindlib.unbox arg in let mark : 'a -> 'a Pos.marked = Pos.mark pos in @@ -116,10 +139,15 @@ let make_matchopt_with_abs_arms (arg : expr Pos.marked Bindlib.box) mark @@ EMatch (arg, [ e_none; e_some ], option_enum) (** [make_matchopt pos v tau arg e_none e_some] builds an expression - [match arg with | None () -> e_none | Some v -> e_some]. It binds v to e_some, permitting it to - be used inside the expression. There is no requirements on the form of both e_some and e_none. *) -let make_matchopt (pos : Pos.t) (v : Var.t) (tau : D.typ Pos.marked) - (arg : expr Pos.marked Bindlib.box) (e_none : expr Pos.marked Bindlib.box) + [match arg with | None () -> e_none | Some v -> e_some]. It binds v to + e_some, permitting it to be used inside the expression. There is no + requirements on the form of both e_some and e_none. *) +let make_matchopt + (pos : Pos.t) + (v : Var.t) + (tau : D.typ Pos.marked) + (arg : expr Pos.marked Bindlib.box) + (e_none : expr Pos.marked Bindlib.box) (e_some : expr Pos.marked Bindlib.box) : expr Pos.marked Bindlib.box = let x = Var.make ("_", pos) in @@ -128,7 +156,6 @@ let make_matchopt (pos : Pos.t) (v : Var.t) (tau : D.typ Pos.marked) (make_abs (Array.of_list [ v ]) e_some pos [ tau ] pos) let handle_default = Var.make ("handle_default", Pos.no_pos) - let handle_default_opt = Var.make ("handle_default_opt", Pos.no_pos) type binder = (expr, expr Pos.marked) Bindlib.binder diff --git a/compiler/lcalc/ast.mli b/compiler/lcalc/ast.mli index 2119dc2b..1d46fbd9 100644 --- a/compiler/lcalc/ast.mli +++ b/compiler/lcalc/ast.mli @@ -1,15 +1,17 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux - +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, contributor: + Denis Merigoux - 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 + 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 + 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. *) open Utils @@ -18,8 +20,8 @@ open Utils (** {1 Abstract syntax tree} *) -(** The expressions use the {{:https://lepigre.fr/ocaml-bindlib/} Bindlib} library, based on - higher-order abstract syntax*) +(** The expressions use the {{:https://lepigre.fr/ocaml-bindlib/} Bindlib} + library, based on higher-order abstract syntax*) type lit = | LBool of bool @@ -37,15 +39,24 @@ type expr = | ETuple of expr Pos.marked list * Dcalc.Ast.StructName.t option (** The [MarkedString.info] is the former struct field name*) | ETupleAccess of - expr Pos.marked * int * Dcalc.Ast.StructName.t option * Dcalc.Ast.typ Pos.marked list + expr Pos.marked + * int + * Dcalc.Ast.StructName.t option + * Dcalc.Ast.typ Pos.marked list (** The [MarkedString.info] is the former struct field name *) - | EInj of expr Pos.marked * int * Dcalc.Ast.EnumName.t * Dcalc.Ast.typ Pos.marked list + | EInj of + expr Pos.marked + * int + * Dcalc.Ast.EnumName.t + * Dcalc.Ast.typ Pos.marked list (** The [MarkedString.info] is the former enum case name *) | EMatch of expr Pos.marked * expr Pos.marked list * Dcalc.Ast.EnumName.t (** The [MarkedString.info] is the former enum case name *) | EArray of expr Pos.marked list | ELit of lit - | EAbs of (expr, expr Pos.marked) Bindlib.mbinder Pos.marked * Dcalc.Ast.typ Pos.marked list + | EAbs of + (expr, expr Pos.marked) Bindlib.mbinder Pos.marked + * Dcalc.Ast.typ Pos.marked list | EApp of expr Pos.marked * expr Pos.marked list | EAssert of expr Pos.marked | EOp of Dcalc.Ast.operator @@ -59,7 +70,6 @@ module Var : sig type t = expr Bindlib.var val make : string Pos.marked -> t - val compare : t -> t -> int end @@ -91,15 +101,13 @@ val make_let_in : expr Pos.marked Bindlib.box val option_enum : Dcalc.Ast.EnumName.t - val none_constr : Dcalc.Ast.EnumConstructor.t - val some_constr : Dcalc.Ast.EnumConstructor.t -val option_enum_config : (Dcalc.Ast.EnumConstructor.t * Dcalc.Ast.typ Pos.marked) list +val option_enum_config : + (Dcalc.Ast.EnumConstructor.t * Dcalc.Ast.typ Pos.marked) list val make_none : Pos.t -> expr Pos.marked Bindlib.box - val make_some : expr Pos.marked Bindlib.box -> expr Pos.marked Bindlib.box val make_matchopt_with_abs_arms : @@ -116,11 +124,10 @@ val make_matchopt : expr Pos.marked Bindlib.box -> expr Pos.marked Bindlib.box -> expr Pos.marked Bindlib.box -(** [e' = make_matchopt'' pos v e e_none e_some] Builds the term corresponding to - [match e with | None -> fun () -> e_none |Some -> fun v -> e_some]. *) +(** [e' = make_matchopt'' pos v e e_none e_some] Builds the term corresponding + to [match e with | None -> fun () -> e_none |Some -> fun v -> e_some]. *) val handle_default : Var.t - val handle_default_opt : Var.t type binder = (expr, expr Pos.marked) Bindlib.binder diff --git a/compiler/lcalc/backends.ml b/compiler/lcalc/backends.ml index bb424363..c55c2f2a 100644 --- a/compiler/lcalc/backends.ml +++ b/compiler/lcalc/backends.ml @@ -1,15 +1,17 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2021 Inria, contributor: Denis Merigoux - +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2021 Inria, contributor: + Denis Merigoux - 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 + 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 + 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. *) let to_ascii (s : string) : string = @@ -48,7 +50,8 @@ let to_lowercase (s : string) : string = out := !out ^ (if is_uppercase && not !is_first then "_" else "") - ^ String.lowercase_ascii (String.make 1 (CamomileLibraryDefault.Camomile.UChar.char_of c)); + ^ String.lowercase_ascii + (String.make 1 (CamomileLibraryDefault.Camomile.UChar.char_of c)); is_first := false) s; !out @@ -59,13 +62,18 @@ let to_uppercase (s : string) : string = let out = ref "" in CamomileLibraryDefault.Camomile.UTF8.iter (fun c -> - let is_underscore = c = CamomileLibraryDefault.Camomile.UChar.of_char '_' in - let c_string = String.make 1 (CamomileLibraryDefault.Camomile.UChar.char_of c) in + let is_underscore = + c = CamomileLibraryDefault.Camomile.UChar.of_char '_' + in + let c_string = + String.make 1 (CamomileLibraryDefault.Camomile.UChar.char_of c) + in out := !out ^ if is_underscore then "" - else if !last_was_underscore || !is_first then String.uppercase_ascii c_string + else if !last_was_underscore || !is_first then + String.uppercase_ascii c_string else c_string; last_was_underscore := is_underscore; is_first := false) diff --git a/compiler/lcalc/backends.mli b/compiler/lcalc/backends.mli index c2d6bb15..2b5d3589 100644 --- a/compiler/lcalc/backends.mli +++ b/compiler/lcalc/backends.mli @@ -1,22 +1,24 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2021 Inria, contributor: Denis Merigoux - +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2021 Inria, contributor: + Denis Merigoux - 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 + 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 + 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. *) (** Helper functions common to all Catala compiler backends *) val to_ascii : string -> string -(** Removes all non-ASCII diacritics from a string by converting them to their base letter in the - Latin alphabet *) +(** Removes all non-ASCII diacritics from a string by converting them to their + base letter in the Latin alphabet *) val to_lowercase : string -> string (** Converts CamlCase into snake_case *) diff --git a/compiler/lcalc/compile_with_exceptions.ml b/compiler/lcalc/compile_with_exceptions.ml index 4fc2174a..f7068237 100644 --- a/compiler/lcalc/compile_with_exceptions.ml +++ b/compiler/lcalc/compile_with_exceptions.ml @@ -1,15 +1,17 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux - +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, contributor: + Denis Merigoux - 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 + 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 + 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. *) open Utils @@ -17,8 +19,8 @@ module D = Dcalc.Ast module A = Ast type ctx = A.expr Pos.marked Bindlib.box D.VarMap.t -(** This environment contains a mapping between the variables in Dcalc and their correspondance in - Lcalc. *) +(** This environment contains a mapping between the variables in Dcalc and their + correspondance in Lcalc. *) let translate_lit (l : D.lit) : A.expr = match l with @@ -31,15 +33,21 @@ let translate_lit (l : D.lit) : A.expr = | D.LDuration d -> A.ELit (A.LDuration d) | D.LEmptyError -> A.ERaise A.EmptyError -let thunk_expr (e : A.expr Pos.marked Bindlib.box) (pos : Pos.t) : A.expr Pos.marked Bindlib.box = +let thunk_expr (e : A.expr Pos.marked Bindlib.box) (pos : Pos.t) : + A.expr Pos.marked Bindlib.box = let dummy_var = A.Var.make ("_", pos) in A.make_abs [| dummy_var |] e pos [ (D.TAny, pos) ] pos -let rec translate_default (ctx : ctx) (exceptions : D.expr Pos.marked list) - (just : D.expr Pos.marked) (cons : D.expr Pos.marked) (pos_default : Pos.t) : - A.expr Pos.marked Bindlib.box = +let rec translate_default + (ctx : ctx) + (exceptions : D.expr Pos.marked list) + (just : D.expr Pos.marked) + (cons : D.expr Pos.marked) + (pos_default : Pos.t) : A.expr Pos.marked Bindlib.box = let exceptions = - List.map (fun except -> thunk_expr (translate_expr ctx except) pos_default) exceptions + List.map + (fun except -> thunk_expr (translate_expr ctx except) pos_default) + exceptions in let exceptions = A.make_app @@ -55,7 +63,8 @@ let rec translate_default (ctx : ctx) (exceptions : D.expr Pos.marked list) in exceptions -and translate_expr (ctx : ctx) (e : D.expr Pos.marked) : A.expr Pos.marked Bindlib.box = +and translate_expr (ctx : ctx) (e : D.expr Pos.marked) : + A.expr Pos.marked Bindlib.box = match Pos.unmark e with | D.EVar v -> D.VarMap.find (Pos.unmark v) ctx | D.ETuple (args, s) -> @@ -86,12 +95,17 @@ and translate_expr (ctx : ctx) (e : D.expr Pos.marked) : A.expr Pos.marked Bindl (fun e1 e2 e3 -> Pos.same_pos_as (A.EIfThenElse (e1, e2, e3)) e) (translate_expr ctx e1) (translate_expr ctx e2) (translate_expr ctx e3) | D.EAssert e1 -> - Bindlib.box_apply (fun e1 -> Pos.same_pos_as (A.EAssert e1) e) (translate_expr ctx e1) + Bindlib.box_apply + (fun e1 -> Pos.same_pos_as (A.EAssert e1) e) + (translate_expr ctx e1) | D.ErrorOnEmpty arg -> Bindlib.box_apply (fun arg -> Pos.same_pos_as - (A.ECatch (arg, A.EmptyError, Pos.same_pos_as (A.ERaise A.NoValueProvided) e)) + (A.ECatch + ( arg, + A.EmptyError, + Pos.same_pos_as (A.ERaise A.NoValueProvided) e )) e) (translate_expr ctx arg) | D.EApp (e1, args) -> @@ -113,7 +127,8 @@ and translate_expr (ctx : ctx) (e : D.expr Pos.marked) : A.expr Pos.marked Bindl let new_body = translate_expr ctx body in let new_binder = Bindlib.bind_mvar lc_vars new_body in Bindlib.box_apply - (fun new_binder -> Pos.same_pos_as (A.EAbs ((new_binder, pos_binder), ts)) e) + (fun new_binder -> + Pos.same_pos_as (A.EAbs ((new_binder, pos_binder), ts)) e) new_binder | D.EDefault ([ exn ], just, cons) when !Cli.optimize_flag -> Bindlib.box_apply3 @@ -123,10 +138,12 @@ and translate_expr (ctx : ctx) (e : D.expr Pos.marked) : A.expr Pos.marked Bindl ( exn, A.EmptyError, Pos.same_pos_as - (A.EIfThenElse (just, cons, Pos.same_pos_as (A.ERaise A.EmptyError) e)) + (A.EIfThenElse + (just, cons, Pos.same_pos_as (A.ERaise A.EmptyError) e)) e )) e) - (translate_expr ctx exn) (translate_expr ctx just) (translate_expr ctx cons) + (translate_expr ctx exn) (translate_expr ctx just) + (translate_expr ctx cons) | D.EDefault (exceptions, just, cons) -> translate_default ctx exceptions just cons (Pos.get_position e) @@ -147,7 +164,8 @@ let translate_program (prgm : D.program) : A.program = (D.VarMap.map (fun v -> A.make_var (v, Pos.no_pos)) ctx) (Bindlib.unbox (D.build_whole_scope_expr prgm.decl_ctx e - (Pos.get_position (Dcalc.Ast.ScopeName.get_info scope_name))))); + (Pos.get_position + (Dcalc.Ast.ScopeName.get_info scope_name))))); } :: acc in diff --git a/compiler/lcalc/compile_with_exceptions.mli b/compiler/lcalc/compile_with_exceptions.mli index 13fa7cd2..a6795a04 100644 --- a/compiler/lcalc/compile_with_exceptions.mli +++ b/compiler/lcalc/compile_with_exceptions.mli @@ -1,18 +1,20 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux - +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, contributor: + Denis Merigoux - 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 + 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 + 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. *) -(** Translation from the default calculus to the lambda calculus. This translation uses exceptions - handle empty default terms. *) +(** Translation from the default calculus to the lambda calculus. This + translation uses exceptions handle empty default terms. *) val translate_program : Dcalc.Ast.program -> Ast.program diff --git a/compiler/lcalc/compile_without_exceptions.ml b/compiler/lcalc/compile_without_exceptions.ml index 231713bd..28baa72f 100644 --- a/compiler/lcalc/compile_without_exceptions.ml +++ b/compiler/lcalc/compile_without_exceptions.ml @@ -1,15 +1,17 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020-2022 Inria, contributor: Alain Delaët-Tixeuil - +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020-2022 Inria, + contributor: Alain Delaët-Tixeuil - 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 + 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 + 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. *) open Utils @@ -17,39 +19,50 @@ module D = Dcalc.Ast module A = Ast open Dcalc.Binded_representation -(** The main idea around this pass is to compile Dcalc to Lcalc without using [raise EmptyError] nor - [try _ with EmptyError -> _]. To do so, we use the same technique as in rust or erlang to handle - this kind of exceptions. Each [raise EmptyError] will be translated as [None] and each - [try e1 with EmtpyError -> e2] as [match e1 with | None -> e2 | Some x -> x]. +(** The main idea around this pass is to compile Dcalc to Lcalc without using + [raise EmptyError] nor [try _ with EmptyError -> _]. To do so, we use the + same technique as in rust or erlang to handle this kind of exceptions. Each + [raise EmptyError] will be translated as [None] and each + [try e1 with EmtpyError -> e2] as + [match e1 with | None -> e2 | Some x -> x]. - When doing this naively, this requires to add matches and Some constructor everywhere. We apply - here an other technique where we generate what we call `hoists`. Hoists are expression whom - could minimally [raise EmptyError]. For instance in - [let x = * 3 in x + 1], the sub-expression - [] can produce an empty error. So we make a hoist with a new - variable [y] linked to the Dcalc expression [], and we return - as the translated expression [let x = y * 3 in x + 1]. + When doing this naively, this requires to add matches and Some constructor + everywhere. We apply here an other technique where we generate what we call + `hoists`. Hoists are expression whom could minimally [raise EmptyError]. For + instance in [let x = * 3 in x + 1], the + sub-expression [] can produce an empty + error. So we make a hoist with a new variable [y] linked to the Dcalc + expression [], and we return as the + translated expression [let x = y * 3 in x + 1]. - The compilation of expressions is found in the functions [translate_and_hoist ctx e] and - [translate_expr ctx e]. Every option-generating expression when calling [translate_and_hoist] - will be hoisted and later handled by the [translate_expr] function. Every other cases is found - in the translate_and_hoist function. *) + The compilation of expressions is found in the functions + [translate_and_hoist ctx e] and [translate_expr ctx e]. Every + option-generating expression when calling [translate_and_hoist] will be + hoisted and later handled by the [translate_expr] function. Every other + cases is found in the translate_and_hoist function. *) type hoists = D.expr Pos.marked A.VarMap.t (** Hoists definition. It represent bindings between [A.Var.t] and [D.expr]. *) -type info = { expr : A.expr Pos.marked Bindlib.box; var : A.expr Bindlib.var; is_pure : bool } -(** Information about each encontered Dcalc variable is stored inside a context : what is the - corresponding LCalc variable; an expression corresponding to the variable build correctly using - Bindlib, and a boolean `is_pure` indicating whenever the variable can be an EmptyError and hence - should be matched (false) or if it never can be EmptyError (true). *) +type info = { + expr : A.expr Pos.marked Bindlib.box; + var : A.expr Bindlib.var; + is_pure : bool; +} +(** Information about each encontered Dcalc variable is stored inside a context + : what is the corresponding LCalc variable; an expression corresponding to + the variable build correctly using Bindlib, and a boolean `is_pure` + indicating whenever the variable can be an EmptyError and hence should be + matched (false) or if it never can be EmptyError (true). *) let pp_info (fmt : Format.formatter) (info : info) = - Format.fprintf fmt "{var: %a; is_pure: %b}" Print.format_var info.var info.is_pure + Format.fprintf fmt "{var: %a; is_pure: %b}" Print.format_var info.var + info.is_pure type ctx = { decl_ctx : D.decl_ctx; - vars : info D.VarMap.t; (** information context about variables in the current scope *) + vars : info D.VarMap.t; + (** information context about variables in the current scope *) } let _pp_ctx (fmt : Format.formatter) (ctx : ctx) = @@ -58,38 +71,48 @@ let _pp_ctx (fmt : Format.formatter) (ctx : ctx) = in let pp_bindings = - Format.pp_print_list ~pp_sep:(fun fmt () -> Format.pp_print_string fmt "; ") pp_binding + Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.pp_print_string fmt "; ") + pp_binding in Format.fprintf fmt "@[<2>[%a]@]" pp_bindings (D.VarMap.bindings ctx.vars) -(** [find ~info n ctx] is a warpper to ocaml's Map.find that handle errors in a slightly better way. *) +(** [find ~info n ctx] is a warpper to ocaml's Map.find that handle errors in a + slightly better way. *) let find ?(info : string = "none") (n : D.Var.t) (ctx : ctx) : info = - (* let _ = Format.asprintf "Searching for variable %a inside context %a" Dcalc.Print.format_var n - pp_ctx ctx |> Cli.debug_print in *) + (* let _ = Format.asprintf "Searching for variable %a inside context %a" + Dcalc.Print.format_var n pp_ctx ctx |> Cli.debug_print in *) try D.VarMap.find n ctx.vars with Not_found -> Errors.raise_spanned_error Pos.no_pos - "Internal Error: Variable %a was not found in the current environment. Additional \ - informations : %s." + "Internal Error: Variable %a was not found in the current environment. \ + Additional informations : %s." Dcalc.Print.format_var n info -(** [add_var pos var is_pure ctx] add to the context [ctx] the Dcalc variable var, creating a unique - corresponding variable in Lcalc, with the corresponding expression, and the boolean is_pure. It - is usefull for debuging purposes as it printing each of the Dcalc/Lcalc variable pairs. *) +(** [add_var pos var is_pure ctx] add to the context [ctx] the Dcalc variable + var, creating a unique corresponding variable in Lcalc, with the + corresponding expression, and the boolean is_pure. It is usefull for + debuging purposes as it printing each of the Dcalc/Lcalc variable pairs. *) let add_var (pos : Pos.t) (var : D.Var.t) (is_pure : bool) (ctx : ctx) : ctx = let new_var = A.Var.make (Bindlib.name_of var, pos) in let expr = A.make_var (new_var, pos) in - (* Cli.debug_print @@ Format.asprintf "D.%a |-> A.%a" Dcalc.Print.format_var var Print.format_var - new_var; *) - { ctx with vars = D.VarMap.update var (fun _ -> Some { expr; var = new_var; is_pure }) ctx.vars } + (* Cli.debug_print @@ Format.asprintf "D.%a |-> A.%a" Dcalc.Print.format_var + var Print.format_var new_var; *) + { + ctx with + vars = + D.VarMap.update var + (fun _ -> Some { expr; var = new_var; is_pure }) + ctx.vars; + } (** [tau' = translate_typ tau] translate the a dcalc type into a lcalc type. - Since positions where there is thunked expressions is exactly where we will put option - expressions. Hence, the transformation simply reduce [unit -> 'a] into ['a option] recursivly. - There is no polymorphism inside catala. *) + Since positions where there is thunked expressions is exactly where we will + put option expressions. Hence, the transformation simply reduce [unit -> 'a] + into ['a option] recursivly. There is no polymorphism inside catala. *) let rec translate_typ (tau : D.typ Pos.marked) : D.typ Pos.marked = (Fun.flip Pos.same_pos_as) tau begin @@ -101,7 +124,9 @@ let rec translate_typ (tau : D.typ Pos.marked) : D.typ Pos.marked = | D.TArray ts -> D.TArray (translate_typ ts) (* catala is not polymorphic *) | D.TArrow ((D.TLit D.TUnit, pos_unit), t2) -> - D.TEnum ([ (D.TLit D.TUnit, pos_unit); translate_typ t2 ], A.option_enum) (* D.TAny *) + D.TEnum + ([ (D.TLit D.TUnit, pos_unit); translate_typ t2 ], A.option_enum) + (* D.TAny *) | D.TArrow (t1, t2) -> D.TArrow (translate_typ t1, translate_typ t2) end @@ -116,45 +141,53 @@ let translate_lit (l : D.lit) (pos : Pos.t) : A.lit = | D.LDuration d -> A.LDuration d | D.LEmptyError -> Errors.raise_spanned_error pos - "Internal Error: An empty error was found in a place that shouldn't be possible." + "Internal Error: An empty error was found in a place that shouldn't be \ + possible." -(** [c = disjoint_union_maps cs] Compute the disjoint union of multiple maps. Raises an internal - error if there is two identicals keys in differnts parts. *) -let disjoint_union_maps (pos : Pos.t) (cs : 'a A.VarMap.t list) : 'a A.VarMap.t = +(** [c = disjoint_union_maps cs] Compute the disjoint union of multiple maps. + Raises an internal error if there is two identicals keys in differnts parts. *) +let disjoint_union_maps (pos : Pos.t) (cs : 'a A.VarMap.t list) : 'a A.VarMap.t + = let disjoint_union = A.VarMap.union (fun _ _ _ -> Errors.raise_spanned_error pos - "Internal Error: Two supposed to be disjoints maps have one shared key.") + "Internal Error: Two supposed to be disjoints maps have one shared \ + key.") in List.fold_left disjoint_union A.VarMap.empty cs -(** [e' = translate_and_hoist ctx e ] Translate the Dcalc expression e into an expression in Lcalc, - given we translate each hoists correctly. It ensures the equivalence between the execution of e - and the execution of e' are equivalent in an environement where each variable v, where (v, e_v) - is in hoists, has the non-empty value in e_v. *) +(** [e' = translate_and_hoist ctx e ] Translate the Dcalc expression e into an + expression in Lcalc, given we translate each hoists correctly. It ensures + the equivalence between the execution of e and the execution of e' are + equivalent in an environement where each variable v, where (v, e_v) is in + hoists, has the non-empty value in e_v. *) let rec translate_and_hoist (ctx : ctx) (e : D.expr Pos.marked) : A.expr Pos.marked Bindlib.box * hoists = let pos = Pos.get_position e in match Pos.unmark e with - (* empty-producing/using terms. We hoist those. (D.EVar in some cases, EApp(D.EVar _, [ELit - LUnit]), EDefault _, ELit LEmptyDefault) I'm unsure about assert. *) + (* empty-producing/using terms. We hoist those. (D.EVar in some cases, + EApp(D.EVar _, [ELit LUnit]), EDefault _, ELit LEmptyDefault) I'm unsure + about assert. *) | D.EVar v -> - (* todo: for now, every unpure (such that [is_pure] is [false] in the current context) is - thunked, hence matched in the next case. This assumption can change in the future, and this - case is here for this reason. *) + (* todo: for now, every unpure (such that [is_pure] is [false] in the + current context) is thunked, hence matched in the next case. This + assumption can change in the future, and this case is here for this + reason. *) let v, pos_v = v in if not (find ~info:"search for a variable" v ctx).is_pure then let v' = A.Var.make (Bindlib.name_of v, pos_v) in - (* Cli.debug_print @@ Format.asprintf "Found an unpure variable %a, created a variable %a to - replace it" Dcalc.Print.format_var v Print.format_var v'; *) + (* Cli.debug_print @@ Format.asprintf "Found an unpure variable %a, + created a variable %a to replace it" Dcalc.Print.format_var v + Print.format_var v'; *) (A.make_var (v', pos), A.VarMap.singleton v' e) else ((find ~info:"should never happend" v ctx).expr, A.VarMap.empty) | D.EApp ((D.EVar (v, pos_v), p), [ (D.ELit D.LUnit, _) ]) -> if not (find ~info:"search for a variable" v ctx).is_pure then let v' = A.Var.make (Bindlib.name_of v, pos_v) in - (* Cli.debug_print @@ Format.asprintf "Found an unpure variable %a, created a variable %a to - replace it" Dcalc.Print.format_var v Print.format_var v'; *) + (* Cli.debug_print @@ Format.asprintf "Found an unpure variable %a, + created a variable %a to replace it" Dcalc.Print.format_var v + Print.format_var v'; *) (A.make_var (v', pos), A.VarMap.singleton v' (D.EVar (v, pos_v), p)) else Errors.raise_spanned_error pos @@ -165,10 +198,11 @@ let rec translate_and_hoist (ctx : ctx) (e : D.expr Pos.marked) : | D.ELit D.LEmptyError -> let v' = A.Var.make ("empty_litteral", pos) in (A.make_var (v', pos), A.VarMap.singleton v' e) - (* This one is a very special case. It transform an unpure expression environement to a pure - expression. *) + (* This one is a very special case. It transform an unpure expression + environement to a pure expression. *) | ErrorOnEmpty arg -> - (* [ match arg with | None -> raise NoValueProvided | Some v -> {{ v }} ] *) + (* [ match arg with | None -> raise NoValueProvided | Some v -> {{ v }} + ] *) let silent_var = A.Var.make ("_", pos) in let x = A.Var.make ("non_empty_argument", pos) in @@ -177,7 +211,9 @@ let rec translate_and_hoist (ctx : ctx) (e : D.expr Pos.marked) : ( A.make_matchopt_with_abs_arms arg' (A.make_abs [| silent_var |] (Bindlib.box (A.ERaise A.NoValueProvided, pos)) - pos [ (D.TAny, pos) ] pos) + pos + [ (D.TAny, pos) ] + pos) (A.make_abs [| x |] (A.make_var (x, pos)) pos [ (D.TAny, pos) ] pos), A.VarMap.empty ) (* pure terms *) @@ -188,43 +224,51 @@ let rec translate_and_hoist (ctx : ctx) (e : D.expr Pos.marked) : let e3', h3 = translate_and_hoist ctx e3 in let e' = - Bindlib.box_apply3 (fun e1' e2' e3' -> (A.EIfThenElse (e1', e2', e3'), pos)) e1' e2' e3' + Bindlib.box_apply3 + (fun e1' e2' e3' -> (A.EIfThenElse (e1', e2', e3'), pos)) + e1' e2' e3' in - (*(* equivalent code : *) let e' = let+ e1' = e1' and+ e2' = e2' and+ e3' = e3' in - (A.EIfThenElse (e1', e2', e3'), pos) in *) + (*(* equivalent code : *) let e' = let+ e1' = e1' and+ e2' = e2' and+ e3' + = e3' in (A.EIfThenElse (e1', e2', e3'), pos) in *) (e', disjoint_union_maps pos [ h1; h2; h3 ]) | D.EAssert e1 -> - (* same behavior as in the ICFP paper: if e1 is empty, then no error is raised. *) + (* same behavior as in the ICFP paper: if e1 is empty, then no error is + raised. *) let e1', h1 = translate_and_hoist ctx e1 in (Bindlib.box_apply (fun e1' -> (A.EAssert e1', pos)) e1', h1) | D.EAbs ((binder, pos_binder), ts) -> let vars, body = Bindlib.unmbind binder in let ctx, lc_vars = - ArrayLabels.fold_right vars ~init:(ctx, []) ~f:(fun var (ctx, lc_vars) -> - (* we suppose the invariant that when applying a function, its arguments cannot be of - the type "option". + ArrayLabels.fold_right vars ~init:(ctx, []) + ~f:(fun var (ctx, lc_vars) -> + (* we suppose the invariant that when applying a function, its + arguments cannot be of the type "option". - The code should behave correctly in the without this assumption if we put here an - is_pure=false, but the types are more compilcated. (unimplemented for now) *) + The code should behave correctly in the without this assumption + if we put here an is_pure=false, but the types are more + compilcated. (unimplemented for now) *) let ctx = add_var pos var true ctx in let lc_var = (find var ctx).var in (ctx, lc_var :: lc_vars)) in let lc_vars = Array.of_list lc_vars in - (* here we take the guess that if we cannot build the closure because one of the variable is - empty, then we cannot build the function. *) + (* here we take the guess that if we cannot build the closure because one + of the variable is empty, then we cannot build the function. *) let new_body, hoists = translate_and_hoist ctx body in let new_binder = Bindlib.bind_mvar lc_vars new_body in ( Bindlib.box_apply - (fun new_binder -> (A.EAbs ((new_binder, pos_binder), List.map translate_typ ts), pos)) + (fun new_binder -> + (A.EAbs ((new_binder, pos_binder), List.map translate_typ ts), pos)) new_binder, hoists ) | EApp (e1, args) -> let e1', h1 = translate_and_hoist ctx e1 in - let args', h_args = args |> List.map (translate_and_hoist ctx) |> List.split in + let args', h_args = + args |> List.map (translate_and_hoist ctx) |> List.split + in let hoists = disjoint_union_maps pos (h1 :: h_args) in let e' = @@ -234,21 +278,32 @@ let rec translate_and_hoist (ctx : ctx) (e : D.expr Pos.marked) : in (e', hoists) | ETuple (args, s) -> - let args', h_args = args |> List.map (translate_and_hoist ctx) |> List.split in + let args', h_args = + args |> List.map (translate_and_hoist ctx) |> List.split + in let hoists = disjoint_union_maps pos h_args in - (Bindlib.box_apply (fun args' -> (A.ETuple (args', s), pos)) (Bindlib.box_list args'), hoists) + ( Bindlib.box_apply + (fun args' -> (A.ETuple (args', s), pos)) + (Bindlib.box_list args'), + hoists ) | ETupleAccess (e1, i, s, ts) -> let e1', hoists = translate_and_hoist ctx e1 in - let e1' = Bindlib.box_apply (fun e1' -> (A.ETupleAccess (e1', i, s, ts), pos)) e1' in + let e1' = + Bindlib.box_apply (fun e1' -> (A.ETupleAccess (e1', i, s, ts), pos)) e1' + in (e1', hoists) | EInj (e1, i, en, ts) -> let e1', hoists = translate_and_hoist ctx e1 in - let e1' = Bindlib.box_apply (fun e1' -> (A.EInj (e1', i, en, ts), pos)) e1' in + let e1' = + Bindlib.box_apply (fun e1' -> (A.EInj (e1', i, en, ts), pos)) e1' + in (e1', hoists) | EMatch (e1, cases, en) -> let e1', h1 = translate_and_hoist ctx e1 in - let cases', h_cases = cases |> List.map (translate_and_hoist ctx) |> List.split in + let cases', h_cases = + cases |> List.map (translate_and_hoist ctx) |> List.split + in let hoists = disjoint_union_maps pos (h1 :: h_cases) in let e' = @@ -258,7 +313,9 @@ let rec translate_and_hoist (ctx : ctx) (e : D.expr Pos.marked) : in (e', hoists) | EArray es -> - let es', hoists = es |> List.map (translate_and_hoist ctx) |> List.split in + let es', hoists = + es |> List.map (translate_and_hoist ctx) |> List.split + in ( Bindlib.box_apply (fun es' -> (A.EArray es', pos)) (Bindlib.box_list es'), disjoint_union_maps pos hoists ) @@ -272,17 +329,19 @@ and translate_expr ?(append_esome = true) (ctx : ctx) (e : D.expr Pos.marked) : let _pos = Pos.get_position e in (* build the hoists *) - (* Cli.debug_print @@ Format.asprintf "hoist for the expression: [%a]" (Format.pp_print_list - Print.format_var) (List.map fst hoists); *) + (* Cli.debug_print @@ Format.asprintf "hoist for the expression: [%a]" + (Format.pp_print_list Print.format_var) (List.map fst hoists); *) ListLabels.fold_left hoists ~init:(if append_esome then A.make_some e' else e') ~f:(fun acc (v, (hoist, pos_hoist)) -> - (* Cli.debug_print @@ Format.asprintf "hoist using A.%a" Print.format_var v; *) + (* Cli.debug_print @@ Format.asprintf "hoist using A.%a" Print.format_var + v; *) let c' : A.expr Pos.marked Bindlib.box = match hoist with - (* Here we have to handle only the cases appearing in hoists, as defined the - [translate_and_hoist] function. *) - | D.EVar v -> (find ~info:"should never happend" (Pos.unmark v) ctx).expr + (* Here we have to handle only the cases appearing in hoists, as defined + the [translate_and_hoist] function. *) + | D.EVar v -> + (find ~info:"should never happend" (Pos.unmark v) ctx).expr | D.EDefault (excep, just, cons) -> let excep' = List.map (translate_expr ctx) excep in let just' = translate_expr ctx just in @@ -302,27 +361,36 @@ and translate_expr ?(append_esome = true) (ctx : ctx) (e : D.expr Pos.marked) : | D.EAssert arg -> let arg' = translate_expr ctx arg in - (* [ match arg with | None -> raise NoValueProvided | Some v -> assert {{ v }} ] *) + (* [ match arg with | None -> raise NoValueProvided | Some v -> + assert {{ v }} ] *) let silent_var = A.Var.make ("_", pos_hoist) in let x = A.Var.make ("assertion_argument", pos_hoist) in A.make_matchopt_with_abs_arms arg' (A.make_abs [| silent_var |] (Bindlib.box (A.ERaise A.NoValueProvided, pos_hoist)) - pos_hoist [ (D.TAny, pos_hoist) ] pos_hoist) + pos_hoist + [ (D.TAny, pos_hoist) ] + pos_hoist) (A.make_abs [| x |] (Bindlib.box_apply (fun arg -> (A.EAssert arg, pos_hoist)) (A.make_var (x, pos_hoist))) - pos_hoist [ (D.TAny, pos_hoist) ] pos_hoist) + pos_hoist + [ (D.TAny, pos_hoist) ] + pos_hoist) | _ -> Errors.raise_spanned_error pos_hoist - "Internal Error: An term was found in a position where it should not be" + "Internal Error: An term was found in a position where it should \ + not be" in - (* [ match {{ c' }} with | None -> None | Some {{ v }} -> {{ acc }} end ] *) - (* Cli.debug_print @@ Format.asprintf "build matchopt using %a" Print.format_var v; *) - A.make_matchopt pos_hoist v (D.TAny, pos_hoist) c' (A.make_none pos_hoist) acc) + (* [ match {{ c' }} with | None -> None | Some {{ v }} -> {{ acc }} end + ] *) + (* Cli.debug_print @@ Format.asprintf "build matchopt using %a" + Print.format_var v; *) + A.make_matchopt pos_hoist v (D.TAny, pos_hoist) c' (A.make_none pos_hoist) + acc) let rec translate_scope_let (ctx : ctx) (lets : scope_lets) = match lets with @@ -335,14 +403,18 @@ let rec translate_scope_let (ctx : ctx) (lets : scope_lets) = scope_let_next = next; scope_let_pos = pos; } -> - (* special case : the subscope variable is thunked (context i/o). We remove this thunking. *) + (* special case : the subscope variable is thunked (context i/o). We + remove this thunking. *) let _, expr = Bindlib.unmbind binder in let var_is_pure = true in let var, next = Bindlib.unbind next in - (* Cli.debug_print @@ Format.asprintf "unbinding %a" Dcalc.Print.format_var var; *) + (* Cli.debug_print @@ Format.asprintf "unbinding %a" + Dcalc.Print.format_var var; *) let ctx' = add_var pos var var_is_pure ctx in - let new_var = (find ~info:"variable that was just created" var ctx').var in + let new_var = + (find ~info:"variable that was just created" var ctx').var + in A.make_let_in new_var (translate_typ typ) (translate_expr ctx ~append_esome:false expr) (translate_scope_let ctx' next) @@ -357,17 +429,26 @@ let rec translate_scope_let (ctx : ctx) (lets : scope_lets) = (* special case: regular input to the subscope *) let var_is_pure = true in let var, next = Bindlib.unbind next in - (* Cli.debug_print @@ Format.asprintf "unbinding %a" Dcalc.Print.format_var var; *) + (* Cli.debug_print @@ Format.asprintf "unbinding %a" + Dcalc.Print.format_var var; *) let ctx' = add_var pos var var_is_pure ctx in - let new_var = (find ~info:"variable that was just created" var ctx').var in + let new_var = + (find ~info:"variable that was just created" var ctx').var + in A.make_let_in new_var (translate_typ typ) (translate_expr ctx ~append_esome:false expr) (translate_scope_let ctx' next) | ScopeLet - { scope_let_kind = SubScopeVarDefinition; scope_let_pos = pos; scope_let_expr = expr; _ } -> + { + scope_let_kind = SubScopeVarDefinition; + scope_let_pos = pos; + scope_let_expr = expr; + _; + } -> Errors.raise_spanned_error pos - "Internal Error: found an SubScopeVarDefinition that does not satisfy the invariants when \ - translating Dcalc to Lcalc without exceptions: @[%a@]" + "Internal Error: found an SubScopeVarDefinition that does not satisfy \ + the invariants when translating Dcalc to Lcalc without exceptions: \ + @[%a@]" (Dcalc.Print.format_expr ctx.decl_ctx) expr | ScopeLet @@ -381,18 +462,24 @@ let rec translate_scope_let (ctx : ctx) (lets : scope_lets) = let var_is_pure = match kind with | DestructuringInputStruct -> ( - (* Here, we have to distinguish between context and input variables. We can do so by - looking at the typ of the destructuring: if it's thunked, then the variable is - context. If it's not thunked, it's a regular input. *) - match Pos.unmark typ with D.TArrow ((D.TLit D.TUnit, _), _) -> false | _ -> true) + (* Here, we have to distinguish between context and input variables. + We can do so by looking at the typ of the destructuring: if it's + thunked, then the variable is context. If it's not thunked, it's + a regular input. *) + match Pos.unmark typ with + | D.TArrow ((D.TLit D.TUnit, _), _) -> false + | _ -> true) | ScopeVarDefinition | SubScopeVarDefinition | CallingSubScope | DestructuringSubScopeResults | Assertion -> true in let var, next = Bindlib.unbind next in - (* Cli.debug_print @@ Format.asprintf "unbinding %a" Dcalc.Print.format_var var; *) + (* Cli.debug_print @@ Format.asprintf "unbinding %a" + Dcalc.Print.format_var var; *) let ctx' = add_var pos var var_is_pure ctx in - let new_var = (find ~info:"variable that was just created" var ctx').var in + let new_var = + (find ~info:"variable that was just created" var ctx').var + in A.make_let_in new_var (translate_typ typ) (translate_expr ctx ~append_esome:false expr) (translate_scope_let ctx' next) @@ -409,17 +496,22 @@ let translate_scope_body (scope_pos : Pos.t) (ctx : ctx) (body : scope_body) : let ctx' = add_var scope_pos v true ctx in let v' = (find ~info:"variable that was just created" v ctx').var in - A.make_abs [| v' |] (translate_scope_let ctx' lets) Pos.no_pos + A.make_abs [| v' |] + (translate_scope_let ctx' lets) + Pos.no_pos [ (D.TTuple ([], Some input_struct), Pos.no_pos) ] Pos.no_pos -let rec translate_scopes (ctx : ctx) (scopes : scopes) : Ast.scope_body list Bindlib.box = +let rec translate_scopes (ctx : ctx) (scopes : scopes) : + Ast.scope_body list Bindlib.box = match scopes with | Nil -> Bindlib.box [] | ScopeDef { scope_name; scope_body; scope_next } -> let scope_var, next = Bindlib.unbind scope_next in let new_ctx = add_var Pos.no_pos scope_var true ctx in - let new_scope_name = (find ~info:"variable that was just created" scope_var new_ctx).var in + let new_scope_name = + (find ~info:"variable that was just created" scope_var new_ctx).var + in let scope_pos = Pos.get_position (D.ScopeName.get_info scope_name) in @@ -445,12 +537,14 @@ let translate_program (prgm : D.program) : A.program = body.D.scope_body_input_struct :: acc) in - (* Cli.debug_print @@ Format.asprintf "List of structs to modify: [%a]" (Format.pp_print_list - D.StructName.format_t) inputs_structs; *) + (* Cli.debug_print @@ Format.asprintf "List of structs to modify: [%a]" + (Format.pp_print_list D.StructName.format_t) inputs_structs; *) let decl_ctx = { prgm.decl_ctx with - D.ctx_enums = prgm.decl_ctx.ctx_enums |> D.EnumMap.add A.option_enum A.option_enum_config; + D.ctx_enums = + prgm.decl_ctx.ctx_enums + |> D.EnumMap.add A.option_enum A.option_enum_config; } in let decl_ctx = @@ -461,9 +555,11 @@ let translate_program (prgm : D.program) : A.program = |> D.StructMap.mapi (fun n l -> if List.mem n inputs_structs then ListLabels.map l ~f:(fun (n, tau) -> - (* Cli.debug_print @@ Format.asprintf "Input type: %a" (Dcalc.Print.format_typ - decl_ctx) tau; Cli.debug_print @@ Format.asprintf "Output type: %a" - (Dcalc.Print.format_typ decl_ctx) (translate_typ tau); *) + (* Cli.debug_print @@ Format.asprintf "Input type: %a" + (Dcalc.Print.format_typ decl_ctx) tau; Cli.debug_print + @@ Format.asprintf "Output type: %a" + (Dcalc.Print.format_typ decl_ctx) (translate_typ + tau); *) (n, translate_typ tau)) else l); } diff --git a/compiler/lcalc/compile_without_exceptions.mli b/compiler/lcalc/compile_without_exceptions.mli index 54c46c57..752924fc 100644 --- a/compiler/lcalc/compile_without_exceptions.mli +++ b/compiler/lcalc/compile_without_exceptions.mli @@ -1,19 +1,22 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020-2022 Inria, contributor: Alain Delaët-Tixeuil - +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020-2022 Inria, + contributor: Alain Delaët-Tixeuil - 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 + 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 + 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. *) -(** Translation from the default calculus to the lambda calculus. This translation uses an option - monad to handle empty defaults terms. This transformation is one piece to permit to compile - toward legacy languages that does not contains exceptions. *) +(** Translation from the default calculus to the lambda calculus. This + translation uses an option monad to handle empty defaults terms. This + transformation is one piece to permit to compile toward legacy languages + that does not contains exceptions. *) val translate_program : Dcalc.Ast.program -> Ast.program diff --git a/compiler/lcalc/optimizations.ml b/compiler/lcalc/optimizations.ml index 62e952e1..ebd97534 100644 --- a/compiler/lcalc/optimizations.ml +++ b/compiler/lcalc/optimizations.ml @@ -1,27 +1,30 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux - +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, contributor: + Denis Merigoux - 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 + 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 + 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. *) open Utils open Ast let ( let+ ) x f = Bindlib.box_apply f x - let ( and+ ) x y = Bindlib.box_pair x y -let visitor_map (t : 'a -> expr Pos.marked -> expr Pos.marked Bindlib.box) (ctx : 'a) +let visitor_map + (t : 'a -> expr Pos.marked -> expr Pos.marked Bindlib.box) + (ctx : 'a) (e : expr Pos.marked) : expr Pos.marked Bindlib.box = - (* calls [t ctx] on every direct childs of [e], then rebuild an abstract syntax tree modified. - Used in other transformations. *) + (* calls [t ctx] on every direct childs of [e], then rebuild an abstract + syntax tree modified. Used in other transformations. *) let default_mark e' = Pos.same_pos_as e' e in match Pos.unmark e with | EVar (v, pos) -> @@ -37,7 +40,8 @@ let visitor_map (t : 'a -> expr Pos.marked -> expr Pos.marked Bindlib.box) (ctx let+ e1 = t ctx e1 in default_mark @@ EInj (e1, i, n, ts) | EMatch (arg, cases, n) -> - let+ arg = t ctx arg and+ cases = cases |> List.map (t ctx) |> Bindlib.box_list in + let+ arg = t ctx arg + and+ cases = cases |> List.map (t ctx) |> Bindlib.box_list in default_mark @@ EMatch (arg, cases, n) | EArray args -> let+ args = args |> List.map (t ctx) |> Bindlib.box_list in @@ -48,7 +52,8 @@ let visitor_map (t : 'a -> expr Pos.marked -> expr Pos.marked Bindlib.box) (ctx let+ binder = Bindlib.bind_mvar vars body in default_mark @@ EAbs ((binder, pos_binder), ts) | EApp (e1, args) -> - let+ e1 = t ctx e1 and+ args = args |> List.map (t ctx) |> Bindlib.box_list in + let+ e1 = t ctx e1 + and+ args = args |> List.map (t ctx) |> Bindlib.box_list in default_mark @@ EApp (e1, args) | EAssert e1 -> let+ e1 = t ctx e1 in @@ -61,10 +66,12 @@ let visitor_map (t : 'a -> expr Pos.marked -> expr Pos.marked Bindlib.box) (ctx default_mark @@ ECatch (e1, exn, e2) | ERaise _ | ELit _ | EOp _ -> Bindlib.box e -let rec iota_expr (_ : unit) (e : expr Pos.marked) : expr Pos.marked Bindlib.box = +let rec iota_expr (_ : unit) (e : expr Pos.marked) : expr Pos.marked Bindlib.box + = let default_mark e' = Pos.mark (Pos.get_position e) e' in match Pos.unmark e with - | EMatch ((EInj (e1, i, n', _ts), _), cases, n) when Dcalc.Ast.EnumName.compare n n' = 0 -> + | EMatch ((EInj (e1, i, n', _ts), _), cases, n) + when Dcalc.Ast.EnumName.compare n n' = 0 -> let+ e1 = visitor_map iota_expr () e1 and+ case = visitor_map iota_expr () (List.nth cases i) in default_mark @@ EApp (case, [ e1 ]) @@ -79,11 +86,13 @@ let rec iota_expr (_ : unit) (e : expr Pos.marked) : expr Pos.marked Bindlib.box visitor_map iota_expr () e' | _ -> visitor_map iota_expr () e -let rec beta_expr (_ : unit) (e : expr Pos.marked) : expr Pos.marked Bindlib.box = +let rec beta_expr (_ : unit) (e : expr Pos.marked) : expr Pos.marked Bindlib.box + = let default_mark e' = Pos.same_pos_as e' e in match Pos.unmark e with | EApp (e1, args) -> ( - let+ e1 = beta_expr () e1 and+ args = List.map (beta_expr ()) args |> Bindlib.box_list in + let+ e1 = beta_expr () e1 + and+ args = List.map (beta_expr ()) args |> Bindlib.box_list in match Pos.unmark e1 with | EAbs ((binder, _pos_binder), _ts) -> let (_ : (_, _) Bindlib.mbinder) = binder in @@ -99,14 +108,16 @@ let iota_optimizations (p : program) : program = (fun scope_body -> { scope_body with - scope_body_expr = Bindlib.unbox (iota_expr () scope_body.scope_body_expr); + scope_body_expr = + Bindlib.unbox (iota_expr () scope_body.scope_body_expr); }) p.scopes; } -(* TODO: beta optimizations apply inlining of the program. We left the inclusion of - beta-optimization as future work since its produce code that is harder to read, and can produce - exponential blowup of the size of the generated program. *) +(* TODO: beta optimizations apply inlining of the program. We left the inclusion + of beta-optimization as future work since its produce code that is harder to + read, and can produce exponential blowup of the size of the generated + program. *) let _beta_optimizations (p : program) : program = { p with @@ -115,20 +126,28 @@ let _beta_optimizations (p : program) : program = (fun scope_body -> { scope_body with - scope_body_expr = Bindlib.unbox (beta_expr () scope_body.scope_body_expr); + scope_body_expr = + Bindlib.unbox (beta_expr () scope_body.scope_body_expr); }) p.scopes; } -let rec peephole_expr (_ : unit) (e : expr Pos.marked) : expr Pos.marked Bindlib.box = +let rec peephole_expr (_ : unit) (e : expr Pos.marked) : + expr Pos.marked Bindlib.box = let default_mark e' = Pos.mark (Pos.get_position e) e' in match Pos.unmark e with | EIfThenElse (e1, e2, e3) -> ( - let+ e1 = peephole_expr () e1 and+ e2 = peephole_expr () e2 and+ e3 = peephole_expr () e3 in + let+ e1 = peephole_expr () e1 + and+ e2 = peephole_expr () e2 + and+ e3 = peephole_expr () e3 in match Pos.unmark e1 with - | ELit (LBool true) | EApp ((EOp (Unop (Log _)), _), [ (ELit (LBool true), _) ]) -> e2 - | ELit (LBool false) | EApp ((EOp (Unop (Log _)), _), [ (ELit (LBool false), _) ]) -> e3 + | ELit (LBool true) + | EApp ((EOp (Unop (Log _)), _), [ (ELit (LBool true), _) ]) -> + e2 + | ELit (LBool false) + | EApp ((EOp (Unop (Log _)), _), [ (ELit (LBool false), _) ]) -> + e3 | _ -> default_mark @@ EIfThenElse (e1, e2, e3)) | _ -> visitor_map peephole_expr () e @@ -140,9 +159,11 @@ let peephole_optimizations (p : program) : program = (fun scope_body -> { scope_body with - scope_body_expr = Bindlib.unbox (peephole_expr () scope_body.scope_body_expr); + scope_body_expr = + Bindlib.unbox (peephole_expr () scope_body.scope_body_expr); }) p.scopes; } -let optimize_program (p : program) : program = p |> iota_optimizations |> peephole_optimizations +let optimize_program (p : program) : program = + p |> iota_optimizations |> peephole_optimizations diff --git a/compiler/lcalc/optimizations.mli b/compiler/lcalc/optimizations.mli index 335fd4c4..4e7ab958 100644 --- a/compiler/lcalc/optimizations.mli +++ b/compiler/lcalc/optimizations.mli @@ -1,15 +1,17 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux - +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, contributor: + Denis Merigoux - 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 + 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 + 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. *) open Ast diff --git a/compiler/lcalc/print.ml b/compiler/lcalc/print.ml index 161c0574..86dcd7f5 100644 --- a/compiler/lcalc/print.ml +++ b/compiler/lcalc/print.ml @@ -1,15 +1,17 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux - +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, contributor: + Denis Merigoux - 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 + 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 + 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. *) open Utils @@ -38,12 +40,18 @@ let format_lit (fmt : Format.formatter) (l : lit Pos.marked) : unit = (Runtime.decimal_to_string ~max_prec_digits:!Utils.Cli.max_prec_digits i) | LMoney e -> ( match !Utils.Cli.locale_lang with - | En -> Dcalc.Print.format_lit_style fmt (Format.asprintf "$%s" (Runtime.money_to_string e)) - | Fr -> Dcalc.Print.format_lit_style fmt (Format.asprintf "%s €" (Runtime.money_to_string e)) + | En -> + Dcalc.Print.format_lit_style fmt + (Format.asprintf "$%s" (Runtime.money_to_string e)) + | Fr -> + Dcalc.Print.format_lit_style fmt + (Format.asprintf "%s €" (Runtime.money_to_string e)) | Pl -> - Dcalc.Print.format_lit_style fmt (Format.asprintf "%s PLN" (Runtime.money_to_string e))) + Dcalc.Print.format_lit_style fmt + (Format.asprintf "%s PLN" (Runtime.money_to_string e))) | LDate d -> Dcalc.Print.format_lit_style fmt (Runtime.date_to_string d) - | LDuration d -> Dcalc.Print.format_lit_style fmt (Runtime.duration_to_string d) + | LDuration d -> + Dcalc.Print.format_lit_style fmt (Runtime.duration_to_string d) let format_exception (fmt : Format.formatter) (exn : except) : unit = Dcalc.Print.format_operator fmt @@ -65,12 +73,16 @@ let needs_parens (e : expr Pos.marked) : bool = let format_var (fmt : Format.formatter) (v : Var.t) : unit = Format.fprintf fmt "%s_%d" (Bindlib.name_of v) (Bindlib.uid_of v) -let rec format_expr (ctx : Dcalc.Ast.decl_ctx) ?(debug : bool = false) (fmt : Format.formatter) +let rec format_expr + (ctx : Dcalc.Ast.decl_ctx) + ?(debug : bool = false) + (fmt : Format.formatter) (e : expr Pos.marked) : unit = let format_expr = format_expr ctx ~debug in let format_with_parens (fmt : Format.formatter) (e : expr Pos.marked) = if needs_parens e then - Format.fprintf fmt "%a%a%a" format_punctuation "(" format_expr e format_punctuation ")" + Format.fprintf fmt "%a%a%a" format_punctuation "(" format_expr e + format_punctuation ")" else Format.fprintf fmt "%a" format_expr e in match Pos.unmark e with @@ -82,15 +94,16 @@ let rec format_expr (ctx : Dcalc.Ast.decl_ctx) ?(debug : bool = false) (fmt : Fo (fun fmt e -> Format.fprintf fmt "%a" format_expr e)) es format_punctuation ")" | ETuple (es, Some s) -> - Format.fprintf fmt "@[%a@ %a%a%a@]" Dcalc.Ast.StructName.format_t s format_punctuation - "{" + Format.fprintf fmt "@[%a@ %a%a%a@]" Dcalc.Ast.StructName.format_t s + format_punctuation "{" (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ") (fun fmt (e, struct_field) -> Format.fprintf fmt "%a%a%a%a %a" format_punctuation "\"" - Dcalc.Ast.StructFieldName.format_t struct_field format_punctuation "\"" - format_punctuation ":" format_expr e)) - (List.combine es (List.map fst (Dcalc.Ast.StructMap.find s ctx.ctx_structs))) + Dcalc.Ast.StructFieldName.format_t struct_field + format_punctuation "\"" format_punctuation ":" format_expr e)) + (List.combine es + (List.map fst (Dcalc.Ast.StructMap.find s ctx.ctx_structs))) format_punctuation "}" | EArray es -> Format.fprintf fmt "@[%a%a%a@]" format_punctuation "[" @@ -100,10 +113,11 @@ let rec format_expr (ctx : Dcalc.Ast.decl_ctx) ?(debug : bool = false) (fmt : Fo es format_punctuation "]" | ETupleAccess (e1, n, s, _ts) -> ( match s with - | None -> Format.fprintf fmt "%a%a%d" format_expr e1 format_punctuation "." n + | None -> + Format.fprintf fmt "%a%a%d" format_expr e1 format_punctuation "." n | Some s -> - Format.fprintf fmt "%a%a%a%a%a" format_expr e1 format_punctuation "." format_punctuation - "\"" Dcalc.Ast.StructFieldName.format_t + Format.fprintf fmt "%a%a%a%a%a" format_expr e1 format_punctuation "." + format_punctuation "\"" Dcalc.Ast.StructFieldName.format_t (fst (List.nth (Dcalc.Ast.StructMap.find s ctx.ctx_structs) n)) format_punctuation "\"") | EInj (e, n, en, _ts) -> @@ -111,26 +125,31 @@ let rec format_expr (ctx : Dcalc.Ast.decl_ctx) ?(debug : bool = false) (fmt : Fo (fst (List.nth (Dcalc.Ast.EnumMap.find en ctx.ctx_enums) n)) format_expr e | EMatch (e, es, e_name) -> - Format.fprintf fmt "@[%a@ %a@ %a@ %a@]" format_keyword "match" format_expr e - format_keyword "with" + Format.fprintf fmt "@[%a@ %a@ %a@ %a@]" format_keyword "match" + format_expr e format_keyword "with" (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n") (fun fmt (e, c) -> Format.fprintf fmt "@[%a %a%a@ %a@]" format_punctuation "|" - Dcalc.Print.format_enum_constructor c format_punctuation ":" format_expr e)) - (List.combine es (List.map fst (Dcalc.Ast.EnumMap.find e_name ctx.ctx_enums))) + Dcalc.Print.format_enum_constructor c format_punctuation ":" + format_expr e)) + (List.combine es + (List.map fst (Dcalc.Ast.EnumMap.find e_name ctx.ctx_enums))) | ELit l -> Format.fprintf fmt "%a" format_lit (Pos.same_pos_as l e) | EApp ((EAbs ((binder, _), taus), _), args) -> let xs, body = Bindlib.unmbind binder in let xs_tau = List.map2 (fun x tau -> (x, tau)) (Array.to_list xs) taus in - let xs_tau_arg = List.map2 (fun (x, tau) arg -> (x, tau, arg)) xs_tau args in + let xs_tau_arg = + List.map2 (fun (x, tau) arg -> (x, tau, arg)) xs_tau args + in Format.fprintf fmt "%a%a" (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "") (fun fmt (x, tau, arg) -> - Format.fprintf fmt "@[%a@ %a@ %a@ %a@ %a@ %a@ %a@]@\n" format_keyword "let" - format_var x format_punctuation ":" (Dcalc.Print.format_typ ctx) tau - format_punctuation "=" format_expr arg format_keyword "in")) + Format.fprintf fmt "@[%a@ %a@ %a@ %a@ %a@ %a@ %a@]@\n" + format_keyword "let" format_var x format_punctuation ":" + (Dcalc.Print.format_typ ctx) + tau format_punctuation "=" format_expr arg format_keyword "in")) xs_tau_arg format_expr body | EAbs ((binder, _), taus) -> let xs, body = Bindlib.unmbind binder in @@ -139,39 +158,57 @@ let rec format_expr (ctx : Dcalc.Ast.decl_ctx) ?(debug : bool = false) (fmt : Fo (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ") (fun fmt (x, tau) -> - Format.fprintf fmt "%a%a%a %a%a" format_punctuation "(" format_var x format_punctuation - ":" (Dcalc.Print.format_typ ctx) tau format_punctuation ")")) + Format.fprintf fmt "%a%a%a %a%a" format_punctuation "(" format_var + x format_punctuation ":" + (Dcalc.Print.format_typ ctx) + tau format_punctuation ")")) xs_tau format_punctuation "→" format_expr body - | EApp ((EOp (Binop ((Dcalc.Ast.Map | Dcalc.Ast.Filter) as op)), _), [ arg1; arg2 ]) -> - Format.fprintf fmt "@[%a@ %a@ %a@]" Dcalc.Print.format_binop (op, Pos.no_pos) - format_with_parens arg1 format_with_parens arg2 + | EApp + ( (EOp (Binop ((Dcalc.Ast.Map | Dcalc.Ast.Filter) as op)), _), + [ arg1; arg2 ] ) -> + Format.fprintf fmt "@[%a@ %a@ %a@]" Dcalc.Print.format_binop + (op, Pos.no_pos) format_with_parens arg1 format_with_parens arg2 | EApp ((EOp (Binop op), _), [ arg1; arg2 ]) -> - Format.fprintf fmt "@[%a@ %a@ %a@]" format_with_parens arg1 Dcalc.Print.format_binop - (op, Pos.no_pos) format_with_parens arg2 + Format.fprintf fmt "@[%a@ %a@ %a@]" format_with_parens arg1 + Dcalc.Print.format_binop (op, Pos.no_pos) format_with_parens arg2 | EApp ((EOp (Unop (Log _)), _), [ arg1 ]) when not debug -> Format.fprintf fmt "%a" format_with_parens arg1 | EApp ((EOp (Unop op), _), [ arg1 ]) -> - Format.fprintf fmt "@[%a@ %a@]" Dcalc.Print.format_unop (op, Pos.no_pos) - format_with_parens arg1 + Format.fprintf fmt "@[%a@ %a@]" Dcalc.Print.format_unop + (op, Pos.no_pos) format_with_parens arg1 | EApp (f, args) -> Format.fprintf fmt "@[%a@ %a@]" format_expr f - (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ") format_with_parens) + (Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ") + format_with_parens) args | EIfThenElse (e1, e2, e3) -> - Format.fprintf fmt "@[%a@ %a@ %a@ %a@ %a@ %a@]" format_keyword "if" format_expr e1 - format_keyword "then" format_expr e2 format_keyword "else" format_expr e3 - | EOp (Ternop op) -> Format.fprintf fmt "%a" Dcalc.Print.format_ternop (op, Pos.no_pos) - | EOp (Binop op) -> Format.fprintf fmt "%a" Dcalc.Print.format_binop (op, Pos.no_pos) - | EOp (Unop op) -> Format.fprintf fmt "%a" Dcalc.Print.format_unop (op, Pos.no_pos) + Format.fprintf fmt "@[%a@ %a@ %a@ %a@ %a@ %a@]" format_keyword "if" + format_expr e1 format_keyword "then" format_expr e2 format_keyword + "else" format_expr e3 + | EOp (Ternop op) -> + Format.fprintf fmt "%a" Dcalc.Print.format_ternop (op, Pos.no_pos) + | EOp (Binop op) -> + Format.fprintf fmt "%a" Dcalc.Print.format_binop (op, Pos.no_pos) + | EOp (Unop op) -> + Format.fprintf fmt "%a" Dcalc.Print.format_unop (op, Pos.no_pos) | ECatch (e1, exn, e2) -> - Format.fprintf fmt "@[%a@ %a@ %a@ %a ->@ %a@]" format_keyword "try" format_with_parens - e1 format_keyword "with" format_exception exn format_with_parens e2 - | ERaise exn -> Format.fprintf fmt "@[%a@ %a@]" format_keyword "raise" format_exception exn + Format.fprintf fmt "@[%a@ %a@ %a@ %a ->@ %a@]" format_keyword "try" + format_with_parens e1 format_keyword "with" format_exception exn + format_with_parens e2 + | ERaise exn -> + Format.fprintf fmt "@[%a@ %a@]" format_keyword "raise" + format_exception exn | EAssert e' -> - Format.fprintf fmt "@[%a@ %a%a%a@]" format_keyword "assert" format_punctuation "(" - format_expr e' format_punctuation ")" + Format.fprintf fmt "@[%a@ %a%a%a@]" format_keyword "assert" + format_punctuation "(" format_expr e' format_punctuation ")" -let format_scope (decl_ctx : Dcalc.Ast.decl_ctx) ?(debug : bool = false) (fmt : Format.formatter) +let format_scope + (decl_ctx : Dcalc.Ast.decl_ctx) + ?(debug : bool = false) + (fmt : Format.formatter) (body : scope_body) : unit = - Format.fprintf fmt "@[%a %a %a@ %a@]" format_keyword "let" format_var body.scope_body_var - format_punctuation "=" (format_expr decl_ctx ~debug) body.scope_body_expr + Format.fprintf fmt "@[%a %a %a@ %a@]" format_keyword "let" format_var + body.scope_body_var format_punctuation "=" + (format_expr decl_ctx ~debug) + body.scope_body_expr diff --git a/compiler/lcalc/print.mli b/compiler/lcalc/print.mli index a82d8c9a..a298b056 100644 --- a/compiler/lcalc/print.mli +++ b/compiler/lcalc/print.mli @@ -1,15 +1,17 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux - +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, contributor: + Denis Merigoux - 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 + 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 + 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. *) open Utils @@ -17,18 +19,24 @@ open Utils (** {1 Helpers} *) val is_uppercase : CamomileLibraryDefault.Camomile.UChar.t -> bool - val begins_with_uppercase : string -> bool (** {1 Formatters} *) val format_lit : Format.formatter -> Ast.lit Pos.marked -> unit - val format_var : Format.formatter -> Ast.Var.t -> unit - val format_exception : Format.formatter -> Ast.except -> unit val format_expr : - Dcalc.Ast.decl_ctx -> ?debug:bool -> Format.formatter -> Ast.expr Pos.marked -> unit + Dcalc.Ast.decl_ctx -> + ?debug:bool -> + Format.formatter -> + Ast.expr Pos.marked -> + unit -val format_scope : Dcalc.Ast.decl_ctx -> ?debug:bool -> Format.formatter -> Ast.scope_body -> unit +val format_scope : + Dcalc.Ast.decl_ctx -> + ?debug:bool -> + Format.formatter -> + Ast.scope_body -> + unit diff --git a/compiler/lcalc/to_ocaml.ml b/compiler/lcalc/to_ocaml.ml index 28a1cd45..35eafd60 100644 --- a/compiler/lcalc/to_ocaml.ml +++ b/compiler/lcalc/to_ocaml.ml @@ -1,15 +1,17 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux - +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, contributor: + Denis Merigoux - 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 + 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 + 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. *) open Utils @@ -23,20 +25,25 @@ let find_struct (s : D.StructName.t) (ctx : D.decl_ctx) : with Not_found -> let s_name, pos = D.StructName.get_info s in Errors.raise_spanned_error pos - "Internal Error: Structure %s was not found in the current environment." s_name + "Internal Error: Structure %s was not found in the current environment." + s_name -let find_enum (en : D.EnumName.t) (ctx : D.decl_ctx) : (D.EnumConstructor.t * D.typ Pos.marked) list - = +let find_enum (en : D.EnumName.t) (ctx : D.decl_ctx) : + (D.EnumConstructor.t * D.typ Pos.marked) list = try D.EnumMap.find en ctx.D.ctx_enums with Not_found -> let en_name, pos = D.EnumName.get_info en in Errors.raise_spanned_error pos - "Internal Error: Enumeration %s was not found in the current environment." en_name + "Internal Error: Enumeration %s was not found in the current environment." + en_name let format_lit (fmt : Format.formatter) (l : lit Pos.marked) : unit = match Pos.unmark l with - | LBool b -> Dcalc.Print.format_lit fmt (Pos.same_pos_as (Dcalc.Ast.LBool b) l) - | LInt i -> Format.fprintf fmt "integer_of_string@ \"%s\"" (Runtime.integer_to_string i) + | LBool b -> + Dcalc.Print.format_lit fmt (Pos.same_pos_as (Dcalc.Ast.LBool b) l) + | LInt i -> + Format.fprintf fmt "integer_of_string@ \"%s\"" + (Runtime.integer_to_string i) | LUnit -> Dcalc.Print.format_lit fmt (Pos.same_pos_as Dcalc.Ast.LUnit l) | LRat i -> Format.fprintf fmt "decimal_of_string \"%a\"" Dcalc.Print.format_lit @@ -55,9 +62,15 @@ let format_lit (fmt : Format.formatter) (l : lit Pos.marked) : unit = let format_op_kind (fmt : Format.formatter) (k : Dcalc.Ast.op_kind) = Format.fprintf fmt "%s" - (match k with KInt -> "!" | KRat -> "&" | KMoney -> "$" | KDate -> "@" | KDuration -> "^") + (match k with + | KInt -> "!" + | KRat -> "&" + | KMoney -> "$" + | KDate -> "@" + | KDuration -> "^") -let format_binop (fmt : Format.formatter) (op : Dcalc.Ast.binop Pos.marked) : unit = +let format_binop (fmt : Format.formatter) (op : Dcalc.Ast.binop Pos.marked) : + unit = match Pos.unmark op with | Add k -> Format.fprintf fmt "+%a" format_op_kind k | Sub k -> Format.fprintf fmt "-%a" format_op_kind k @@ -75,14 +88,17 @@ let format_binop (fmt : Format.formatter) (op : Dcalc.Ast.binop Pos.marked) : un | Map -> Format.fprintf fmt "Array.map" | Filter -> Format.fprintf fmt "array_filter" -let format_ternop (fmt : Format.formatter) (op : Dcalc.Ast.ternop Pos.marked) : unit = +let format_ternop (fmt : Format.formatter) (op : Dcalc.Ast.ternop Pos.marked) : + unit = match Pos.unmark op with Fold -> Format.fprintf fmt "Array.fold_left" -let format_uid_list (fmt : Format.formatter) (uids : Uid.MarkedString.info list) : unit = +let format_uid_list (fmt : Format.formatter) (uids : Uid.MarkedString.info list) + : unit = Format.fprintf fmt "@[[%a]@]" (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt ";@ ") - (fun fmt info -> Format.fprintf fmt "\"%a\"" Utils.Uid.MarkedString.format_info info)) + (fun fmt info -> + Format.fprintf fmt "\"%a\"" Utils.Uid.MarkedString.format_info info)) uids let format_string_list (fmt : Format.formatter) (uids : string list) : unit = @@ -92,13 +108,15 @@ let format_string_list (fmt : Format.formatter) (uids : string list) : unit = (fun fmt info -> Format.fprintf fmt "\"%s\"" info)) uids -let format_unop (fmt : Format.formatter) (op : Dcalc.Ast.unop Pos.marked) : unit = +let format_unop (fmt : Format.formatter) (op : Dcalc.Ast.unop Pos.marked) : unit + = match Pos.unmark op with | Minus k -> Format.fprintf fmt "~-%a" format_op_kind k | Not -> Format.fprintf fmt "%s" "not" | Log (_entry, _infos) -> Errors.raise_spanned_error (Pos.get_position op) - "Internal error: a log operator has not been caught by the expression match" + "Internal error: a log operator has not been caught by the expression \ + match" | Length -> Format.fprintf fmt "%s" "array_length" | IntToRat -> Format.fprintf fmt "%s" "decimal_of_integer" | GetDay -> Format.fprintf fmt "%s" "day_of_month_of_date" @@ -108,36 +126,49 @@ let format_unop (fmt : Format.formatter) (op : Dcalc.Ast.unop Pos.marked) : unit let avoid_keywords (s : string) : string = if match s with - (* list taken from http://caml.inria.fr/pub/docs/manual-ocaml/lex.html#sss:keywords *) - | "and" | "as" | "assert" | "asr" | "begin" | "class" | "constraint" | "do" | "done" | "downto" - | "else" | "end" | "exception" | "external" | "false" | "for" | "fun" | "function" | "functor" - | "if" | "in" | "include" | "inherit" | "initializer" | "land" | "lazy" | "let" | "lor" | "lsl" - | "lsr" | "lxor" | "match" | "method" | "mod" | "module" | "mutable" | "new" | "nonrec" - | "object" | "of" | "open" | "or" | "private" | "rec" | "sig" | "struct" | "then" | "to" - | "true" | "try" | "type" | "val" | "virtual" | "when" | "while" | "with" -> + (* list taken from + http://caml.inria.fr/pub/docs/manual-ocaml/lex.html#sss:keywords *) + | "and" | "as" | "assert" | "asr" | "begin" | "class" | "constraint" | "do" + | "done" | "downto" | "else" | "end" | "exception" | "external" | "false" + | "for" | "fun" | "function" | "functor" | "if" | "in" | "include" + | "inherit" | "initializer" | "land" | "lazy" | "let" | "lor" | "lsl" + | "lsr" | "lxor" | "match" | "method" | "mod" | "module" | "mutable" | "new" + | "nonrec" | "object" | "of" | "open" | "or" | "private" | "rec" | "sig" + | "struct" | "then" | "to" | "true" | "try" | "type" | "val" | "virtual" + | "when" | "while" | "with" -> true | _ -> false then s ^ "_" else s -let format_struct_name (fmt : Format.formatter) (v : Dcalc.Ast.StructName.t) : unit = +let format_struct_name (fmt : Format.formatter) (v : Dcalc.Ast.StructName.t) : + unit = Format.fprintf fmt "%s" (avoid_keywords - (to_lowercase (to_ascii (Format.asprintf "%a" Dcalc.Ast.StructName.format_t v)))) + (to_lowercase + (to_ascii (Format.asprintf "%a" Dcalc.Ast.StructName.format_t v)))) -let format_struct_field_name (fmt : Format.formatter) (v : Dcalc.Ast.StructFieldName.t) : unit = +let format_struct_field_name + (fmt : Format.formatter) (v : Dcalc.Ast.StructFieldName.t) : unit = Format.fprintf fmt "%s" - (avoid_keywords (to_ascii (Format.asprintf "%a" Dcalc.Ast.StructFieldName.format_t v))) + (avoid_keywords + (to_ascii (Format.asprintf "%a" Dcalc.Ast.StructFieldName.format_t v))) -let format_enum_name (fmt : Format.formatter) (v : Dcalc.Ast.EnumName.t) : unit = +let format_enum_name (fmt : Format.formatter) (v : Dcalc.Ast.EnumName.t) : unit + = Format.fprintf fmt "%s" - (avoid_keywords (to_lowercase (to_ascii (Format.asprintf "%a" Dcalc.Ast.EnumName.format_t v)))) + (avoid_keywords + (to_lowercase + (to_ascii (Format.asprintf "%a" Dcalc.Ast.EnumName.format_t v)))) -let format_enum_cons_name (fmt : Format.formatter) (v : Dcalc.Ast.EnumConstructor.t) : unit = +let format_enum_cons_name + (fmt : Format.formatter) (v : Dcalc.Ast.EnumConstructor.t) : unit = Format.fprintf fmt "%s" - (avoid_keywords (to_ascii (Format.asprintf "%a" Dcalc.Ast.EnumConstructor.format_t v))) + (avoid_keywords + (to_ascii (Format.asprintf "%a" Dcalc.Ast.EnumConstructor.format_t v))) -let rec typ_embedding_name (fmt : Format.formatter) (ty : D.typ Pos.marked) : unit = +let rec typ_embedding_name (fmt : Format.formatter) (ty : D.typ Pos.marked) : + unit = match Pos.unmark ty with | D.TLit D.TUnit -> Format.fprintf fmt "embed_unit" | D.TLit D.TBool -> Format.fprintf fmt "embed_bool" @@ -146,7 +177,8 @@ let rec typ_embedding_name (fmt : Format.formatter) (ty : D.typ Pos.marked) : un | D.TLit D.TMoney -> Format.fprintf fmt "embed_money" | D.TLit D.TDate -> Format.fprintf fmt "embed_date" | D.TLit D.TDuration -> Format.fprintf fmt "embed_duration" - | D.TTuple (_, Some s_name) -> Format.fprintf fmt "embed_%a" format_struct_name s_name + | D.TTuple (_, Some s_name) -> + Format.fprintf fmt "embed_%a" format_struct_name s_name | D.TEnum (_, e_name) -> Format.fprintf fmt "embed_%a" format_enum_name e_name | D.TArray ty -> Format.fprintf fmt "embed_array (%a)" typ_embedding_name ty | _ -> Format.fprintf fmt "unembeddable" @@ -154,9 +186,11 @@ let rec typ_embedding_name (fmt : Format.formatter) (ty : D.typ Pos.marked) : un let typ_needs_parens (e : Dcalc.Ast.typ Pos.marked) : bool = match Pos.unmark e with TArrow _ | TArray _ -> true | _ -> false -let rec format_typ (fmt : Format.formatter) (typ : Dcalc.Ast.typ Pos.marked) : unit = +let rec format_typ (fmt : Format.formatter) (typ : Dcalc.Ast.typ Pos.marked) : + unit = let format_typ = format_typ in - let format_typ_with_parens (fmt : Format.formatter) (t : Dcalc.Ast.typ Pos.marked) = + let format_typ_with_parens + (fmt : Format.formatter) (t : Dcalc.Ast.typ Pos.marked) = if typ_needs_parens t then Format.fprintf fmt "(%a)" format_typ t else Format.fprintf fmt "%a" format_typ t in @@ -170,20 +204,25 @@ let rec format_typ (fmt : Format.formatter) (typ : Dcalc.Ast.typ Pos.marked) : u ts | TTuple (_, Some s) -> Format.fprintf fmt "%a" format_struct_name s | TEnum ([ t ], e) when D.EnumName.compare e Ast.option_enum = 0 -> - Format.fprintf fmt "@[(%a)@] %a" format_typ_with_parens t format_enum_name e + Format.fprintf fmt "@[(%a)@] %a" format_typ_with_parens t + format_enum_name e | TEnum (_, e) when D.EnumName.compare e Ast.option_enum = 0 -> Errors.raise_spanned_error (Pos.get_position typ) - "Internal Error: found an typing parameter for an eoption type of the wrong lenght." + "Internal Error: found an typing parameter for an eoption type of the \ + wrong lenght." | TEnum (_ts, e) -> Format.fprintf fmt "%a" format_enum_name e | TArrow (t1, t2) -> - Format.fprintf fmt "@[%a ->@ %a@]" format_typ_with_parens t1 format_typ_with_parens t2 + Format.fprintf fmt "@[%a ->@ %a@]" format_typ_with_parens t1 + format_typ_with_parens t2 | TArray t1 -> Format.fprintf fmt "@[%a@ array@]" format_typ_with_parens t1 | TAny -> Format.fprintf fmt "_" let format_var (fmt : Format.formatter) (v : Var.t) : unit = let lowercase_name = to_lowercase (to_ascii (Bindlib.name_of v)) in let lowercase_name = - Re.Pcre.substitute ~rex:(Re.Pcre.regexp "\\.") ~subst:(fun _ -> "_dot_") lowercase_name + Re.Pcre.substitute ~rex:(Re.Pcre.regexp "\\.") + ~subst:(fun _ -> "_dot_") + lowercase_name in let lowercase_name = avoid_keywords (to_ascii lowercase_name) in if @@ -195,7 +234,10 @@ let format_var (fmt : Format.formatter) (v : Var.t) : unit = let needs_parens (e : expr Pos.marked) : bool = match Pos.unmark e with - | EApp ((EAbs (_, _), _), _) | ELit (LBool _ | LUnit) | EVar _ | ETuple _ | EOp _ -> false + | EApp ((EAbs (_, _), _), _) + | ELit (LBool _ | LUnit) + | EVar _ | ETuple _ | EOp _ -> + false | _ -> true let format_exception (fmt : Format.formatter) (exc : except Pos.marked) : unit = @@ -206,13 +248,15 @@ let format_exception (fmt : Format.formatter) (exc : except Pos.marked) : unit = | NoValueProvided -> let pos = Pos.get_position exc in Format.fprintf fmt - "(NoValueProvided@ @[{filename = \"%s\";@ start_line=%d;@ start_column=%d;@ \ - end_line=%d; end_column=%d;@ law_headings=%a}@])" + "(NoValueProvided@ @[{filename = \"%s\";@ start_line=%d;@ \ + start_column=%d;@ end_line=%d; end_column=%d;@ law_headings=%a}@])" (Pos.get_file pos) (Pos.get_start_line pos) (Pos.get_start_column pos) - (Pos.get_end_line pos) (Pos.get_end_column pos) format_string_list (Pos.get_law_info pos) + (Pos.get_end_line pos) (Pos.get_end_column pos) format_string_list + (Pos.get_law_info pos) -let rec format_expr (ctx : Dcalc.Ast.decl_ctx) (fmt : Format.formatter) (e : expr Pos.marked) : unit - = +let rec format_expr + (ctx : Dcalc.Ast.decl_ctx) (fmt : Format.formatter) (e : expr Pos.marked) : + unit = let format_expr = format_expr ctx in let format_with_parens (fmt : Format.formatter) (e : expr Pos.marked) = if needs_parens e then Format.fprintf fmt "(%a)" format_expr e @@ -233,8 +277,8 @@ let rec format_expr (ctx : Dcalc.Ast.decl_ctx) (fmt : Format.formatter) (e : exp (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt ";@ ") (fun fmt (e, struct_field) -> - Format.fprintf fmt "@[%a =@ %a@]" format_struct_field_name struct_field - format_with_parens e)) + Format.fprintf fmt "@[%a =@ %a@]" format_struct_field_name + struct_field format_with_parens e)) (List.combine es (List.map fst (find_struct s ctx))) | EArray es -> Format.fprintf fmt "@[[|%a|]@]" @@ -248,11 +292,13 @@ let rec format_expr (ctx : Dcalc.Ast.decl_ctx) (fmt : Format.formatter) (e : exp Format.fprintf fmt "let@ %a@ = %a@ in@ x" (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ") - (fun fmt i -> Format.fprintf fmt "%s" (if i = n then "x" else "_"))) + (fun fmt i -> + Format.fprintf fmt "%s" (if i = n then "x" else "_"))) (List.mapi (fun i _ -> i) ts) format_with_parens e1 | Some s -> - Format.fprintf fmt "%a.%a" format_with_parens e1 format_struct_field_name + Format.fprintf fmt "%a.%a" format_with_parens e1 + format_struct_field_name (fst (List.nth (find_struct s ctx) n))) | EInj (e, n, en, _ts) -> Format.fprintf fmt "@[%a@ %a@]" format_enum_cons_name @@ -281,13 +327,15 @@ let rec format_expr (ctx : Dcalc.Ast.decl_ctx) (fmt : Format.formatter) (e : exp | EApp ((EAbs ((binder, _), taus), _), args) -> let xs, body = Bindlib.unmbind binder in let xs_tau = List.map2 (fun x tau -> (x, tau)) (Array.to_list xs) taus in - let xs_tau_arg = List.map2 (fun (x, tau) arg -> (x, tau, arg)) xs_tau args in + let xs_tau_arg = + List.map2 (fun (x, tau) arg -> (x, tau, arg)) xs_tau args + in Format.fprintf fmt "(%a%a)" (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "") (fun fmt (x, tau, arg) -> - Format.fprintf fmt "@[let@ %a@ :@ %a@ =@ %a@]@ in@\n" format_var x format_typ - tau format_with_parens arg)) + Format.fprintf fmt "@[let@ %a@ :@ %a@ =@ %a@]@ in@\n" + format_var x format_typ tau format_with_parens arg)) xs_tau_arg format_with_parens body | EAbs ((binder, _), taus) -> let xs, body = Bindlib.unmbind binder in @@ -296,114 +344,145 @@ let rec format_expr (ctx : Dcalc.Ast.decl_ctx) (fmt : Format.formatter) (e : exp (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ") (fun fmt (x, tau) -> - Format.fprintf fmt "@[(%a:@ %a)@]" format_var x format_typ tau)) + Format.fprintf fmt "@[(%a:@ %a)@]" format_var x format_typ + tau)) xs_tau format_expr body - | EApp ((EOp (Binop ((Dcalc.Ast.Map | Dcalc.Ast.Filter) as op)), _), [ arg1; arg2 ]) -> - Format.fprintf fmt "@[%a@ %a@ %a@]" format_binop (op, Pos.no_pos) format_with_parens - arg1 format_with_parens arg2 + | EApp + ( (EOp (Binop ((Dcalc.Ast.Map | Dcalc.Ast.Filter) as op)), _), + [ arg1; arg2 ] ) -> + Format.fprintf fmt "@[%a@ %a@ %a@]" format_binop (op, Pos.no_pos) + format_with_parens arg1 format_with_parens arg2 | EApp ((EOp (Binop op), _), [ arg1; arg2 ]) -> - Format.fprintf fmt "@[%a@ %a@ %a@]" format_with_parens arg1 format_binop - (op, Pos.no_pos) format_with_parens arg2 - | EApp ((EApp ((EOp (Unop (D.Log (D.BeginCall, info))), _), [ f ]), _), [ arg ]) + Format.fprintf fmt "@[%a@ %a@ %a@]" format_with_parens arg1 + format_binop (op, Pos.no_pos) format_with_parens arg2 + | EApp + ((EApp ((EOp (Unop (D.Log (D.BeginCall, info))), _), [ f ]), _), [ arg ]) when !Cli.trace_flag -> - Format.fprintf fmt "(log_begin_call@ %a@ %a@ %a)" format_uid_list info format_with_parens f - format_with_parens arg - | EApp ((EOp (Unop (D.Log (D.VarDef tau, info))), _), [ arg1 ]) when !Cli.trace_flag -> - Format.fprintf fmt "(log_variable_definition@ %a@ (%a)@ %a)" format_uid_list info - typ_embedding_name (tau, Pos.no_pos) format_with_parens arg1 - | EApp ((EOp (Unop (D.Log (D.PosRecordIfTrueBool, _))), pos), [ arg1 ]) when !Cli.trace_flag -> - Format.fprintf fmt - "(log_decision_taken@ @[{filename = \"%s\";@ start_line=%d;@ start_column=%d;@ \ - end_line=%d; end_column=%d;@ law_headings=%a}@]@ %a)" - (Pos.get_file pos) (Pos.get_start_line pos) (Pos.get_start_column pos) - (Pos.get_end_line pos) (Pos.get_end_column pos) format_string_list (Pos.get_law_info pos) + Format.fprintf fmt "(log_begin_call@ %a@ %a@ %a)" format_uid_list info + format_with_parens f format_with_parens arg + | EApp ((EOp (Unop (D.Log (D.VarDef tau, info))), _), [ arg1 ]) + when !Cli.trace_flag -> + Format.fprintf fmt "(log_variable_definition@ %a@ (%a)@ %a)" + format_uid_list info typ_embedding_name (tau, Pos.no_pos) format_with_parens arg1 - | EApp ((EOp (Unop (D.Log (D.EndCall, info))), _), [ arg1 ]) when !Cli.trace_flag -> - Format.fprintf fmt "(log_end_call@ %a@ %a)" format_uid_list info format_with_parens arg1 - | EApp ((EOp (Unop (D.Log _)), _), [ arg1 ]) -> Format.fprintf fmt "%a" format_with_parens arg1 + | EApp ((EOp (Unop (D.Log (D.PosRecordIfTrueBool, _))), pos), [ arg1 ]) + when !Cli.trace_flag -> + Format.fprintf fmt + "(log_decision_taken@ @[{filename = \"%s\";@ start_line=%d;@ \ + start_column=%d;@ end_line=%d; end_column=%d;@ law_headings=%a}@]@ \ + %a)" + (Pos.get_file pos) (Pos.get_start_line pos) (Pos.get_start_column pos) + (Pos.get_end_line pos) (Pos.get_end_column pos) format_string_list + (Pos.get_law_info pos) format_with_parens arg1 + | EApp ((EOp (Unop (D.Log (D.EndCall, info))), _), [ arg1 ]) + when !Cli.trace_flag -> + Format.fprintf fmt "(log_end_call@ %a@ %a)" format_uid_list info + format_with_parens arg1 + | EApp ((EOp (Unop (D.Log _)), _), [ arg1 ]) -> + Format.fprintf fmt "%a" format_with_parens arg1 | EApp ((EOp (Unop op), _), [ arg1 ]) -> - Format.fprintf fmt "@[%a@ %a@]" format_unop (op, Pos.no_pos) format_with_parens arg1 + Format.fprintf fmt "@[%a@ %a@]" format_unop (op, Pos.no_pos) + format_with_parens arg1 | EApp (f, args) -> Format.fprintf fmt "@[%a@ %a@]" format_with_parens f - (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ") format_with_parens) + (Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ") + format_with_parens) args | EIfThenElse (e1, e2, e3) -> - Format.fprintf fmt "@[ if@ @[%a@]@ then@ @[%a@]@ else@ @[%a@]@]" + Format.fprintf fmt + "@[ if@ @[%a@]@ then@ @[%a@]@ else@ @[%a@]@]" format_with_parens e1 format_with_parens e2 format_with_parens e3 | EOp (Ternop op) -> Format.fprintf fmt "%a" format_ternop (op, Pos.no_pos) | EOp (Binop op) -> Format.fprintf fmt "%a" format_binop (op, Pos.no_pos) | EOp (Unop op) -> Format.fprintf fmt "%a" format_unop (op, Pos.no_pos) | EAssert e' -> - Format.fprintf fmt "@[if @ %a@ then@ ()@ else@ raise AssertionFailed@]" + Format.fprintf fmt + "@[if @ %a@ then@ ()@ else@ raise AssertionFailed@]" format_with_parens e' - | ERaise exc -> Format.fprintf fmt "raise@ %a" format_exception (exc, Pos.get_position e) + | ERaise exc -> + Format.fprintf fmt "raise@ %a" format_exception (exc, Pos.get_position e) | ECatch (e1, exc, e2) -> - Format.fprintf fmt "@[try@ %a@ with@ %a@ ->@ %a@]" format_with_parens e1 - format_exception + Format.fprintf fmt "@[try@ %a@ with@ %a@ ->@ %a@]" + format_with_parens e1 format_exception (exc, Pos.get_position e) format_with_parens e2 -let format_struct_embedding (fmt : Format.formatter) - ((struct_name, struct_fields) : D.StructName.t * (D.StructFieldName.t * D.typ Pos.marked) list) - = +let format_struct_embedding + (fmt : Format.formatter) + ((struct_name, struct_fields) : + D.StructName.t * (D.StructFieldName.t * D.typ Pos.marked) list) = if List.length struct_fields = 0 then - Format.fprintf fmt "let embed_%a (_: %a) : runtime_value = Unit@\n@\n" format_struct_name - struct_name format_struct_name struct_name + Format.fprintf fmt "let embed_%a (_: %a) : runtime_value = Unit@\n@\n" + format_struct_name struct_name format_struct_name struct_name else Format.fprintf fmt - "@[let embed_%a (x: %a) : runtime_value =@ Struct([\"%a\"],@ @[[%a]@])@]@\n@\n" - format_struct_name struct_name format_struct_name struct_name D.StructName.format_t - struct_name + "@[let embed_%a (x: %a) : runtime_value =@ Struct([\"%a\"],@ \ + @[[%a]@])@]@\n\ + @\n" + format_struct_name struct_name format_struct_name struct_name + D.StructName.format_t struct_name (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt ";@\n") (fun _fmt (struct_field, struct_field_type) -> - Format.fprintf fmt "(\"%a\",@ %a@ x.%a)" D.StructFieldName.format_t struct_field - typ_embedding_name struct_field_type format_struct_field_name struct_field)) + Format.fprintf fmt "(\"%a\",@ %a@ x.%a)" D.StructFieldName.format_t + struct_field typ_embedding_name struct_field_type + format_struct_field_name struct_field)) struct_fields -let format_enum_embedding (fmt : Format.formatter) - ((enum_name, enum_cases) : D.EnumName.t * (D.EnumConstructor.t * D.typ Pos.marked) list) = +let format_enum_embedding + (fmt : Format.formatter) + ((enum_name, enum_cases) : + D.EnumName.t * (D.EnumConstructor.t * D.typ Pos.marked) list) = if List.length enum_cases = 0 then - Format.fprintf fmt "let embed_%a (_: %a) : runtime_value = Unit@\n@\n" format_enum_name - enum_name format_enum_name enum_name + Format.fprintf fmt "let embed_%a (_: %a) : runtime_value = Unit@\n@\n" + format_enum_name enum_name format_enum_name enum_name else Format.fprintf fmt - "@[let embed_%a (x: %a) : runtime_value =@ Enum([\"%a\"],@ @[match x with@ \ - %a@])@]@\n\ + "@[let embed_%a (x: %a) : runtime_value =@ Enum([\"%a\"],@ @[match x with@ %a@])@]@\n\ @\n" - format_enum_name enum_name format_enum_name enum_name D.EnumName.format_t enum_name + format_enum_name enum_name format_enum_name enum_name D.EnumName.format_t + enum_name (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n") (fun _fmt (enum_cons, enum_cons_type) -> - Format.fprintf fmt "@[| %a x ->@ (\"%a\", %a x)@]" format_enum_cons_name enum_cons - D.EnumConstructor.format_t enum_cons typ_embedding_name enum_cons_type)) + Format.fprintf fmt "@[| %a x ->@ (\"%a\", %a x)@]" + format_enum_cons_name enum_cons D.EnumConstructor.format_t + enum_cons typ_embedding_name enum_cons_type)) enum_cases -let format_ctx (type_ordering : Scopelang.Dependency.TVertex.t list) (fmt : Format.formatter) +let format_ctx + (type_ordering : Scopelang.Dependency.TVertex.t list) + (fmt : Format.formatter) (ctx : D.decl_ctx) : unit = let format_struct_decl fmt (struct_name, struct_fields) = if List.length struct_fields = 0 then Format.fprintf fmt "type %a = unit@\n@\n" format_struct_name struct_name else - Format.fprintf fmt "type %a = {@\n@[ %a@]@\n}@\n@\n" format_struct_name struct_name + Format.fprintf fmt "type %a = {@\n@[ %a@]@\n}@\n@\n" + format_struct_name struct_name (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n") (fun _fmt (struct_field, struct_field_type) -> - Format.fprintf fmt "%a:@ %a;" format_struct_field_name struct_field format_typ - struct_field_type)) + Format.fprintf fmt "%a:@ %a;" format_struct_field_name struct_field + format_typ struct_field_type)) struct_fields; - if !Cli.trace_flag then format_struct_embedding fmt (struct_name, struct_fields) + if !Cli.trace_flag then + format_struct_embedding fmt (struct_name, struct_fields) in let format_enum_decl fmt (enum_name, enum_cons) = if List.length enum_cons = 0 then Format.fprintf fmt "type %a = unit@\n@\n" format_enum_name enum_name else - Format.fprintf fmt "type %a =@\n@[ %a@]@\n@\n" format_enum_name enum_name + Format.fprintf fmt "type %a =@\n@[ %a@]@\n@\n" format_enum_name + enum_name (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n") (fun _fmt (enum_cons, enum_cons_type) -> - Format.fprintf fmt "| %a@ of@ %a" format_enum_cons_name enum_cons format_typ - enum_cons_type)) + Format.fprintf fmt "| %a@ of@ %a" format_enum_cons_name enum_cons + format_typ enum_cons_type)) enum_cons; if !Cli.trace_flag then format_enum_embedding fmt (enum_name, enum_cons) in @@ -419,7 +498,9 @@ let format_ctx (type_ordering : Scopelang.Dependency.TVertex.t list) (fmt : Form List.map (fun (s, _) -> Scopelang.Dependency.TVertex.Struct s) (Dcalc.Ast.StructMap.bindings - (Dcalc.Ast.StructMap.filter (fun s _ -> not (is_in_type_ordering s)) ctx.ctx_structs)) + (Dcalc.Ast.StructMap.filter + (fun s _ -> not (is_in_type_ordering s)) + ctx.ctx_structs)) in List.iter (fun struct_or_enum -> @@ -430,7 +511,9 @@ let format_ctx (type_ordering : Scopelang.Dependency.TVertex.t list) (fmt : Form Format.fprintf fmt "%a@\n@\n" format_enum_decl (e, find_enum e ctx)) (type_ordering @ scope_structs) -let format_program (fmt : Format.formatter) (p : Ast.program) +let format_program + (fmt : Format.formatter) + (p : Ast.program) (type_ordering : Scopelang.Dependency.TVertex.t list) : unit = Cli.style_flag := false; Format.fprintf fmt @@ -447,6 +530,6 @@ let format_program (fmt : Format.formatter) (p : Ast.program) (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n@\n") (fun fmt body -> - Format.fprintf fmt "@[let@ %a@ =@ %a@]" format_var body.scope_body_var - (format_expr p.decl_ctx) body.scope_body_expr)) + Format.fprintf fmt "@[let@ %a@ =@ %a@]" format_var + body.scope_body_var (format_expr p.decl_ctx) body.scope_body_expr)) p.scopes diff --git a/compiler/lcalc/to_ocaml.mli b/compiler/lcalc/to_ocaml.mli index a2e44dcb..f9e22f03 100644 --- a/compiler/lcalc/to_ocaml.mli +++ b/compiler/lcalc/to_ocaml.mli @@ -1,18 +1,21 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux - +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, contributor: + Denis Merigoux - 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 + 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 + 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. *) (** Formats a lambda calculus program into a valid OCaml program *) -val format_program : Format.formatter -> Ast.program -> Scopelang.Dependency.TVertex.t list -> unit +val format_program : + Format.formatter -> Ast.program -> Scopelang.Dependency.TVertex.t list -> unit (** Usage [format_program fmt p type_dependencies_ordering] *) diff --git a/compiler/literate/html.ml b/compiler/literate/html.ml index 2467871e..1a80ee09 100644 --- a/compiler/literate/html.ml +++ b/compiler/literate/html.ml @@ -1,19 +1,22 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020 Inria, contributors: Denis Merigoux - , Emile Rolley +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, + contributors: Denis Merigoux , Emile Rolley + - 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 + 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 + 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. *) -(** This modules weaves the source code and the legislative text together into a document that law - professionals can understand. *) +(** This modules weaves the source code and the legislative text together into a + document that law professionals can understand. *) open Utils open Literate_common @@ -33,29 +36,40 @@ let pre_html (s : string) = (** Raise an error if pygments cannot be found *) let raise_failed_pygments (command : string) (error_code : int) : 'a = - Errors.raise_error "Weaving to HTML failed: pygmentize command \"%s\" returned with error code %d" + Errors.raise_error + "Weaving to HTML failed: pygmentize command \"%s\" returned with error \ + code %d" command error_code -(** Partial application allowing to remove first code lines of [] and - [] generated HTML. Basically, remove all code block first lines. *) +(** Partial application allowing to remove first code lines of + [] and [] generated HTML. Basically, + remove all code block first lines. *) let remove_cb_first_lines : string -> string = R.substitute ~rex:(R.regexp "

.*\n") ~subst:(function _ -> "
\n")
 
-(** Partial application allowing to remove last code lines of [] and
-    [] generated HTML. Basically, remove all code block last lines. *)
+(** Partial application allowing to remove last code lines of
+    [] and [] generated HTML. Basically,
+    remove all code block last lines. *)
 let remove_cb_last_lines : string -> string =
   R.substitute ~rex:(R.regexp "<.*\n*
") ~subst:(function _ -> "
") (** Usage: [wrap_html source_files custom_pygments language fmt wrapped] Prints an HTML complete page structure around the [wrapped] content. *) -let wrap_html (source_files : string list) (language : Cli.backend_lang) (fmt : Format.formatter) +let wrap_html + (source_files : string list) + (language : Cli.backend_lang) + (fmt : Format.formatter) (wrapped : Format.formatter -> unit) : unit = let pygments = "pygmentize" in let css_file = Filename.temp_file "catala_css_pygments" "" in - let pygments_args = [| "-f"; "html"; "-S"; "colorful"; "-a"; ".catala-code" |] in + let pygments_args = + [| "-f"; "html"; "-S"; "colorful"; "-a"; ".catala-code" |] + in let cmd = - Format.sprintf "%s %s > %s" pygments (String.concat " " (Array.to_list pygments_args)) css_file + Format.sprintf "%s %s > %s" pygments + (String.concat " " (Array.to_list pygments_args)) + css_file in let return_code = Sys.command cmd in if return_code <> 0 then raise_failed_pygments cmd return_code; @@ -78,7 +92,9 @@ let wrap_html (source_files : string list) (language : Cli.backend_lang) (fmt :
    \n\ %s\n\
\n" - css_as_string (literal_title language) (literal_generated_by language) Utils.Cli.version + css_as_string (literal_title language) + (literal_generated_by language) + Utils.Cli.version (literal_source_files language) (String.concat "\n" (List.map @@ -86,8 +102,10 @@ let wrap_html (source_files : string list) (language : Cli.backend_lang) (fmt : let mtime = (Unix.stat filename).Unix.st_mtime in let ltime = Unix.localtime mtime in let ftime = - Printf.sprintf "%d-%02d-%02d, %d:%02d" (1900 + ltime.Unix.tm_year) - (ltime.Unix.tm_mon + 1) ltime.Unix.tm_mday ltime.Unix.tm_hour ltime.Unix.tm_min + Printf.sprintf "%d-%02d-%02d, %d:%02d" + (1900 + ltime.Unix.tm_year) + (ltime.Unix.tm_mon + 1) ltime.Unix.tm_mday ltime.Unix.tm_hour + ltime.Unix.tm_min in Printf.sprintf "
  • %s, %s %s
    • " (pre_html (Filename.basename filename)) @@ -96,9 +114,12 @@ let wrap_html (source_files : string list) (language : Cli.backend_lang) (fmt : source_files)); wrapped fmt -(** Performs syntax highlighting on a piece of code by using Pygments and the special Catala lexer. *) -let pygmentize_code (c : string Pos.marked) (language : C.backend_lang) : string = - C.debug_print "Pygmenting the code chunk %s" (Pos.to_string (Pos.get_position c)); +(** Performs syntax highlighting on a piece of code by using Pygments and the + special Catala lexer. *) +let pygmentize_code (c : string Pos.marked) (language : C.backend_lang) : string + = + C.debug_print "Pygmenting the code chunk %s" + (Pos.to_string (Pos.get_position c)); let temp_file_in = Filename.temp_file "catala_html_pygments" "in" in let temp_file_out = Filename.temp_file "catala_html_pygments" "out" in let oc = open_out temp_file_in in @@ -122,48 +143,66 @@ let pygmentize_code (c : string Pos.marked) (language : C.backend_lang) : string temp_file_in; |] in - let cmd = Format.asprintf "%s %s" pygments (String.concat " " (Array.to_list pygments_args)) in + let cmd = + Format.asprintf "%s %s" pygments + (String.concat " " (Array.to_list pygments_args)) + in let return_code = Sys.command cmd in if return_code <> 0 then raise_failed_pygments cmd return_code; let oc = open_in temp_file_out in let output = really_input_string oc (in_channel_length oc) in close_in oc; (* Remove code blocks delimiters needed by [Pygments]. *) - let trimmed_output = output |> remove_cb_first_lines |> remove_cb_last_lines in + let trimmed_output = + output |> remove_cb_first_lines |> remove_cb_last_lines + in trimmed_output (** {1 Weaving} *) -let rec law_structure_to_html (language : C.backend_lang) (fmt : Format.formatter) - (i : A.law_structure) : unit = +let rec law_structure_to_html + (language : C.backend_lang) (fmt : Format.formatter) (i : A.law_structure) : + unit = match i with | A.LawText t -> let t = pre_html t in if t = "" then () else Format.fprintf fmt "

    %s

    " t | A.CodeBlock (_, c, metadata) -> - Format.fprintf fmt "
    \n
    %s
    \n%s\n
    " + Format.fprintf fmt + "
    \n\ +
    %s
    \n\ + %s\n\ +
    " (if metadata then " code-metadata" else "") (Pos.get_file (Pos.get_position c)) - (pygmentize_code (Pos.same_pos_as ("```catala\n" ^ Pos.unmark c ^ "```") c) language) + (pygmentize_code + (Pos.same_pos_as ("```catala\n" ^ Pos.unmark c ^ "```") c) + language) | A.LawHeading (heading, children) -> let h_number = heading.law_heading_precedence + 1 in - Format.fprintf fmt "%s\n" h_number + Format.fprintf fmt "%s\n" + h_number (match (heading.law_heading_id, language) with | Some id, Fr -> let ltime = Unix.localtime (Unix.time ()) in P.sprintf "https://legifrance.gouv.fr/codes/id/%s/%d-%02d-%02d" id - (1900 + ltime.Unix.tm_year) (ltime.Unix.tm_mon + 1) ltime.Unix.tm_mday + (1900 + ltime.Unix.tm_year) + (ltime.Unix.tm_mon + 1) ltime.Unix.tm_mday | _ -> "#") (pre_html (Pos.unmark heading.law_heading_name)) h_number; Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "\n") - (law_structure_to_html language) fmt children + (law_structure_to_html language) + fmt children | A.LawInclude _ -> () (** {1 API} *) -let ast_to_html (language : C.backend_lang) (fmt : Format.formatter) (program : A.program) : unit = +let ast_to_html + (language : C.backend_lang) (fmt : Format.formatter) (program : A.program) : + unit = Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "\n\n") - (law_structure_to_html language) fmt program.program_items + (law_structure_to_html language) + fmt program.program_items diff --git a/compiler/literate/html.mli b/compiler/literate/html.mli index 587644a4..f4c51209 100644 --- a/compiler/literate/html.mli +++ b/compiler/literate/html.mli @@ -1,30 +1,37 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux - +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, contributor: + Denis Merigoux - 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 + 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 + 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. *) -(** This modules weaves the source code and the legislative text together into a document that law - professionals can understand. *) +(** This modules weaves the source code and the legislative text together into a + document that law professionals can understand. *) open Utils (** {1 Helpers} *) val wrap_html : - string list -> Cli.backend_lang -> Format.formatter -> (Format.formatter -> unit) -> unit + string list -> + Cli.backend_lang -> + Format.formatter -> + (Format.formatter -> unit) -> + unit (** Usage: [wrap_html source_files language fmt wrapped] Prints an HTML complete page structure around the [wrapped] content. *) (** {1 API} *) -val ast_to_html : Cli.backend_lang -> Format.formatter -> Surface.Ast.program -> unit +val ast_to_html : + Cli.backend_lang -> Format.formatter -> Surface.Ast.program -> unit diff --git a/compiler/literate/latex.ml b/compiler/literate/latex.ml index 5ad3d827..9a9ea118 100644 --- a/compiler/literate/latex.ml +++ b/compiler/literate/latex.ml @@ -1,19 +1,22 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020 Inria, contributors: Denis Merigoux - , Emile Rolley +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, + contributors: Denis Merigoux , Emile Rolley + - 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 + 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 + 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. *) -(** This modules weaves the source code and the legislative text together into a document that law - professionals can understand. *) +(** This modules weaves the source code and the legislative text together into a + document that law professionals can understand. *) open Utils open Literate_common @@ -25,7 +28,9 @@ module C = Cli (** Espaces various LaTeX-sensitive characters *) let pre_latexify (s : string) : string = - let substitute s (old_s, new_s) = R.substitute ~rex:(R.regexp old_s) ~subst:(fun _ -> new_s) s in + let substitute s (old_s, new_s) = + R.substitute ~rex:(R.regexp old_s) ~subst:(fun _ -> new_s) s + in [ ("\\$", "\\$"); ("%", "\\%"); @@ -39,7 +44,10 @@ let pre_latexify (s : string) : string = (** Usage: [wrap_latex source_files custom_pygments language fmt wrapped] Prints an LaTeX complete documùent structure around the [wrapped] content. *) -let wrap_latex (source_files : string list) (language : C.backend_lang) (fmt : Format.formatter) +let wrap_latex + (source_files : string list) + (language : C.backend_lang) + (fmt : Format.formatter) (wrapped : Format.formatter -> unit) = Format.fprintf fmt "\\documentclass[%s, 11pt, a4paper]{article}\n\n\ @@ -83,7 +91,9 @@ let wrap_latex (source_files : string list) (language : C.backend_lang) (fmt : F \\begin{itemize}%s\\end{itemize}\n\n\ \\[\\star\\star\\star\\]\\\\\n" (match language with Fr -> "french" | En -> "english" | Pl -> "polish") - (literal_title language) (literal_generated_by language) Utils.Cli.version + (literal_title language) + (literal_generated_by language) + Utils.Cli.version (literal_source_files language) (String.concat "," (List.map @@ -91,8 +101,10 @@ let wrap_latex (source_files : string list) (language : C.backend_lang) (fmt : F let mtime = (Unix.stat filename).Unix.st_mtime in let ltime = Unix.localtime mtime in let ftime = - Printf.sprintf "%d-%02d-%02d, %d:%02d" (1900 + ltime.Unix.tm_year) - (ltime.Unix.tm_mon + 1) ltime.Unix.tm_mday ltime.Unix.tm_hour ltime.Unix.tm_min + Printf.sprintf "%d-%02d-%02d, %d:%02d" + (1900 + ltime.Unix.tm_year) + (ltime.Unix.tm_mon + 1) ltime.Unix.tm_mday ltime.Unix.tm_hour + ltime.Unix.tm_min in Printf.sprintf "\\item\\texttt{%s}, %s %s" (pre_latexify (Filename.basename filename)) @@ -104,8 +116,9 @@ let wrap_latex (source_files : string list) (language : C.backend_lang) (fmt : F (** {1 Weaving} *) -let rec law_structure_to_latex (language : C.backend_lang) (fmt : Format.formatter) - (i : A.law_structure) : unit = +let rec law_structure_to_latex + (language : C.backend_lang) (fmt : Format.formatter) (i : A.law_structure) : + unit = match i with | A.LawHeading (heading, children) -> Format.fprintf fmt "\\%s*{%s}\n\n" @@ -118,11 +131,16 @@ let rec law_structure_to_latex (language : C.backend_lang) (fmt : Format.formatt (pre_latexify (Pos.unmark heading.law_heading_name)); Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "\n\n") - (law_structure_to_latex language) fmt children + (law_structure_to_latex language) + fmt children | A.LawInclude (A.PdfFile ((file, _), page)) -> - let label = file ^ match page with None -> "" | Some p -> Format.sprintf "_page_%d," p in + let label = + file + ^ match page with None -> "" | Some p -> Format.sprintf "_page_%d," p + in Format.fprintf fmt - "\\begin{center}\\textit{Annexe incluse, retranscrite page \\pageref{%s}}\\end{center} \ + "\\begin{center}\\textit{Annexe incluse, retranscrite page \ + \\pageref{%s}}\\end{center} \ \\begin{figure}[p]\\begin{center}\\includegraphics[%swidth=\\textwidth]{%s}\\label{%s}\\end{center}\\end{figure}" label (match page with None -> "" | Some p -> Format.sprintf "page=%d," p) @@ -137,16 +155,22 @@ let rec law_structure_to_latex (language : C.backend_lang) (fmt : Format.formatt \\end{minted}" (pre_latexify (Filename.basename (Pos.get_file (Pos.get_position c)))) (Pos.get_start_line (Pos.get_position c) - 1) - (get_language_extension language) (Pos.unmark c) + (get_language_extension language) + (Pos.unmark c) | A.CodeBlock (_, c, true) -> let metadata_title = - match language with Fr -> "Métadonnées" | En -> "Metadata" | Pl -> "Metadane" + match language with + | Fr -> "Métadonnées" + | En -> "Metadata" + | Pl -> "Metadane" in Format.fprintf fmt "\\begin{tcolorbox}[colframe=OliveGreen, breakable, \ title=\\textcolor{black}{\\texttt{%s}},title after \ - break=\\textcolor{black}{\\texttt{%s}},before skip=1em, after skip=1em]\n\ - \\begin{minted}[numbersep=9mm, firstnumber=%d, label={\\hspace*{\\fill}\\texttt{%s}}]{%s}\n\ + break=\\textcolor{black}{\\texttt{%s}},before skip=1em, after \ + skip=1em]\n\ + \\begin{minted}[numbersep=9mm, firstnumber=%d, \ + label={\\hspace*{\\fill}\\texttt{%s}}]{%s}\n\ ```catala\n\ %s```\n\ \\end{minted}\n\ @@ -154,11 +178,15 @@ let rec law_structure_to_latex (language : C.backend_lang) (fmt : Format.formatt metadata_title metadata_title (Pos.get_start_line (Pos.get_position c) - 1) (pre_latexify (Filename.basename (Pos.get_file (Pos.get_position c)))) - (get_language_extension language) (Pos.unmark c) + (get_language_extension language) + (Pos.unmark c) (** {1 API} *) -let ast_to_latex (language : C.backend_lang) (fmt : Format.formatter) (program : A.program) : unit = +let ast_to_latex + (language : C.backend_lang) (fmt : Format.formatter) (program : A.program) : + unit = Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "\n\n") - (law_structure_to_latex language) fmt program.program_items + (law_structure_to_latex language) + fmt program.program_items diff --git a/compiler/literate/latex.mli b/compiler/literate/latex.mli index 0fe3765d..236d92f0 100644 --- a/compiler/literate/latex.mli +++ b/compiler/literate/latex.mli @@ -1,30 +1,37 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux - +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, contributor: + Denis Merigoux - 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 + 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 + 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. *) -(** This modules weaves the source code and the legislative text together into a document that law - professionals can understand. *) +(** This modules weaves the source code and the legislative text together into a + document that law professionals can understand. *) open Utils (** {1 Helpers} *) val wrap_latex : - string list -> Cli.backend_lang -> Format.formatter -> (Format.formatter -> unit) -> unit + string list -> + Cli.backend_lang -> + Format.formatter -> + (Format.formatter -> unit) -> + unit (** Usage: [wrap_latex source_files language fmt wrapped] Prints an LaTeX complete documùent structure around the [wrapped] content. *) (** {1 API} *) -val ast_to_latex : Cli.backend_lang -> Format.formatter -> Surface.Ast.program -> unit +val ast_to_latex : + Cli.backend_lang -> Format.formatter -> Surface.Ast.program -> unit diff --git a/compiler/literate/literate_common.ml b/compiler/literate/literate_common.ml index 16e6e767..54325043 100644 --- a/compiler/literate/literate_common.ml +++ b/compiler/literate/literate_common.ml @@ -1,14 +1,17 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020 Inria, contributor: Emile Rolley +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, contributor: + Emile Rolley - 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 + 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 + 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. *) open Utils @@ -34,4 +37,7 @@ let literal_last_modification = function | Fr -> "dernière modification le" | Pl -> "ostatnia modyfikacja" -let get_language_extension = function Fr -> "catala_fr" | En -> "catala_en" | Pl -> "catala_pl" +let get_language_extension = function + | Fr -> "catala_fr" + | En -> "catala_en" + | Pl -> "catala_pl" diff --git a/compiler/literate/literate_common.mli b/compiler/literate/literate_common.mli index 45df12b7..c1a1ccfc 100644 --- a/compiler/literate/literate_common.mli +++ b/compiler/literate/literate_common.mli @@ -1,29 +1,37 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020 Inria, contributor: Emile Rolley +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, contributor: + Emile Rolley - 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 + 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 + 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. *) open Utils val literal_title : Cli.backend_lang -> string -(** Return the title traduction according the given {!type: Utils.Cli.backend_lang}. *) +(** Return the title traduction according the given {!type: + Utils.Cli.backend_lang}. *) val literal_generated_by : Cli.backend_lang -> string -(** Return the 'generated by' traduction according the given {!type: Utils.Cli.backend_lang}. *) +(** Return the 'generated by' traduction according the given {!type: + Utils.Cli.backend_lang}. *) val literal_source_files : Cli.backend_lang -> string -(** Return the 'source files weaved' traduction according the given {!type: Utils.Cli.backend_lang}. *) +(** Return the 'source files weaved' traduction according the given {!type: + Utils.Cli.backend_lang}. *) val literal_last_modification : Cli.backend_lang -> string -(** Return the 'last modification' traduction according the given {!type: Utils.Cli.backend_lang}. *) +(** Return the 'last modification' traduction according the given {!type: + Utils.Cli.backend_lang}. *) val get_language_extension : Cli.backend_lang -> string -(** Return the file extension corresponding to the given {!type: Utils.Cli.backend_lang}. *) +(** Return the file extension corresponding to the given {!type: + Utils.Cli.backend_lang}. *) diff --git a/compiler/runtime.ml b/compiler/runtime.ml index 2537b6b4..6d486c54 100644 --- a/compiler/runtime.ml +++ b/compiler/runtime.ml @@ -1,25 +1,23 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux - , Emile Rolley +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, contributor: + Denis Merigoux , Emile Rolley - 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 + 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 + 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. *) type money = Z.t - type integer = Z.t - type decimal = Q.t - type date = CalendarLib.Date.t - type duration = CalendarLib.Date.Period.t type source_position = { @@ -34,17 +32,11 @@ type source_position = { type 'a eoption = ENone of unit | ESome of 'a exception EmptyError - exception AssertionFailed - exception ConflictError - exception UncomparableDurations - exception IndivisableDurations - exception ImpossibleDate - exception NoValueProvided of source_position type runtime_value = @@ -61,21 +53,13 @@ type runtime_value = | Unembeddable let unembeddable _ = Unembeddable - let embed_unit () = Unit - let embed_bool x = Bool x - let embed_money x = Money x - let embed_integer x = Integer x - let embed_decimal x = Decimal x - let embed_date x = Date x - let embed_duration x = Duration x - let embed_array f x = Array (Array.map f x) type event = @@ -85,9 +69,7 @@ type event = | DecisionTaken of source_position let log_ref : event list ref = ref [] - let reset_log () = log_ref := [] - let retrieve_log () = List.rev !log_ref let log_begin_call info f x = @@ -107,24 +89,17 @@ let log_decision_taken pos x = x let money_of_cents_string (cents : string) : money = Z.of_string cents - let money_of_units_int (units : int) : money = Z.(of_int units * of_int 100) - let money_of_cents_integer (cents : integer) : money = cents - let money_to_float (m : money) : float = Z.to_float m /. 100. let money_to_string (m : money) : string = Format.asprintf "%.2f" Q.(to_float (of_bigint m / of_int 100)) let money_to_cents m = m - let decimal_of_string (d : string) : decimal = Q.of_string d - let decimal_to_float (d : decimal) : float = Q.to_float d - let decimal_of_float (d : float) : decimal = Q.of_float d - let decimal_of_integer (d : integer) : decimal = Q.of_bigint d let decimal_to_string ~(max_prec_digits : int) (i : decimal) : string = @@ -146,7 +121,10 @@ let decimal_to_string ~(max_prec_digits : int) (i : decimal) : string = | `End i -> i | `Begin i -> i in - while !n <> Z.zero && List.length !digits - leading_zeroes !digits < max_prec_digits do + while + !n <> Z.zero + && List.length !digits - leading_zeroes !digits < max_prec_digits + do n := Z.mul !n (Z.of_int 10); digits := Z.ediv !n d :: !digits; n := Z.erem !n d @@ -158,26 +136,22 @@ let decimal_to_string ~(max_prec_digits : int) (i : decimal) : string = ~pp_sep:(fun _fmt () -> ()) (fun fmt digit -> Format.fprintf fmt "%a" Z.pp_print digit)) (List.rev !digits) - (if List.length !digits - leading_zeroes !digits = max_prec_digits then "…" else "") + (if List.length !digits - leading_zeroes !digits = max_prec_digits then "…" + else "") let integer_of_string (s : string) : integer = Z.of_string s - let integer_to_string (i : integer) : string = Z.to_string i - let integer_to_int (i : integer) : int = Z.to_int i - let integer_of_int (i : int) : integer = Z.of_int i - let integer_exponentiation (i : integer) (e : int) : integer = Z.pow i e - let integer_log2 = Z.log2 - let year_of_date (d : date) : integer = Z.of_int (CalendarLib.Date.year d) let month_number_of_date (d : date) : integer = Z.of_int (CalendarLib.Date.int_of_month (CalendarLib.Date.month d)) -let day_of_month_of_date (d : date) : integer = Z.of_int (CalendarLib.Date.day_of_month d) +let day_of_month_of_date (d : date) : integer = + Z.of_int (CalendarLib.Date.day_of_month d) let date_of_numbers (year : int) (month : int) (day : int) : date = try CalendarLib.Date.make year month day with _ -> raise ImpossibleDate @@ -189,7 +163,11 @@ let duration_of_numbers (year : int) (month : int) (day : int) : duration = let duration_to_string (d : duration) : string = let x, y, z = CalendarLib.Date.Period.ymd d in - let to_print = List.filter (fun (a, _) -> a <> 0) [ (x, "years"); (y, "months"); (z, "days") ] in + let to_print = + List.filter + (fun (a, _) -> a <> 0) + [ (x, "years"); (y, "months"); (z, "days") ] + in match to_print with | [] -> "empty duration" | _ -> @@ -199,9 +177,11 @@ let duration_to_string (d : duration) : string = (fun fmt (d, l) -> Format.fprintf fmt "%d %s" d l)) to_print -let duration_to_years_months_days (d : duration) : int * int * int = CalendarLib.Date.Period.ymd d +let duration_to_years_months_days (d : duration) : int * int * int = + CalendarLib.Date.Period.ymd d -let handle_default : 'a. (unit -> 'a) array -> (unit -> bool) -> (unit -> 'a) -> 'a = +let handle_default : + 'a. (unit -> 'a) array -> (unit -> bool) -> (unit -> 'a) -> 'a = fun exceptions just cons -> let except = Array.fold_left @@ -213,9 +193,12 @@ let handle_default : 'a. (unit -> 'a) array -> (unit -> bool) -> (unit -> 'a) -> | Some _, Some _ -> raise ConflictError) None exceptions in - match except with Some x -> x | None -> if just () then cons () else raise EmptyError + match except with + | Some x -> x + | None -> if just () then cons () else raise EmptyError -let handle_default_opt (exceptions : 'a eoption array) (just : bool eoption) (cons : 'a eoption) : +let handle_default_opt + (exceptions : 'a eoption array) (just : bool eoption) (cons : 'a eoption) : 'a eoption = let except = Array.fold_left @@ -228,58 +211,56 @@ let handle_default_opt (exceptions : 'a eoption array) (just : bool eoption) (co in match except with | ESome _ -> except - | ENone _ -> ( match just with ESome b -> if b then cons else ENone () | ENone _ -> ENone ()) + | ENone _ -> ( + match just with + | ESome b -> if b then cons else ENone () + | ENone _ -> ENone ()) let no_input : unit -> 'a = fun _ -> raise EmptyError let ( *$ ) (i1 : money) (i2 : decimal) : money = let rat_result = Q.mul (Q.of_bigint i1) i2 in let res, remainder = Z.div_rem (Q.num rat_result) (Q.den rat_result) in - (* we perform nearest rounding when multiplying an amount of money by a decimal !*) - if Z.(of_int 2 * remainder >= Q.den rat_result) then Z.add res (Z.of_int 1) else res + (* we perform nearest rounding when multiplying an amount of money by a + decimal !*) + if Z.(of_int 2 * remainder >= Q.den rat_result) then Z.add res (Z.of_int 1) + else res let ( /$ ) (m1 : money) (m2 : money) : decimal = - if Z.zero = m2 then raise Division_by_zero else Q.div (Q.of_bigint m1) (Q.of_bigint m2) + if Z.zero = m2 then raise Division_by_zero + else Q.div (Q.of_bigint m1) (Q.of_bigint m2) let ( +$ ) (m1 : money) (m2 : money) : money = Z.add m1 m2 - let ( -$ ) (m1 : money) (m2 : money) : money = Z.sub m1 m2 - let ( ~-$ ) (m1 : money) : money = Z.sub Z.zero m1 - let ( +! ) (i1 : integer) (i2 : integer) : integer = Z.add i1 i2 - let ( -! ) (i1 : integer) (i2 : integer) : integer = Z.sub i1 i2 - let ( ~-! ) (i1 : integer) : integer = Z.sub Z.zero i1 - let ( *! ) (i1 : integer) (i2 : integer) : integer = Z.mul i1 i2 let ( /! ) (i1 : integer) (i2 : integer) : integer = if Z.zero = i2 then raise Division_by_zero else Z.div i1 i2 let ( +& ) (i1 : decimal) (i2 : decimal) : decimal = Q.add i1 i2 - let ( -& ) (i1 : decimal) (i2 : decimal) : decimal = Q.sub i1 i2 - let ( ~-& ) (i1 : decimal) : decimal = Q.sub Q.zero i1 - let ( *& ) (i1 : decimal) (i2 : decimal) : decimal = Q.mul i1 i2 let ( /& ) (i1 : decimal) (i2 : decimal) : decimal = if Q.zero = i2 then raise Division_by_zero else Q.div i1 i2 let ( +@ ) (d1 : date) (d2 : duration) : date = CalendarLib.Date.add d1 d2 - let ( -@ ) (d1 : date) (d2 : date) : duration = CalendarLib.Date.sub d1 d2 -let ( +^ ) (d1 : duration) (d2 : duration) : duration = CalendarLib.Date.Period.add d1 d2 +let ( +^ ) (d1 : duration) (d2 : duration) : duration = + CalendarLib.Date.Period.add d1 d2 -let ( -^ ) (d1 : duration) (d2 : duration) : duration = CalendarLib.Date.Period.sub d1 d2 +let ( -^ ) (d1 : duration) (d2 : duration) : duration = + CalendarLib.Date.Period.sub d1 d2 (* (EmileRolley) NOTE: {!CalendarLib.Date.Period.nb_days} is deprecated, - {!CalendarLib.Date.Period.safe_nb_days} should be used. But the current {!duration} is greater - that the supported polymorphic variants.*) + {!CalendarLib.Date.Period.safe_nb_days} should be used. But the current + {!duration} is greater that the supported polymorphic variants.*) let ( /^ ) (d1 : duration) (d2 : duration) : decimal = try let nb_day1 = CalendarLib.Date.Period.nb_days d1 in @@ -288,46 +269,28 @@ let ( /^ ) (d1 : duration) (d2 : duration) : decimal = with CalendarLib.Date.Period.Not_computable -> raise IndivisableDurations let ( <=$ ) (m1 : money) (m2 : money) : bool = Z.compare m1 m2 <= 0 - let ( >=$ ) (m1 : money) (m2 : money) : bool = Z.compare m1 m2 >= 0 - let ( <$ ) (m1 : money) (m2 : money) : bool = Z.compare m1 m2 < 0 - let ( >$ ) (m1 : money) (m2 : money) : bool = Z.compare m1 m2 > 0 - let ( =$ ) (m1 : money) (m2 : money) : bool = Z.compare m1 m2 = 0 - let ( >=! ) (i1 : integer) (i2 : integer) : bool = Z.compare i1 i2 >= 0 - let ( <=! ) (i1 : integer) (i2 : integer) : bool = Z.compare i1 i2 <= 0 - let ( >! ) (i1 : integer) (i2 : integer) : bool = Z.compare i1 i2 > 0 - let ( =& ) (i1 : decimal) (i2 : decimal) : bool = Q.compare i1 i2 >= 0 - let ( <=& ) (i1 : decimal) (i2 : decimal) : bool = Q.compare i1 i2 <= 0 - let ( >& ) (i1 : decimal) (i2 : decimal) : bool = Q.compare i1 i2 > 0 - let ( <& ) (i1 : decimal) (i2 : decimal) : bool = Q.compare i1 i2 < 0 - let ( =& ) (i1 : decimal) (i2 : decimal) : bool = Q.compare i1 i2 = 0 - let ( >=@ ) (d1 : date) (d2 : date) : bool = CalendarLib.Date.compare d1 d2 >= 0 - let ( <=@ ) (d1 : date) (d2 : date) : bool = CalendarLib.Date.compare d1 d2 <= 0 - let ( >@ ) (d1 : date) (d2 : date) : bool = CalendarLib.Date.compare d1 d2 > 0 - let ( <@ ) (d1 : date) (d2 : date) : bool = CalendarLib.Date.compare d1 d2 < 0 - let ( =@ ) (d1 : date) (d2 : date) : bool = CalendarLib.Date.compare d1 d2 = 0 -let compare_periods (p1 : CalendarLib.Date.Period.t) (p2 : CalendarLib.Date.Period.t) : int = +let compare_periods + (p1 : CalendarLib.Date.Period.t) (p2 : CalendarLib.Date.Period.t) : int = try let p1_days = CalendarLib.Date.Period.nb_days p1 in let p2_days = CalendarLib.Date.Period.nb_days p2 in @@ -335,15 +298,10 @@ let compare_periods (p1 : CalendarLib.Date.Period.t) (p2 : CalendarLib.Date.Peri with CalendarLib.Date.Period.Not_computable -> raise UncomparableDurations let ( >=^ ) (d1 : duration) (d2 : duration) : bool = compare_periods d1 d2 >= 0 - let ( <=^ ) (d1 : duration) (d2 : duration) : bool = compare_periods d1 d2 <= 0 - let ( >^ ) (d1 : duration) (d2 : duration) : bool = compare_periods d1 d2 > 0 - let ( <^ ) (d1 : duration) (d2 : duration) : bool = compare_periods d1 d2 < 0 - let ( =^ ) (d1 : duration) (d2 : duration) : bool = compare_periods d1 d2 = 0 - let ( ~-^ ) (d1 : duration) : duration = CalendarLib.Date.Period.opp d1 let array_filter (f : 'a -> bool) (a : 'a array) : 'a array = diff --git a/compiler/runtime.mli b/compiler/runtime.mli index af955937..23156990 100644 --- a/compiler/runtime.mli +++ b/compiler/runtime.mli @@ -1,27 +1,26 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020 Inria, contributors: Denis Merigoux - , Emile Rolley +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, + contributors: Denis Merigoux , Emile Rolley + - 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 + 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 + 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. *) (** {1 Types} *) type money - type integer - type decimal - type date - type duration type source_position = { @@ -38,17 +37,11 @@ type 'a eoption = ENone of unit | ESome of 'a (** {1 Exceptions} *) exception EmptyError - exception AssertionFailed - exception ConflictError - exception UncomparableDurations - exception IndivisableDurations - exception ImpossibleDate - exception NoValueProvided of source_position (** {1 Value Embedding} *) @@ -67,21 +60,13 @@ type runtime_value = | Unembeddable val unembeddable : 'a -> runtime_value - val embed_unit : unit -> runtime_value - val embed_bool : bool -> runtime_value - val embed_money : money -> runtime_value - val embed_integer : integer -> runtime_value - val embed_decimal : decimal -> runtime_value - val embed_date : date -> runtime_value - val embed_duration : duration -> runtime_value - val embed_array : ('a -> runtime_value) -> 'a Array.t -> runtime_value (** {1 Logging} *) @@ -93,15 +78,10 @@ type event = | DecisionTaken of source_position val reset_log : unit -> unit - val retrieve_log : unit -> event list - val log_begin_call : string list -> ('a -> 'b) -> 'a -> 'b - val log_end_call : string list -> 'a -> 'a - val log_variable_definition : string list -> ('a -> runtime_value) -> 'a -> 'a - val log_decision_taken : source_position -> bool -> bool (**{1 Constructors and conversions} *) @@ -109,51 +89,34 @@ val log_decision_taken : source_position -> bool -> bool (**{2 Money}*) val money_of_cents_string : string -> money - val money_of_units_int : int -> money - val money_of_cents_integer : integer -> money - val money_to_float : money -> float - val money_to_string : money -> string - val money_to_cents : money -> integer (** {2 Decimals} *) val decimal_of_string : string -> decimal - val decimal_to_string : max_prec_digits:int -> decimal -> string - val decimal_of_integer : integer -> decimal - val decimal_of_float : float -> decimal - val decimal_to_float : decimal -> float (**{2 Integers} *) val integer_of_string : string -> integer - val integer_to_string : integer -> string - val integer_to_int : integer -> int - val integer_of_int : int -> integer - val integer_log2 : integer -> int - val integer_exponentiation : integer -> int -> integer (**{2 Dates} *) val day_of_month_of_date : date -> integer - val month_number_of_date : date -> integer - val year_of_date : date -> integer - val date_to_string : date -> string val date_of_numbers : int -> int -> int -> date @@ -164,9 +127,7 @@ val date_of_numbers : int -> int -> int -> date (**{2 Durations} *) val duration_of_numbers : int -> int -> int -> duration - val duration_to_years_months_days : duration -> int * int * int - val duration_to_string : duration -> string (**{1 Defaults} *) @@ -175,7 +136,8 @@ val handle_default : (unit -> 'a) array -> (unit -> bool) -> (unit -> 'a) -> 'a (** @raise EmptyError @raise ConflictError *) -val handle_default_opt : 'a eoption array -> bool eoption -> 'a eoption -> 'a eoption +val handle_default_opt : + 'a eoption array -> bool eoption -> 'a eoption -> 'a eoption (** @raise ConflictError *) val no_input : unit -> 'a @@ -190,87 +152,59 @@ val ( /$ ) : money -> money -> decimal (** @raise Division_by_zero *) val ( +$ ) : money -> money -> money - val ( -$ ) : money -> money -> money - val ( ~-$ ) : money -> money - val ( =$ ) : money -> money -> bool - val ( <=$ ) : money -> money -> bool - val ( >=$ ) : money -> money -> bool - val ( <$ ) : money -> money -> bool - val ( >$ ) : money -> money -> bool (**{2 Integers} *) val ( +! ) : integer -> integer -> integer - val ( -! ) : integer -> integer -> integer - val ( ~-! ) : integer -> integer - val ( *! ) : integer -> integer -> integer val ( /! ) : integer -> integer -> integer (** @raise Division_by_zero *) val ( =! ) : integer -> integer -> bool - val ( >=! ) : integer -> integer -> bool - val ( <=! ) : integer -> integer -> bool - val ( >! ) : integer -> integer -> bool - val ( integer -> bool (** {2 Decimals} *) val ( +& ) : decimal -> decimal -> decimal - val ( -& ) : decimal -> decimal -> decimal - val ( ~-& ) : decimal -> decimal - val ( *& ) : decimal -> decimal -> decimal val ( /& ) : decimal -> decimal -> decimal (** @raise Division_by_zero *) val ( =& ) : decimal -> decimal -> bool - val ( >=& ) : decimal -> decimal -> bool - val ( <=& ) : decimal -> decimal -> bool - val ( >& ) : decimal -> decimal -> bool - val ( <& ) : decimal -> decimal -> bool (** {2 Dates} *) val ( +@ ) : date -> duration -> date - val ( -@ ) : date -> date -> duration - val ( =@ ) : date -> date -> bool - val ( >=@ ) : date -> date -> bool - val ( <=@ ) : date -> date -> bool - val ( >@ ) : date -> date -> bool - val ( <@ ) : date -> date -> bool (** {2 Durations} *) val ( +^ ) : duration -> duration -> duration - val ( -^ ) : duration -> duration -> duration val ( /^ ) : duration -> duration -> decimal @@ -278,7 +212,6 @@ val ( /^ ) : duration -> duration -> decimal @raise IndivisableDurations *) val ( ~-^ ) : duration -> duration - val ( =^ ) : duration -> duration -> bool val ( >=^ ) : duration -> duration -> bool @@ -296,5 +229,4 @@ val ( <^ ) : duration -> duration -> bool (** {2 Arrays} *) val array_filter : ('a -> bool) -> 'a array -> 'a array - val array_length : 'a array -> integer diff --git a/compiler/scalc/ast.ml b/compiler/scalc/ast.ml index 6c9c4ae1..da3ddb4e 100644 --- a/compiler/scalc/ast.ml +++ b/compiler/scalc/ast.ml @@ -1,23 +1,23 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2021 Inria, contributor: Denis Merigoux - +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2021 Inria, contributor: + Denis Merigoux - 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 + 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 + 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. *) open Utils module D = Dcalc.Ast module L = Lcalc.Ast - module TopLevelName = Uid.Make (Uid.MarkedString) () - module LocalName = Uid.Make (Uid.MarkedString) () type expr = @@ -49,7 +49,10 @@ type stmt = and block = stmt Pos.marked list -and func = { func_params : (LocalName.t Pos.marked * D.typ Pos.marked) list; func_body : block } +and func = { + func_params : (LocalName.t Pos.marked * D.typ Pos.marked) list; + func_body : block; +} type scope_body = { scope_body_name : Dcalc.Ast.ScopeName.t; diff --git a/compiler/scalc/compile_from_lambda.ml b/compiler/scalc/compile_from_lambda.ml index 32bb53a2..a02512d6 100644 --- a/compiler/scalc/compile_from_lambda.ml +++ b/compiler/scalc/compile_from_lambda.ml @@ -1,15 +1,17 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2021 Inria, contributor: Denis Merigoux - +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2021 Inria, contributor: + Denis Merigoux - 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 + 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 + 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. *) open Utils @@ -24,14 +26,16 @@ type ctxt = { inside_definition_of : A.LocalName.t option; } -(* Expressions can spill out side effect, hence this function also returns a list of statements to - be prepended before the expression is evaluated *) -let rec translate_expr (ctxt : ctxt) (expr : L.expr Pos.marked) : A.block * A.expr Pos.marked = +(* Expressions can spill out side effect, hence this function also returns a + list of statements to be prepended before the expression is evaluated *) +let rec translate_expr (ctxt : ctxt) (expr : L.expr Pos.marked) : + A.block * A.expr Pos.marked = match Pos.unmark expr with | L.EVar v -> let local_var = try A.EVar (L.VarMap.find (Pos.unmark v) ctxt.var_dict) - with Not_found -> A.EFunc (L.VarMap.find (Pos.unmark v) ctxt.func_dict) + with Not_found -> + A.EFunc (L.VarMap.find (Pos.unmark v) ctxt.func_dict) in ([], (local_var, Pos.get_position v)) | L.ETuple (args, Some s_name) -> @@ -45,17 +49,26 @@ let rec translate_expr (ctxt : ctxt) (expr : L.expr Pos.marked) : A.block * A.ex let new_args = List.rev new_args in let args_stmts = List.rev args_stmts in (args_stmts, (A.EStruct (new_args, s_name), Pos.get_position expr)) - | L.ETuple (_, None) -> failwith "Non-struct tuples cannot be compiled to scalc" + | L.ETuple (_, None) -> + failwith "Non-struct tuples cannot be compiled to scalc" | L.ETupleAccess (e1, num_field, Some s_name, _) -> let e1_stmts, new_e1 = translate_expr ctxt e1 in let field_name = - fst (List.nth (D.StructMap.find s_name ctxt.decl_ctx.ctx_structs) num_field) + fst + (List.nth + (D.StructMap.find s_name ctxt.decl_ctx.ctx_structs) + num_field) in - (e1_stmts, (A.EStructFieldAccess (new_e1, field_name, s_name), Pos.get_position expr)) - | L.ETupleAccess (_, _, None, _) -> failwith "Non-struct tuples cannot be compiled to scalc" + ( e1_stmts, + ( A.EStructFieldAccess (new_e1, field_name, s_name), + Pos.get_position expr ) ) + | L.ETupleAccess (_, _, None, _) -> + failwith "Non-struct tuples cannot be compiled to scalc" | L.EInj (e1, num_cons, e_name, _) -> let e1_stmts, new_e1 = translate_expr ctxt e1 in - let cons_name = fst (List.nth (D.EnumMap.find e_name ctxt.decl_ctx.ctx_enums) num_cons) in + let cons_name = + fst (List.nth (D.EnumMap.find e_name ctxt.decl_ctx.ctx_enums) num_cons) + in (e1_stmts, (A.EInj (new_e1, cons_name, e_name), Pos.get_position expr)) | L.EApp (f, args) -> let f_stmts, new_f = translate_expr ctxt f in @@ -84,14 +97,18 @@ let rec translate_expr (ctxt : ctxt) (expr : L.expr Pos.marked) : A.block * A.ex let tmp_var = A.LocalName.fresh ("local_var", Pos.get_position expr) in let ctxt = { ctxt with inside_definition_of = Some tmp_var } in let tmp_stmts = translate_statements ctxt expr in - ( ( A.SLocalDecl ((tmp_var, Pos.get_position expr), (D.TAny, Pos.get_position expr)), + ( ( A.SLocalDecl + ((tmp_var, Pos.get_position expr), (D.TAny, Pos.get_position expr)), Pos.get_position expr ) :: tmp_stmts, (A.EVar tmp_var, Pos.get_position expr) ) -and translate_statements (ctxt : ctxt) (block_expr : L.expr Pos.marked) : A.block = +and translate_statements (ctxt : ctxt) (block_expr : L.expr Pos.marked) : + A.block = match Pos.unmark block_expr with - | L.EApp ((L.EAbs ((binder, _), [ (D.TLit D.TUnit, _) ]), _), [ (L.EAssert e, _) ]) -> + | L.EApp + ((L.EAbs ((binder, _), [ (D.TLit D.TUnit, _) ]), _), [ (L.EAssert e, _) ]) + -> (* Assertions are always encapsulated in a unit-typed let binding *) let _, body = Bindlib.unmbind binder in let e_stmts, new_e = translate_expr ctxt e in @@ -101,32 +118,40 @@ and translate_statements (ctxt : ctxt) (block_expr : L.expr Pos.marked) : A.bloc | L.EApp ((L.EAbs ((binder, binder_pos), taus), eabs_pos), args) -> (* This defines multiple local variables at the time *) let vars, body = Bindlib.unmbind binder in - let vars_tau = List.map2 (fun x tau -> (x, tau)) (Array.to_list vars) taus in + let vars_tau = + List.map2 (fun x tau -> (x, tau)) (Array.to_list vars) taus + in let ctxt = { ctxt with var_dict = List.fold_left (fun var_dict (x, _) -> - L.VarMap.add x (A.LocalName.fresh (Bindlib.name_of x, binder_pos)) var_dict) + L.VarMap.add x + (A.LocalName.fresh (Bindlib.name_of x, binder_pos)) + var_dict) ctxt.var_dict vars_tau; } in let local_decls = List.map (fun (x, tau) -> - (A.SLocalDecl ((L.VarMap.find x ctxt.var_dict, binder_pos), tau), eabs_pos)) + ( A.SLocalDecl ((L.VarMap.find x ctxt.var_dict, binder_pos), tau), + eabs_pos )) vars_tau in let vars_args = List.map2 - (fun (x, tau) arg -> ((L.VarMap.find x ctxt.var_dict, binder_pos), tau, arg)) + (fun (x, tau) arg -> + ((L.VarMap.find x ctxt.var_dict, binder_pos), tau, arg)) vars_tau args in let def_blocks = List.map (fun (x, _tau, arg) -> - let ctxt = { ctxt with inside_definition_of = Some (Pos.unmark x) } in + let ctxt = + { ctxt with inside_definition_of = Some (Pos.unmark x) } + in let arg_stmts, new_arg = translate_expr ctxt arg in arg_stmts @ [ (A.SLocalDef (x, new_arg), binder_pos) ]) vars_args @@ -135,7 +160,9 @@ and translate_statements (ctxt : ctxt) (block_expr : L.expr Pos.marked) : A.bloc local_decls @ List.flatten def_blocks @ rest_of_block | L.EAbs ((binder, binder_pos), taus) -> let vars, body = Bindlib.unmbind binder in - let vars_tau = List.map2 (fun x tau -> (x, tau)) (Array.to_list vars) taus in + let vars_tau = + List.map2 (fun x tau -> (x, tau)) (Array.to_list vars) taus + in let closure_name = match ctxt.inside_definition_of with | None -> A.LocalName.fresh ("closure", Pos.get_position block_expr) @@ -147,7 +174,9 @@ and translate_statements (ctxt : ctxt) (block_expr : L.expr Pos.marked) : A.bloc var_dict = List.fold_left (fun var_dict (x, _) -> - L.VarMap.add x (A.LocalName.fresh (Bindlib.name_of x, binder_pos)) var_dict) + L.VarMap.add x + (A.LocalName.fresh (Bindlib.name_of x, binder_pos)) + var_dict) ctxt.var_dict vars_tau; inside_definition_of = None; } @@ -159,7 +188,8 @@ and translate_statements (ctxt : ctxt) (block_expr : L.expr Pos.marked) : A.bloc { func_params = List.map - (fun (var, tau) -> ((L.VarMap.find var ctxt.var_dict, binder_pos), tau)) + (fun (var, tau) -> + ((L.VarMap.find var ctxt.var_dict, binder_pos), tau)) vars_tau; func_body = new_body; } ), @@ -175,8 +205,15 @@ and translate_statements (ctxt : ctxt) (block_expr : L.expr Pos.marked) : A.bloc let vars, body = Bindlib.unmbind binder in assert (Array.length vars = 1); let var = vars.(0) in - let scalc_var = A.LocalName.fresh (Bindlib.name_of var, pos_binder) in - let ctxt = { ctxt with var_dict = L.VarMap.add var scalc_var ctxt.var_dict } in + let scalc_var = + A.LocalName.fresh (Bindlib.name_of var, pos_binder) + in + let ctxt = + { + ctxt with + var_dict = L.VarMap.add var scalc_var ctxt.var_dict; + } + in let new_arg = translate_statements ctxt body in (new_arg, scalc_var) :: new_args | _ -> assert false @@ -184,16 +221,23 @@ and translate_statements (ctxt : ctxt) (block_expr : L.expr Pos.marked) : A.bloc [] args in let new_args = List.rev new_args in - e1_stmts @ [ (A.SSwitch (new_e1, e_name, new_args), Pos.get_position block_expr) ] + e1_stmts + @ [ (A.SSwitch (new_e1, e_name, new_args), Pos.get_position block_expr) ] | L.EIfThenElse (cond, e_true, e_false) -> let cond_stmts, s_cond = translate_expr ctxt cond in let s_e_true = translate_statements ctxt e_true in let s_e_false = translate_statements ctxt e_false in - cond_stmts @ [ (A.SIfThenElse (s_cond, s_e_true, s_e_false), Pos.get_position block_expr) ] + cond_stmts + @ [ + ( A.SIfThenElse (s_cond, s_e_true, s_e_false), + Pos.get_position block_expr ); + ] | L.ECatch (e_try, except, e_catch) -> let s_e_try = translate_statements ctxt e_try in let s_e_catch = translate_statements ctxt e_catch in - [ (A.STryExcept (s_e_try, except, s_e_catch), Pos.get_position block_expr) ] + [ + (A.STryExcept (s_e_try, except, s_e_catch), Pos.get_position block_expr); + ] | L.ERaise except -> [ (A.SRaise except, Pos.get_position block_expr) ] | _ -> ( let e_stmts, new_e = translate_expr ctxt block_expr in @@ -201,8 +245,9 @@ and translate_statements (ctxt : ctxt) (block_expr : L.expr Pos.marked) : A.bloc @ match e_stmts with | (A.SRaise _, _) :: _ -> - (* if the last statement raises an exception, then we don't need to return or to define - the current variable since this code will be unreachable *) + (* if the last statement raises an exception, then we don't need to + return or to define the current variable since this code will be + unreachable *) [] | _ -> [ @@ -212,16 +257,20 @@ and translate_statements (ctxt : ctxt) (block_expr : L.expr Pos.marked) : A.bloc Pos.get_position block_expr ); ]) -let translate_scope (decl_ctx : D.decl_ctx) (func_dict : A.TopLevelName.t L.VarMap.t) - (scope_expr : L.expr Pos.marked) : (A.LocalName.t Pos.marked * D.typ Pos.marked) list * A.block - = +let translate_scope + (decl_ctx : D.decl_ctx) + (func_dict : A.TopLevelName.t L.VarMap.t) + (scope_expr : L.expr Pos.marked) : + (A.LocalName.t Pos.marked * D.typ Pos.marked) list * A.block = match Pos.unmark scope_expr with | L.EAbs ((binder, binder_pos), typs) -> let vars, body = Bindlib.unmbind binder in let var_dict = Array.fold_left (fun var_dict var -> - L.VarMap.add var (A.LocalName.fresh (Bindlib.name_of var, binder_pos)) var_dict) + L.VarMap.add var + (A.LocalName.fresh (Bindlib.name_of var, binder_pos)) + var_dict) L.VarMap.empty vars in let param_list = @@ -230,7 +279,9 @@ let translate_scope (decl_ctx : D.decl_ctx) (func_dict : A.TopLevelName.t L.VarM (Array.to_list vars) typs in let new_body = - translate_statements { decl_ctx; func_dict; var_dict; inside_definition_of = None } body + translate_statements + { decl_ctx; func_dict; var_dict; inside_definition_of = None } + body in (param_list, new_body) | _ -> assert false @@ -244,18 +295,25 @@ let translate_program (p : L.program) : A.program = List.fold_left (fun (func_dict, new_scopes) body -> let new_scope_params, new_scope_body = - translate_scope p.decl_ctx func_dict body.Lcalc.Ast.scope_body_expr + translate_scope p.decl_ctx func_dict + body.Lcalc.Ast.scope_body_expr in let func_id = - A.TopLevelName.fresh (Bindlib.name_of body.Lcalc.Ast.scope_body_var, Pos.no_pos) + A.TopLevelName.fresh + (Bindlib.name_of body.Lcalc.Ast.scope_body_var, Pos.no_pos) + in + let func_dict = + L.VarMap.add body.Lcalc.Ast.scope_body_var func_id func_dict in - let func_dict = L.VarMap.add body.Lcalc.Ast.scope_body_var func_id func_dict in ( func_dict, { Ast.scope_body_name = body.Lcalc.Ast.scope_body_name; Ast.scope_body_var = func_id; scope_body_func = - { A.func_params = new_scope_params; A.func_body = new_scope_body }; + { + A.func_params = new_scope_params; + A.func_body = new_scope_body; + }; } :: new_scopes )) ( (if !Cli.avoid_exceptions_flag then diff --git a/compiler/scalc/print.ml b/compiler/scalc/print.ml index 11667747..e5390757 100644 --- a/compiler/scalc/print.ml +++ b/compiler/scalc/print.ml @@ -1,15 +1,17 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2022 Inria, contributor: Denis Merigoux - +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2022 Inria, contributor: + Denis Merigoux - 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 + 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 + 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. *) open Utils @@ -18,15 +20,19 @@ open Ast let needs_parens (_e : expr Pos.marked) : bool = false let format_local_name (fmt : Format.formatter) (v : LocalName.t) : unit = - Format.fprintf fmt "%a_%s" LocalName.format_t v (string_of_int (LocalName.hash v)) + Format.fprintf fmt "%a_%s" LocalName.format_t v + (string_of_int (LocalName.hash v)) -let rec format_expr (decl_ctx : Dcalc.Ast.decl_ctx) ?(debug : bool = false) (fmt : Format.formatter) +let rec format_expr + (decl_ctx : Dcalc.Ast.decl_ctx) + ?(debug : bool = false) + (fmt : Format.formatter) (e : expr Pos.marked) : unit = let format_expr = format_expr decl_ctx ~debug in let format_with_parens (fmt : Format.formatter) (e : expr Pos.marked) = if needs_parens e then - Format.fprintf fmt "%a%a%a" Dcalc.Print.format_punctuation "(" format_expr e - Dcalc.Print.format_punctuation ")" + Format.fprintf fmt "%a%a%a" Dcalc.Print.format_punctuation "(" format_expr + e Dcalc.Print.format_punctuation ")" else Format.fprintf fmt "%a" format_expr e in match Pos.unmark e with @@ -38,10 +44,12 @@ let rec format_expr (decl_ctx : Dcalc.Ast.decl_ctx) ?(debug : bool = false) (fmt (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ") (fun fmt (e, struct_field) -> - Format.fprintf fmt "%a%a%a%a %a" Dcalc.Print.format_punctuation "\"" - Dcalc.Ast.StructFieldName.format_t struct_field Dcalc.Print.format_punctuation "\"" + Format.fprintf fmt "%a%a%a%a %a" Dcalc.Print.format_punctuation + "\"" Dcalc.Ast.StructFieldName.format_t struct_field + Dcalc.Print.format_punctuation "\"" Dcalc.Print.format_punctuation ":" format_expr e)) - (List.combine es (List.map fst (Dcalc.Ast.StructMap.find s decl_ctx.ctx_structs))) + (List.combine es + (List.map fst (Dcalc.Ast.StructMap.find s decl_ctx.ctx_structs))) Dcalc.Print.format_punctuation "}" | EArray es -> Format.fprintf fmt "@[%a%a%a@]" Dcalc.Print.format_punctuation "[" @@ -50,76 +58,103 @@ let rec format_expr (decl_ctx : Dcalc.Ast.decl_ctx) ?(debug : bool = false) (fmt (fun fmt e -> Format.fprintf fmt "%a" format_expr e)) es Dcalc.Print.format_punctuation "]" | EStructFieldAccess (e1, field, s) -> - Format.fprintf fmt "%a%a%a%a%a" format_expr e1 Dcalc.Print.format_punctuation "." - Dcalc.Print.format_punctuation "\"" Dcalc.Ast.StructFieldName.format_t + Format.fprintf fmt "%a%a%a%a%a" format_expr e1 + Dcalc.Print.format_punctuation "." Dcalc.Print.format_punctuation "\"" + Dcalc.Ast.StructFieldName.format_t (fst (List.find - (fun (field', _) -> Dcalc.Ast.StructFieldName.compare field' field = 0) + (fun (field', _) -> + Dcalc.Ast.StructFieldName.compare field' field = 0) (Dcalc.Ast.StructMap.find s decl_ctx.ctx_structs))) Dcalc.Print.format_punctuation "\"" | EInj (e, case, enum) -> Format.fprintf fmt "@[%a@ %a@]" Dcalc.Print.format_enum_constructor (fst (List.find - (fun (case', _) -> Dcalc.Ast.EnumConstructor.compare case' case = 0) + (fun (case', _) -> + Dcalc.Ast.EnumConstructor.compare case' case = 0) (Dcalc.Ast.EnumMap.find enum decl_ctx.ctx_enums))) format_expr e - | ELit l -> Format.fprintf fmt "%a" Lcalc.Print.format_lit (Pos.same_pos_as l e) - | EApp ((EOp (Binop ((Dcalc.Ast.Map | Dcalc.Ast.Filter) as op)), _), [ arg1; arg2 ]) -> - Format.fprintf fmt "@[%a@ %a@ %a@]" Dcalc.Print.format_binop (op, Pos.no_pos) - format_with_parens arg1 format_with_parens arg2 + | ELit l -> + Format.fprintf fmt "%a" Lcalc.Print.format_lit (Pos.same_pos_as l e) + | EApp + ( (EOp (Binop ((Dcalc.Ast.Map | Dcalc.Ast.Filter) as op)), _), + [ arg1; arg2 ] ) -> + Format.fprintf fmt "@[%a@ %a@ %a@]" Dcalc.Print.format_binop + (op, Pos.no_pos) format_with_parens arg1 format_with_parens arg2 | EApp ((EOp (Binop op), _), [ arg1; arg2 ]) -> - Format.fprintf fmt "@[%a@ %a@ %a@]" format_with_parens arg1 Dcalc.Print.format_binop - (op, Pos.no_pos) format_with_parens arg2 + Format.fprintf fmt "@[%a@ %a@ %a@]" format_with_parens arg1 + Dcalc.Print.format_binop (op, Pos.no_pos) format_with_parens arg2 | EApp ((EOp (Unop (Log _)), _), [ arg1 ]) when not debug -> Format.fprintf fmt "%a" format_with_parens arg1 | EApp ((EOp (Unop op), _), [ arg1 ]) -> - Format.fprintf fmt "@[%a@ %a@]" Dcalc.Print.format_unop (op, Pos.no_pos) - format_with_parens arg1 + Format.fprintf fmt "@[%a@ %a@]" Dcalc.Print.format_unop + (op, Pos.no_pos) format_with_parens arg1 | EApp (f, args) -> Format.fprintf fmt "@[%a@ %a@]" format_expr f - (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ") format_with_parens) + (Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ") + format_with_parens) args - | EOp (Ternop op) -> Format.fprintf fmt "%a" Dcalc.Print.format_ternop (op, Pos.no_pos) - | EOp (Binop op) -> Format.fprintf fmt "%a" Dcalc.Print.format_binop (op, Pos.no_pos) - | EOp (Unop op) -> Format.fprintf fmt "%a" Dcalc.Print.format_unop (op, Pos.no_pos) + | EOp (Ternop op) -> + Format.fprintf fmt "%a" Dcalc.Print.format_ternop (op, Pos.no_pos) + | EOp (Binop op) -> + Format.fprintf fmt "%a" Dcalc.Print.format_binop (op, Pos.no_pos) + | EOp (Unop op) -> + Format.fprintf fmt "%a" Dcalc.Print.format_unop (op, Pos.no_pos) -let rec format_statement (decl_ctx : Dcalc.Ast.decl_ctx) ?(debug : bool = false) - (fmt : Format.formatter) (stmt : stmt Pos.marked) : unit = +let rec format_statement + (decl_ctx : Dcalc.Ast.decl_ctx) + ?(debug : bool = false) + (fmt : Format.formatter) + (stmt : stmt Pos.marked) : unit = if debug then () else (); match Pos.unmark stmt with | SInnerFuncDef (name, func) -> - Format.fprintf fmt "@[%a@ %a@ %a@ %a@]@\n@[ %a@]" Dcalc.Print.format_keyword - "let" LocalName.format_t (Pos.unmark name) + Format.fprintf fmt "@[%a@ %a@ %a@ %a@]@\n@[ %a@]" + Dcalc.Print.format_keyword "let" LocalName.format_t (Pos.unmark name) (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ") (fun fmt ((name, _), typ) -> - Format.fprintf fmt "%a%a %a@ %a%a" Dcalc.Print.format_punctuation "(" - LocalName.format_t name Dcalc.Print.format_punctuation ":" - (Dcalc.Print.format_typ decl_ctx) typ Dcalc.Print.format_punctuation ")")) - func.func_params Dcalc.Print.format_punctuation "=" (format_block decl_ctx ~debug) + Format.fprintf fmt "%a%a %a@ %a%a" Dcalc.Print.format_punctuation + "(" LocalName.format_t name Dcalc.Print.format_punctuation ":" + (Dcalc.Print.format_typ decl_ctx) + typ Dcalc.Print.format_punctuation ")")) + func.func_params Dcalc.Print.format_punctuation "=" + (format_block decl_ctx ~debug) func.func_body | SLocalDecl (name, typ) -> - Format.fprintf fmt "@[%a %a %a@ %a@]" Dcalc.Print.format_keyword "decl" - LocalName.format_t (Pos.unmark name) Dcalc.Print.format_punctuation ":" - (Dcalc.Print.format_typ decl_ctx) typ + Format.fprintf fmt "@[%a %a %a@ %a@]" Dcalc.Print.format_keyword + "decl" LocalName.format_t (Pos.unmark name) + Dcalc.Print.format_punctuation ":" + (Dcalc.Print.format_typ decl_ctx) + typ | SLocalDef (name, expr) -> - Format.fprintf fmt "@[%a %a@ %a@]" LocalName.format_t (Pos.unmark name) - Dcalc.Print.format_punctuation "=" (format_expr decl_ctx ~debug) expr + Format.fprintf fmt "@[%a %a@ %a@]" LocalName.format_t + (Pos.unmark name) Dcalc.Print.format_punctuation "=" + (format_expr decl_ctx ~debug) + expr | STryExcept (b_try, except, b_with) -> - Format.fprintf fmt "@[%a%a@ %a@]@\n@[%a %a%a@ %a@]" Dcalc.Print.format_keyword "try" - Dcalc.Print.format_punctuation ":" (format_block decl_ctx ~debug) b_try - Dcalc.Print.format_keyword "with" Lcalc.Print.format_exception except - Dcalc.Print.format_punctuation ":" (format_block decl_ctx ~debug) b_with + Format.fprintf fmt "@[%a%a@ %a@]@\n@[%a %a%a@ %a@]" + Dcalc.Print.format_keyword "try" Dcalc.Print.format_punctuation ":" + (format_block decl_ctx ~debug) + b_try Dcalc.Print.format_keyword "with" Lcalc.Print.format_exception + except Dcalc.Print.format_punctuation ":" + (format_block decl_ctx ~debug) + b_with | SRaise except -> Format.fprintf fmt "@[%a %a@]" Dcalc.Print.format_keyword "raise" Lcalc.Print.format_exception except | SIfThenElse (e_if, b_true, b_false) -> Format.fprintf fmt "@[%a @[%a@]%a@ %a@ @]@[%a%a@ %a@]" - Dcalc.Print.format_keyword "if" (format_expr decl_ctx ~debug) e_if - Dcalc.Print.format_punctuation ":" (format_block decl_ctx ~debug) b_true - Dcalc.Print.format_keyword "else" Dcalc.Print.format_punctuation ":" - (format_block decl_ctx ~debug) b_false + Dcalc.Print.format_keyword "if" + (format_expr decl_ctx ~debug) + e_if Dcalc.Print.format_punctuation ":" + (format_block decl_ctx ~debug) + b_true Dcalc.Print.format_keyword "else" Dcalc.Print.format_punctuation + ":" + (format_block decl_ctx ~debug) + b_false | SReturn ret -> Format.fprintf fmt "@[%a %a@]" Dcalc.Print.format_keyword "return" (format_expr decl_ctx ~debug) @@ -129,34 +164,48 @@ let rec format_statement (decl_ctx : Dcalc.Ast.decl_ctx) ?(debug : bool = false) (format_expr decl_ctx ~debug) (expr, Pos.get_position stmt) | SSwitch (e_switch, enum, arms) -> - Format.fprintf fmt "@[%a @[%a@]%a@]%a" Dcalc.Print.format_keyword "switch" - (format_expr decl_ctx ~debug) e_switch Dcalc.Print.format_punctuation ":" + Format.fprintf fmt "@[%a @[%a@]%a@]%a" + Dcalc.Print.format_keyword "switch" + (format_expr decl_ctx ~debug) + e_switch Dcalc.Print.format_punctuation ":" (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n") (fun fmt ((case, _), (arm_block, payload_name)) -> - Format.fprintf fmt "%a %a%a@ %a @[%a@ %a@]" Dcalc.Print.format_punctuation "|" - Dcalc.Print.format_enum_constructor case Dcalc.Print.format_punctuation ":" - LocalName.format_t payload_name Dcalc.Print.format_punctuation "→" - (format_block decl_ctx ~debug) arm_block)) + Format.fprintf fmt "%a %a%a@ %a @[%a@ %a@]" + Dcalc.Print.format_punctuation "|" + Dcalc.Print.format_enum_constructor case + Dcalc.Print.format_punctuation ":" LocalName.format_t + payload_name Dcalc.Print.format_punctuation "→" + (format_block decl_ctx ~debug) + arm_block)) (List.combine (Dcalc.Ast.EnumMap.find enum decl_ctx.ctx_enums) arms) -and format_block (decl_ctx : Dcalc.Ast.decl_ctx) ?(debug : bool = false) (fmt : Format.formatter) +and format_block + (decl_ctx : Dcalc.Ast.decl_ctx) + ?(debug : bool = false) + (fmt : Format.formatter) (block : block) : unit = Format.pp_print_list - ~pp_sep:(fun fmt () -> Format.fprintf fmt "%a@ " Dcalc.Print.format_punctuation ";") + ~pp_sep:(fun fmt () -> + Format.fprintf fmt "%a@ " Dcalc.Print.format_punctuation ";") (format_statement decl_ctx ~debug) fmt block -let format_scope (decl_ctx : Dcalc.Ast.decl_ctx) ?(debug : bool = false) (fmt : Format.formatter) +let format_scope + (decl_ctx : Dcalc.Ast.decl_ctx) + ?(debug : bool = false) + (fmt : Format.formatter) (body : scope_body) : unit = if debug then () else (); - Format.fprintf fmt "@[%a@ %a@ %a@ %a@]@\n@[ %a@]" Dcalc.Print.format_keyword "let" - TopLevelName.format_t body.scope_body_var + Format.fprintf fmt "@[%a@ %a@ %a@ %a@]@\n@[ %a@]" + Dcalc.Print.format_keyword "let" TopLevelName.format_t body.scope_body_var (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ") (fun fmt ((name, _), typ) -> - Format.fprintf fmt "%a%a %a@ %a%a" Dcalc.Print.format_punctuation "(" LocalName.format_t - name Dcalc.Print.format_punctuation ":" (Dcalc.Print.format_typ decl_ctx) typ - Dcalc.Print.format_punctuation ")")) + Format.fprintf fmt "%a%a %a@ %a%a" Dcalc.Print.format_punctuation "(" + LocalName.format_t name Dcalc.Print.format_punctuation ":" + (Dcalc.Print.format_typ decl_ctx) + typ Dcalc.Print.format_punctuation ")")) body.scope_body_func.func_params Dcalc.Print.format_punctuation "=" - (format_block decl_ctx ~debug) body.scope_body_func.func_body + (format_block decl_ctx ~debug) + body.scope_body_func.func_body diff --git a/compiler/scalc/print.mli b/compiler/scalc/print.mli index 6d6a2406..b2a5a0fe 100644 --- a/compiler/scalc/print.mli +++ b/compiler/scalc/print.mli @@ -1,15 +1,22 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2022 Inria, contributor: Denis Merigoux - +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2022 Inria, contributor: + Denis Merigoux - 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 + 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 + 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. *) -val format_scope : Dcalc.Ast.decl_ctx -> ?debug:bool -> Format.formatter -> Ast.scope_body -> unit +val format_scope : + Dcalc.Ast.decl_ctx -> + ?debug:bool -> + Format.formatter -> + Ast.scope_body -> + unit diff --git a/compiler/scalc/to_python.ml b/compiler/scalc/to_python.ml index 0b9a0092..365ad07c 100644 --- a/compiler/scalc/to_python.ml +++ b/compiler/scalc/to_python.ml @@ -1,15 +1,17 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux - +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, contributor: + Denis Merigoux - 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 + 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 + 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. *) [@@@warning "-32-27"] @@ -23,7 +25,9 @@ let format_lit (fmt : Format.formatter) (l : L.lit Pos.marked) : unit = match Pos.unmark l with | LBool true -> Format.fprintf fmt "True" | LBool false -> Format.fprintf fmt "False" - | LInt i -> Format.fprintf fmt "integer_of_string(\"%s\")" (Runtime.integer_to_string i) + | LInt i -> + Format.fprintf fmt "integer_of_string(\"%s\")" + (Runtime.integer_to_string i) | LUnit -> Format.fprintf fmt "Unit()" | LRat i -> Format.fprintf fmt "decimal_of_string(\"%a\")" Dcalc.Print.format_lit @@ -40,14 +44,16 @@ let format_lit (fmt : Format.formatter) (l : L.lit Pos.marked) : unit = let years, months, days = Runtime.duration_to_years_months_days d in Format.fprintf fmt "duration_of_numbers(%d,%d,%d)" years months days -let format_log_entry (fmt : Format.formatter) (entry : Dcalc.Ast.log_entry) : unit = +let format_log_entry (fmt : Format.formatter) (entry : Dcalc.Ast.log_entry) : + unit = match entry with | VarDef _ -> Format.fprintf fmt ":=" | BeginCall -> Format.fprintf fmt "→ " | EndCall -> Format.fprintf fmt "%s" "← " | PosRecordIfTrueBool -> Format.fprintf fmt "☛ " -let format_binop (fmt : Format.formatter) (op : Dcalc.Ast.binop Pos.marked) : unit = +let format_binop (fmt : Format.formatter) (op : Dcalc.Ast.binop Pos.marked) : + unit = match Pos.unmark op with | Add _ | Concat -> Format.fprintf fmt "+" | Sub _ -> Format.fprintf fmt "-" @@ -65,14 +71,17 @@ let format_binop (fmt : Format.formatter) (op : Dcalc.Ast.binop Pos.marked) : un | Map -> Format.fprintf fmt "list_map" | Filter -> Format.fprintf fmt "list_filter" -let format_ternop (fmt : Format.formatter) (op : Dcalc.Ast.ternop Pos.marked) : unit = +let format_ternop (fmt : Format.formatter) (op : Dcalc.Ast.ternop Pos.marked) : + unit = match Pos.unmark op with Fold -> Format.fprintf fmt "list_fold_left" -let format_uid_list (fmt : Format.formatter) (uids : Uid.MarkedString.info list) : unit = +let format_uid_list (fmt : Format.formatter) (uids : Uid.MarkedString.info list) + : unit = Format.fprintf fmt "[%a]" (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ") - (fun fmt info -> Format.fprintf fmt "\"%a\"" Utils.Uid.MarkedString.format_info info)) + (fun fmt info -> + Format.fprintf fmt "\"%a\"" Utils.Uid.MarkedString.format_info info)) uids let format_string_list (fmt : Format.formatter) (uids : string list) : unit = @@ -82,7 +91,8 @@ let format_string_list (fmt : Format.formatter) (uids : string list) : unit = (fun fmt info -> Format.fprintf fmt "\"%s\"" info)) uids -let format_unop (fmt : Format.formatter) (op : Dcalc.Ast.unop Pos.marked) : unit = +let format_unop (fmt : Format.formatter) (op : Dcalc.Ast.unop Pos.marked) : unit + = match Pos.unmark op with | Minus _ -> Format.fprintf fmt "-" | Not -> Format.fprintf fmt "not" @@ -96,39 +106,52 @@ let format_unop (fmt : Format.formatter) (op : Dcalc.Ast.unop Pos.marked) : unit let avoid_keywords (s : string) : string = if match s with - (* list taken from https://www.programiz.com/python-programming/keyword-list *) - | "False" | "None" | "True" | "and" | "as" | "assert" | "async" | "await" | "break" | "class" - | "continue" | "def" | "del" | "elif" | "else" | "except" | "finally" | "for" | "from" - | "global" | "if" | "import" | "in" | "is" | "lambda" | "nonlocal" | "not" | "or" | "pass" - | "raise" | "return" | "try" | "while" | "with" | "yield" -> + (* list taken from + https://www.programiz.com/python-programming/keyword-list *) + | "False" | "None" | "True" | "and" | "as" | "assert" | "async" | "await" + | "break" | "class" | "continue" | "def" | "del" | "elif" | "else" + | "except" | "finally" | "for" | "from" | "global" | "if" | "import" | "in" + | "is" | "lambda" | "nonlocal" | "not" | "or" | "pass" | "raise" | "return" + | "try" | "while" | "with" | "yield" -> true | _ -> false then s ^ "_" else s -let format_struct_name (fmt : Format.formatter) (v : Dcalc.Ast.StructName.t) : unit = +let format_struct_name (fmt : Format.formatter) (v : Dcalc.Ast.StructName.t) : + unit = Format.fprintf fmt "%s" (avoid_keywords - (to_uppercase (to_ascii (Format.asprintf "%a" Dcalc.Ast.StructName.format_t v)))) + (to_uppercase + (to_ascii (Format.asprintf "%a" Dcalc.Ast.StructName.format_t v)))) -let format_struct_field_name (fmt : Format.formatter) (v : Dcalc.Ast.StructFieldName.t) : unit = +let format_struct_field_name + (fmt : Format.formatter) (v : Dcalc.Ast.StructFieldName.t) : unit = Format.fprintf fmt "%s" - (avoid_keywords (to_ascii (Format.asprintf "%a" Dcalc.Ast.StructFieldName.format_t v))) + (avoid_keywords + (to_ascii (Format.asprintf "%a" Dcalc.Ast.StructFieldName.format_t v))) -let format_enum_name (fmt : Format.formatter) (v : Dcalc.Ast.EnumName.t) : unit = +let format_enum_name (fmt : Format.formatter) (v : Dcalc.Ast.EnumName.t) : unit + = Format.fprintf fmt "%s" - (avoid_keywords (to_uppercase (to_ascii (Format.asprintf "%a" Dcalc.Ast.EnumName.format_t v)))) + (avoid_keywords + (to_uppercase + (to_ascii (Format.asprintf "%a" Dcalc.Ast.EnumName.format_t v)))) -let format_enum_cons_name (fmt : Format.formatter) (v : Dcalc.Ast.EnumConstructor.t) : unit = +let format_enum_cons_name + (fmt : Format.formatter) (v : Dcalc.Ast.EnumConstructor.t) : unit = Format.fprintf fmt "%s" - (avoid_keywords (to_ascii (Format.asprintf "%a" Dcalc.Ast.EnumConstructor.format_t v))) + (avoid_keywords + (to_ascii (Format.asprintf "%a" Dcalc.Ast.EnumConstructor.format_t v))) let typ_needs_parens (e : Dcalc.Ast.typ Pos.marked) : bool = match Pos.unmark e with TArrow _ | TArray _ -> true | _ -> false -let rec format_typ (fmt : Format.formatter) (typ : Dcalc.Ast.typ Pos.marked) : unit = +let rec format_typ (fmt : Format.formatter) (typ : Dcalc.Ast.typ Pos.marked) : + unit = let format_typ = format_typ in - let format_typ_with_parens (fmt : Format.formatter) (t : Dcalc.Ast.typ Pos.marked) = + let format_typ_with_parens + (fmt : Format.formatter) (t : Dcalc.Ast.typ Pos.marked) = if typ_needs_parens t then Format.fprintf fmt "(%a)" format_typ t else Format.fprintf fmt "%a" format_typ t in @@ -152,14 +175,17 @@ let rec format_typ (fmt : Format.formatter) (typ : Dcalc.Ast.typ Pos.marked) : u Format.fprintf fmt "Optional[%a]" format_typ some_typ | TEnum (_, e) -> Format.fprintf fmt "%a" format_enum_name e | TArrow (t1, t2) -> - Format.fprintf fmt "Callable[[%a], %a]" format_typ_with_parens t1 format_typ_with_parens t2 + Format.fprintf fmt "Callable[[%a], %a]" format_typ_with_parens t1 + format_typ_with_parens t2 | TArray t1 -> Format.fprintf fmt "List[%a]" format_typ_with_parens t1 | TAny -> Format.fprintf fmt "Any" let format_name_cleaned (fmt : Format.formatter) (s : string) : unit = let lowercase_name = to_lowercase (to_ascii s) in let lowercase_name = - Re.Pcre.substitute ~rex:(Re.Pcre.regexp "\\.") ~subst:(fun _ -> "_dot_") lowercase_name + Re.Pcre.substitute ~rex:(Re.Pcre.regexp "\\.") + ~subst:(fun _ -> "_dot_") + lowercase_name in let lowercase_name = avoid_keywords (to_ascii lowercase_name) in Format.fprintf fmt "%s" lowercase_name @@ -174,9 +200,12 @@ let format_toplevel_name (fmt : Format.formatter) (v : TopLevelName.t) : unit = format_name_cleaned fmt v_str let needs_parens (e : expr Pos.marked) : bool = - match Pos.unmark e with ELit (LBool _ | LUnit) | EVar _ | EOp _ -> false | _ -> true + match Pos.unmark e with + | ELit (LBool _ | LUnit) | EVar _ | EOp _ -> false + | _ -> true -let format_exception (fmt : Format.formatter) (exc : L.except Pos.marked) : unit = +let format_exception (fmt : Format.formatter) (exc : L.except Pos.marked) : unit + = match Pos.unmark exc with | ConflictError -> Format.fprintf fmt "ConflictError" | EmptyError -> Format.fprintf fmt "EmptyError" @@ -184,13 +213,16 @@ let format_exception (fmt : Format.formatter) (exc : L.except Pos.marked) : unit | NoValueProvided -> let pos = Pos.get_position exc in Format.fprintf fmt - "NoValueProvided(@[SourcePosition(@[filename=\"%s\",@ start_line=%d,@ \ - start_column=%d,@ end_line=%d,@ end_column=%d,@ law_headings=%a)@])@]" + "NoValueProvided(@[SourcePosition(@[filename=\"%s\",@ \ + start_line=%d,@ start_column=%d,@ end_line=%d,@ end_column=%d,@ \ + law_headings=%a)@])@]" (Pos.get_file pos) (Pos.get_start_line pos) (Pos.get_start_column pos) - (Pos.get_end_line pos) (Pos.get_end_column pos) format_string_list (Pos.get_law_info pos) + (Pos.get_end_line pos) (Pos.get_end_column pos) format_string_list + (Pos.get_law_info pos) -let rec format_expression (ctx : Dcalc.Ast.decl_ctx) (fmt : Format.formatter) (e : expr Pos.marked) - : unit = +let rec format_expression + (ctx : Dcalc.Ast.decl_ctx) (fmt : Format.formatter) (e : expr Pos.marked) : + unit = match Pos.unmark e with | EVar v -> format_var fmt v | EFunc f -> format_toplevel_name fmt f @@ -201,9 +233,11 @@ let rec format_expression (ctx : Dcalc.Ast.decl_ctx) (fmt : Format.formatter) (e (fun fmt (e, struct_field) -> Format.fprintf fmt "%a = %a" format_struct_field_name struct_field (format_expression ctx) e)) - (List.combine es (List.map fst (Dcalc.Ast.StructMap.find s ctx.ctx_structs))) + (List.combine es + (List.map fst (Dcalc.Ast.StructMap.find s ctx.ctx_structs))) | EStructFieldAccess (e1, field, _) -> - Format.fprintf fmt "%a.%a" (format_expression ctx) e1 format_struct_field_name field + Format.fprintf fmt "%a.%a" (format_expression ctx) e1 + format_struct_field_name field | EInj (_, cons, e_name) when D.EnumName.compare e_name L.option_enum = 0 && D.EnumConstructor.compare cons L.none_constr = 0 -> @@ -215,8 +249,9 @@ let rec format_expression (ctx : Dcalc.Ast.decl_ctx) (fmt : Format.formatter) (e (* We translate the option type with an overloading by Python's [None] *) format_expression ctx fmt e | EInj (e, cons, enum_name) -> - Format.fprintf fmt "%a(%a_Code.%a,@ %a)" format_enum_name enum_name format_enum_name enum_name - format_enum_cons_name cons (format_expression ctx) e + Format.fprintf fmt "%a(%a_Code.%a,@ %a)" format_enum_name enum_name + format_enum_name enum_name format_enum_cons_name cons + (format_expression ctx) e | EArray es -> Format.fprintf fmt "[%a]" (Format.pp_print_list @@ -224,34 +259,43 @@ let rec format_expression (ctx : Dcalc.Ast.decl_ctx) (fmt : Format.formatter) (e (fun fmt e -> Format.fprintf fmt "%a" (format_expression ctx) e)) es | ELit l -> Format.fprintf fmt "%a" format_lit (Pos.same_pos_as l e) - | EApp ((EOp (Binop ((Dcalc.Ast.Map | Dcalc.Ast.Filter) as op)), _), [ arg1; arg2 ]) -> - Format.fprintf fmt "%a(%a,@ %a)" format_binop (op, Pos.no_pos) (format_expression ctx) arg1 - (format_expression ctx) arg2 + | EApp + ( (EOp (Binop ((Dcalc.Ast.Map | Dcalc.Ast.Filter) as op)), _), + [ arg1; arg2 ] ) -> + Format.fprintf fmt "%a(%a,@ %a)" format_binop (op, Pos.no_pos) + (format_expression ctx) arg1 (format_expression ctx) arg2 | EApp ((EOp (Binop op), _), [ arg1; arg2 ]) -> - Format.fprintf fmt "(%a %a@ %a)" (format_expression ctx) arg1 format_binop (op, Pos.no_pos) - (format_expression ctx) arg2 - | EApp ((EApp ((EOp (Unop (D.Log (D.BeginCall, info))), _), [ f ]), _), [ arg ]) + Format.fprintf fmt "(%a %a@ %a)" (format_expression ctx) arg1 format_binop + (op, Pos.no_pos) (format_expression ctx) arg2 + | EApp + ((EApp ((EOp (Unop (D.Log (D.BeginCall, info))), _), [ f ]), _), [ arg ]) + when !Cli.trace_flag -> + Format.fprintf fmt "log_begin_call(%a,@ %a,@ %a)" format_uid_list info + (format_expression ctx) f (format_expression ctx) arg + | EApp ((EOp (Unop (D.Log (D.VarDef tau, info))), _), [ arg1 ]) when !Cli.trace_flag -> - Format.fprintf fmt "log_begin_call(%a,@ %a,@ %a)" format_uid_list info (format_expression ctx) - f (format_expression ctx) arg - | EApp ((EOp (Unop (D.Log (D.VarDef tau, info))), _), [ arg1 ]) when !Cli.trace_flag -> Format.fprintf fmt "log_variable_definition(%a,@ %a)" format_uid_list info (format_expression ctx) arg1 - | EApp ((EOp (Unop (D.Log (D.PosRecordIfTrueBool, _))), pos), [ arg1 ]) when !Cli.trace_flag -> + | EApp ((EOp (Unop (D.Log (D.PosRecordIfTrueBool, _))), pos), [ arg1 ]) + when !Cli.trace_flag -> Format.fprintf fmt - "log_decision_taken(SourcePosition(filename=\"%s\",@ start_line=%d,@ start_column=%d,@ \ - end_line=%d, end_column=%d,@ law_headings=%a), %a)" + "log_decision_taken(SourcePosition(filename=\"%s\",@ start_line=%d,@ \ + start_column=%d,@ end_line=%d, end_column=%d,@ law_headings=%a), %a)" (Pos.get_file pos) (Pos.get_start_line pos) (Pos.get_start_column pos) - (Pos.get_end_line pos) (Pos.get_end_column pos) format_string_list (Pos.get_law_info pos) + (Pos.get_end_line pos) (Pos.get_end_column pos) format_string_list + (Pos.get_law_info pos) (format_expression ctx) arg1 + | EApp ((EOp (Unop (D.Log (D.EndCall, info))), _), [ arg1 ]) + when !Cli.trace_flag -> + Format.fprintf fmt "log_end_call(%a,@ %a)" format_uid_list info (format_expression ctx) arg1 - | EApp ((EOp (Unop (D.Log (D.EndCall, info))), _), [ arg1 ]) when !Cli.trace_flag -> - Format.fprintf fmt "log_end_call(%a,@ %a)" format_uid_list info (format_expression ctx) arg1 | EApp ((EOp (Unop (D.Log _)), _), [ arg1 ]) -> Format.fprintf fmt "%a" (format_expression ctx) arg1 | EApp ((EOp (Unop ((Minus _ | Not) as op)), _), [ arg1 ]) -> - Format.fprintf fmt "%a %a" format_unop (op, Pos.no_pos) (format_expression ctx) arg1 + Format.fprintf fmt "%a %a" format_unop (op, Pos.no_pos) + (format_expression ctx) arg1 | EApp ((EOp (Unop op), _), [ arg1 ]) -> - Format.fprintf fmt "%a(%a)" format_unop (op, Pos.no_pos) (format_expression ctx) arg1 + Format.fprintf fmt "%a(%a)" format_unop (op, Pos.no_pos) + (format_expression ctx) arg1 | EApp (f, args) -> Format.fprintf fmt "%a(@[%a)@]" (format_expression ctx) f (Format.pp_print_list @@ -262,60 +306,85 @@ let rec format_expression (ctx : Dcalc.Ast.decl_ctx) (fmt : Format.formatter) (e | EOp (Binop op) -> Format.fprintf fmt "%a" format_binop (op, Pos.no_pos) | EOp (Unop op) -> Format.fprintf fmt "%a" format_unop (op, Pos.no_pos) -let rec format_statement (ctx : Dcalc.Ast.decl_ctx) (fmt : Format.formatter) (s : stmt Pos.marked) : +let rec format_statement + (ctx : Dcalc.Ast.decl_ctx) (fmt : Format.formatter) (s : stmt Pos.marked) : unit = match Pos.unmark s with | SInnerFuncDef (name, { func_params; func_body }) -> - Format.fprintf fmt "@[def %a(%a):@\n%a@]" format_var (Pos.unmark name) + Format.fprintf fmt "@[def %a(%a):@\n%a@]" format_var + (Pos.unmark name) (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt ", ") (fun fmt (var, typ) -> - Format.fprintf fmt "%a:%a" format_var (Pos.unmark var) format_typ typ)) + Format.fprintf fmt "%a:%a" format_var (Pos.unmark var) format_typ + typ)) func_params (format_block ctx) func_body - | SLocalDecl _ -> assert false (* We don't need to declare variables in Python *) + | SLocalDecl _ -> + assert false (* We don't need to declare variables in Python *) | SLocalDef (v, e) -> - Format.fprintf fmt "@[%a = %a@]" format_var (Pos.unmark v) (format_expression ctx) e + Format.fprintf fmt "@[%a = %a@]" format_var (Pos.unmark v) + (format_expression ctx) e | STryExcept (try_b, except, catch_b) -> - Format.fprintf fmt "@[try:@\n%a@]@\n@[except %a:@\n%a@]" (format_block ctx) - try_b format_exception (except, Pos.no_pos) (format_block ctx) catch_b + Format.fprintf fmt "@[try:@\n%a@]@\n@[except %a:@\n%a@]" + (format_block ctx) try_b format_exception (except, Pos.no_pos) + (format_block ctx) catch_b | SRaise except -> - Format.fprintf fmt "@[raise %a@]" format_exception (except, Pos.get_position s) + Format.fprintf fmt "@[raise %a@]" format_exception + (except, Pos.get_position s) | SIfThenElse (cond, b1, b2) -> - Format.fprintf fmt "@[if %a:@\n%a@]@\n@[else:@\n%a@]" (format_expression ctx) - cond (format_block ctx) b1 (format_block ctx) b2 + Format.fprintf fmt "@[if %a:@\n%a@]@\n@[else:@\n%a@]" + (format_expression ctx) cond (format_block ctx) b1 (format_block ctx) b2 | SSwitch (e1, e_name, [ (case_none, _); (case_some, case_some_var) ]) when D.EnumName.compare e_name L.option_enum = 0 -> (* We translate the option type with an overloading by Python's [None] *) let tmp_var = LocalName.fresh ("perhaps_none_arg", Pos.no_pos) in Format.fprintf fmt - "%a = %a@\n@[if %a is None:@\n%a@]@\n@[else:@\n%a = %a@\n%a@]" format_var - tmp_var (format_expression ctx) e1 format_var tmp_var (format_block ctx) case_none - format_var case_some_var format_var tmp_var (format_block ctx) case_some + "%a = %a@\n\ + @[if %a is None:@\n\ + %a@]@\n\ + @[else:@\n\ + %a = %a@\n\ + %a@]" + format_var tmp_var (format_expression ctx) e1 format_var tmp_var + (format_block ctx) case_none format_var case_some_var format_var tmp_var + (format_block ctx) case_some | SSwitch (e1, e_name, cases) -> let cases = - List.map2 (fun (x, y) (cons, _) -> (x, y, cons)) cases (D.EnumMap.find e_name ctx.ctx_enums) + List.map2 + (fun (x, y) (cons, _) -> (x, y, cons)) + cases + (D.EnumMap.find e_name ctx.ctx_enums) in let tmp_var = LocalName.fresh ("match_arg", Pos.no_pos) in - Format.fprintf fmt "%a = %a@\n@[if %a@]" format_var tmp_var (format_expression ctx) e1 + Format.fprintf fmt "%a = %a@\n@[if %a@]" format_var tmp_var + (format_expression ctx) e1 (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "@]@\n@[elif ") (fun fmt (case_block, payload_var, cons_name) -> - Format.fprintf fmt "%a.code == %a_Code.%a:@\n%a = %a.value@\n%a" format_var tmp_var - format_enum_name e_name format_enum_cons_name cons_name format_var payload_var - format_var tmp_var (format_block ctx) case_block)) + Format.fprintf fmt "%a.code == %a_Code.%a:@\n%a = %a.value@\n%a" + format_var tmp_var format_enum_name e_name format_enum_cons_name + cons_name format_var payload_var format_var tmp_var + (format_block ctx) case_block)) cases | SReturn e1 -> - Format.fprintf fmt "@[return %a@]" (format_expression ctx) (e1, Pos.get_position s) + Format.fprintf fmt "@[return %a@]" (format_expression ctx) + (e1, Pos.get_position s) | SAssert e1 -> - Format.fprintf fmt "@[assert %a@]" (format_expression ctx) (e1, Pos.get_position s) + Format.fprintf fmt "@[assert %a@]" (format_expression ctx) + (e1, Pos.get_position s) -and format_block (ctx : Dcalc.Ast.decl_ctx) (fmt : Format.formatter) (b : block) : unit = +and format_block (ctx : Dcalc.Ast.decl_ctx) (fmt : Format.formatter) (b : block) + : unit = Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n") (format_statement ctx) fmt - (List.filter (fun s -> match Pos.unmark s with SLocalDecl _ -> false | _ -> true) b) + (List.filter + (fun s -> match Pos.unmark s with SLocalDecl _ -> false | _ -> true) + b) -let format_ctx (type_ordering : Scopelang.Dependency.TVertex.t list) (fmt : Format.formatter) +let format_ctx + (type_ordering : Scopelang.Dependency.TVertex.t list) + (fmt : Format.formatter) (ctx : D.decl_ctx) : unit = let format_struct_decl fmt (struct_name, struct_fields) = Format.fprintf fmt @@ -333,27 +402,29 @@ let format_ctx (type_ordering : Scopelang.Dependency.TVertex.t list) (fmt : Form \t\treturn not (self == other)@\n\ @\n\ \tdef __str__(self) -> str:@\n\ - \t\t@[return \"%a(%a)\".format(%a)@]" format_struct_name struct_name + \t\t@[return \"%a(%a)\".format(%a)@]" format_struct_name + struct_name (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt ", ") (fun _fmt (struct_field, struct_field_type) -> - Format.fprintf fmt "%a: %a" format_struct_field_name struct_field format_typ - struct_field_type)) + Format.fprintf fmt "%a: %a" format_struct_field_name struct_field + format_typ struct_field_type)) struct_fields - (if List.length struct_fields = 0 then fun fmt _ -> Format.fprintf fmt "\t\tpass" + (if List.length struct_fields = 0 then fun fmt _ -> + Format.fprintf fmt "\t\tpass" else Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n") (fun _fmt (struct_field, _) -> - Format.fprintf fmt "\t\tself.%a = %a" format_struct_field_name struct_field - format_struct_field_name struct_field)) + Format.fprintf fmt "\t\tself.%a = %a" format_struct_field_name + struct_field format_struct_field_name struct_field)) struct_fields format_struct_name struct_name (if List.length struct_fields > 0 then Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt " and@ ") (fun _fmt (struct_field, _) -> - Format.fprintf fmt "self.%a == other.%a" format_struct_field_name struct_field - format_struct_field_name struct_field) + Format.fprintf fmt "self.%a == other.%a" format_struct_field_name + struct_field format_struct_field_name struct_field) else fun fmt _ -> Format.fprintf fmt "True") struct_fields format_struct_name struct_name (Format.pp_print_list @@ -391,13 +462,15 @@ let format_ctx (type_ordering : Scopelang.Dependency.TVertex.t list) (fmt : Form \t\treturn not (self == other)@\n\ @\n\ \tdef __str__(self) -> str:@\n\ - \t\t@[return \"{}({})\".format(self.code, self.value)@]" format_enum_name enum_name + \t\t@[return \"{}({})\".format(self.code, self.value)@]" + format_enum_name enum_name (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n") (fun _fmt (i, enum_cons, enum_cons_type) -> Format.fprintf fmt "%a = %d" format_enum_cons_name enum_cons i)) (List.mapi (fun i (x, y) -> (i, x, y)) enum_cons) - format_enum_name enum_name format_enum_name enum_name format_enum_name enum_name + format_enum_name enum_name format_enum_name enum_name format_enum_name + enum_name in let is_in_type_ordering s = @@ -412,7 +485,9 @@ let format_ctx (type_ordering : Scopelang.Dependency.TVertex.t list) (fmt : Form List.map (fun (s, _) -> Scopelang.Dependency.TVertex.Struct s) (Dcalc.Ast.StructMap.bindings - (Dcalc.Ast.StructMap.filter (fun s _ -> not (is_in_type_ordering s)) ctx.ctx_structs)) + (Dcalc.Ast.StructMap.filter + (fun s _ -> not (is_in_type_ordering s)) + ctx.ctx_structs)) in List.iter (fun struct_or_enum -> @@ -425,10 +500,13 @@ let format_ctx (type_ordering : Scopelang.Dependency.TVertex.t list) (fmt : Form (e, Dcalc.Ast.EnumMap.find e ctx.Dcalc.Ast.ctx_enums)) (type_ordering @ scope_structs) -let format_program (fmt : Format.formatter) (p : Ast.program) +let format_program + (fmt : Format.formatter) + (p : Ast.program) (type_ordering : Scopelang.Dependency.TVertex.t list) : unit = - (* We disable the style flag in order to enjoy formatting from the pretty-printers of Dcalc and - Lcalc but without the color terminal markers. *) + (* We disable the style flag in order to enjoy formatting from the + pretty-printers of Dcalc and Lcalc but without the color terminal + markers. *) Cli.style_flag := false; Format.fprintf fmt "# This file has been generated by the Catala compiler, do not edit!\n\ @@ -445,10 +523,12 @@ let format_program (fmt : Format.formatter) (p : Ast.program) ~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n@\n") (fun fmt body -> let { Ast.func_params; Ast.func_body } = body.scope_body_func in - Format.fprintf fmt "@[def %a(%a):@\n%a@]" format_toplevel_name body.scope_body_var + Format.fprintf fmt "@[def %a(%a):@\n%a@]" format_toplevel_name + body.scope_body_var (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt ", ") (fun fmt (var, typ) -> - Format.fprintf fmt "%a:%a" format_var (Pos.unmark var) format_typ typ)) + Format.fprintf fmt "%a:%a" format_var (Pos.unmark var) + format_typ typ)) func_params (format_block p.decl_ctx) func_body)) p.scopes diff --git a/compiler/scalc/to_python.mli b/compiler/scalc/to_python.mli index 59e6b925..1cc4e3fa 100644 --- a/compiler/scalc/to_python.mli +++ b/compiler/scalc/to_python.mli @@ -1,18 +1,21 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2021 Inria, contributor: Denis Merigoux - +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2021 Inria, contributor: + Denis Merigoux - 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 + 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 + 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. *) (** Formats a lambda calculus program into a valid Python program *) -val format_program : Format.formatter -> Ast.program -> Scopelang.Dependency.TVertex.t list -> unit +val format_program : + Format.formatter -> Ast.program -> Scopelang.Dependency.TVertex.t list -> unit (** Usage [format_program fmt p type_dependencies_ordering] *) diff --git a/compiler/scopelang/ast.ml b/compiler/scopelang/ast.ml index 7ace0eab..5793112f 100644 --- a/compiler/scopelang/ast.ml +++ b/compiler/scopelang/ast.ml @@ -1,63 +1,69 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux - +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, contributor: + Denis Merigoux - 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 + 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 + 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. *) open Utils module ScopeName = Dcalc.Ast.ScopeName - module ScopeNameSet : Set.S with type elt = ScopeName.t = Set.Make (ScopeName) - module ScopeMap : Map.S with type key = ScopeName.t = Map.Make (ScopeName) -module SubScopeName : Uid.Id with type info = Uid.MarkedString.info = Uid.Make (Uid.MarkedString) () +module SubScopeName : Uid.Id with type info = Uid.MarkedString.info = + Uid.Make (Uid.MarkedString) () -module SubScopeNameSet : Set.S with type elt = SubScopeName.t = Set.Make (SubScopeName) +module SubScopeNameSet : Set.S with type elt = SubScopeName.t = + Set.Make (SubScopeName) -module SubScopeMap : Map.S with type key = SubScopeName.t = Map.Make (SubScopeName) +module SubScopeMap : Map.S with type key = SubScopeName.t = + Map.Make (SubScopeName) -module ScopeVar : Uid.Id with type info = Uid.MarkedString.info = Uid.Make (Uid.MarkedString) () +module ScopeVar : Uid.Id with type info = Uid.MarkedString.info = + Uid.Make (Uid.MarkedString) () module ScopeVarSet : Set.S with type elt = ScopeVar.t = Set.Make (ScopeVar) - module ScopeVarMap : Map.S with type key = ScopeVar.t = Map.Make (ScopeVar) - module StructName = Dcalc.Ast.StructName module StructMap = Dcalc.Ast.StructMap module StructFieldName = Dcalc.Ast.StructFieldName -module StructFieldMap : Map.S with type key = StructFieldName.t = Map.Make (StructFieldName) +module StructFieldMap : Map.S with type key = StructFieldName.t = + Map.Make (StructFieldName) module StructFieldMapLift = Bindlib.Lift (StructFieldMap) module EnumName = Dcalc.Ast.EnumName module EnumMap = Dcalc.Ast.EnumMap module EnumConstructor = Dcalc.Ast.EnumConstructor -module EnumConstructorMap : Map.S with type key = EnumConstructor.t = Map.Make (EnumConstructor) +module EnumConstructorMap : Map.S with type key = EnumConstructor.t = + Map.Make (EnumConstructor) module EnumConstructorMapLift = Bindlib.Lift (EnumConstructorMap) type location = | ScopeVar of ScopeVar.t Pos.marked - | SubScopeVar of ScopeName.t * SubScopeName.t Pos.marked * ScopeVar.t Pos.marked + | SubScopeVar of + ScopeName.t * SubScopeName.t Pos.marked * ScopeVar.t Pos.marked -module LocationSet : Set.S with type elt = location Pos.marked = Set.Make (struct +module LocationSet : Set.S with type elt = location Pos.marked = +Set.Make (struct type t = location Pos.marked let compare x y = match (Pos.unmark x, Pos.unmark y) with | ScopeVar (vx, _), ScopeVar (vy, _) -> ScopeVar.compare vx vy - | SubScopeVar (_, (xsubindex, _), (xsubvar, _)), SubScopeVar (_, (ysubindex, _), (ysubvar, _)) - -> + | ( SubScopeVar (_, (xsubindex, _), (xsubvar, _)), + SubScopeVar (_, (ysubindex, _), (ysubvar, _)) ) -> let c = SubScopeName.compare xsubindex ysubindex in if c = 0 then ScopeVar.compare xsubvar ysubvar else c | ScopeVar _, SubScopeVar _ -> -1 @@ -78,9 +84,11 @@ type expr = | EStruct of StructName.t * expr Pos.marked StructFieldMap.t | EStructAccess of expr Pos.marked * StructFieldName.t * StructName.t | EEnumInj of expr Pos.marked * EnumConstructor.t * EnumName.t - | EMatch of expr Pos.marked * EnumName.t * expr Pos.marked EnumConstructorMap.t + | EMatch of + expr Pos.marked * EnumName.t * expr Pos.marked EnumConstructorMap.t | ELit of Dcalc.Ast.lit - | EAbs of (expr, expr Pos.marked) Bindlib.mbinder Pos.marked * typ Pos.marked list + | EAbs of + (expr, expr Pos.marked) Bindlib.mbinder Pos.marked * typ Pos.marked list | EApp of expr Pos.marked * expr Pos.marked list | EOp of Dcalc.Ast.operator | EDefault of expr Pos.marked list * expr Pos.marked * expr Pos.marked @@ -118,11 +126,12 @@ let rec locations_used (e : expr Pos.marked) : LocationSet.t = (LocationSet.union (locations_used just) (locations_used cons)) excepts | EArray es -> - List.fold_left (fun acc e' -> LocationSet.union acc (locations_used e')) LocationSet.empty es + List.fold_left + (fun acc e' -> LocationSet.union acc (locations_used e')) + LocationSet.empty es | ErrorOnEmpty e' -> locations_used e' type io_input = NoInput | OnlyInput | Reentrant - type io = { io_output : bool Pos.marked; io_input : io_input Pos.marked } type rule = @@ -137,7 +146,6 @@ type scope_decl = { } type struct_ctx = (StructFieldName.t * typ Pos.marked) list StructMap.t - type enum_ctx = (EnumConstructor.t * typ Pos.marked) list EnumMap.t type program = { @@ -162,15 +170,26 @@ type vars = expr Bindlib.mvar let make_var ((x, pos) : Var.t Pos.marked) : expr Pos.marked Bindlib.box = Bindlib.box_apply (fun v -> (v, pos)) (Bindlib.box_var x) -let make_abs (xs : vars) (e : expr Pos.marked Bindlib.box) (pos_binder : Pos.t) - (taus : typ Pos.marked list) (pos : Pos.t) : expr Pos.marked Bindlib.box = - Bindlib.box_apply (fun b -> (EAbs ((b, pos_binder), taus), pos)) (Bindlib.bind_mvar xs e) +let make_abs + (xs : vars) + (e : expr Pos.marked Bindlib.box) + (pos_binder : Pos.t) + (taus : typ Pos.marked list) + (pos : Pos.t) : expr Pos.marked Bindlib.box = + Bindlib.box_apply + (fun b -> (EAbs ((b, pos_binder), taus), pos)) + (Bindlib.bind_mvar xs e) -let make_app (e : expr Pos.marked Bindlib.box) (u : expr Pos.marked Bindlib.box list) (pos : Pos.t) - : expr Pos.marked Bindlib.box = +let make_app + (e : expr Pos.marked Bindlib.box) + (u : expr Pos.marked Bindlib.box list) + (pos : Pos.t) : expr Pos.marked Bindlib.box = Bindlib.box_apply2 (fun e u -> (EApp (e, u), pos)) e (Bindlib.box_list u) -let make_let_in (x : Var.t) (tau : typ Pos.marked) (e1 : expr Pos.marked Bindlib.box) +let make_let_in + (x : Var.t) + (tau : typ Pos.marked) + (e1 : expr Pos.marked Bindlib.box) (e2 : expr Pos.marked Bindlib.box) : expr Pos.marked Bindlib.box = Bindlib.box_apply2 (fun e u -> (EApp (e, u), Pos.get_position (Bindlib.unbox e2))) diff --git a/compiler/scopelang/ast.mli b/compiler/scopelang/ast.mli index 345a1efb..f75a9a6f 100644 --- a/compiler/scopelang/ast.mli +++ b/compiler/scopelang/ast.mli @@ -1,15 +1,17 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux - +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, contributor: + Denis Merigoux - 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 + 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 + 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. *) (** Abstract syntax tree of the scope language *) @@ -19,46 +21,38 @@ open Utils (** {1 Identifiers} *) module ScopeName = Dcalc.Ast.ScopeName - module ScopeNameSet : Set.S with type elt = ScopeName.t - module ScopeMap : Map.S with type key = ScopeName.t - module SubScopeName : Uid.Id with type info = Uid.MarkedString.info - module SubScopeNameSet : Set.S with type elt = SubScopeName.t - module SubScopeMap : Map.S with type key = SubScopeName.t - module ScopeVar : Uid.Id with type info = Uid.MarkedString.info - module ScopeVarSet : Set.S with type elt = ScopeVar.t - module ScopeVarMap : Map.S with type key = ScopeVar.t - module StructName = Dcalc.Ast.StructName module StructMap = Dcalc.Ast.StructMap module StructFieldName = Dcalc.Ast.StructFieldName - module StructFieldMap : Map.S with type key = StructFieldName.t module StructFieldMapLift : sig - val lift_box : 'a Bindlib.box StructFieldMap.t -> 'a StructFieldMap.t Bindlib.box + val lift_box : + 'a Bindlib.box StructFieldMap.t -> 'a StructFieldMap.t Bindlib.box end module EnumName = Dcalc.Ast.EnumName module EnumMap = Dcalc.Ast.EnumMap module EnumConstructor = Dcalc.Ast.EnumConstructor - module EnumConstructorMap : Map.S with type key = EnumConstructor.t module EnumConstructorMapLift : sig - val lift_box : 'a Bindlib.box EnumConstructorMap.t -> 'a EnumConstructorMap.t Bindlib.box + val lift_box : + 'a Bindlib.box EnumConstructorMap.t -> 'a EnumConstructorMap.t Bindlib.box end type location = | ScopeVar of ScopeVar.t Pos.marked - | SubScopeVar of ScopeName.t * SubScopeName.t Pos.marked * ScopeVar.t Pos.marked + | SubScopeVar of + ScopeName.t * SubScopeName.t Pos.marked * ScopeVar.t Pos.marked module LocationSet : Set.S with type elt = location Pos.marked @@ -72,17 +66,19 @@ type typ = | TArray of typ | TAny -(** The expressions use the {{:https://lepigre.fr/ocaml-bindlib/} Bindlib} library, based on - higher-order abstract syntax*) +(** The expressions use the {{:https://lepigre.fr/ocaml-bindlib/} Bindlib} + library, based on higher-order abstract syntax*) type expr = | ELocation of location | EVar of expr Bindlib.var Pos.marked | EStruct of StructName.t * expr Pos.marked StructFieldMap.t | EStructAccess of expr Pos.marked * StructFieldName.t * StructName.t | EEnumInj of expr Pos.marked * EnumConstructor.t * EnumName.t - | EMatch of expr Pos.marked * EnumName.t * expr Pos.marked EnumConstructorMap.t + | EMatch of + expr Pos.marked * EnumName.t * expr Pos.marked EnumConstructorMap.t | ELit of Dcalc.Ast.lit - | EAbs of (expr, expr Pos.marked) Bindlib.mbinder Pos.marked * typ Pos.marked list + | EAbs of + (expr, expr Pos.marked) Bindlib.mbinder Pos.marked * typ Pos.marked list | EApp of expr Pos.marked * expr Pos.marked list | EOp of Dcalc.Ast.operator | EDefault of expr Pos.marked list * expr Pos.marked * expr Pos.marked @@ -92,19 +88,23 @@ type expr = val locations_used : expr Pos.marked -> LocationSet.t -(** This type characterizes the three levels of visibility for a given scope variable with regards - to the scope's input and possible redefinitions inside the scope.. *) +(** This type characterizes the three levels of visibility for a given scope + variable with regards to the scope's input and possible redefinitions inside + the scope.. *) type io_input = | NoInput - (** For an internal variable defined only in the scope, and does not appear in the input. *) + (** For an internal variable defined only in the scope, and does not + appear in the input. *) | OnlyInput - (** For variables that should not be redefined in the scope, because they appear in the input. *) + (** For variables that should not be redefined in the scope, because they + appear in the input. *) | Reentrant - (** For variables defined in the scope that can also be redefined by the caller as they appear - in the input. *) + (** For variables defined in the scope that can also be redefined by the + caller as they appear in the input. *) type io = { - io_output : bool Pos.marked; (** [true] is present in the output of the scope. *) + io_output : bool Pos.marked; + (** [true] is present in the output of the scope. *) io_input : io_input Pos.marked; } (** Characterization of the input/output status of a scope variable. *) @@ -121,7 +121,6 @@ type scope_decl = { } type struct_ctx = (StructFieldName.t * typ Pos.marked) list StructMap.t - type enum_ctx = (EnumConstructor.t * typ Pos.marked) list EnumMap.t type program = { @@ -136,7 +135,6 @@ module Var : sig type t = expr Bindlib.var val make : string Pos.marked -> t - val compare : t -> t -> int end diff --git a/compiler/scopelang/dependency.ml b/compiler/scopelang/dependency.ml index 24003c8b..37d68123 100644 --- a/compiler/scopelang/dependency.ml +++ b/compiler/scopelang/dependency.ml @@ -1,19 +1,21 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux - +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, contributor: + Denis Merigoux - 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 + 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 + 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. *) -(** Graph representation of the dependencies between scopes in the Catala program. Vertices are - functions, x -> y if x is used in the definition of y. *) +(** Graph representation of the dependencies between scopes in the Catala + program. Vertices are functions, x -> y if x is used in the definition of y. *) open Utils @@ -21,22 +23,22 @@ module SVertex = struct type t = Ast.ScopeName.t let hash x = Ast.ScopeName.hash x - let compare = Ast.ScopeName.compare - let equal x y = Ast.ScopeName.compare x y = 0 end -(** On the edges, the label is the expression responsible for the use of the function *) +(** On the edges, the label is the expression responsible for the use of the + function *) module SEdge = struct type t = Pos.t let compare = compare - let default = Pos.no_pos end -module SDependencies = Graph.Persistent.Digraph.ConcreteBidirectionalLabeled (SVertex) (SEdge) +module SDependencies = + Graph.Persistent.Digraph.ConcreteBidirectionalLabeled (SVertex) (SEdge) + module STopologicalTraversal = Graph.Topological.Make (SDependencies) module SSCC = Graph.Components.Make (SDependencies) @@ -44,7 +46,11 @@ module SSCC = Graph.Components.Make (SDependencies) let build_program_dep_graph (prgm : Ast.program) : SDependencies.t = let g = SDependencies.empty in - let g = Ast.ScopeMap.fold (fun v _ g -> SDependencies.add_vertex g v) prgm.program_scopes g in + let g = + Ast.ScopeMap.fold + (fun v _ g -> SDependencies.add_vertex g v) + prgm.program_scopes g + in Ast.ScopeMap.fold (fun scope_name scope g -> let subscopes = @@ -55,9 +61,10 @@ let build_program_dep_graph (prgm : Ast.program) : SDependencies.t = | Ast.Call (subscope, subindex) -> if subscope = scope_name then Errors.raise_spanned_error - (Pos.get_position (Ast.ScopeName.get_info scope.Ast.scope_decl_name)) - "The scope %a is calling into itself as a subscope, which is forbidden since \ - Catala does not provide recursion" + (Pos.get_position + (Ast.ScopeName.get_info scope.Ast.scope_decl_name)) + "The scope %a is calling into itself as a subscope, which \ + is forbidden since Catala does not provide recursion" Ast.ScopeName.format_t scope.Ast.scope_decl_name else Ast.ScopeMap.add subscope @@ -73,7 +80,8 @@ let build_program_dep_graph (prgm : Ast.program) : SDependencies.t = prgm.program_scopes g let check_for_cycle_in_scope (g : SDependencies.t) : unit = - (* if there is a cycle, there will be an strongly connected component of cardinality > 1 *) + (* if there is a cycle, there will be an strongly connected component of + cardinality > 1 *) let sccs = SSCC.scc_list g in if List.length sccs < SDependencies.nb_vertex g then let scc = List.find (fun scc -> List.length scc > 1) sccs in @@ -82,19 +90,26 @@ let check_for_cycle_in_scope (g : SDependencies.t) : unit = (List.map (fun v -> let var_str, var_info = - (Format.asprintf "%a" Ast.ScopeName.format_t v, Ast.ScopeName.get_info v) + ( Format.asprintf "%a" Ast.ScopeName.format_t v, + Ast.ScopeName.get_info v ) in let succs = SDependencies.succ_e g v in - let _, edge_pos, succ = List.find (fun (_, _, succ) -> List.mem succ scc) succs in + let _, edge_pos, succ = + List.find (fun (_, _, succ) -> List.mem succ scc) succs + in let succ_str = Format.asprintf "%a" Ast.ScopeName.format_t succ in [ - (Some ("Cycle variable " ^ var_str ^ ", declared:"), Pos.get_position var_info); - ( Some ("Used here in the definition of another cycle variable " ^ succ_str ^ ":"), + ( Some ("Cycle variable " ^ var_str ^ ", declared:"), + Pos.get_position var_info ); + ( Some + ("Used here in the definition of another cycle variable " + ^ succ_str ^ ":"), edge_pos ); ]) scc) in - Errors.raise_multispanned_error spans "Cyclic dependency detected between scopes!" + Errors.raise_multispanned_error spans + "Cyclic dependency detected between scopes!" let get_scope_ordering (g : SDependencies.t) : Ast.ScopeName.t list = List.rev (STopologicalTraversal.fold (fun sd acc -> sd :: acc) g []) @@ -102,7 +117,10 @@ let get_scope_ordering (g : SDependencies.t) : Ast.ScopeName.t list = module TVertex = struct type t = Struct of Ast.StructName.t | Enum of Ast.EnumName.t - let hash x = match x with Struct x -> Ast.StructName.hash x | Enum x -> Ast.EnumName.hash x + let hash x = + match x with + | Struct x -> Ast.StructName.hash x + | Enum x -> Ast.EnumName.hash x let compare x y = match (x, y) with @@ -118,24 +136,30 @@ module TVertex = struct | _ -> false let format_t (fmt : Format.formatter) (x : t) : unit = - match x with Struct x -> Ast.StructName.format_t fmt x | Enum x -> Ast.EnumName.format_t fmt x + match x with + | Struct x -> Ast.StructName.format_t fmt x + | Enum x -> Ast.EnumName.format_t fmt x let get_info (x : t) = - match x with Struct x -> Ast.StructName.get_info x | Enum x -> Ast.EnumName.get_info x + match x with + | Struct x -> Ast.StructName.get_info x + | Enum x -> Ast.EnumName.get_info x end module TVertexSet = Set.Make (TVertex) -(** On the edges, the label is the expression responsible for the use of the function *) +(** On the edges, the label is the expression responsible for the use of the + function *) module TEdge = struct type t = Pos.t let compare = compare - let default = Pos.no_pos end -module TDependencies = Graph.Persistent.Digraph.ConcreteBidirectionalLabeled (TVertex) (TEdge) +module TDependencies = + Graph.Persistent.Digraph.ConcreteBidirectionalLabeled (TVertex) (TEdge) + module TTopologicalTraversal = Graph.Topological.Make (TDependencies) module TSCC = Graph.Components.Make (TDependencies) @@ -146,11 +170,14 @@ let rec get_structs_or_enums_in_type (t : Ast.typ Pos.marked) : TVertexSet.t = | Ast.TStruct s -> TVertexSet.singleton (TVertex.Struct s) | Ast.TEnum e -> TVertexSet.singleton (TVertex.Enum e) | Ast.TArrow (t1, t2) -> - TVertexSet.union (get_structs_or_enums_in_type t1) (get_structs_or_enums_in_type t2) + TVertexSet.union + (get_structs_or_enums_in_type t1) + (get_structs_or_enums_in_type t2) | Ast.TLit _ | Ast.TAny -> TVertexSet.empty | Ast.TArray t1 -> get_structs_or_enums_in_type (Pos.same_pos_as t1 t) -let build_type_graph (structs : Ast.struct_ctx) (enums : Ast.enum_ctx) : TDependencies.t = +let build_type_graph (structs : Ast.struct_ctx) (enums : Ast.enum_ctx) : + TDependencies.t = let g = TDependencies.empty in let g = Ast.StructMap.fold @@ -164,11 +191,13 @@ let build_type_graph (structs : Ast.struct_ctx) (enums : Ast.enum_ctx) : TDepend (fun used g -> if TVertex.equal used def then Errors.raise_spanned_error (Pos.get_position typ) - "The type %a is defined using itself, which is forbidden since Catala does not \ - provide recursive types" + "The type %a is defined using itself, which is forbidden \ + since Catala does not provide recursive types" TVertex.format_t used else - let edge = TDependencies.E.create used (Pos.get_position typ) def in + let edge = + TDependencies.E.create used (Pos.get_position typ) def + in TDependencies.add_edge_e g edge) used g) g fields) @@ -186,11 +215,13 @@ let build_type_graph (structs : Ast.struct_ctx) (enums : Ast.enum_ctx) : TDepend (fun used g -> if TVertex.equal used def then Errors.raise_spanned_error (Pos.get_position typ) - "The type %a is defined using itself, which is forbidden since Catala does not \ - provide recursive types" + "The type %a is defined using itself, which is forbidden \ + since Catala does not provide recursive types" TVertex.format_t used else - let edge = TDependencies.E.create used (Pos.get_position typ) def in + let edge = + TDependencies.E.create used (Pos.get_position typ) def + in TDependencies.add_edge_e g edge) used g) g cases) @@ -198,9 +229,11 @@ let build_type_graph (structs : Ast.struct_ctx) (enums : Ast.enum_ctx) : TDepend in g -let check_type_cycles (structs : Ast.struct_ctx) (enums : Ast.enum_ctx) : TVertex.t list = +let check_type_cycles (structs : Ast.struct_ctx) (enums : Ast.enum_ctx) : + TVertex.t list = let g = build_type_graph structs enums in - (* if there is a cycle, there will be an strongly connected component of cardinality > 1 *) + (* if there is a cycle, there will be an strongly connected component of + cardinality > 1 *) let sccs = TSCC.scc_list g in (if List.length sccs < TDependencies.nb_vertex g then let scc = List.find (fun scc -> List.length scc > 1) sccs in @@ -208,16 +241,24 @@ let check_type_cycles (structs : Ast.struct_ctx) (enums : Ast.enum_ctx) : TVerte List.flatten (List.map (fun v -> - let var_str, var_info = (Format.asprintf "%a" TVertex.format_t v, TVertex.get_info v) in + let var_str, var_info = + (Format.asprintf "%a" TVertex.format_t v, TVertex.get_info v) + in let succs = TDependencies.succ_e g v in - let _, edge_pos, succ = List.find (fun (_, _, succ) -> List.mem succ scc) succs in + let _, edge_pos, succ = + List.find (fun (_, _, succ) -> List.mem succ scc) succs + in let succ_str = Format.asprintf "%a" TVertex.format_t succ in [ - (Some ("Cycle type " ^ var_str ^ ", declared:"), Pos.get_position var_info); - ( Some ("Used here in the definition of another cycle type " ^ succ_str ^ ":"), + ( Some ("Cycle type " ^ var_str ^ ", declared:"), + Pos.get_position var_info ); + ( Some + ("Used here in the definition of another cycle type " + ^ succ_str ^ ":"), edge_pos ); ]) scc) in - Errors.raise_multispanned_error spans "Cyclic dependency detected between types!"); + Errors.raise_multispanned_error spans + "Cyclic dependency detected between types!"); List.rev (TTopologicalTraversal.fold (fun v acc -> v :: acc) g []) diff --git a/compiler/scopelang/dependency.mli b/compiler/scopelang/dependency.mli index 87ba650e..0775dca1 100644 --- a/compiler/scopelang/dependency.mli +++ b/compiler/scopelang/dependency.mli @@ -1,31 +1,33 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux - +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, contributor: + Denis Merigoux - 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 + 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 + 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. *) -(** Graph representation of the dependencies between scopes in the Catala program. Vertices are - functions, x -> y if x is used in the definition of y. *) +(** Graph representation of the dependencies between scopes in the Catala + program. Vertices are functions, x -> y if x is used in the definition of y. *) open Utils (** {1 Scope dependencies} *) -(** On the edges, the label is the expression responsible for the use of the function *) -module SDependencies : Graph.Sig.P with type V.t = Ast.ScopeName.t and type E.label = Pos.t +(** On the edges, the label is the expression responsible for the use of the + function *) +module SDependencies : + Graph.Sig.P with type V.t = Ast.ScopeName.t and type E.label = Pos.t val build_program_dep_graph : Ast.program -> SDependencies.t - val check_for_cycle_in_scope : SDependencies.t -> unit - val get_scope_ordering : SDependencies.t -> Ast.ScopeName.t list (** {1 Type dependencies} *) @@ -34,7 +36,6 @@ module TVertex : sig type t = Struct of Ast.StructName.t | Enum of Ast.EnumName.t val format_t : Format.formatter -> t -> unit - val get_info : t -> Ast.StructName.info include Graph.Sig.COMPARABLE with type t := t @@ -42,11 +43,11 @@ end module TVertexSet : Set.S with type elt = TVertex.t -(** On the edges, the label is the expression responsible for the use of the function *) -module TDependencies : Graph.Sig.P with type V.t = TVertex.t and type E.label = Pos.t +(** On the edges, the label is the expression responsible for the use of the + function *) +module TDependencies : + Graph.Sig.P with type V.t = TVertex.t and type E.label = Pos.t val get_structs_or_enums_in_type : Ast.typ Pos.marked -> TVertexSet.t - val build_type_graph : Ast.struct_ctx -> Ast.enum_ctx -> TDependencies.t - val check_type_cycles : Ast.struct_ctx -> Ast.enum_ctx -> TVertex.t list diff --git a/compiler/scopelang/print.ml b/compiler/scopelang/print.ml index 6fc65fdf..39d9329e 100644 --- a/compiler/scopelang/print.ml +++ b/compiler/scopelang/print.ml @@ -1,15 +1,17 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux - +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, contributor: + Denis Merigoux - 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 + 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 + 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. *) open Utils @@ -25,8 +27,8 @@ let format_location (fmt : Format.formatter) (l : location) : unit = match l with | ScopeVar v -> Format.fprintf fmt "%a" ScopeVar.format_t (Pos.unmark v) | SubScopeVar (_, subindex, subvar) -> - Format.fprintf fmt "%a.%a" SubScopeName.format_t (Pos.unmark subindex) ScopeVar.format_t - (Pos.unmark subvar) + Format.fprintf fmt "%a.%a" SubScopeName.format_t (Pos.unmark subindex) + ScopeVar.format_t (Pos.unmark subvar) let typ_needs_parens (e : typ Pos.marked) : bool = match Pos.unmark e with TArrow _ -> true | _ -> false @@ -34,8 +36,8 @@ let typ_needs_parens (e : typ Pos.marked) : bool = let rec format_typ (fmt : Format.formatter) (typ : typ Pos.marked) : unit = let format_typ_with_parens (fmt : Format.formatter) (t : typ Pos.marked) = if typ_needs_parens t then - Format.fprintf fmt "%a%a%a" Dcalc.Print.format_punctuation "(" format_typ t - Dcalc.Print.format_punctuation ")" + Format.fprintf fmt "%a%a%a" Dcalc.Print.format_punctuation "(" format_typ + t Dcalc.Print.format_punctuation ")" else Format.fprintf fmt "%a" format_typ t in match Pos.unmark typ with @@ -58,84 +60,108 @@ let rec format_expr (fmt : Format.formatter) (e : expr Pos.marked) : unit = match Pos.unmark e with | ELocation l -> Format.fprintf fmt "%a" format_location l | EVar v -> Format.fprintf fmt "%a" format_var (Pos.unmark v) - | ELit l -> Format.fprintf fmt "%a" Dcalc.Print.format_lit (Pos.same_pos_as l e) + | ELit l -> + Format.fprintf fmt "%a" Dcalc.Print.format_lit (Pos.same_pos_as l e) | EStruct (name, fields) -> - Format.fprintf fmt " @[%a@ %a@ %a@ %a@]" Ast.StructName.format_t name - Dcalc.Print.format_punctuation "{" + Format.fprintf fmt " @[%a@ %a@ %a@ %a@]" Ast.StructName.format_t + name Dcalc.Print.format_punctuation "{" (Format.pp_print_list - ~pp_sep:(fun fmt () -> Format.fprintf fmt "%a@ " Dcalc.Print.format_punctuation ";") + ~pp_sep:(fun fmt () -> + Format.fprintf fmt "%a@ " Dcalc.Print.format_punctuation ";") (fun fmt (field_name, field_expr) -> - Format.fprintf fmt "%a%a%a%a@ %a" Dcalc.Print.format_punctuation "\"" - Ast.StructFieldName.format_t field_name Dcalc.Print.format_punctuation "\"" + Format.fprintf fmt "%a%a%a%a@ %a" Dcalc.Print.format_punctuation + "\"" Ast.StructFieldName.format_t field_name + Dcalc.Print.format_punctuation "\"" Dcalc.Print.format_punctuation "=" format_expr field_expr)) (Ast.StructFieldMap.bindings fields) Dcalc.Print.format_punctuation "}" | EStructAccess (e1, field, _) -> - Format.fprintf fmt "%a%a%a%a%a" format_expr e1 Dcalc.Print.format_punctuation "." - Dcalc.Print.format_punctuation "\"" Ast.StructFieldName.format_t field - Dcalc.Print.format_punctuation "\"" + Format.fprintf fmt "%a%a%a%a%a" format_expr e1 + Dcalc.Print.format_punctuation "." Dcalc.Print.format_punctuation "\"" + Ast.StructFieldName.format_t field Dcalc.Print.format_punctuation "\"" | EEnumInj (e1, cons, _) -> - Format.fprintf fmt "%a@ %a" Ast.EnumConstructor.format_t cons format_expr e1 + Format.fprintf fmt "%a@ %a" Ast.EnumConstructor.format_t cons format_expr + e1 | EMatch (e1, _, cases) -> - Format.fprintf fmt "@[%a@ @[%a@]@ %a@ %a@]" Dcalc.Print.format_keyword "match" - format_expr e1 Dcalc.Print.format_keyword "with" + Format.fprintf fmt "@[%a@ @[%a@]@ %a@ %a@]" + Dcalc.Print.format_keyword "match" format_expr e1 + Dcalc.Print.format_keyword "with" (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n") (fun fmt (cons_name, case_expr) -> - Format.fprintf fmt "@[%a %a@ %a@ %a@]" Dcalc.Print.format_punctuation "|" - Dcalc.Print.format_enum_constructor cons_name Dcalc.Print.format_punctuation "→" - format_expr case_expr)) + Format.fprintf fmt "@[%a %a@ %a@ %a@]" + Dcalc.Print.format_punctuation "|" + Dcalc.Print.format_enum_constructor cons_name + Dcalc.Print.format_punctuation "→" format_expr case_expr)) (Ast.EnumConstructorMap.bindings cases) | EApp ((EAbs ((binder, _), taus), _), args) -> let xs, body = Bindlib.unmbind binder in let xs_tau = List.map2 (fun x tau -> (x, tau)) (Array.to_list xs) taus in - let xs_tau_arg = List.map2 (fun (x, tau) arg -> (x, tau, arg)) xs_tau args in + let xs_tau_arg = + List.map2 (fun (x, tau) arg -> (x, tau, arg)) xs_tau args + in Format.fprintf fmt "@[%a%a@]" (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt " ") (fun fmt (x, tau, arg) -> Format.fprintf fmt "@[%a@ %a@ %a@ %a@ %a@ %a@ %a@\n@]" - Dcalc.Print.format_keyword "let" format_var x Dcalc.Print.format_punctuation ":" - format_typ tau Dcalc.Print.format_punctuation "=" format_expr arg + Dcalc.Print.format_keyword "let" format_var x + Dcalc.Print.format_punctuation ":" format_typ tau + Dcalc.Print.format_punctuation "=" format_expr arg Dcalc.Print.format_keyword "in")) xs_tau_arg format_expr body | EAbs ((binder, _), taus) -> let xs, body = Bindlib.unmbind binder in let xs_tau = List.map2 (fun x tau -> (x, tau)) (Array.to_list xs) taus in - Format.fprintf fmt "@[%a@ %a@ %a@ %a@]" Dcalc.Print.format_punctuation "λ" + Format.fprintf fmt "@[%a@ %a@ %a@ %a@]" + Dcalc.Print.format_punctuation "λ" (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt " ") (fun fmt (x, tau) -> - Format.fprintf fmt "@[%a%a%a@ %a%a@]" Dcalc.Print.format_punctuation "(" format_var x - Dcalc.Print.format_punctuation ":" format_typ tau Dcalc.Print.format_punctuation ")")) + Format.fprintf fmt "@[%a%a%a@ %a%a@]" + Dcalc.Print.format_punctuation "(" format_var x + Dcalc.Print.format_punctuation ":" format_typ tau + Dcalc.Print.format_punctuation ")")) xs_tau Dcalc.Print.format_punctuation "→" format_expr body | EApp ((EOp (Binop op), _), [ arg1; arg2 ]) -> - Format.fprintf fmt "@[%a@ %a@ %a@]" format_with_parens arg1 Dcalc.Print.format_binop - (op, Pos.no_pos) format_with_parens arg2 + Format.fprintf fmt "@[%a@ %a@ %a@]" format_with_parens arg1 + Dcalc.Print.format_binop (op, Pos.no_pos) format_with_parens arg2 | EApp ((EOp (Unop op), _), [ arg1 ]) -> - Format.fprintf fmt "@[%a@ %a@]" Dcalc.Print.format_unop (op, Pos.no_pos) format_with_parens - arg1 + Format.fprintf fmt "@[%a@ %a@]" Dcalc.Print.format_unop (op, Pos.no_pos) + format_with_parens arg1 | EApp (f, args) -> Format.fprintf fmt "@[%a@ %a@]" format_expr f - (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ") format_with_parens) + (Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ") + format_with_parens) args | EIfThenElse (e1, e2, e3) -> - Format.fprintf fmt "@[%a@ %a@ %a@ %a@ %a@ %a@]" Dcalc.Print.format_keyword "if" - format_expr e1 Dcalc.Print.format_keyword "then" format_expr e2 Dcalc.Print.format_keyword - "else" format_expr e3 - | EOp (Ternop op) -> Format.fprintf fmt "%a" Dcalc.Print.format_ternop (op, Pos.no_pos) - | EOp (Binop op) -> Format.fprintf fmt "%a" Dcalc.Print.format_binop (op, Pos.no_pos) - | EOp (Unop op) -> Format.fprintf fmt "%a" Dcalc.Print.format_unop (op, Pos.no_pos) + Format.fprintf fmt "@[%a@ %a@ %a@ %a@ %a@ %a@]" + Dcalc.Print.format_keyword "if" format_expr e1 + Dcalc.Print.format_keyword "then" format_expr e2 + Dcalc.Print.format_keyword "else" format_expr e3 + | EOp (Ternop op) -> + Format.fprintf fmt "%a" Dcalc.Print.format_ternop (op, Pos.no_pos) + | EOp (Binop op) -> + Format.fprintf fmt "%a" Dcalc.Print.format_binop (op, Pos.no_pos) + | EOp (Unop op) -> + Format.fprintf fmt "%a" Dcalc.Print.format_unop (op, Pos.no_pos) | EDefault (excepts, just, cons) -> if List.length excepts = 0 then - Format.fprintf fmt "@[%a%a %a@ %a%a@]" Dcalc.Print.format_punctuation "⟨" format_expr just - Dcalc.Print.format_punctuation "⊢" format_expr cons Dcalc.Print.format_punctuation "⟩" + Format.fprintf fmt "@[%a%a %a@ %a%a@]" Dcalc.Print.format_punctuation + "⟨" format_expr just Dcalc.Print.format_punctuation "⊢" format_expr + cons Dcalc.Print.format_punctuation "⟩" else - Format.fprintf fmt "@[%a%a@ %a@ %a %a@ %a%a@]" Dcalc.Print.format_punctuation "⟨" - (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ") format_expr) - excepts Dcalc.Print.format_punctuation "|" format_expr just Dcalc.Print.format_punctuation - "⊢" format_expr cons Dcalc.Print.format_punctuation "⟩" - | ErrorOnEmpty e' -> Format.fprintf fmt "error_empty@ %a" format_with_parens e' + Format.fprintf fmt "@[%a%a@ %a@ %a %a@ %a%a@]" + Dcalc.Print.format_punctuation "⟨" + (Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ") + format_expr) + excepts Dcalc.Print.format_punctuation "|" format_expr just + Dcalc.Print.format_punctuation "⊢" format_expr cons + Dcalc.Print.format_punctuation "⟩" + | ErrorOnEmpty e' -> + Format.fprintf fmt "error_empty@ %a" format_with_parens e' | EArray es -> Format.fprintf fmt "%a%a%a" Dcalc.Print.format_punctuation "[" (Format.pp_print_list @@ -143,10 +169,13 @@ let rec format_expr (fmt : Format.formatter) (e : expr Pos.marked) : unit = (fun fmt e -> Format.fprintf fmt "@[%a@]" format_expr e)) es Dcalc.Print.format_punctuation "]" -let format_struct (fmt : Format.formatter) - ((name, fields) : StructName.t * (StructFieldName.t * typ Pos.marked) list) : unit = - Format.fprintf fmt "%a %a %a %a@\n@[ %a@]@\n%a" Dcalc.Print.format_keyword "type" - StructName.format_t name Dcalc.Print.format_punctuation "=" Dcalc.Print.format_punctuation "{" +let format_struct + (fmt : Format.formatter) + ((name, fields) : StructName.t * (StructFieldName.t * typ Pos.marked) list) + : unit = + Format.fprintf fmt "%a %a %a %a@\n@[ %a@]@\n%a" + Dcalc.Print.format_keyword "type" StructName.format_t name + Dcalc.Print.format_punctuation "=" Dcalc.Print.format_punctuation "{" (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n") (fun fmt (field_name, typ) -> @@ -154,26 +183,32 @@ let format_struct (fmt : Format.formatter) Dcalc.Print.format_punctuation ":" format_typ typ)) fields Dcalc.Print.format_punctuation "}" -let format_enum (fmt : Format.formatter) - ((name, cases) : EnumName.t * (EnumConstructor.t * typ Pos.marked) list) : unit = - Format.fprintf fmt "%a %a %a @\n@[ %a@]" Dcalc.Print.format_keyword "type" - EnumName.format_t name Dcalc.Print.format_punctuation "=" +let format_enum + (fmt : Format.formatter) + ((name, cases) : EnumName.t * (EnumConstructor.t * typ Pos.marked) list) : + unit = + Format.fprintf fmt "%a %a %a @\n@[ %a@]" Dcalc.Print.format_keyword + "type" EnumName.format_t name Dcalc.Print.format_punctuation "=" (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n") (fun fmt (field_name, typ) -> - Format.fprintf fmt "%a %a%a %a" Dcalc.Print.format_punctuation "|" EnumConstructor.format_t - field_name Dcalc.Print.format_punctuation ":" format_typ typ)) + Format.fprintf fmt "%a %a%a %a" Dcalc.Print.format_punctuation "|" + EnumConstructor.format_t field_name Dcalc.Print.format_punctuation + ":" format_typ typ)) cases -let format_scope (fmt : Format.formatter) ((name, decl) : ScopeName.t * scope_decl) : unit = - Format.fprintf fmt "@[%a@ %a@ %a@ %a@ %a@]@\n@[ %a@]" Dcalc.Print.format_keyword - "let" Dcalc.Print.format_keyword "scope" ScopeName.format_t name +let format_scope + (fmt : Format.formatter) ((name, decl) : ScopeName.t * scope_decl) : unit = + Format.fprintf fmt "@[%a@ %a@ %a@ %a@ %a@]@\n@[ %a@]" + Dcalc.Print.format_keyword "let" Dcalc.Print.format_keyword "scope" + ScopeName.format_t name (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ") (fun fmt (scope_var, (typ, vis)) -> - Format.fprintf fmt "%a%a%a %a%a%a%a%a" Dcalc.Print.format_punctuation "(" ScopeVar.format_t - scope_var Dcalc.Print.format_punctuation ":" format_typ typ - Dcalc.Print.format_punctuation "|" Dcalc.Print.format_keyword + Format.fprintf fmt "%a%a%a %a%a%a%a%a" Dcalc.Print.format_punctuation + "(" ScopeVar.format_t scope_var Dcalc.Print.format_punctuation ":" + format_typ typ Dcalc.Print.format_punctuation "|" + Dcalc.Print.format_keyword (match Pos.unmark vis.io_input with | NoInput -> "internal" | OnlyInput -> "input" @@ -186,19 +221,23 @@ let format_scope (fmt : Format.formatter) ((name, decl) : ScopeName.t * scope_de (ScopeVarMap.bindings decl.scope_sig) Dcalc.Print.format_punctuation "=" (Format.pp_print_list - ~pp_sep:(fun fmt () -> Format.fprintf fmt "%a@ " Dcalc.Print.format_punctuation ";") + ~pp_sep:(fun fmt () -> + Format.fprintf fmt "%a@ " Dcalc.Print.format_punctuation ";") (fun fmt rule -> match rule with | Definition (loc, typ, _, e) -> - Format.fprintf fmt "@[%a %a %a %a %a@ %a@]" Dcalc.Print.format_keyword "let" - format_location (Pos.unmark loc) Dcalc.Print.format_punctuation ":" format_typ typ + Format.fprintf fmt "@[%a %a %a %a %a@ %a@]" + Dcalc.Print.format_keyword "let" format_location (Pos.unmark loc) + Dcalc.Print.format_punctuation ":" format_typ typ Dcalc.Print.format_punctuation "=" (fun fmt e -> match Pos.unmark loc with | SubScopeVar _ -> format_expr fmt e | ScopeVar v -> ( match - Pos.unmark (snd (ScopeVarMap.find (Pos.unmark v) decl.scope_sig)).io_input + Pos.unmark + (snd (ScopeVarMap.find (Pos.unmark v) decl.scope_sig)) + .io_input with | Reentrant -> Format.fprintf fmt "%a@ %a" Dcalc.Print.format_operator @@ -206,25 +245,34 @@ let format_scope (fmt : Format.formatter) ((name, decl) : ScopeName.t * scope_de | _ -> Format.fprintf fmt "%a" format_expr e)) e | Assertion e -> - Format.fprintf fmt "%a %a" Dcalc.Print.format_keyword "assert" format_expr e + Format.fprintf fmt "%a %a" Dcalc.Print.format_keyword "assert" + format_expr e | Call (scope_name, subscope_name) -> - Format.fprintf fmt "%a %a%a%a%a" Dcalc.Print.format_keyword "call" ScopeName.format_t - scope_name Dcalc.Print.format_punctuation "[" SubScopeName.format_t subscope_name + Format.fprintf fmt "%a %a%a%a%a" Dcalc.Print.format_keyword "call" + ScopeName.format_t scope_name Dcalc.Print.format_punctuation "[" + SubScopeName.format_t subscope_name Dcalc.Print.format_punctuation "]")) decl.scope_decl_rules let format_program (fmt : Format.formatter) (p : program) : unit = Format.fprintf fmt "%a%a%a%a%a" - (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "\n\n") format_struct) + (Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.fprintf fmt "\n\n") + format_struct) (StructMap.bindings p.program_structs) (fun fmt () -> if StructMap.is_empty p.program_structs then Format.fprintf fmt "" else Format.fprintf fmt "\n\n") () - (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "\n\n") format_enum) + (Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.fprintf fmt "\n\n") + format_enum) (EnumMap.bindings p.program_enums) (fun fmt () -> - if EnumMap.is_empty p.program_enums then Format.fprintf fmt "" else Format.fprintf fmt "\n\n") + if EnumMap.is_empty p.program_enums then Format.fprintf fmt "" + else Format.fprintf fmt "\n\n") () - (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "\n\n") format_scope) + (Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.fprintf fmt "\n\n") + format_scope) (ScopeMap.bindings p.program_scopes) diff --git a/compiler/scopelang/print.mli b/compiler/scopelang/print.mli index 687dd506..1ac87c0d 100644 --- a/compiler/scopelang/print.mli +++ b/compiler/scopelang/print.mli @@ -1,27 +1,24 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux - +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, contributor: + Denis Merigoux - 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 + 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 + 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. *) open Utils val format_var : Format.formatter -> Ast.Var.t -> unit - val format_location : Format.formatter -> Ast.location -> unit - val format_typ : Format.formatter -> Ast.typ Pos.marked -> unit - val format_expr : Format.formatter -> Ast.expr Pos.marked -> unit - val format_scope : Format.formatter -> Ast.ScopeName.t * Ast.scope_decl -> unit - val format_program : Format.formatter -> Ast.program -> unit diff --git a/compiler/scopelang/scope_to_dcalc.ml b/compiler/scopelang/scope_to_dcalc.ml index f5c839c8..8bb35ea8 100644 --- a/compiler/scopelang/scope_to_dcalc.ml +++ b/compiler/scopelang/scope_to_dcalc.ml @@ -1,15 +1,17 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux - +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, contributor: + Denis Merigoux - 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 + 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 + 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. *) open Utils @@ -37,11 +39,16 @@ type ctx = { scope_name : Ast.ScopeName.t; scopes_parameters : scope_sigs_ctx; scope_vars : (Dcalc.Ast.Var.t * Dcalc.Ast.typ * Ast.io) Ast.ScopeVarMap.t; - subscope_vars : (Dcalc.Ast.Var.t * Dcalc.Ast.typ * Ast.io) Ast.ScopeVarMap.t Ast.SubScopeMap.t; + subscope_vars : + (Dcalc.Ast.Var.t * Dcalc.Ast.typ * Ast.io) Ast.ScopeVarMap.t + Ast.SubScopeMap.t; local_vars : Dcalc.Ast.Var.t Ast.VarMap.t; } -let empty_ctx (struct_ctx : Ast.struct_ctx) (enum_ctx : Ast.enum_ctx) (scopes_ctx : scope_sigs_ctx) +let empty_ctx + (struct_ctx : Ast.struct_ctx) + (enum_ctx : Ast.enum_ctx) + (scopes_ctx : scope_sigs_ctx) (scope_name : Ast.ScopeName.t) = { structs = struct_ctx; @@ -53,23 +60,30 @@ let empty_ctx (struct_ctx : Ast.struct_ctx) (enum_ctx : Ast.enum_ctx) (scopes_ct local_vars = Ast.VarMap.empty; } -let rec translate_typ (ctx : ctx) (t : Ast.typ Pos.marked) : Dcalc.Ast.typ Pos.marked = +let rec translate_typ (ctx : ctx) (t : Ast.typ Pos.marked) : + Dcalc.Ast.typ Pos.marked = Pos.same_pos_as (match Pos.unmark t with | Ast.TLit l -> Dcalc.Ast.TLit l - | Ast.TArrow (t1, t2) -> Dcalc.Ast.TArrow (translate_typ ctx t1, translate_typ ctx t2) + | Ast.TArrow (t1, t2) -> + Dcalc.Ast.TArrow (translate_typ ctx t1, translate_typ ctx t2) | Ast.TStruct s_uid -> let s_fields = Ast.StructMap.find s_uid ctx.structs in - Dcalc.Ast.TTuple (List.map (fun (_, t) -> translate_typ ctx t) s_fields, Some s_uid) + Dcalc.Ast.TTuple + (List.map (fun (_, t) -> translate_typ ctx t) s_fields, Some s_uid) | Ast.TEnum e_uid -> let e_cases = Ast.EnumMap.find e_uid ctx.enums in - Dcalc.Ast.TEnum (List.map (fun (_, t) -> translate_typ ctx t) e_cases, e_uid) - | Ast.TArray t1 -> Dcalc.Ast.TArray (translate_typ ctx (Pos.same_pos_as t1 t)) + Dcalc.Ast.TEnum + (List.map (fun (_, t) -> translate_typ ctx t) e_cases, e_uid) + | Ast.TArray t1 -> + Dcalc.Ast.TArray (translate_typ ctx (Pos.same_pos_as t1 t)) | Ast.TAny -> Dcalc.Ast.TAny) t -let merge_defaults (caller : Dcalc.Ast.expr Pos.marked Bindlib.box) - (callee : Dcalc.Ast.expr Pos.marked Bindlib.box) : Dcalc.Ast.expr Pos.marked Bindlib.box = +let merge_defaults + (caller : Dcalc.Ast.expr Pos.marked Bindlib.box) + (callee : Dcalc.Ast.expr Pos.marked Bindlib.box) : + Dcalc.Ast.expr Pos.marked Bindlib.box = let caller = Dcalc.Ast.make_app caller [ Bindlib.box (Dcalc.Ast.ELit Dcalc.Ast.LUnit, Pos.no_pos) ] @@ -79,23 +93,30 @@ let merge_defaults (caller : Dcalc.Ast.expr Pos.marked Bindlib.box) Bindlib.box_apply2 (fun caller callee -> ( Dcalc.Ast.EDefault - ([ caller ], (Dcalc.Ast.ELit (Dcalc.Ast.LBool true), Pos.no_pos), callee), + ( [ caller ], + (Dcalc.Ast.ELit (Dcalc.Ast.LBool true), Pos.no_pos), + callee ), Pos.no_pos )) caller callee in body -let tag_with_log_entry (e : Dcalc.Ast.expr Pos.marked Bindlib.box) (l : Dcalc.Ast.log_entry) - (markings : Utils.Uid.MarkedString.info list) : Dcalc.Ast.expr Pos.marked Bindlib.box = +let tag_with_log_entry + (e : Dcalc.Ast.expr Pos.marked Bindlib.box) + (l : Dcalc.Ast.log_entry) + (markings : Utils.Uid.MarkedString.info list) : + Dcalc.Ast.expr Pos.marked Bindlib.box = Bindlib.box_apply (fun e -> ( Dcalc.Ast.EApp - ((Dcalc.Ast.EOp (Dcalc.Ast.Unop (Dcalc.Ast.Log (l, markings))), Pos.get_position e), [ e ]), + ( ( Dcalc.Ast.EOp (Dcalc.Ast.Unop (Dcalc.Ast.Log (l, markings))), + Pos.get_position e ), + [ e ] ), Pos.get_position e )) e -let rec translate_expr (ctx : ctx) (e : Ast.expr Pos.marked) : Dcalc.Ast.expr Pos.marked Bindlib.box - = +let rec translate_expr (ctx : ctx) (e : Ast.expr Pos.marked) : + Dcalc.Ast.expr Pos.marked Bindlib.box = Bindlib.box_apply (fun (x : Dcalc.Ast.expr) -> Pos.same_pos_as x e) (match Pos.unmark e with @@ -108,13 +129,14 @@ let rec translate_expr (ctx : ctx) (e : Ast.expr Pos.marked) : Dcalc.Ast.expr Po (fun (field_name, _) (d_fields, e_fields) -> let field_e = Ast.StructFieldMap.find field_name e_fields in let field_d = translate_expr ctx field_e in - (field_d :: d_fields, Ast.StructFieldMap.remove field_name e_fields)) + ( field_d :: d_fields, + Ast.StructFieldMap.remove field_name e_fields )) struct_sig ([], e_fields) in if Ast.StructFieldMap.cardinal remaining_e_fields > 0 then Errors.raise_spanned_error (Pos.get_position e) - "The fields \"%a\" do not belong to the structure %a" Ast.StructName.format_t - struct_name + "The fields \"%a\" do not belong to the structure %a" + Ast.StructName.format_t struct_name (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt ", ") (fun fmt (field_name, _) -> @@ -127,11 +149,14 @@ let rec translate_expr (ctx : ctx) (e : Ast.expr Pos.marked) : Dcalc.Ast.expr Po | EStructAccess (e1, field_name, struct_name) -> let struct_sig = Ast.StructMap.find struct_name ctx.structs in let _, field_index = - try List.assoc field_name (List.mapi (fun i (x, y) -> (x, (y, i))) struct_sig) + try + List.assoc field_name + (List.mapi (fun i (x, y) -> (x, (y, i))) struct_sig) with Not_found -> Errors.raise_spanned_error (Pos.get_position e) - "The field \"%a\" does not belong to the structure %a" Ast.StructFieldName.format_t - field_name Ast.StructName.format_t struct_name + "The field \"%a\" does not belong to the structure %a" + Ast.StructFieldName.format_t field_name Ast.StructName.format_t + struct_name in let e1 = translate_expr ctx e1 in Bindlib.box_apply @@ -145,11 +170,14 @@ let rec translate_expr (ctx : ctx) (e : Ast.expr Pos.marked) : Dcalc.Ast.expr Po | EEnumInj (e1, constructor, enum_name) -> let enum_sig = Ast.EnumMap.find enum_name ctx.enums in let _, constructor_index = - try List.assoc constructor (List.mapi (fun i (x, y) -> (x, (y, i))) enum_sig) + try + List.assoc constructor + (List.mapi (fun i (x, y) -> (x, (y, i))) enum_sig) with Not_found -> Errors.raise_spanned_error (Pos.get_position e) - "The constructor \"%a\" does not belong to the enum %a" Ast.EnumConstructor.format_t - constructor Ast.EnumName.format_t enum_name + "The constructor \"%a\" does not belong to the enum %a" + Ast.EnumConstructor.format_t constructor Ast.EnumName.format_t + enum_name in let e1 = translate_expr ctx e1 in Bindlib.box_apply @@ -169,17 +197,20 @@ let rec translate_expr (ctx : ctx) (e : Ast.expr Pos.marked) : Dcalc.Ast.expr Po try Ast.EnumConstructorMap.find constructor e_cases with Not_found -> Errors.raise_spanned_error (Pos.get_position e) - "The constructor %a of enum %a is missing from this pattern matching" - Ast.EnumConstructor.format_t constructor Ast.EnumName.format_t enum_name + "The constructor %a of enum %a is missing from this \ + pattern matching" + Ast.EnumConstructor.format_t constructor + Ast.EnumName.format_t enum_name in let case_d = translate_expr ctx case_e in - (case_d :: d_cases, Ast.EnumConstructorMap.remove constructor e_cases)) + ( case_d :: d_cases, + Ast.EnumConstructorMap.remove constructor e_cases )) enum_sig ([], cases) in if Ast.EnumConstructorMap.cardinal remaining_e_cases > 0 then Errors.raise_spanned_error (Pos.get_position e) - "Patter matching is incomplete for enum %a: missing cases %a" Ast.EnumName.format_t - enum_name + "Patter matching is incomplete for enum %a: missing cases %a" + Ast.EnumName.format_t enum_name (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt ", ") (fun fmt (case_name, _) -> @@ -191,18 +222,20 @@ let rec translate_expr (ctx : ctx) (e : Ast.expr Pos.marked) : Dcalc.Ast.expr Po (fun d_fields e1 -> Dcalc.Ast.EMatch (e1, d_fields, enum_name)) (Bindlib.box_list d_cases) e1 | EApp (e1, args) -> - (* We insert various log calls to record arguments and outputs of user-defined functions - belonging to scopes *) + (* We insert various log calls to record arguments and outputs of + user-defined functions belonging to scopes *) let e1_func = translate_expr ctx e1 in let markings l = match l with | Ast.ScopeVar (v, _) -> [ Ast.ScopeName.get_info ctx.scope_name; Ast.ScopeVar.get_info v ] - | Ast.SubScopeVar (s, _, (v, _)) -> [ Ast.ScopeName.get_info s; Ast.ScopeVar.get_info v ] + | Ast.SubScopeVar (s, _, (v, _)) -> + [ Ast.ScopeName.get_info s; Ast.ScopeVar.get_info v ] in let e1_func = match Pos.unmark e1 with - | ELocation l -> tag_with_log_entry e1_func Dcalc.Ast.BeginCall (markings l) + | ELocation l -> + tag_with_log_entry e1_func Dcalc.Ast.BeginCall (markings l) | _ -> e1_func in let new_args = List.map (translate_expr ctx) args in @@ -218,7 +251,8 @@ let rec translate_expr (ctx : ctx) (e : Ast.expr Pos.marked) : Dcalc.Ast.expr Po let new_e = Bindlib.box_apply2 (fun e' u -> (Dcalc.Ast.EApp (e', u), Pos.get_position e)) - e1_func (Bindlib.box_list new_args) + e1_func + (Bindlib.box_list new_args) in let new_e = match Pos.unmark e1 with @@ -232,7 +266,11 @@ let rec translate_expr (ctx : ctx) (e : Ast.expr Pos.marked) : Dcalc.Ast.expr Po Bindlib.box_apply Pos.unmark new_e | EAbs ((binder, pos_binder), typ) -> let xs, body = Bindlib.unmbind binder in - let new_xs = Array.map (fun x -> Dcalc.Ast.Var.make (Bindlib.name_of x, Pos.no_pos)) xs in + let new_xs = + Array.map + (fun x -> Dcalc.Ast.Var.make (Bindlib.name_of x, Pos.no_pos)) + xs + in let both_xs = Array.map2 (fun x new_x -> (x, new_x)) xs new_xs in let body = translate_expr @@ -240,17 +278,22 @@ let rec translate_expr (ctx : ctx) (e : Ast.expr Pos.marked) : Dcalc.Ast.expr Po ctx with local_vars = Array.fold_left - (fun local_vars (x, new_x) -> Ast.VarMap.add x new_x local_vars) + (fun local_vars (x, new_x) -> + Ast.VarMap.add x new_x local_vars) ctx.local_vars both_xs; } body in let binder = Bindlib.bind_mvar new_xs body in Bindlib.box_apply - (fun b -> Dcalc.Ast.EAbs ((b, pos_binder), List.map (translate_typ ctx) typ)) + (fun b -> + Dcalc.Ast.EAbs ((b, pos_binder), List.map (translate_typ ctx) typ)) binder | EDefault (excepts, just, cons) -> - let just = tag_with_log_entry (translate_expr ctx just) Dcalc.Ast.PosRecordIfTrueBool [] in + let just = + tag_with_log_entry (translate_expr ctx just) + Dcalc.Ast.PosRecordIfTrueBool [] + in Bindlib.box_apply3 (fun e j c -> Dcalc.Ast.EDefault (e, j, c)) (Bindlib.box_list (List.map (translate_expr ctx) excepts)) @@ -274,28 +317,36 @@ let rec translate_expr (ctx : ctx) (e : Ast.expr Pos.marked) : Dcalc.Ast.expr Po ( Some "Incriminated subscope declaration:", Pos.get_position (Ast.SubScopeName.get_info (Pos.unmark s)) ); ] - "The variable %a.%a cannot be used here, as it is not part subscope %a's results. \ - Maybe you forgot to qualify it as an output?" - Ast.SubScopeName.format_t (Pos.unmark s) Ast.ScopeVar.format_t (Pos.unmark a) - Ast.SubScopeName.format_t (Pos.unmark s)) + "The variable %a.%a cannot be used here, as it is not part \ + subscope %a's results. Maybe you forgot to qualify it as an \ + output?" + Ast.SubScopeName.format_t (Pos.unmark s) Ast.ScopeVar.format_t + (Pos.unmark a) Ast.SubScopeName.format_t (Pos.unmark s)) | EIfThenElse (cond, et, ef) -> Bindlib.box_apply3 (fun c t f -> Dcalc.Ast.EIfThenElse (c, t, f)) - (translate_expr ctx cond) (translate_expr ctx et) (translate_expr ctx ef) + (translate_expr ctx cond) (translate_expr ctx et) + (translate_expr ctx ef) | EOp op -> Bindlib.box (Dcalc.Ast.EOp op) | ErrorOnEmpty e' -> - Bindlib.box_apply (fun e' -> Dcalc.Ast.ErrorOnEmpty e') (translate_expr ctx e') + Bindlib.box_apply + (fun e' -> Dcalc.Ast.ErrorOnEmpty e') + (translate_expr ctx e') | EArray es -> Bindlib.box_apply (fun es -> Dcalc.Ast.EArray es) (Bindlib.box_list (List.map (translate_expr ctx) es))) -(** The result of a rule translation is a list of assignment, with variables and expressions. We - also return the new translation context available after the assignment to use in later rule - translations. The list is actually a list of list because we want to group in assignments that - are independent of each other to speed up the translation by minimizing Bindlib.bind_mvar *) -let translate_rule (ctx : ctx) (rule : Ast.rule) - ((sigma_name, pos_sigma) : Utils.Uid.MarkedString.info) : Dcalc.Ast.scope_let list * ctx = +(** The result of a rule translation is a list of assignment, with variables and + expressions. We also return the new translation context available after the + assignment to use in later rule translations. The list is actually a list of + list because we want to group in assignments that are independent of each + other to speed up the translation by minimizing Bindlib.bind_mvar *) +let translate_rule + (ctx : ctx) + (rule : Ast.rule) + ((sigma_name, pos_sigma) : Utils.Uid.MarkedString.info) : + Dcalc.Ast.scope_let list * ctx = match rule with | Definition ((ScopeVar a, var_def_pos), tau, a_io, e) -> let a_name = Ast.ScopeVar.get_info (Pos.unmark a) in @@ -305,11 +356,13 @@ let translate_rule (ctx : ctx) (rule : Ast.rule) let a_expr = Dcalc.Ast.make_var (a_var, var_def_pos) in let merged_expr = Bindlib.box_apply - (fun merged_expr -> (Dcalc.Ast.ErrorOnEmpty merged_expr, Pos.get_position a_name)) + (fun merged_expr -> + (Dcalc.Ast.ErrorOnEmpty merged_expr, Pos.get_position a_name)) (match Pos.unmark a_io.io_input with | OnlyInput -> failwith "should not happen" - (* scopelang should not contain any definitions of input only variables *) + (* scopelang should not contain any definitions of input only + variables *) | Reentrant -> merge_defaults a_expr new_e | NoInput -> new_e) in @@ -329,12 +382,19 @@ let translate_rule (ctx : ctx) (rule : Ast.rule) { ctx with scope_vars = - Ast.ScopeVarMap.add (Pos.unmark a) (a_var, Pos.unmark tau, a_io) ctx.scope_vars; + Ast.ScopeVarMap.add (Pos.unmark a) + (a_var, Pos.unmark tau, a_io) + ctx.scope_vars; } ) - | Definition ((SubScopeVar (_subs_name, subs_index, subs_var), var_def_pos), tau, a_io, e) -> + | Definition + ( (SubScopeVar (_subs_name, subs_index, subs_var), var_def_pos), + tau, + a_io, + e ) -> let a_name = Pos.map_under_mark - (fun str -> str ^ "." ^ Pos.unmark (Ast.ScopeVar.get_info (Pos.unmark subs_var))) + (fun str -> + str ^ "." ^ Pos.unmark (Ast.ScopeVar.get_info (Pos.unmark subs_var))) (Ast.SubScopeName.get_info (Pos.unmark subs_index)) in let a_var = Dcalc.Ast.Var.make a_name in @@ -350,7 +410,8 @@ let translate_rule (ctx : ctx) (rule : Ast.rule) | NoInput -> failwith "should not happen" | OnlyInput -> Bindlib.box_apply - (fun new_e -> (Dcalc.Ast.ErrorOnEmpty new_e, Pos.get_position subs_var)) + (fun new_e -> + (Dcalc.Ast.ErrorOnEmpty new_e, Pos.get_position subs_var)) new_e | Reentrant -> Dcalc.Ast.make_abs @@ -366,7 +427,9 @@ let translate_rule (ctx : ctx) (rule : Ast.rule) (match Pos.unmark a_io.io_input with | NoInput -> failwith "should not happen" | OnlyInput -> tau - | Reentrant -> (Dcalc.Ast.TArrow ((TLit TUnit, var_def_pos), tau), var_def_pos)); + | Reentrant -> + ( Dcalc.Ast.TArrow ((TLit TUnit, var_def_pos), tau), + var_def_pos )); Dcalc.Ast.scope_let_expr = thunked_or_nonempty_new_e; Dcalc.Ast.scope_let_kind = Dcalc.Ast.SubScopeVarDefinition; }; @@ -379,7 +442,9 @@ let translate_rule (ctx : ctx) (rule : Ast.rule) match map with | Some map -> Some - (Ast.ScopeVarMap.add (Pos.unmark subs_var) (a_var, Pos.unmark tau, a_io) map) + (Ast.ScopeVarMap.add (Pos.unmark subs_var) + (a_var, Pos.unmark tau, a_io) + map) | None -> Some (Ast.ScopeVarMap.singleton (Pos.unmark subs_var) @@ -392,11 +457,15 @@ let translate_rule (ctx : ctx) (rule : Ast.rule) let all_subscope_input_vars = List.filter (fun var_ctx -> - match Pos.unmark var_ctx.scope_var_io.Ast.io_input with NoInput -> false | _ -> true) + match Pos.unmark var_ctx.scope_var_io.Ast.io_input with + | NoInput -> false + | _ -> true) all_subscope_vars in let all_subscope_output_vars = - List.filter (fun var_ctx -> Pos.unmark var_ctx.scope_var_io.Ast.io_output) all_subscope_vars + List.filter + (fun var_ctx -> Pos.unmark var_ctx.scope_var_io.Ast.io_output) + all_subscope_vars in let scope_dcalc_var = subscope_sig.scope_sig_scope_var in let called_scope_input_struct = subscope_sig.scope_sig_input_struct in @@ -413,19 +482,23 @@ let translate_rule (ctx : ctx) (rule : Ast.rule) List.map (fun (subvar : scope_var_ctx) -> if subscope_var_not_yet_defined subvar.scope_var_name then - (* This is a redundant check. Normally, all subscope varaibles should have been - defined (even an empty definition, if they're not defined by any rule in the source - code) by the translation from desugared to the scope language. *) + (* This is a redundant check. Normally, all subscope varaibles + should have been defined (even an empty definition, if they're + not defined by any rule in the source code) by the translation + from desugared to the scope language. *) Bindlib.box Dcalc.Ast.empty_thunked_term else - let a_var, _, _ = Ast.ScopeVarMap.find subvar.scope_var_name subscope_vars_defined in + let a_var, _, _ = + Ast.ScopeVarMap.find subvar.scope_var_name subscope_vars_defined + in Dcalc.Ast.make_var (a_var, pos_call)) all_subscope_input_vars in let subscope_struct_arg = Bindlib.box_apply (fun subscope_args -> - (Dcalc.Ast.ETuple (subscope_args, Some called_scope_input_struct), pos_call)) + ( Dcalc.Ast.ETuple (subscope_args, Some called_scope_input_struct), + pos_call )) (Bindlib.box_list subscope_args) in let all_subscope_output_vars_dcalc = @@ -434,7 +507,8 @@ let translate_rule (ctx : ctx) (rule : Ast.rule) let sub_dcalc_var = Dcalc.Ast.Var.make (Pos.map_under_mark - (fun s -> Pos.unmark (Ast.SubScopeName.get_info subindex) ^ "." ^ s) + (fun s -> + Pos.unmark (Ast.SubScopeName.get_info subindex) ^ "." ^ s) (Ast.ScopeVar.get_info subvar.scope_var_name)) in (subvar, sub_dcalc_var)) @@ -443,7 +517,8 @@ let translate_rule (ctx : ctx) (rule : Ast.rule) let subscope_func = tag_with_log_entry (Dcalc.Ast.make_var - (scope_dcalc_var, Pos.get_position (Ast.SubScopeName.get_info subindex))) + ( scope_dcalc_var, + Pos.get_position (Ast.SubScopeName.get_info subindex) )) Dcalc.Ast.BeginCall [ (sigma_name, pos_sigma); @@ -495,7 +570,8 @@ let translate_rule (ctx : ctx) (rule : Ast.rule) i, Some called_scope_return_struct, List.map - (fun (var_ctx, _) -> (var_ctx.scope_var_typ, pos_sigma)) + (fun (var_ctx, _) -> + (var_ctx.scope_var_typ, pos_sigma)) all_subscope_output_vars_dcalc ), pos_sigma )) (Dcalc.Ast.make_var (result_tuple_var, pos_sigma)); @@ -523,12 +599,13 @@ let translate_rule (ctx : ctx) (rule : Ast.rule) (Dcalc.Ast.Var.make ("_", Pos.get_position e), Pos.get_position e); Dcalc.Ast.scope_let_typ = (Dcalc.Ast.TLit TUnit, Pos.get_position e); Dcalc.Ast.scope_let_expr = - (* To ensure that we throw an error if the value is not defined, we add an check - "ErrorOnEmpty" here. *) + (* To ensure that we throw an error if the value is not defined, + we add an check "ErrorOnEmpty" here. *) Bindlib.box_apply (fun new_e -> Pos.same_pos_as - (Dcalc.Ast.EAssert (Dcalc.Ast.ErrorOnEmpty new_e, Pos.get_position e)) + (Dcalc.Ast.EAssert + (Dcalc.Ast.ErrorOnEmpty new_e, Pos.get_position e)) e) new_e; Dcalc.Ast.scope_let_kind = Dcalc.Ast.Assertion; @@ -536,50 +613,66 @@ let translate_rule (ctx : ctx) (rule : Ast.rule) ], ctx ) -let translate_rules (ctx : ctx) (rules : Ast.rule list) +let translate_rules + (ctx : ctx) + (rules : Ast.rule list) ((sigma_name, pos_sigma) : Utils.Uid.MarkedString.info) (sigma_return_struct_name : Ast.StructName.t) : Dcalc.Ast.scope_let list * Dcalc.Ast.expr Pos.marked Bindlib.box * ctx = let scope_lets, new_ctx = List.fold_left (fun (scope_lets, ctx) rule -> - let new_scope_lets, new_ctx = translate_rule ctx rule (sigma_name, pos_sigma) in + let new_scope_lets, new_ctx = + translate_rule ctx rule (sigma_name, pos_sigma) + in (scope_lets @ new_scope_lets, new_ctx)) ([], ctx) rules in let scope_variables = Ast.ScopeVarMap.bindings new_ctx.scope_vars in let scope_output_variables = - List.filter (fun (_, (_, _, io)) -> Pos.unmark io.Ast.io_output) scope_variables + List.filter + (fun (_, (_, _, io)) -> Pos.unmark io.Ast.io_output) + scope_variables in let return_exp = Bindlib.box_apply - (fun args -> (Dcalc.Ast.ETuple (args, Some sigma_return_struct_name), pos_sigma)) + (fun args -> + (Dcalc.Ast.ETuple (args, Some sigma_return_struct_name), pos_sigma)) (Bindlib.box_list (List.map - (fun (_, (dcalc_var, _, _)) -> Dcalc.Ast.make_var (dcalc_var, pos_sigma)) + (fun (_, (dcalc_var, _, _)) -> + Dcalc.Ast.make_var (dcalc_var, pos_sigma)) scope_output_variables)) in (scope_lets, return_exp, new_ctx) -let translate_scope_decl (struct_ctx : Ast.struct_ctx) (enum_ctx : Ast.enum_ctx) - (sctx : scope_sigs_ctx) (scope_name : Ast.ScopeName.t) (sigma : Ast.scope_decl) : - Dcalc.Ast.scope_body * Dcalc.Ast.struct_ctx = +let translate_scope_decl + (struct_ctx : Ast.struct_ctx) + (enum_ctx : Ast.enum_ctx) + (sctx : scope_sigs_ctx) + (scope_name : Ast.ScopeName.t) + (sigma : Ast.scope_decl) : Dcalc.Ast.scope_body * Dcalc.Ast.struct_ctx = let sigma_info = Ast.ScopeName.get_info sigma.scope_decl_name in let scope_sig = Ast.ScopeMap.find sigma.scope_decl_name sctx in let scope_variables = scope_sig.scope_sig_local_vars in let ctx = - (* the context must be initialized for fresh variables for all only-input scope variables *) + (* the context must be initialized for fresh variables for all only-input + scope variables *) List.fold_left (fun ctx scope_var -> match Pos.unmark scope_var.scope_var_io.io_input with | OnlyInput -> - let scope_var_name = Ast.ScopeVar.get_info scope_var.scope_var_name in + let scope_var_name = + Ast.ScopeVar.get_info scope_var.scope_var_name + in let scope_var_dcalc = Dcalc.Ast.Var.make scope_var_name in { ctx with scope_vars = Ast.ScopeVarMap.add scope_var.scope_var_name - (scope_var_dcalc, scope_var.scope_var_typ, scope_var.scope_var_io) + ( scope_var_dcalc, + scope_var.scope_var_typ, + scope_var.scope_var_io ) ctx.scope_vars; } | _ -> ctx) @@ -591,12 +684,15 @@ let translate_scope_decl (struct_ctx : Ast.struct_ctx) (enum_ctx : Ast.enum_ctx) let scope_return_struct_name = scope_sig.scope_sig_output_struct in let pos_sigma = Pos.get_position sigma_info in let rules, return_exp, ctx = - translate_rules ctx sigma.scope_decl_rules sigma_info scope_return_struct_name + translate_rules ctx sigma.scope_decl_rules sigma_info + scope_return_struct_name in let scope_variables = List.map (fun var_ctx -> - let dcalc_x, _, _ = Ast.ScopeVarMap.find var_ctx.scope_var_name ctx.scope_vars in + let dcalc_x, _, _ = + Ast.ScopeVarMap.find var_ctx.scope_var_name ctx.scope_vars + in (var_ctx, dcalc_x)) scope_variables in @@ -604,17 +700,23 @@ let translate_scope_decl (struct_ctx : Ast.struct_ctx) (enum_ctx : Ast.enum_ctx) let scope_input_variables = List.filter (fun (var_ctx, _) -> - match Pos.unmark var_ctx.scope_var_io.io_input with NoInput -> false | _ -> true) + match Pos.unmark var_ctx.scope_var_io.io_input with + | NoInput -> false + | _ -> true) scope_variables in let scope_output_variables = - List.filter (fun (var_ctx, _) -> Pos.unmark var_ctx.scope_var_io.io_output) scope_variables + List.filter + (fun (var_ctx, _) -> Pos.unmark var_ctx.scope_var_io.io_output) + scope_variables in let input_var_typ (var_ctx : scope_var_ctx) = match Pos.unmark var_ctx.scope_var_io.io_input with | OnlyInput -> (var_ctx.scope_var_typ, pos_sigma) | Reentrant -> - ( Dcalc.Ast.TArrow ((Dcalc.Ast.TLit TUnit, pos_sigma), (var_ctx.scope_var_typ, pos_sigma)), + ( Dcalc.Ast.TArrow + ( (Dcalc.Ast.TLit TUnit, pos_sigma), + (var_ctx.scope_var_typ, pos_sigma) ), pos_sigma ) | NoInput -> failwith "should not happen" in @@ -632,7 +734,9 @@ let translate_scope_decl (struct_ctx : Ast.struct_ctx) (enum_ctx : Ast.enum_ctx) ( r, i, Some scope_input_struct_name, - List.map (fun (var_ctx, _) -> input_var_typ var_ctx) scope_input_variables ), + List.map + (fun (var_ctx, _) -> input_var_typ var_ctx) + scope_input_variables ), pos_sigma )) (Dcalc.Ast.make_var (scope_input_var, pos_sigma)); }) @@ -658,7 +762,8 @@ let translate_scope_decl (struct_ctx : Ast.struct_ctx) (enum_ctx : Ast.enum_ctx) in let new_struct_ctx = Ast.StructMap.add scope_input_struct_name scope_input_struct_fields - (Ast.StructMap.singleton scope_return_struct_name scope_return_struct_fields) + (Ast.StructMap.singleton scope_return_struct_name + scope_return_struct_fields) in ( { Dcalc.Ast.scope_body_lets = input_destructurings @ rules; @@ -669,10 +774,13 @@ let translate_scope_decl (struct_ctx : Ast.struct_ctx) (enum_ctx : Ast.enum_ctx) }, new_struct_ctx ) -let translate_program (prgm : Ast.program) : Dcalc.Ast.program * Dependency.TVertex.t list = +let translate_program (prgm : Ast.program) : + Dcalc.Ast.program * Dependency.TVertex.t list = let scope_dependencies = Dependency.build_program_dep_graph prgm in Dependency.check_for_cycle_in_scope scope_dependencies; - let types_ordering = Dependency.check_type_cycles prgm.program_structs prgm.program_enums in + let types_ordering = + Dependency.check_type_cycles prgm.program_structs prgm.program_enums + in let scope_ordering = Dependency.get_scope_ordering scope_dependencies in let struct_ctx = prgm.program_structs in let enum_ctx = prgm.program_enums in @@ -684,36 +792,52 @@ let translate_program (prgm : Ast.program) : Dcalc.Ast.program * Dependency.TVer { Dcalc.Ast.ctx_structs = Ast.StructMap.map - (List.map (fun (x, y) -> (x, translate_typ (ctx_for_typ_translation dummy_scope) y))) + (List.map (fun (x, y) -> + (x, translate_typ (ctx_for_typ_translation dummy_scope) y))) struct_ctx; Dcalc.Ast.ctx_enums = Ast.EnumMap.map - (List.map (fun (x, y) -> (x, (translate_typ (ctx_for_typ_translation dummy_scope)) y))) + (List.map (fun (x, y) -> + (x, (translate_typ (ctx_for_typ_translation dummy_scope)) y))) enum_ctx; } in let sctx : scope_sigs_ctx = Ast.ScopeMap.mapi (fun scope_name scope -> - let scope_dvar = Dcalc.Ast.Var.make (Ast.ScopeName.get_info scope.Ast.scope_decl_name) in + let scope_dvar = + Dcalc.Ast.Var.make (Ast.ScopeName.get_info scope.Ast.scope_decl_name) + in let scope_return_struct_name = Ast.StructName.fresh - (Pos.map_under_mark (fun s -> s ^ "_out") (Ast.ScopeName.get_info scope_name)) + (Pos.map_under_mark + (fun s -> s ^ "_out") + (Ast.ScopeName.get_info scope_name)) in let scope_input_var = Dcalc.Ast.Var.make - (Pos.map_under_mark (fun s -> s ^ "_in") (Ast.ScopeName.get_info scope_name)) + (Pos.map_under_mark + (fun s -> s ^ "_in") + (Ast.ScopeName.get_info scope_name)) in let scope_input_struct_name = Ast.StructName.fresh - (Pos.map_under_mark (fun s -> s ^ "_in") (Ast.ScopeName.get_info scope_name)) + (Pos.map_under_mark + (fun s -> s ^ "_in") + (Ast.ScopeName.get_info scope_name)) in { scope_sig_local_vars = List.map (fun (scope_var, (tau, vis)) -> - let tau = translate_typ (ctx_for_typ_translation scope_name) tau in - { scope_var_name = scope_var; scope_var_typ = Pos.unmark tau; scope_var_io = vis }) + let tau = + translate_typ (ctx_for_typ_translation scope_name) tau + in + { + scope_var_name = scope_var; + scope_var_typ = Pos.unmark tau; + scope_var_io = vis; + }) (Ast.ScopeVarMap.bindings scope.scope_sig); scope_sig_scope_var = scope_dvar; scope_sig_input_var = scope_input_var; @@ -722,14 +846,20 @@ let translate_program (prgm : Ast.program) : Dcalc.Ast.program * Dependency.TVer }) prgm.program_scopes in - (* the resulting expression is the list of definitions of all the scopes, ending with the - top-level scope. *) + (* the resulting expression is the list of definitions of all the scopes, + ending with the top-level scope. *) let (scopes, decl_ctx) - : (Ast.ScopeName.t * Dcalc.Ast.expr Bindlib.var * Dcalc.Ast.scope_body) list * _ = + : (Ast.ScopeName.t * Dcalc.Ast.expr Bindlib.var * Dcalc.Ast.scope_body) + list + * _ = List.fold_right (fun scope_name ((scopes, decl_ctx) : - (Ast.ScopeName.t * Dcalc.Ast.expr Bindlib.var * Dcalc.Ast.scope_body) list * _) -> + (Ast.ScopeName.t + * Dcalc.Ast.expr Bindlib.var + * Dcalc.Ast.scope_body) + list + * _) -> let scope = Ast.ScopeMap.find scope_name prgm.program_scopes in let scope_body, scope_out_struct = translate_scope_decl struct_ctx enum_ctx sctx scope_name scope diff --git a/compiler/scopelang/scope_to_dcalc.mli b/compiler/scopelang/scope_to_dcalc.mli index 5ba4eadf..b61e8d09 100644 --- a/compiler/scopelang/scope_to_dcalc.mli +++ b/compiler/scopelang/scope_to_dcalc.mli @@ -1,20 +1,24 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux - +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, contributor: + Denis Merigoux - 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 + 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 + 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. *) (** Scope language to default calculus translator *) -val translate_program : Ast.program -> Dcalc.Ast.program * Dependency.TVertex.t list -(** Usage [translate_program p] returns a tuple [(new_program, types_list)] where [new_program] is - the map of translated scopes. Finally, [types_list] is a list of all types (structs and enums) - used in the program, correctly ordered with respect to inter-types dependency. *) +val translate_program : + Ast.program -> Dcalc.Ast.program * Dependency.TVertex.t list +(** Usage [translate_program p] returns a tuple [(new_program, types_list)] + where [new_program] is the map of translated scopes. Finally, [types_list] + is a list of all types (structs and enums) used in the program, correctly + ordered with respect to inter-types dependency. *) diff --git a/compiler/surface/ast.ml b/compiler/surface/ast.ml index edf48a9a..9e6a495f 100644 --- a/compiler/surface/ast.ml +++ b/compiler/surface/ast.ml @@ -1,15 +1,18 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020 Inria, contributors: Denis Merigoux - , Emile Rolley +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, + contributors: Denis Merigoux , Emile Rolley + - 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 + 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 + 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. *) (** Abstract syntax tree built by the Catala parser *) @@ -19,10 +22,11 @@ open Utils (** {1 Visitor classes for programs} *) -(** To allow for quick traversal and/or modification of this AST structure, we provide a - {{:https://en.wikipedia.org/wiki/Visitor_pattern} visitor design pattern}. This feature is - implemented via {{:https://gitlab.inria.fr/fpottier/visitors} François Pottier's OCaml visitors - library}. *) +(** To allow for quick traversal and/or modification of this AST structure, we + provide a {{:https://en.wikipedia.org/wiki/Visitor_pattern} visitor design + pattern}. This feature is implemented via + {{:https://gitlab.inria.fr/fpottier/visitors} François Pottier's OCaml + visitors library}. *) (** {1 Type definitions} *) @@ -40,9 +44,18 @@ type ident = (string[@opaque]) type qident = ident Pos.marked list [@@deriving - visitors { variety = "map"; ancestors = [ "Pos.marked_map"; "ident_map" ]; name = "qident_map" }, + visitors + { + variety = "map"; + ancestors = [ "Pos.marked_map"; "ident_map" ]; + name = "qident_map"; + }, visitors - { variety = "iter"; ancestors = [ "Pos.marked_iter"; "ident_iter" ]; name = "qident_iter" }] + { + variety = "iter"; + ancestors = [ "Pos.marked_iter"; "ident_iter" ]; + name = "qident_iter"; + }] type primitive_typ = | Integer @@ -54,10 +67,22 @@ type primitive_typ = | Date | Named of constructor [@@deriving - visitors { variety = "map"; ancestors = [ "constructor_map" ]; name = "primitive_typ_map" }, - visitors { variety = "iter"; ancestors = [ "constructor_iter" ]; name = "primitive_typ_iter" }] + visitors + { + variety = "map"; + ancestors = [ "constructor_map" ]; + name = "primitive_typ_map"; + }, + visitors + { + variety = "iter"; + ancestors = [ "constructor_iter" ]; + name = "primitive_typ_iter"; + }] -type base_typ_data = Primitive of primitive_typ | Collection of base_typ_data Pos.marked +type base_typ_data = + | Primitive of primitive_typ + | Collection of base_typ_data Pos.marked [@@deriving visitors { @@ -75,7 +100,12 @@ type base_typ_data = Primitive of primitive_typ | Collection of base_typ_data Po type base_typ = Condition | Data of base_typ_data [@@deriving visitors - { variety = "map"; ancestors = [ "base_typ_data_map" ]; name = "base_typ_map"; nude = true }, + { + variety = "map"; + ancestors = [ "base_typ_data_map" ]; + name = "base_typ_map"; + nude = true; + }, visitors { variety = "iter"; @@ -84,16 +114,42 @@ type base_typ = Condition | Data of base_typ_data nude = true; }] -type func_typ = { arg_typ : base_typ Pos.marked; return_typ : base_typ Pos.marked } +type func_typ = { + arg_typ : base_typ Pos.marked; + return_typ : base_typ Pos.marked; +} [@@deriving - visitors { variety = "map"; ancestors = [ "base_typ_map" ]; name = "func_typ_map"; nude = true }, + visitors + { + variety = "map"; + ancestors = [ "base_typ_map" ]; + name = "func_typ_map"; + nude = true; + }, visitors - { variety = "iter"; ancestors = [ "base_typ_iter" ]; name = "func_typ_iter"; nude = true }] + { + variety = "iter"; + ancestors = [ "base_typ_iter" ]; + name = "func_typ_iter"; + nude = true; + }] type typ = Base of base_typ | Func of func_typ [@@deriving - visitors { variety = "map"; ancestors = [ "func_typ_map" ]; name = "typ_map"; nude = true }, - visitors { variety = "iter"; ancestors = [ "func_typ_iter" ]; name = "typ_iter"; nude = true }] + visitors + { + variety = "map"; + ancestors = [ "func_typ_map" ]; + name = "typ_map"; + nude = true; + }, + visitors + { + variety = "iter"; + ancestors = [ "func_typ_iter" ]; + name = "typ_iter"; + nude = true; + }] type struct_decl_field = { struct_decl_field_name : ident Pos.marked; @@ -101,7 +157,11 @@ type struct_decl_field = { } [@@deriving visitors - { variety = "map"; ancestors = [ "typ_map"; "ident_map" ]; name = "struct_decl_field_map" }, + { + variety = "map"; + ancestors = [ "typ_map"; "ident_map" ]; + name = "struct_decl_field_map"; + }, visitors { variety = "iter"; @@ -114,18 +174,38 @@ type struct_decl = { struct_decl_fields : struct_decl_field Pos.marked list; } [@@deriving - visitors { variety = "map"; ancestors = [ "struct_decl_field_map" ]; name = "struct_decl_map" }, + visitors + { + variety = "map"; + ancestors = [ "struct_decl_field_map" ]; + name = "struct_decl_map"; + }, visitors - { variety = "iter"; ancestors = [ "struct_decl_field_iter" ]; name = "struct_decl_iter" }] + { + variety = "iter"; + ancestors = [ "struct_decl_field_iter" ]; + name = "struct_decl_iter"; + }] type enum_decl_case = { enum_decl_case_name : constructor Pos.marked; enum_decl_case_typ : typ Pos.marked option; } [@@deriving - visitors { variety = "map"; ancestors = [ "typ_map" ]; name = "enum_decl_case_map"; nude = true }, + visitors + { + variety = "map"; + ancestors = [ "typ_map" ]; + name = "enum_decl_case_map"; + nude = true; + }, visitors - { variety = "iter"; ancestors = [ "typ_iter" ]; name = "enum_decl_case_iter"; nude = true }] + { + variety = "iter"; + ancestors = [ "typ_iter" ]; + name = "enum_decl_case_iter"; + nude = true; + }] type enum_decl = { enum_decl_name : constructor Pos.marked; @@ -133,7 +213,12 @@ type enum_decl = { } [@@deriving visitors - { variety = "map"; ancestors = [ "enum_decl_case_map" ]; name = "enum_decl_map"; nude = true }, + { + variety = "map"; + ancestors = [ "enum_decl_case_map" ]; + name = "enum_decl_map"; + nude = true; + }, visitors { variety = "iter"; @@ -143,7 +228,8 @@ type enum_decl = { }] type match_case_pattern = - (constructor Pos.marked option * constructor Pos.marked) list * ident Pos.marked option + (constructor Pos.marked option * constructor Pos.marked) list + * ident Pos.marked option [@@deriving visitors { @@ -179,13 +265,37 @@ type binop = | Neq | Concat [@@deriving - visitors { variety = "map"; ancestors = [ "op_kind_map" ]; name = "binop_map"; nude = true }, - visitors { variety = "iter"; ancestors = [ "op_kind_iter" ]; name = "binop_iter"; nude = true }] + visitors + { + variety = "map"; + ancestors = [ "op_kind_map" ]; + name = "binop_map"; + nude = true; + }, + visitors + { + variety = "iter"; + ancestors = [ "op_kind_iter" ]; + name = "binop_iter"; + nude = true; + }] type unop = Not | Minus of op_kind [@@deriving - visitors { variety = "map"; ancestors = [ "op_kind_map" ]; name = "unop_map"; nude = true }, - visitors { variety = "iter"; ancestors = [ "op_kind_iter" ]; name = "unop_iter"; nude = true }] + visitors + { + variety = "map"; + ancestors = [ "op_kind_map" ]; + name = "unop_map"; + nude = true; + }, + visitors + { + variety = "iter"; + ancestors = [ "op_kind_iter" ]; + name = "unop_iter"; + nude = true; + }] type builtin_expression = Cardinal | IntToDec | GetDay | GetMonth | GetYear [@@deriving @@ -198,8 +308,18 @@ type literal_date = { literal_date_year : (int[@opaque]) Pos.marked; } [@@deriving - visitors { variety = "map"; ancestors = [ "Pos.marked_map" ]; name = "literal_date_map" }, - visitors { variety = "iter"; ancestors = [ "Pos.marked_iter" ]; name = "literal_date_iter" }] + visitors + { + variety = "map"; + ancestors = [ "Pos.marked_map" ]; + name = "literal_date_map"; + }, + visitors + { + variety = "iter"; + ancestors = [ "Pos.marked_iter" ]; + name = "literal_date_iter"; + }] type literal_number = | Int of (Runtime.integer[@opaque]) @@ -231,14 +351,24 @@ type literal = { variety = "map"; ancestors = - [ "literal_number_map"; "money_amount_map"; "literal_date_map"; "literal_unit_map" ]; + [ + "literal_number_map"; + "money_amount_map"; + "literal_date_map"; + "literal_unit_map"; + ]; name = "literal_map"; }, visitors { variety = "iter"; ancestors = - [ "literal_number_iter"; "money_amount_iter"; "literal_date_iter"; "literal_unit_iter" ]; + [ + "literal_number_iter"; + "money_amount_iter"; + "literal_date_iter"; + "literal_unit_iter"; + ]; name = "literal_iter"; }] @@ -248,35 +378,50 @@ type aggregate_func = | AggregateExtremum of bool * primitive_typ * expression Pos.marked | AggregateArgExtremum of bool * primitive_typ * expression Pos.marked -and collection_op = Exists | Forall | Aggregate of aggregate_func | Map | Filter +and collection_op = + | Exists + | Forall + | Aggregate of aggregate_func + | Map + | Filter and explicit_match_case = { match_case_pattern : match_case_pattern Pos.marked; match_case_expr : expression Pos.marked; } -and match_case = WildCard of expression Pos.marked | MatchCase of explicit_match_case +and match_case = + | WildCard of expression Pos.marked + | MatchCase of explicit_match_case and match_cases = match_case Pos.marked list and expression = | MatchWith of expression Pos.marked * match_cases Pos.marked - | IfThenElse of expression Pos.marked * expression Pos.marked * expression Pos.marked + | IfThenElse of + expression Pos.marked * expression Pos.marked * expression Pos.marked | Binop of binop Pos.marked * expression Pos.marked * expression Pos.marked | Unop of unop Pos.marked * expression Pos.marked | CollectionOp of - collection_op Pos.marked * ident Pos.marked * expression Pos.marked * expression Pos.marked + collection_op Pos.marked + * ident Pos.marked + * expression Pos.marked + * expression Pos.marked | MemCollection of expression Pos.marked * expression Pos.marked | TestMatchCase of expression Pos.marked * match_case_pattern Pos.marked | FunCall of expression Pos.marked * expression Pos.marked | Builtin of builtin_expression | Literal of literal | EnumInject of - constructor Pos.marked option * constructor Pos.marked * expression Pos.marked option - | StructLit of constructor Pos.marked * (ident Pos.marked * expression Pos.marked) list + constructor Pos.marked option + * constructor Pos.marked + * expression Pos.marked option + | StructLit of + constructor Pos.marked * (ident Pos.marked * expression Pos.marked) list | ArrayLit of expression Pos.marked list | Ident of ident - | Dotted of expression Pos.marked * constructor Pos.marked option * ident Pos.marked + | Dotted of + expression Pos.marked * constructor Pos.marked option * ident Pos.marked (** Dotted is for both struct field projection and sub-scope variables *) [@@deriving visitors @@ -308,10 +453,17 @@ and expression = name = "expression_iter"; }] -type exception_to = NotAnException | UnlabeledException | ExceptionToLabel of ident Pos.marked +type exception_to = + | NotAnException + | UnlabeledException + | ExceptionToLabel of ident Pos.marked [@@deriving visitors - { variety = "map"; ancestors = [ "ident_map"; "Pos.marked_map" ]; name = "exception_to_map" }, + { + variety = "map"; + ancestors = [ "ident_map"; "Pos.marked_map" ]; + name = "exception_to_map"; + }, visitors { variety = "iter"; @@ -374,7 +526,10 @@ type variation_typ = Increasing | Decreasing type meta_assertion = | FixedBy of qident Pos.marked * ident Pos.marked - | VariesWith of qident Pos.marked * expression Pos.marked * variation_typ Pos.marked option + | VariesWith of + qident Pos.marked + * expression Pos.marked + * variation_typ Pos.marked option [@@deriving visitors { @@ -394,8 +549,18 @@ type assertion = { assertion_content : expression Pos.marked; } [@@deriving - visitors { variety = "map"; ancestors = [ "expression_map" ]; name = "assertion_map" }, - visitors { variety = "iter"; ancestors = [ "expression_iter" ]; name = "assertion_iter" }] + visitors + { + variety = "map"; + ancestors = [ "expression_map" ]; + name = "assertion_map"; + }, + visitors + { + variety = "iter"; + ancestors = [ "expression_iter" ]; + name = "assertion_iter"; + }] type scope_use_item = | Rule of rule @@ -406,13 +571,20 @@ type scope_use_item = visitors { variety = "map"; - ancestors = [ "meta_assertion_map"; "definition_map"; "assertion_map"; "rule_map" ]; + ancestors = + [ "meta_assertion_map"; "definition_map"; "assertion_map"; "rule_map" ]; name = "scope_use_item_map"; }, visitors { variety = "iter"; - ancestors = [ "meta_assertion_iter"; "definition_iter"; "assertion_iter"; "rule_iter" ]; + ancestors = + [ + "meta_assertion_iter"; + "definition_iter"; + "assertion_iter"; + "rule_iter"; + ]; name = "scope_use_item_iter"; }] @@ -467,14 +639,25 @@ type scope_decl_context_scope = { visitors { variety = "map"; - ancestors = [ "ident_map"; "constructor_map"; "scope_decl_context_io_map"; "Pos.marked_map" ]; + ancestors = + [ + "ident_map"; + "constructor_map"; + "scope_decl_context_io_map"; + "Pos.marked_map"; + ]; name = "scope_decl_context_scope_map"; }, visitors { variety = "iter"; ancestors = - [ "ident_iter"; "constructor_iter"; "scope_decl_context_io_iter"; "Pos.marked_iter" ]; + [ + "ident_iter"; + "constructor_iter"; + "scope_decl_context_io_iter"; + "Pos.marked_iter"; + ]; name = "scope_decl_context_scope_iter"; }] @@ -505,13 +688,15 @@ type scope_decl_context_item = visitors { variety = "map"; - ancestors = [ "scope_decl_context_data_map"; "scope_decl_context_scope_map" ]; + ancestors = + [ "scope_decl_context_data_map"; "scope_decl_context_scope_map" ]; name = "scope_decl_context_item_map"; }, visitors { variety = "iter"; - ancestors = [ "scope_decl_context_data_iter"; "scope_decl_context_scope_iter" ]; + ancestors = + [ "scope_decl_context_data_iter"; "scope_decl_context_scope_iter" ]; name = "scope_decl_context_item_iter"; }] @@ -521,9 +706,17 @@ type scope_decl = { } [@@deriving visitors - { variety = "map"; ancestors = [ "scope_decl_context_item_map" ]; name = "scope_decl_map" }, + { + variety = "map"; + ancestors = [ "scope_decl_context_item_map" ]; + name = "scope_decl_map"; + }, visitors - { variety = "iter"; ancestors = [ "scope_decl_context_item_iter" ]; name = "scope_decl_iter" }] + { + variety = "iter"; + ancestors = [ "scope_decl_context_item_iter" ]; + name = "scope_decl_iter"; + }] type code_item = | ScopeUse of scope_use @@ -534,25 +727,54 @@ type code_item = visitors { variety = "map"; - ancestors = [ "scope_decl_map"; "enum_decl_map"; "struct_decl_map"; "scope_use_map" ]; + ancestors = + [ + "scope_decl_map"; "enum_decl_map"; "struct_decl_map"; "scope_use_map"; + ]; name = "code_item_map"; }, visitors { variety = "iter"; - ancestors = [ "scope_decl_iter"; "enum_decl_iter"; "struct_decl_iter"; "scope_use_iter" ]; + ancestors = + [ + "scope_decl_iter"; + "enum_decl_iter"; + "struct_decl_iter"; + "scope_use_iter"; + ]; name = "code_item_iter"; }] type code_block = code_item Pos.marked list [@@deriving - visitors { variety = "map"; ancestors = [ "code_item_map" ]; name = "code_block_map" }, - visitors { variety = "iter"; ancestors = [ "code_item_iter" ]; name = "code_block_iter" }] + visitors + { + variety = "map"; + ancestors = [ "code_item_map" ]; + name = "code_block_map"; + }, + visitors + { + variety = "iter"; + ancestors = [ "code_item_iter" ]; + name = "code_block_iter"; + }] type source_repr = (string[@opaque]) Pos.marked [@@deriving - visitors { variety = "map"; ancestors = [ "Pos.marked_map" ]; name = "source_repr_map" }, - visitors { variety = "iter"; ancestors = [ "Pos.marked_iter" ]; name = "source_repr_iter" }] + visitors + { + variety = "map"; + ancestors = [ "Pos.marked_map" ]; + name = "source_repr_map"; + }, + visitors + { + variety = "iter"; + ancestors = [ "Pos.marked_iter" ]; + name = "source_repr_iter"; + }] type law_heading = { law_heading_name : (string[@opaque]) Pos.marked; @@ -561,16 +783,36 @@ type law_heading = { law_heading_precedence : (int[@opaque]); } [@@deriving - visitors { variety = "map"; ancestors = [ "Pos.marked_map" ]; name = "law_heading_map" }, - visitors { variety = "iter"; ancestors = [ "Pos.marked_iter" ]; name = "law_heading_iter" }] + visitors + { + variety = "map"; + ancestors = [ "Pos.marked_map" ]; + name = "law_heading_map"; + }, + visitors + { + variety = "iter"; + ancestors = [ "Pos.marked_iter" ]; + name = "law_heading_iter"; + }] type law_include = | PdfFile of (string[@opaque]) Pos.marked * (int[@opaque]) option | CatalaFile of (string[@opaque]) Pos.marked | LegislativeText of (string[@opaque]) Pos.marked [@@deriving - visitors { variety = "map"; ancestors = [ "Pos.marked_map" ]; name = "law_include_map" }, - visitors { variety = "iter"; ancestors = [ "Pos.marked_iter" ]; name = "law_include_iter" }] + visitors + { + variety = "map"; + ancestors = [ "Pos.marked_map" ]; + name = "law_include_map"; + }, + visitors + { + variety = "iter"; + ancestors = [ "Pos.marked_iter" ]; + name = "law_include_iter"; + }] type law_structure = | LawInclude of law_include @@ -581,21 +823,45 @@ type law_structure = visitors { variety = "map"; - ancestors = [ "law_include_map"; "code_block_map"; "source_repr_map"; "law_heading_map" ]; + ancestors = + [ + "law_include_map"; + "code_block_map"; + "source_repr_map"; + "law_heading_map"; + ]; name = "law_structure_map"; }, visitors { variety = "iter"; ancestors = - [ "law_include_iter"; "code_block_iter"; "source_repr_iter"; "law_heading_iter" ]; + [ + "law_include_iter"; + "code_block_iter"; + "source_repr_iter"; + "law_heading_iter"; + ]; name = "law_structure_iter"; }] -type program = { program_items : law_structure list; program_source_files : (string[@opaque]) list } +type program = { + program_items : law_structure list; + program_source_files : (string[@opaque]) list; +} [@@deriving - visitors { variety = "map"; ancestors = [ "law_structure_map" ]; name = "program_map" }, - visitors { variety = "iter"; ancestors = [ "law_structure_iter" ]; name = "program_iter" }] + visitors + { + variety = "map"; + ancestors = [ "law_structure_map" ]; + name = "program_map"; + }, + visitors + { + variety = "iter"; + ancestors = [ "law_structure_iter" ]; + name = "program_iter"; + }] type source_file = law_structure list diff --git a/compiler/surface/desugaring.ml b/compiler/surface/desugaring.ml index d43e7931..dcb287d9 100644 --- a/compiler/surface/desugaring.ml +++ b/compiler/surface/desugaring.ml @@ -1,15 +1,18 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020 Inria, contributor: Nicolas Chataing - Denis Merigoux +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, contributor: + Nicolas Chataing Denis Merigoux + - 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 + 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 + 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. *) open Utils @@ -48,17 +51,19 @@ let translate_binop (op : Ast.binop) : Dcalc.Ast.binop = let translate_unop (op : Ast.unop) : Dcalc.Ast.unop = match op with Not -> Not | Minus l -> Minus (translate_op_kind l) -(** The two modules below help performing operations on map with the {!type: Bindlib.box}. Indeed, - Catala uses the {{:https://lepigre.fr/ocaml-bindlib/} Bindlib} library to represent bound - variables in the AST. In this translation, bound variables are used to represent function - parameters or pattern macthing bindings. *) +(** The two modules below help performing operations on map with the {!type: + Bindlib.box}. Indeed, Catala uses the {{:https://lepigre.fr/ocaml-bindlib/} + Bindlib} library to represent bound variables in the AST. In this + translation, bound variables are used to represent function parameters or + pattern macthing bindings. *) module LiftStructFieldMap = Bindlib.Lift (Scopelang.Ast.StructFieldMap) module LiftEnumConstructorMap = Bindlib.Lift (Scopelang.Ast.EnumConstructorMap) -let disambiguate_constructor (ctxt : Name_resolution.context) - (constructor : (string Pos.marked option * string Pos.marked) list) (pos : Pos.t) : - Scopelang.Ast.EnumName.t * Scopelang.Ast.EnumConstructor.t = +let disambiguate_constructor + (ctxt : Name_resolution.context) + (constructor : (string Pos.marked option * string Pos.marked) list) + (pos : Pos.t) : Scopelang.Ast.EnumName.t * Scopelang.Ast.EnumConstructor.t = let enum, constructor = match constructor with | [ c ] -> c @@ -67,54 +72,67 @@ let disambiguate_constructor (ctxt : Name_resolution.context) "The deep pattern matching syntactic sugar is not yet supported" in let possible_c_uids = - try Desugared.Ast.IdentMap.find (Pos.unmark constructor) ctxt.constructor_idmap + try + Desugared.Ast.IdentMap.find (Pos.unmark constructor) + ctxt.constructor_idmap with Not_found -> - Errors.raise_spanned_error (Pos.get_position constructor) - "The name of this constructor has not been defined before, maybe it is a typo?" + Errors.raise_spanned_error + (Pos.get_position constructor) + "The name of this constructor has not been defined before, maybe it is \ + a typo?" in match enum with | None -> if Scopelang.Ast.EnumMap.cardinal possible_c_uids > 1 then - Errors.raise_spanned_error (Pos.get_position constructor) - "This constructor name is ambiguous, it can belong to %a. Disambiguate it by prefixing \ - it with the enum name." + Errors.raise_spanned_error + (Pos.get_position constructor) + "This constructor name is ambiguous, it can belong to %a. \ + Disambiguate it by prefixing it with the enum name." (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt " or ") - (fun fmt (s_name, _) -> Format.fprintf fmt "%a" Scopelang.Ast.EnumName.format_t s_name)) + (fun fmt (s_name, _) -> + Format.fprintf fmt "%a" Scopelang.Ast.EnumName.format_t s_name)) (Scopelang.Ast.EnumMap.bindings possible_c_uids); Scopelang.Ast.EnumMap.choose possible_c_uids | Some enum -> ( try (* The path is fully qualified *) - let e_uid = Desugared.Ast.IdentMap.find (Pos.unmark enum) ctxt.enum_idmap in + let e_uid = + Desugared.Ast.IdentMap.find (Pos.unmark enum) ctxt.enum_idmap + in try let c_uid = Scopelang.Ast.EnumMap.find e_uid possible_c_uids in (e_uid, c_uid) with Not_found -> - Errors.raise_spanned_error pos "Enum %s does not contain case %s" (Pos.unmark enum) - (Pos.unmark constructor) + Errors.raise_spanned_error pos "Enum %s does not contain case %s" + (Pos.unmark enum) (Pos.unmark constructor) with Not_found -> - Errors.raise_spanned_error (Pos.get_position enum) "Enum %s has not been defined before" - (Pos.unmark enum)) + Errors.raise_spanned_error (Pos.get_position enum) + "Enum %s has not been defined before" (Pos.unmark enum)) (** Usage: [translate_expr scope ctxt expr] - Translates [expr] into its desugared equivalent. [scope] is used to disambiguate the scope and - subscopes variables than occur in the expresion *) -let rec translate_expr (scope : Scopelang.Ast.ScopeName.t) + Translates [expr] into its desugared equivalent. [scope] is used to + disambiguate the scope and subscopes variables than occur in the expresion *) +let rec translate_expr + (scope : Scopelang.Ast.ScopeName.t) (inside_definition_of : Desugared.Ast.ScopeDef.t Pos.marked option) - (ctxt : Name_resolution.context) ((expr, pos) : Ast.expression Pos.marked) : + (ctxt : Name_resolution.context) + ((expr, pos) : Ast.expression Pos.marked) : Desugared.Ast.expr Pos.marked Bindlib.box = let scope_ctxt = Scopelang.Ast.ScopeMap.find scope ctxt.scopes in let rec_helper = translate_expr scope inside_definition_of ctxt in match expr with | Binop ( (Ast.And, _pos_op), - (TestMatchCase (e1_sub, ((constructors, Some binding), pos_pattern)), _pos_e1), + ( TestMatchCase (e1_sub, ((constructors, Some binding), pos_pattern)), + _pos_e1 ), e2 ) -> - (* This sugar corresponds to [e is P x && e'] and should desugar to [match e with P x -> e' | - _ -> false] *) - let enum_uid, c_uid = disambiguate_constructor ctxt constructors pos_pattern in + (* This sugar corresponds to [e is P x && e'] and should desugar to [match + e with P x -> e' | _ -> false] *) + let enum_uid, c_uid = + disambiguate_constructor ctxt constructors pos_pattern + in let cases = Scopelang.Ast.EnumConstructorMap.mapi (fun c_uid' tau -> @@ -122,12 +140,16 @@ let rec translate_expr (scope : Scopelang.Ast.ScopeName.t) let nop_var = Desugared.Ast.Var.make ("_", pos) in Bindlib.unbox (Desugared.Ast.make_abs [| nop_var |] - (Bindlib.box (Desugared.Ast.ELit (Dcalc.Ast.LBool false), pos)) + (Bindlib.box + (Desugared.Ast.ELit (Dcalc.Ast.LBool false), pos)) pos [ tau ] pos) else - let ctxt, binding_var = Name_resolution.add_def_local_var ctxt binding in + let ctxt, binding_var = + Name_resolution.add_def_local_var ctxt binding + in let e2 = translate_expr scope inside_definition_of ctxt e2 in - Bindlib.unbox (Desugared.Ast.make_abs [| binding_var |] e2 pos [ tau ] pos)) + Bindlib.unbox + (Desugared.Ast.make_abs [| binding_var |] e2 pos [ tau ] pos)) (Scopelang.Ast.EnumMap.find enum_uid ctxt.enums) in Bindlib.box_apply @@ -135,30 +157,42 @@ let rec translate_expr (scope : Scopelang.Ast.ScopeName.t) (translate_expr scope inside_definition_of ctxt e1_sub) | IfThenElse (e_if, e_then, e_else) -> Bindlib.box_apply3 - (fun e_if e_then e_else -> (Desugared.Ast.EIfThenElse (e_if, e_then, e_else), pos)) + (fun e_if e_then e_else -> + (Desugared.Ast.EIfThenElse (e_if, e_then, e_else), pos)) (rec_helper e_if) (rec_helper e_then) (rec_helper e_else) | Binop (op, e1, e2) -> let op_term = - Pos.same_pos_as (Desugared.Ast.EOp (Dcalc.Ast.Binop (translate_binop (Pos.unmark op)))) op + Pos.same_pos_as + (Desugared.Ast.EOp (Dcalc.Ast.Binop (translate_binop (Pos.unmark op)))) + op in Bindlib.box_apply2 (fun e1 e2 -> (Desugared.Ast.EApp (op_term, [ e1; e2 ]), pos)) (rec_helper e1) (rec_helper e2) | Unop (op, e) -> let op_term = - Pos.same_pos_as (Desugared.Ast.EOp (Dcalc.Ast.Unop (translate_unop (Pos.unmark op)))) op + Pos.same_pos_as + (Desugared.Ast.EOp (Dcalc.Ast.Unop (translate_unop (Pos.unmark op)))) + op in - Bindlib.box_apply (fun e -> (Desugared.Ast.EApp (op_term, [ e ]), pos)) (rec_helper e) + Bindlib.box_apply + (fun e -> (Desugared.Ast.EApp (op_term, [ e ]), pos)) + (rec_helper e) | Literal l -> let untyped_term = match l with | LNumber ((Int i, _), None) -> Desugared.Ast.ELit (Dcalc.Ast.LInt i) | LNumber ((Int i, _), Some (Percent, _)) -> Desugared.Ast.ELit - (Dcalc.Ast.LRat Runtime.(decimal_of_integer i /& decimal_of_string "100")) + (Dcalc.Ast.LRat + Runtime.(decimal_of_integer i /& decimal_of_string "100")) | LNumber ((Dec (i, f), _), None) -> let digits_f = - try int_of_float (ceil (float_of_int (Runtime.integer_log2 f) *. log 2.0 /. log 10.0)) + try + int_of_float + (ceil + (float_of_int (Runtime.integer_log2 f) + *. log 2.0 /. log 10.0)) with Invalid_argument _ -> 0 in Desugared.Ast.ELit @@ -166,10 +200,15 @@ let rec translate_expr (scope : Scopelang.Ast.ScopeName.t) Runtime.( decimal_of_integer i +& decimal_of_integer f - /& decimal_of_integer (integer_exponentiation (integer_of_int 10) digits_f))) + /& decimal_of_integer + (integer_exponentiation (integer_of_int 10) digits_f))) | LNumber ((Dec (i, f), _), Some (Percent, _)) -> let digits_f = - try int_of_float (ceil (float_of_int (Runtime.integer_log2 f) *. log 2.0 /. log 10.0)) + try + int_of_float + (ceil + (float_of_int (Runtime.integer_log2 f) + *. log 2.0 /. log 10.0)) with Invalid_argument _ -> 0 in Desugared.Ast.ELit @@ -177,7 +216,9 @@ let rec translate_expr (scope : Scopelang.Ast.ScopeName.t) Runtime.( (decimal_of_integer i +& decimal_of_integer f - /& decimal_of_integer (integer_exponentiation (integer_of_int 10) digits_f)) + /& decimal_of_integer + (integer_exponentiation (integer_of_int 10) digits_f) + ) /& decimal_of_string "100")) | LBool b -> Desugared.Ast.ELit (Dcalc.Ast.LBool b) | LMoneyAmount i -> @@ -185,16 +226,20 @@ let rec translate_expr (scope : Scopelang.Ast.ScopeName.t) (Dcalc.Ast.LMoney Runtime.( money_of_cents_integer - ((i.money_amount_units *! integer_of_int 100) +! i.money_amount_cents))) + ((i.money_amount_units *! integer_of_int 100) + +! i.money_amount_cents))) | LNumber ((Int i, _), Some (Year, _)) -> Desugared.Ast.ELit - (Dcalc.Ast.LDuration (Runtime.duration_of_numbers (Runtime.integer_to_int i) 0 0)) + (Dcalc.Ast.LDuration + (Runtime.duration_of_numbers (Runtime.integer_to_int i) 0 0)) | LNumber ((Int i, _), Some (Month, _)) -> Desugared.Ast.ELit - (Dcalc.Ast.LDuration (Runtime.duration_of_numbers 0 (Runtime.integer_to_int i) 0)) + (Dcalc.Ast.LDuration + (Runtime.duration_of_numbers 0 (Runtime.integer_to_int i) 0)) | LNumber ((Int i, _), Some (Day, _)) -> Desugared.Ast.ELit - (Dcalc.Ast.LDuration (Runtime.duration_of_numbers 0 0 (Runtime.integer_to_int i))) + (Dcalc.Ast.LDuration + (Runtime.duration_of_numbers 0 0 (Runtime.integer_to_int i))) | LNumber ((Dec (_, _), _), Some ((Year | Month | Day), _)) -> Errors.raise_spanned_error pos "Impossible to specify decimal amounts of days, months or years" @@ -202,11 +247,13 @@ let rec translate_expr (scope : Scopelang.Ast.ScopeName.t) if Pos.unmark date.literal_date_month > 12 then Errors.raise_spanned_error (Pos.get_position date.literal_date_month) - "There is an error in this date: the month number is bigger than 12"; + "There is an error in this date: the month number is bigger \ + than 12"; if Pos.unmark date.literal_date_day > 31 then Errors.raise_spanned_error (Pos.get_position date.literal_date_day) - "There is an error in this date: the day number is bigger than 31"; + "There is an error in this date: the day number is bigger than \ + 31"; Desugared.Ast.ELit (Dcalc.Ast.LDate (try @@ -216,19 +263,21 @@ let rec translate_expr (scope : Scopelang.Ast.ScopeName.t) (Pos.unmark date.literal_date_day) with Runtime.ImpossibleDate -> Errors.raise_spanned_error pos - "There is an error in this date, it does not correspond to a correct \ - calendar day")) + "There is an error in this date, it does not correspond \ + to a correct calendar day")) in Bindlib.box (untyped_term, pos) | Ident x -> ( - (* first we check whether this is a local var, then we resort to scope-wide variables *) + (* first we check whether this is a local var, then we resort to + scope-wide variables *) match Desugared.Ast.IdentMap.find_opt x ctxt.local_var_idmap with | None -> ( match Desugared.Ast.IdentMap.find_opt x scope_ctxt.var_idmap with | Some uid -> - (* If the referenced variable has states, then here are the rules to desambiguate. In - general, only the last state can be referenced. Except if defining a state of the - same variable, then it references the previous state in the chain. *) + (* If the referenced variable has states, then here are the rules + to desambiguate. In general, only the last state can be + referenced. Except if defining a state of the same variable, + then it references the previous state in the chain. *) let x_sig = Desugared.Ast.ScopeVarMap.find uid ctxt.var_typs in let x_state = match x_sig.var_sig_states_list with @@ -240,36 +289,45 @@ let rec translate_expr (scope : Scopelang.Ast.ScopeName.t) match sx' with | None -> failwith - "inconsistent state: inside a definition of a variable with no state \ - but variable has states" + "inconsistent state: inside a definition of a \ + variable with no state but variable has states" | Some inside_def_state -> - if Desugared.Ast.StateName.compare inside_def_state (List.hd states) = 0 + if + Desugared.Ast.StateName.compare inside_def_state + (List.hd states) + = 0 then Errors.raise_spanned_error pos - "It is impossible to refer to the variable you are defining when \ - defining its first state." + "It is impossible to refer to the variable you \ + are defining when defining its first state." else - (* Tricky: we have to retrieve in the list the previous state with - respect to the state that we are defining. *) + (* Tricky: we have to retrieve in the list the + previous state with respect to the state that + we are defining. *) let correct_state = ref None in ignore (List.fold_left (fun previous_state state -> - if Desugared.Ast.StateName.compare inside_def_state state = 0 + if + Desugared.Ast.StateName.compare + inside_def_state state + = 0 then correct_state := previous_state; Some state) None states); !correct_state) | _ -> - (* we take the last state in the chain *) Some (List.hd (List.rev states))) + (* we take the last state in the chain *) + Some (List.hd (List.rev states))) in - Bindlib.box (Desugared.Ast.ELocation (ScopeVar ((uid, pos), x_state)), pos) + Bindlib.box + (Desugared.Ast.ELocation (ScopeVar ((uid, pos), x_state)), pos) | None -> - Name_resolution.raise_unknown_identifier "for a local or scope-wide variable" (x, pos) - ) + Name_resolution.raise_unknown_identifier + "for a local or scope-wide variable" (x, pos)) | Some uid -> - Desugared.Ast.make_var (uid, pos) (* the whole box thing is to accomodate for this case *) - ) + Desugared.Ast.make_var (uid, pos) + (* the whole box thing is to accomodate for this case *)) | Dotted (e, c, x) -> ( match Pos.unmark e with | Ident y when Name_resolution.is_subscope_uid scope ctxt y -> @@ -280,10 +338,15 @@ let rec translate_expr (scope : Scopelang.Ast.ScopeName.t) let subscope_real_uid : Scopelang.Ast.ScopeName.t = Scopelang.Ast.SubScopeMap.find subscope_uid scope_ctxt.sub_scopes in - let subscope_var_uid = Name_resolution.get_var_uid subscope_real_uid ctxt x in + let subscope_var_uid = + Name_resolution.get_var_uid subscope_real_uid ctxt x + in Bindlib.box ( Desugared.Ast.ELocation - (SubScopeVar (subscope_real_uid, (subscope_uid, pos), (subscope_var_uid, pos))), + (SubScopeVar + ( subscope_real_uid, + (subscope_uid, pos), + (subscope_var_uid, pos) )), pos ) | _ -> ( (* In this case e.x is the struct field x access of expression e *) @@ -299,27 +362,40 @@ let rec translate_expr (scope : Scopelang.Ast.ScopeName.t) (* No constructor name was specified *) if Scopelang.Ast.StructMap.cardinal x_possible_structs > 1 then Errors.raise_spanned_error (Pos.get_position x) - "This struct field name is ambiguous, it can belong to %a. Disambiguate it by \ - prefixing it with the struct name." + "This struct field name is ambiguous, it can belong to %a. \ + Disambiguate it by prefixing it with the struct name." (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt " or ") (fun fmt (s_name, _) -> - Format.fprintf fmt "%a" Scopelang.Ast.StructName.format_t s_name)) + Format.fprintf fmt "%a" Scopelang.Ast.StructName.format_t + s_name)) (Scopelang.Ast.StructMap.bindings x_possible_structs) else - let s_uid, f_uid = Scopelang.Ast.StructMap.choose x_possible_structs in - Bindlib.box_apply (fun e -> (Desugared.Ast.EStructAccess (e, f_uid, s_uid), pos)) e + let s_uid, f_uid = + Scopelang.Ast.StructMap.choose x_possible_structs + in + Bindlib.box_apply + (fun e -> + (Desugared.Ast.EStructAccess (e, f_uid, s_uid), pos)) + e | Some c_name -> ( try - let c_uid = Desugared.Ast.IdentMap.find (Pos.unmark c_name) ctxt.struct_idmap in + let c_uid = + Desugared.Ast.IdentMap.find (Pos.unmark c_name) + ctxt.struct_idmap + in try - let f_uid = Scopelang.Ast.StructMap.find c_uid x_possible_structs in + let f_uid = + Scopelang.Ast.StructMap.find c_uid x_possible_structs + in Bindlib.box_apply - (fun e -> (Desugared.Ast.EStructAccess (e, f_uid, c_uid), pos)) + (fun e -> + (Desugared.Ast.EStructAccess (e, f_uid, c_uid), pos)) e with Not_found -> - Errors.raise_spanned_error pos "Struct %s does not contain field %s" - (Pos.unmark c_name) (Pos.unmark x) + Errors.raise_spanned_error pos + "Struct %s does not contain field %s" (Pos.unmark c_name) + (Pos.unmark x) with Not_found -> Errors.raise_spanned_error (Pos.get_position c_name) "Struct %s has not been defined before" (Pos.unmark c_name)))) @@ -341,18 +417,23 @@ let rec translate_expr (scope : Scopelang.Ast.ScopeName.t) let f_uid = try Scopelang.Ast.StructMap.find s_uid - (Desugared.Ast.IdentMap.find (Pos.unmark f_name) ctxt.field_idmap) + (Desugared.Ast.IdentMap.find (Pos.unmark f_name) + ctxt.field_idmap) with Not_found -> Errors.raise_spanned_error (Pos.get_position f_name) - "This identifier should refer to a field of struct %s" (Pos.unmark s_name) + "This identifier should refer to a field of struct %s" + (Pos.unmark s_name) in (match Scopelang.Ast.StructFieldMap.find_opt f_uid s_fields with | None -> () | Some e_field -> Errors.raise_multispanned_error - [ (None, Pos.get_position f_e); (None, Pos.get_position (Bindlib.unbox e_field)) ] - "The field %a has been defined twice:" Scopelang.Ast.StructFieldName.format_t - f_uid); + [ + (None, Pos.get_position f_e); + (None, Pos.get_position (Bindlib.unbox e_field)); + ] + "The field %a has been defined twice:" + Scopelang.Ast.StructFieldName.format_t f_uid); let f_e = translate_expr scope inside_definition_of ctxt f_e in Scopelang.Ast.StructFieldMap.add f_uid f_e s_fields) Scopelang.Ast.StructFieldMap.empty fields @@ -361,9 +442,10 @@ let rec translate_expr (scope : Scopelang.Ast.ScopeName.t) Scopelang.Ast.StructFieldMap.iter (fun expected_f _ -> if not (Scopelang.Ast.StructFieldMap.mem expected_f s_fields) then - Errors.raise_spanned_error pos "Missing field for structure %a: \"%a\"" - Scopelang.Ast.StructName.format_t s_uid Scopelang.Ast.StructFieldName.format_t - expected_f) + Errors.raise_spanned_error pos + "Missing field for structure %a: \"%a\"" + Scopelang.Ast.StructName.format_t s_uid + Scopelang.Ast.StructFieldName.format_t expected_f) expected_s_fields; Bindlib.box_apply @@ -371,10 +453,14 @@ let rec translate_expr (scope : Scopelang.Ast.ScopeName.t) (LiftStructFieldMap.lift_box s_fields) | EnumInject (enum, constructor, payload) -> ( let possible_c_uids = - try Desugared.Ast.IdentMap.find (Pos.unmark constructor) ctxt.constructor_idmap + try + Desugared.Ast.IdentMap.find (Pos.unmark constructor) + ctxt.constructor_idmap with Not_found -> - Errors.raise_spanned_error (Pos.get_position constructor) - "The name of this constructor has not been defined before, maybe it is a typo?" + Errors.raise_spanned_error + (Pos.get_position constructor) + "The name of this constructor has not been defined before, maybe \ + it is a typo?" in match enum with @@ -383,23 +469,31 @@ let rec translate_expr (scope : Scopelang.Ast.ScopeName.t) (* No constructor name was specified *) Scopelang.Ast.EnumMap.cardinal possible_c_uids > 1 then - Errors.raise_spanned_error (Pos.get_position constructor) - "This constructor name is ambiguous, it can belong to %a. Desambiguate it by \ - prefixing it with the enum name." + Errors.raise_spanned_error + (Pos.get_position constructor) + "This constructor name is ambiguous, it can belong to %a. \ + Desambiguate it by prefixing it with the enum name." (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt " or ") (fun fmt (s_name, _) -> - Format.fprintf fmt "%a" Scopelang.Ast.EnumName.format_t s_name)) + Format.fprintf fmt "%a" Scopelang.Ast.EnumName.format_t + s_name)) (Scopelang.Ast.EnumMap.bindings possible_c_uids) else let e_uid, c_uid = Scopelang.Ast.EnumMap.choose possible_c_uids in - let payload = Option.map (translate_expr scope inside_definition_of ctxt) payload in + let payload = + Option.map + (translate_expr scope inside_definition_of ctxt) + payload + in Bindlib.box_apply (fun payload -> ( Desugared.Ast.EEnumInj ( (match payload with | Some e' -> e' - | None -> (Desugared.Ast.ELit Dcalc.Ast.LUnit, Pos.get_position constructor)), + | None -> + ( Desugared.Ast.ELit Dcalc.Ast.LUnit, + Pos.get_position constructor )), c_uid, e_uid ), pos )) @@ -407,30 +501,39 @@ let rec translate_expr (scope : Scopelang.Ast.ScopeName.t) | Some enum -> ( try (* The path has been fully qualified *) - let e_uid = Desugared.Ast.IdentMap.find (Pos.unmark enum) ctxt.enum_idmap in + let e_uid = + Desugared.Ast.IdentMap.find (Pos.unmark enum) ctxt.enum_idmap + in try let c_uid = Scopelang.Ast.EnumMap.find e_uid possible_c_uids in - let payload = Option.map (translate_expr scope inside_definition_of ctxt) payload in + let payload = + Option.map + (translate_expr scope inside_definition_of ctxt) + payload + in Bindlib.box_apply (fun payload -> ( Desugared.Ast.EEnumInj ( (match payload with | Some e' -> e' - | None -> (Desugared.Ast.ELit Dcalc.Ast.LUnit, Pos.get_position constructor)), + | None -> + ( Desugared.Ast.ELit Dcalc.Ast.LUnit, + Pos.get_position constructor )), c_uid, e_uid ), pos )) (Bindlib.box_opt payload) with Not_found -> - Errors.raise_spanned_error pos "Enum %s does not contain case %s" (Pos.unmark enum) - (Pos.unmark constructor) + Errors.raise_spanned_error pos "Enum %s does not contain case %s" + (Pos.unmark enum) (Pos.unmark constructor) with Not_found -> - Errors.raise_spanned_error (Pos.get_position enum) "Enum %s has not been defined before" - (Pos.unmark enum))) + Errors.raise_spanned_error (Pos.get_position enum) + "Enum %s has not been defined before" (Pos.unmark enum))) | MatchWith (e1, (cases, _cases_pos)) -> let e1 = translate_expr scope inside_definition_of ctxt e1 in let cases_d, e_uid = - disambiguate_match_and_build_expression scope inside_definition_of ctxt cases + disambiguate_match_and_build_expression scope inside_definition_of ctxt + cases in Bindlib.box_apply2 (fun e1 cases_d -> (Desugared.Ast.EMatch (e1, e_uid, cases_d), pos)) @@ -443,7 +546,9 @@ let rec translate_expr (scope : Scopelang.Ast.ScopeName.t) Errors.format_spanned_warning (Pos.get_position binding) "This binding will be ignored (remove it to suppress warning)"); let enum_uid, c_uid = - disambiguate_constructor ctxt (fst (Pos.unmark pattern)) (Pos.get_position pattern) + disambiguate_constructor ctxt + (fst (Pos.unmark pattern)) + (Pos.get_position pattern) in let cases = Scopelang.Ast.EnumConstructorMap.mapi @@ -453,7 +558,9 @@ let rec translate_expr (scope : Scopelang.Ast.ScopeName.t) (Desugared.Ast.make_abs [| nop_var |] (Bindlib.box ( Desugared.Ast.ELit - (Dcalc.Ast.LBool (Scopelang.Ast.EnumConstructor.compare c_uid c_uid' = 0)), + (Dcalc.Ast.LBool + (Scopelang.Ast.EnumConstructor.compare c_uid c_uid' + = 0)), pos )) pos [ tau ] pos)) (Scopelang.Ast.EnumMap.find enum_uid ctxt.enums) @@ -465,13 +572,19 @@ let rec translate_expr (scope : Scopelang.Ast.ScopeName.t) Bindlib.box_apply (fun es -> (Desugared.Ast.EArray es, pos)) (Bindlib.box_list (List.map rec_helper es)) - | CollectionOp ((((Ast.Filter | Ast.Map) as op'), _pos_op'), param', collection, predicate) -> + | CollectionOp + ( (((Ast.Filter | Ast.Map) as op'), _pos_op'), + param', + collection, + predicate ) -> let collection = rec_helper collection in let ctxt, param = Name_resolution.add_def_local_var ctxt param' in let f_pred = Desugared.Ast.make_abs [| param |] (translate_expr scope inside_definition_of ctxt predicate) - pos [ (Scopelang.Ast.TAny, pos) ] pos + pos + [ (Scopelang.Ast.TAny, pos) ] + pos in Bindlib.box_apply2 (fun f_pred collection -> @@ -486,7 +599,8 @@ let rec translate_expr (scope : Scopelang.Ast.ScopeName.t) pos )) f_pred collection | CollectionOp - ( (Ast.Aggregate (Ast.AggregateArgExtremum (max_or_min, pred_typ, init)), pos_op'), + ( ( Ast.Aggregate (Ast.AggregateArgExtremum (max_or_min, pred_typ, init)), + pos_op' ), param', collection, predicate ) -> @@ -506,19 +620,31 @@ let rec translate_expr (scope : Scopelang.Ast.ScopeName.t) (if max_or_min then "max" else "min") Print.format_primitive_typ pred_typ in - let cmp_op = if max_or_min then Dcalc.Ast.Gt op_kind else Dcalc.Ast.Lt op_kind in + let cmp_op = + if max_or_min then Dcalc.Ast.Gt op_kind else Dcalc.Ast.Lt op_kind + in let f_pred = Desugared.Ast.make_abs [| param |] (translate_expr scope inside_definition_of ctxt predicate) - pos [ (Scopelang.Ast.TAny, pos) ] pos + pos + [ (Scopelang.Ast.TAny, pos) ] + pos + in + let f_pred_var = + Desugared.Ast.Var.make ("predicate", Pos.get_position predicate) + in + let f_pred_var_e = + Desugared.Ast.make_var (f_pred_var, Pos.get_position predicate) in - let f_pred_var = Desugared.Ast.Var.make ("predicate", Pos.get_position predicate) in - let f_pred_var_e = Desugared.Ast.make_var (f_pred_var, Pos.get_position predicate) in let acc_var = Desugared.Ast.Var.make ("acc", pos) in let acc_var_e = Desugared.Ast.make_var (acc_var, pos) in - let item_var = Desugared.Ast.Var.make ("item", Pos.get_position (Bindlib.unbox collection)) in + let item_var = + Desugared.Ast.Var.make + ("item", Pos.get_position (Bindlib.unbox collection)) + in let item_var_e = - Desugared.Ast.make_var (item_var, Pos.get_position (Bindlib.unbox collection)) + Desugared.Ast.make_var + (item_var, Pos.get_position (Bindlib.unbox collection)) in let fold_body = Bindlib.box_apply3 @@ -528,7 +654,8 @@ let rec translate_expr (scope : Scopelang.Ast.ScopeName.t) ( (Desugared.Ast.EOp (Dcalc.Ast.Binop cmp_op), pos_op'), [ (Desugared.Ast.EApp (f_pred_var_e, [ acc_var_e ]), pos); - (Desugared.Ast.EApp (f_pred_var_e, [ item_var_e ]), pos); + ( Desugared.Ast.EApp (f_pred_var_e, [ item_var_e ]), + pos ); ] ), pos ), acc_var_e, @@ -559,31 +686,40 @@ let rec translate_expr (scope : Scopelang.Ast.ScopeName.t) | Ast.Map | Ast.Filter | Ast.Aggregate (Ast.AggregateArgExtremum _) -> assert false (* should not happen *) | Ast.Exists -> - Bindlib.box (Desugared.Ast.ELit (Dcalc.Ast.LBool false), Pos.get_position op') - | Ast.Forall -> Bindlib.box (Desugared.Ast.ELit (Dcalc.Ast.LBool true), Pos.get_position op') + Bindlib.box + (Desugared.Ast.ELit (Dcalc.Ast.LBool false), Pos.get_position op') + | Ast.Forall -> + Bindlib.box + (Desugared.Ast.ELit (Dcalc.Ast.LBool true), Pos.get_position op') | Ast.Aggregate (Ast.AggregateSum Ast.Integer) -> Bindlib.box - (Desugared.Ast.ELit (Dcalc.Ast.LInt (Runtime.integer_of_int 0)), Pos.get_position op') + ( Desugared.Ast.ELit (Dcalc.Ast.LInt (Runtime.integer_of_int 0)), + Pos.get_position op' ) | Ast.Aggregate (Ast.AggregateSum Ast.Decimal) -> Bindlib.box - ( Desugared.Ast.ELit (Dcalc.Ast.LRat (Runtime.decimal_of_string "0")), + ( Desugared.Ast.ELit + (Dcalc.Ast.LRat (Runtime.decimal_of_string "0")), Pos.get_position op' ) | Ast.Aggregate (Ast.AggregateSum Ast.Money) -> Bindlib.box ( Desugared.Ast.ELit - (Dcalc.Ast.LMoney (Runtime.money_of_cents_integer (Runtime.integer_of_int 0))), + (Dcalc.Ast.LMoney + (Runtime.money_of_cents_integer (Runtime.integer_of_int 0))), Pos.get_position op' ) | Ast.Aggregate (Ast.AggregateSum Ast.Duration) -> Bindlib.box - ( Desugared.Ast.ELit (Dcalc.Ast.LDuration (Runtime.duration_of_numbers 0 0 0)), + ( Desugared.Ast.ELit + (Dcalc.Ast.LDuration (Runtime.duration_of_numbers 0 0 0)), Pos.get_position op' ) | Ast.Aggregate (Ast.AggregateSum t) -> - Errors.raise_spanned_error pos "It is impossible to sum two values of type %a together" + Errors.raise_spanned_error pos + "It is impossible to sum two values of type %a together" Print.format_primitive_typ t | Ast.Aggregate (Ast.AggregateExtremum (_, _, init)) -> rec_helper init | Ast.Aggregate Ast.AggregateCount -> Bindlib.box - (Desugared.Ast.ELit (Dcalc.Ast.LInt (Runtime.integer_of_int 0)), Pos.get_position op') + ( Desugared.Ast.ELit (Dcalc.Ast.LInt (Runtime.integer_of_int 0)), + Pos.get_position op' ) in let acc_var = Desugared.Ast.Var.make ("acc", Pos.get_position param') in let acc = Desugared.Ast.make_var (acc_var, Pos.get_position param') in @@ -592,14 +728,18 @@ let rec translate_expr (scope : Scopelang.Ast.ScopeName.t) Bindlib.box_apply2 (fun predicate acc -> ( Desugared.Ast.EApp - ( (Desugared.Ast.EOp (Dcalc.Ast.Binop op), Pos.get_position op'), + ( ( Desugared.Ast.EOp (Dcalc.Ast.Binop op), + Pos.get_position op' ), [ acc; predicate ] ), pos )) (translate_expr scope inside_definition_of ctxt predicate) acc in - let make_extr_body (cmp_op : Dcalc.Ast.binop) (t : Scopelang.Ast.typ Pos.marked) = - let tmp_var = Desugared.Ast.Var.make ("tmp", Pos.get_position param') in + let make_extr_body + (cmp_op : Dcalc.Ast.binop) (t : Scopelang.Ast.typ Pos.marked) = + let tmp_var = + Desugared.Ast.Var.make ("tmp", Pos.get_position param') + in let tmp = Desugared.Ast.make_var (tmp_var, Pos.get_position param') in Desugared.Ast.make_let_in tmp_var t (translate_expr scope inside_definition_of ctxt predicate) @@ -607,7 +747,8 @@ let rec translate_expr (scope : Scopelang.Ast.ScopeName.t) (fun acc tmp -> ( Desugared.Ast.EIfThenElse ( ( Desugared.Ast.EApp - ( (Desugared.Ast.EOp (Dcalc.Ast.Binop cmp_op), Pos.get_position op'), + ( ( Desugared.Ast.EOp (Dcalc.Ast.Binop cmp_op), + Pos.get_position op' ), [ acc; tmp ] ), pos ), acc, @@ -620,27 +761,35 @@ let rec translate_expr (scope : Scopelang.Ast.ScopeName.t) assert false (* should not happen *) | Ast.Exists -> make_body Dcalc.Ast.Or | Ast.Forall -> make_body Dcalc.Ast.And - | Ast.Aggregate (Ast.AggregateSum Ast.Integer) -> make_body (Dcalc.Ast.Add Dcalc.Ast.KInt) - | Ast.Aggregate (Ast.AggregateSum Ast.Decimal) -> make_body (Dcalc.Ast.Add Dcalc.Ast.KRat) - | Ast.Aggregate (Ast.AggregateSum Ast.Money) -> make_body (Dcalc.Ast.Add Dcalc.Ast.KMoney) + | Ast.Aggregate (Ast.AggregateSum Ast.Integer) -> + make_body (Dcalc.Ast.Add Dcalc.Ast.KInt) + | Ast.Aggregate (Ast.AggregateSum Ast.Decimal) -> + make_body (Dcalc.Ast.Add Dcalc.Ast.KRat) + | Ast.Aggregate (Ast.AggregateSum Ast.Money) -> + make_body (Dcalc.Ast.Add Dcalc.Ast.KMoney) | Ast.Aggregate (Ast.AggregateSum Ast.Duration) -> make_body (Dcalc.Ast.Add Dcalc.Ast.KDuration) - | Ast.Aggregate (Ast.AggregateSum _) -> assert false (* should not happen *) + | Ast.Aggregate (Ast.AggregateSum _) -> + assert false (* should not happen *) | Ast.Aggregate (Ast.AggregateExtremum (max_or_min, t, _)) -> let op_kind, typ = match t with | Ast.Integer -> (Dcalc.Ast.KInt, (Scopelang.Ast.TLit TInt, pos)) | Ast.Decimal -> (Dcalc.Ast.KRat, (Scopelang.Ast.TLit TRat, pos)) | Ast.Money -> (Dcalc.Ast.KMoney, (Scopelang.Ast.TLit TMoney, pos)) - | Ast.Duration -> (Dcalc.Ast.KDuration, (Scopelang.Ast.TLit TDuration, pos)) + | Ast.Duration -> + (Dcalc.Ast.KDuration, (Scopelang.Ast.TLit TDuration, pos)) | Ast.Date -> (Dcalc.Ast.KDate, (Scopelang.Ast.TLit TDate, pos)) | _ -> Errors.raise_spanned_error pos - "It is impossible to compute the %s of two values of type %a" + "It is impossible to compute the %s of two values of type \ + %a" (if max_or_min then "max" else "min") Print.format_primitive_typ t in - let cmp_op = if max_or_min then Dcalc.Ast.Gt op_kind else Dcalc.Ast.Lt op_kind in + let cmp_op = + if max_or_min then Dcalc.Ast.Gt op_kind else Dcalc.Ast.Lt op_kind + in make_extr_body cmp_op typ | Ast.Aggregate Ast.AggregateCount -> Bindlib.box_apply2 @@ -648,11 +797,13 @@ let rec translate_expr (scope : Scopelang.Ast.ScopeName.t) ( Desugared.Ast.EIfThenElse ( predicate, ( Desugared.Ast.EApp - ( ( Desugared.Ast.EOp (Dcalc.Ast.Binop (Dcalc.Ast.Add Dcalc.Ast.KInt)), + ( ( Desugared.Ast.EOp + (Dcalc.Ast.Binop (Dcalc.Ast.Add Dcalc.Ast.KInt)), Pos.get_position op' ), [ acc; - ( Desugared.Ast.ELit (Dcalc.Ast.LInt (Runtime.integer_of_int 1)), + ( Desugared.Ast.ELit + (Dcalc.Ast.LInt (Runtime.integer_of_int 1)), Pos.get_position predicate ); ] ), pos ), @@ -670,8 +821,9 @@ let rec translate_expr (scope : Scopelang.Ast.ScopeName.t) [ (Scopelang.Ast.TLit t, Pos.get_position op'); (Scopelang.Ast.TAny, pos) - (* we put any here because the type of the elements of the arrays is not - always the type of the accumulator; for instance in AggregateCount. *); + (* we put any here because the type of the elements of the + arrays is not always the type of the accumulator; for + instance in AggregateCount. *); ] ), pos )) (Bindlib.bind_mvar [| acc_var; param |] f_body) @@ -693,21 +845,25 @@ let rec translate_expr (scope : Scopelang.Ast.ScopeName.t) | Ast.Aggregate (Ast.AggregateSum Ast.Duration) | Ast.Aggregate (Ast.AggregateExtremum (_, Ast.Duration, _)) -> make_f Dcalc.Ast.TDuration - | Ast.Aggregate (Ast.AggregateSum _) | Ast.Aggregate (Ast.AggregateExtremum _) -> + | Ast.Aggregate (Ast.AggregateSum _) + | Ast.Aggregate (Ast.AggregateExtremum _) -> assert false (* should not happen *) | Ast.Aggregate Ast.AggregateCount -> make_f Dcalc.Ast.TInt in Bindlib.box_apply3 (fun f collection init -> ( Desugared.Ast.EApp - ((Desugared.Ast.EOp (Dcalc.Ast.Ternop Dcalc.Ast.Fold), pos), [ f; init; collection ]), + ( (Desugared.Ast.EOp (Dcalc.Ast.Ternop Dcalc.Ast.Fold), pos), + [ f; init; collection ] ), pos )) f collection init | MemCollection (member, collection) -> let param_var = Desugared.Ast.Var.make ("collection_member", pos) in let param = Desugared.Ast.make_var (param_var, pos) in let collection = rec_helper collection in - let init = Bindlib.box (Desugared.Ast.ELit (Dcalc.Ast.LBool false), pos) in + let init = + Bindlib.box (Desugared.Ast.ELit (Dcalc.Ast.LBool false), pos) + in let acc_var = Desugared.Ast.Var.make ("acc", pos) in let acc = Desugared.Ast.make_var (acc_var, pos) in let f_body = @@ -717,7 +873,8 @@ let rec translate_expr (scope : Scopelang.Ast.ScopeName.t) ( (Desugared.Ast.EOp (Dcalc.Ast.Binop Dcalc.Ast.Or), pos), [ ( Desugared.Ast.EApp - ((Desugared.Ast.EOp (Dcalc.Ast.Binop Dcalc.Ast.Eq), pos), [ member; param ]), + ( (Desugared.Ast.EOp (Dcalc.Ast.Binop Dcalc.Ast.Eq), pos), + [ member; param ] ), pos ); acc; ] ), @@ -730,25 +887,36 @@ let rec translate_expr (scope : Scopelang.Ast.ScopeName.t) (fun binder -> ( Desugared.Ast.EAbs ( (binder, pos), - [ (Scopelang.Ast.TLit Dcalc.Ast.TBool, pos); (Scopelang.Ast.TAny, pos) ] ), + [ + (Scopelang.Ast.TLit Dcalc.Ast.TBool, pos); + (Scopelang.Ast.TAny, pos); + ] ), pos )) (Bindlib.bind_mvar [| acc_var; param_var |] f_body) in Bindlib.box_apply3 (fun f collection init -> ( Desugared.Ast.EApp - ((Desugared.Ast.EOp (Dcalc.Ast.Ternop Dcalc.Ast.Fold), pos), [ f; init; collection ]), + ( (Desugared.Ast.EOp (Dcalc.Ast.Ternop Dcalc.Ast.Fold), pos), + [ f; init; collection ] ), pos )) f collection init - | Builtin IntToDec -> Bindlib.box (Desugared.Ast.EOp (Dcalc.Ast.Unop Dcalc.Ast.IntToRat), pos) - | Builtin Cardinal -> Bindlib.box (Desugared.Ast.EOp (Dcalc.Ast.Unop Dcalc.Ast.Length), pos) - | Builtin GetDay -> Bindlib.box (Desugared.Ast.EOp (Dcalc.Ast.Unop Dcalc.Ast.GetDay), pos) - | Builtin GetMonth -> Bindlib.box (Desugared.Ast.EOp (Dcalc.Ast.Unop Dcalc.Ast.GetMonth), pos) - | Builtin GetYear -> Bindlib.box (Desugared.Ast.EOp (Dcalc.Ast.Unop Dcalc.Ast.GetYear), pos) + | Builtin IntToDec -> + Bindlib.box (Desugared.Ast.EOp (Dcalc.Ast.Unop Dcalc.Ast.IntToRat), pos) + | Builtin Cardinal -> + Bindlib.box (Desugared.Ast.EOp (Dcalc.Ast.Unop Dcalc.Ast.Length), pos) + | Builtin GetDay -> + Bindlib.box (Desugared.Ast.EOp (Dcalc.Ast.Unop Dcalc.Ast.GetDay), pos) + | Builtin GetMonth -> + Bindlib.box (Desugared.Ast.EOp (Dcalc.Ast.Unop Dcalc.Ast.GetMonth), pos) + | Builtin GetYear -> + Bindlib.box (Desugared.Ast.EOp (Dcalc.Ast.Unop Dcalc.Ast.GetYear), pos) -and disambiguate_match_and_build_expression (scope : Scopelang.Ast.ScopeName.t) +and disambiguate_match_and_build_expression + (scope : Scopelang.Ast.ScopeName.t) (inside_definition_of : Desugared.Ast.ScopeDef.t Pos.marked option) - (ctxt : Name_resolution.context) (cases : Ast.match_case Pos.marked list) : + (ctxt : Name_resolution.context) + (cases : Ast.match_case Pos.marked list) : Desugared.Ast.expr Pos.marked Bindlib.box Scopelang.Ast.EnumConstructorMap.t * Scopelang.Ast.EnumName.t = let create_var = function @@ -757,10 +925,15 @@ and disambiguate_match_and_build_expression (scope : Scopelang.Ast.ScopeName.t) let ctxt, param_var = Name_resolution.add_def_local_var ctxt param in (ctxt, (param_var, Pos.get_position param)) in - let bind_case_body (c_uid : Dcalc.Ast.EnumConstructor.t) (e_uid : Dcalc.Ast.EnumName.t) - (ctxt : Name_resolution.context) (param_pos : Pos.t) (case_body : ('a * Pos.t) Bindlib.box) - (e_binder : (Desugared.Ast.expr, Desugared.Ast.expr * Pos.t) Bindlib.mbinder Bindlib.box) : - 'c Bindlib.box = + let bind_case_body + (c_uid : Dcalc.Ast.EnumConstructor.t) + (e_uid : Dcalc.Ast.EnumName.t) + (ctxt : Name_resolution.context) + (param_pos : Pos.t) + (case_body : ('a * Pos.t) Bindlib.box) + (e_binder : + (Desugared.Ast.expr, Desugared.Ast.expr * Pos.t) Bindlib.mbinder + Bindlib.box) : 'c Bindlib.box = Bindlib.box_apply2 (fun e_binder case_body -> Pos.same_pos_as @@ -778,7 +951,8 @@ and disambiguate_match_and_build_expression (scope : Scopelang.Ast.ScopeName.t) | Ast.MatchCase case -> let constructor, binding = Pos.unmark case.Ast.match_case_pattern in let e_uid', c_uid = - disambiguate_constructor ctxt constructor (Pos.get_position case.Ast.match_case_pattern) + disambiguate_constructor ctxt constructor + (Pos.get_position case.Ast.match_case_pattern) in let e_uid = match e_uid with @@ -788,9 +962,10 @@ and disambiguate_match_and_build_expression (scope : Scopelang.Ast.ScopeName.t) else Errors.raise_spanned_error (Pos.get_position case.Ast.match_case_pattern) - "This case matches a constructor of enumeration %a but previous case were \ - matching constructors of enumeration %a" - Scopelang.Ast.EnumName.format_t e_uid Scopelang.Ast.EnumName.format_t e_uid' + "This case matches a constructor of enumeration %a but \ + previous case were matching constructors of enumeration %a" + Scopelang.Ast.EnumName.format_t e_uid + Scopelang.Ast.EnumName.format_t e_uid' in (match Scopelang.Ast.EnumConstructorMap.find_opt c_uid cases_d with | None -> () @@ -800,20 +975,30 @@ and disambiguate_match_and_build_expression (scope : Scopelang.Ast.ScopeName.t) (None, Pos.get_position case.match_case_expr); (None, Pos.get_position (Bindlib.unbox e_case)); ] - "The constructor %a has been matched twice:" Scopelang.Ast.EnumConstructor.format_t - c_uid); + "The constructor %a has been matched twice:" + Scopelang.Ast.EnumConstructor.format_t c_uid); let ctxt, (param_var, param_pos) = create_var binding in - let case_body = translate_expr scope inside_definition_of ctxt case.Ast.match_case_expr in - let e_binder = Bindlib.bind_mvar (Array.of_list [ param_var ]) case_body in - let case_expr = bind_case_body c_uid e_uid ctxt param_pos case_body e_binder in - (Scopelang.Ast.EnumConstructorMap.add c_uid case_expr cases_d, Some e_uid, curr_index + 1) + let case_body = + translate_expr scope inside_definition_of ctxt + case.Ast.match_case_expr + in + let e_binder = + Bindlib.bind_mvar (Array.of_list [ param_var ]) case_body + in + let case_expr = + bind_case_body c_uid e_uid ctxt param_pos case_body e_binder + in + ( Scopelang.Ast.EnumConstructorMap.add c_uid case_expr cases_d, + Some e_uid, + curr_index + 1 ) | Ast.WildCard match_case_expr -> ( let nb_cases = List.length cases in let raise_wildcard_not_last_case_err () = Errors.raise_multispanned_error [ (Some "Not ending wildcard:", case_pos); - (Some "Next reachable case:", curr_index + 1 |> List.nth cases |> Pos.get_position); + ( Some "Next reachable case:", + curr_index + 1 |> List.nth cases |> Pos.get_position ); ] "Wildcard must be the last match case" in @@ -821,22 +1006,26 @@ and disambiguate_match_and_build_expression (scope : Scopelang.Ast.ScopeName.t) | None -> if 1 = nb_cases then Errors.raise_spanned_error case_pos - "Couldn't infer the enumeration name from lonely wildcard (wildcard cannot be used \ - as single match case)" + "Couldn't infer the enumeration name from lonely wildcard \ + (wildcard cannot be used as single match case)" else raise_wildcard_not_last_case_err () | Some e_uid -> - if curr_index < nb_cases - 1 then raise_wildcard_not_last_case_err (); + if curr_index < nb_cases - 1 then + raise_wildcard_not_last_case_err (); let missing_constructors = Scopelang.Ast.EnumMap.find e_uid ctxt.Name_resolution.enums |> Scopelang.Ast.EnumConstructorMap.filter_map (fun c_uid _ -> - match Scopelang.Ast.EnumConstructorMap.find_opt c_uid cases_d with + match + Scopelang.Ast.EnumConstructorMap.find_opt c_uid cases_d + with | Some _ -> None | None -> Some c_uid) in - if Scopelang.Ast.EnumConstructorMap.is_empty missing_constructors then + if Scopelang.Ast.EnumConstructorMap.is_empty missing_constructors + then Errors.format_spanned_warning case_pos - "Unreachable match case, all constructors of the enumeration %a are already \ - specified" + "Unreachable match case, all constructors of the enumeration \ + %a are already specified" Scopelang.Ast.EnumName.format_t e_uid; (* The current used strategy is to replace the wildcard branch: match foo with @@ -851,52 +1040,69 @@ and disambiguate_match_and_build_expression (scope : Scopelang.Ast.ScopeName.t) | CaseN -> wildcard_payload *) (* Creates the wildcard payload *) let ctxt, (payload_var, var_pos) = create_var None in - let case_body = translate_expr scope inside_definition_of ctxt match_case_expr in - let e_binder = Bindlib.bind_mvar (Array.of_list [ payload_var ]) case_body in + let case_body = + translate_expr scope inside_definition_of ctxt match_case_expr + in + let e_binder = + Bindlib.bind_mvar (Array.of_list [ payload_var ]) case_body + in (* For each missing cases, binds the wildcard payload. *) Scopelang.Ast.EnumConstructorMap.fold (fun c_uid _ (cases_d, e_uid_opt, curr_index) -> - let case_expr = bind_case_body c_uid e_uid ctxt var_pos case_body e_binder in + let case_expr = + bind_case_body c_uid e_uid ctxt var_pos case_body e_binder + in ( Scopelang.Ast.EnumConstructorMap.add c_uid case_expr cases_d, e_uid_opt, curr_index + 1 )) - missing_constructors (cases_d, Some e_uid, curr_index)) + missing_constructors + (cases_d, Some e_uid, curr_index)) in let expr, e_name, _ = - List.fold_left bind_match_cases (Scopelang.Ast.EnumConstructorMap.empty, None, 0) cases + List.fold_left bind_match_cases + (Scopelang.Ast.EnumConstructorMap.empty, None, 0) + cases in (expr, Option.get e_name) [@@ocamlformat "wrap-comments=false"] (** {1 Translating scope definitions} *) -(** A scope use can be annotated with a pervasive precondition, in which case this precondition has - to be appended to the justifications of each definition in the subscope use. This is what this - function does. *) -let merge_conditions (precond : Desugared.Ast.expr Pos.marked Bindlib.box option) - (cond : Desugared.Ast.expr Pos.marked Bindlib.box option) (default_pos : Pos.t) : - Desugared.Ast.expr Pos.marked Bindlib.box = +(** A scope use can be annotated with a pervasive precondition, in which case + this precondition has to be appended to the justifications of each + definition in the subscope use. This is what this function does. *) +let merge_conditions + (precond : Desugared.Ast.expr Pos.marked Bindlib.box option) + (cond : Desugared.Ast.expr Pos.marked Bindlib.box option) + (default_pos : Pos.t) : Desugared.Ast.expr Pos.marked Bindlib.box = match (precond, cond) with | Some precond, Some cond -> let op_term = - (Desugared.Ast.EOp (Dcalc.Ast.Binop Dcalc.Ast.And), Pos.get_position (Bindlib.unbox precond)) + ( Desugared.Ast.EOp (Dcalc.Ast.Binop Dcalc.Ast.And), + Pos.get_position (Bindlib.unbox precond) ) in Bindlib.box_apply2 (fun precond cond -> - (Desugared.Ast.EApp (op_term, [ precond; cond ]), Pos.get_position precond)) + ( Desugared.Ast.EApp (op_term, [ precond; cond ]), + Pos.get_position precond )) precond cond | Some cond, None | None, Some cond -> cond - | None, None -> Bindlib.box (Desugared.Ast.ELit (Dcalc.Ast.LBool true), default_pos) + | None, None -> + Bindlib.box (Desugared.Ast.ELit (Dcalc.Ast.LBool true), default_pos) -(** Translates a surface definition into condition into a desugared {!type: Desugared.Ast.rule} *) -let process_default (ctxt : Name_resolution.context) (scope : Scopelang.Ast.ScopeName.t) - (def_key : Desugared.Ast.ScopeDef.t Pos.marked) (rule_id : Desugared.Ast.RuleName.t) +(** Translates a surface definition into condition into a desugared {!type: + Desugared.Ast.rule} *) +let process_default + (ctxt : Name_resolution.context) + (scope : Scopelang.Ast.ScopeName.t) + (def_key : Desugared.Ast.ScopeDef.t Pos.marked) + (rule_id : Desugared.Ast.RuleName.t) (param_uid : Desugared.Ast.Var.t Pos.marked option) (precond : Desugared.Ast.expr Pos.marked Bindlib.box option) (exception_to_rules : Desugared.Ast.RuleSet.t Pos.marked) - (just : Ast.expression Pos.marked option) (cons : Ast.expression Pos.marked) : - Desugared.Ast.rule = + (just : Ast.expression Pos.marked option) + (cons : Ast.expression Pos.marked) : Desugared.Ast.rule = let just = match just with | Some just -> Some (translate_expr scope (Some def_key) ctxt just) @@ -908,9 +1114,12 @@ let process_default (ctxt : Name_resolution.context) (scope : Scopelang.Ast.Scop rule_just = just; rule_cons = cons; rule_parameter = - (let def_key_typ = Name_resolution.get_def_typ ctxt (Pos.unmark def_key) in + (let def_key_typ = + Name_resolution.get_def_typ ctxt (Pos.unmark def_key) + in match (Pos.unmark def_key_typ, param_uid) with - | Scopelang.Ast.TArrow (t_in, _), Some param_uid -> Some (Pos.unmark param_uid, t_in) + | Scopelang.Ast.TArrow (t_in, _), Some param_uid -> + Some (Pos.unmark param_uid, t_in) | Scopelang.Ast.TArrow _, None -> Errors.raise_spanned_error (Pos.get_position (Bindlib.unbox cons)) @@ -924,17 +1133,27 @@ let process_default (ctxt : Name_resolution.context) (scope : Scopelang.Ast.Scop rule_id; } -(** Wrapper around {!val: process_default} that performs some name disambiguation *) -let process_def (precond : Desugared.Ast.expr Pos.marked Bindlib.box option) - (scope_uid : Scopelang.Ast.ScopeName.t) (ctxt : Name_resolution.context) - (prgm : Desugared.Ast.program) (def : Ast.definition) : Desugared.Ast.program = - let scope : Desugared.Ast.scope = Scopelang.Ast.ScopeMap.find scope_uid prgm.program_scopes in +(** Wrapper around {!val: process_default} that performs some name + disambiguation *) +let process_def + (precond : Desugared.Ast.expr Pos.marked Bindlib.box option) + (scope_uid : Scopelang.Ast.ScopeName.t) + (ctxt : Name_resolution.context) + (prgm : Desugared.Ast.program) + (def : Ast.definition) : Desugared.Ast.program = + let scope : Desugared.Ast.scope = + Scopelang.Ast.ScopeMap.find scope_uid prgm.program_scopes + in let scope_ctxt = Scopelang.Ast.ScopeMap.find scope_uid ctxt.scopes in let def_key = - Name_resolution.get_def_key (Pos.unmark def.definition_name) def.definition_state scope_uid ctxt + Name_resolution.get_def_key + (Pos.unmark def.definition_name) + def.definition_state scope_uid ctxt (Pos.get_position def.definition_expr) in - let scope_def_ctxt = Desugared.Ast.ScopeDefMap.find def_key scope_ctxt.scope_defs_contexts in + let scope_def_ctxt = + Desugared.Ast.ScopeDefMap.find def_key scope_ctxt.scope_defs_contexts + in (* We add to the name resolution context the name of the parameter variable *) let param_uid, new_ctxt = match def.definition_parameter with @@ -948,24 +1167,29 @@ let process_def (precond : Desugared.Ast.expr Pos.marked Bindlib.box option) let rule_name = def.definition_id in let parent_rules = match def.Ast.definition_exception_to with - | NotAnException -> (Desugared.Ast.RuleSet.empty, Pos.get_position def.Ast.definition_name) + | NotAnException -> + (Desugared.Ast.RuleSet.empty, Pos.get_position def.Ast.definition_name) | UnlabeledException -> ( match scope_def_ctxt.default_exception_rulename with - (* This should have been caught previously by check_unlabeled_exception *) - | None | Some (Name_resolution.Ambiguous _) -> assert false (* should not happen *) - | Some (Name_resolution.Unique (name, pos)) -> (Desugared.Ast.RuleSet.singleton name, pos) - ) + (* This should have been caught previously by + check_unlabeled_exception *) + | None | Some (Name_resolution.Ambiguous _) -> + assert false (* should not happen *) + | Some (Name_resolution.Unique (name, pos)) -> + (Desugared.Ast.RuleSet.singleton name, pos)) | ExceptionToLabel label -> ( try let label_id = - Desugared.Ast.IdentMap.find (Pos.unmark label) scope_def_ctxt.label_idmap + Desugared.Ast.IdentMap.find (Pos.unmark label) + scope_def_ctxt.label_idmap in - ( Desugared.Ast.LabelMap.find label_id scope_def.scope_def_label_groups, + ( Desugared.Ast.LabelMap.find label_id + scope_def.scope_def_label_groups, Pos.get_position def.Ast.definition_name ) with Not_found -> Errors.raise_spanned_error (Pos.get_position label) - "Unknown label for the scope variable %a: \"%s\"" Desugared.Ast.ScopeDef.format_t - def_key (Pos.unmark label)) + "Unknown label for the scope variable %a: \"%s\"" + Desugared.Ast.ScopeDef.format_t def_key (Pos.unmark label)) in let scope_def = { @@ -974,36 +1198,52 @@ let process_def (precond : Desugared.Ast.expr Pos.marked Bindlib.box option) Desugared.Ast.RuleMap.add rule_name (process_default new_ctxt scope_uid (def_key, Pos.get_position def.definition_name) - rule_name param_uid precond parent_rules def.definition_condition def.definition_expr) + rule_name param_uid precond parent_rules def.definition_condition + def.definition_expr) scope_def.scope_def_rules; } in - { scope with scope_defs = Desugared.Ast.ScopeDefMap.add def_key scope_def scope.scope_defs } + { + scope with + scope_defs = + Desugared.Ast.ScopeDefMap.add def_key scope_def scope.scope_defs; + } in { prgm with - program_scopes = Scopelang.Ast.ScopeMap.add scope_uid scope_updated prgm.program_scopes; + program_scopes = + Scopelang.Ast.ScopeMap.add scope_uid scope_updated prgm.program_scopes; } (** Translates a {!type: Surface.Ast.rule} from the surface language *) -let process_rule (precond : Desugared.Ast.expr Pos.marked Bindlib.box option) - (scope : Scopelang.Ast.ScopeName.t) (ctxt : Name_resolution.context) - (prgm : Desugared.Ast.program) (rule : Ast.rule) : Desugared.Ast.program = +let process_rule + (precond : Desugared.Ast.expr Pos.marked Bindlib.box option) + (scope : Scopelang.Ast.ScopeName.t) + (ctxt : Name_resolution.context) + (prgm : Desugared.Ast.program) + (rule : Ast.rule) : Desugared.Ast.program = let def = Ast.rule_to_def rule in process_def precond scope ctxt prgm def (** Translates assertions *) -let process_assert (precond : Desugared.Ast.expr Pos.marked Bindlib.box option) - (scope_uid : Scopelang.Ast.ScopeName.t) (ctxt : Name_resolution.context) - (prgm : Desugared.Ast.program) (ass : Ast.assertion) : Desugared.Ast.program = - let scope : Desugared.Ast.scope = Scopelang.Ast.ScopeMap.find scope_uid prgm.program_scopes in +let process_assert + (precond : Desugared.Ast.expr Pos.marked Bindlib.box option) + (scope_uid : Scopelang.Ast.ScopeName.t) + (ctxt : Name_resolution.context) + (prgm : Desugared.Ast.program) + (ass : Ast.assertion) : Desugared.Ast.program = + let scope : Desugared.Ast.scope = + Scopelang.Ast.ScopeMap.find scope_uid prgm.program_scopes + in let ass = translate_expr scope_uid None ctxt (match ass.Ast.assertion_condition with | None -> ass.Ast.assertion_content | Some cond -> ( Ast.IfThenElse - (cond, ass.Ast.assertion_content, Pos.same_pos_as (Ast.Literal (Ast.LBool true)) cond), + ( cond, + ass.Ast.assertion_content, + Pos.same_pos_as (Ast.Literal (Ast.LBool true)) cond ), Pos.get_position cond )) in let ass = @@ -1012,18 +1252,30 @@ let process_assert (precond : Desugared.Ast.expr Pos.marked Bindlib.box option) Bindlib.box_apply2 (fun precond ass -> ( Desugared.Ast.EIfThenElse - (precond, ass, Pos.same_pos_as (Desugared.Ast.ELit (Dcalc.Ast.LBool true)) precond), + ( precond, + ass, + Pos.same_pos_as (Desugared.Ast.ELit (Dcalc.Ast.LBool true)) + precond ), Pos.get_position precond )) precond ass | None -> ass in - let new_scope = { scope with scope_assertions = ass :: scope.scope_assertions } in - { prgm with program_scopes = Scopelang.Ast.ScopeMap.add scope_uid new_scope prgm.program_scopes } + let new_scope = + { scope with scope_assertions = ass :: scope.scope_assertions } + in + { + prgm with + program_scopes = + Scopelang.Ast.ScopeMap.add scope_uid new_scope prgm.program_scopes; + } (** Translates a surface definition, rule or assertion *) -let process_scope_use_item (precond : Ast.expression Pos.marked option) - (scope : Scopelang.Ast.ScopeName.t) (ctxt : Name_resolution.context) - (prgm : Desugared.Ast.program) (item : Ast.scope_use_item Pos.marked) : Desugared.Ast.program = +let process_scope_use_item + (precond : Ast.expression Pos.marked option) + (scope : Scopelang.Ast.ScopeName.t) + (ctxt : Name_resolution.context) + (prgm : Desugared.Ast.program) + (item : Ast.scope_use_item Pos.marked) : Desugared.Ast.program = let precond = Option.map (translate_expr scope None ctxt) precond in match Pos.unmark item with | Ast.Rule rule -> process_rule precond scope ctxt prgm rule @@ -1033,8 +1285,11 @@ let process_scope_use_item (precond : Ast.expression Pos.marked option) (** {1 Translating top-level items} *) -(* If this is an unlabeled exception, ensures that it has a unique default definition *) -let check_unlabeled_exception (scope : Scopelang.Ast.ScopeName.t) (ctxt : Name_resolution.context) +(* If this is an unlabeled exception, ensures that it has a unique default + definition *) +let check_unlabeled_exception + (scope : Scopelang.Ast.ScopeName.t) + (ctxt : Name_resolution.context) (item : Ast.scope_use_item Pos.marked) : unit = let scope_ctxt = Scopelang.Ast.ScopeMap.find scope ctxt.scopes in match Pos.unmark item with @@ -1042,21 +1297,27 @@ let check_unlabeled_exception (scope : Scopelang.Ast.ScopeName.t) (ctxt : Name_r let def_key, exception_to = match Pos.unmark item with | Ast.Rule rule -> - ( Name_resolution.get_def_key (Pos.unmark rule.rule_name) rule.rule_state scope ctxt + ( Name_resolution.get_def_key + (Pos.unmark rule.rule_name) + rule.rule_state scope ctxt (Pos.get_position rule.rule_name), rule.rule_exception_to ) | Ast.Definition def -> - ( Name_resolution.get_def_key (Pos.unmark def.definition_name) def.definition_state - scope ctxt + ( Name_resolution.get_def_key + (Pos.unmark def.definition_name) + def.definition_state scope ctxt (Pos.get_position def.definition_name), def.definition_exception_to ) | _ -> assert false (* should not happen *) in - let scope_def_ctxt = Desugared.Ast.ScopeDefMap.find def_key scope_ctxt.scope_defs_contexts in + let scope_def_ctxt = + Desugared.Ast.ScopeDefMap.find def_key scope_ctxt.scope_defs_contexts + in match exception_to with | Ast.NotAnException | Ast.ExceptionToLabel _ -> () - (* If this is an unlabeled exception, we check that it has a unique default definition *) + (* If this is an unlabeled exception, we check that it has a unique + default definition *) | Ast.UnlabeledException -> ( match scope_def_ctxt.default_exception_rulename with | None -> @@ -1066,12 +1327,15 @@ let check_unlabeled_exception (scope : Scopelang.Ast.ScopeName.t) (ctxt : Name_r Errors.raise_multispanned_error ([ (Some "Ambiguous exception", Pos.get_position item) ] @ List.map (fun p -> (Some "Candidate definition", p)) pos) - "This exception can refer to several definitions. Try using labels to disambiguate" + "This exception can refer to several definitions. Try using \ + labels to disambiguate" | Some (Unique _) -> ())) | _ -> () (** Translates a surface scope use, which is a bunch of definitions *) -let process_scope_use (ctxt : Name_resolution.context) (prgm : Desugared.Ast.program) +let process_scope_use + (ctxt : Name_resolution.context) + (prgm : Desugared.Ast.program) (use : Ast.scope_use) : Desugared.Ast.program = let name = fst use.scope_use_name in let scope_uid = Desugared.Ast.IdentMap.find name ctxt.scope_idmap in @@ -1084,7 +1348,9 @@ let process_scope_use (ctxt : Name_resolution.context) (prgm : Desugared.Ast.pro in let precond = use.scope_use_condition in List.iter (check_unlabeled_exception scope_uid ctxt) use.scope_use_items; - List.fold_left (process_scope_use_item precond scope_uid ctxt) prgm use.scope_use_items + List.fold_left + (process_scope_use_item precond scope_uid ctxt) + prgm use.scope_use_items let attribute_to_io (attr : Ast.scope_decl_context_io) : Scopelang.Ast.io = { @@ -1100,7 +1366,8 @@ let attribute_to_io (attr : Ast.scope_decl_context_io) : Scopelang.Ast.io = } (** Main function of this module *) -let desugar_program (ctxt : Name_resolution.context) (prgm : Ast.program) : Desugared.Ast.program = +let desugar_program (ctxt : Name_resolution.context) (prgm : Ast.program) : + Desugared.Ast.program = let empty_prgm = { Desugared.Ast.program_structs = @@ -1116,57 +1383,81 @@ let desugar_program (ctxt : Name_resolution.context) (prgm : Ast.program) : Desu Desugared.Ast.scope_vars = Desugared.Ast.IdentMap.fold (fun _ v acc -> - let v_sig = Desugared.Ast.ScopeVarMap.find v ctxt.var_typs in + let v_sig = + Desugared.Ast.ScopeVarMap.find v ctxt.var_typs + in match v_sig.var_sig_states_list with - | [] -> Desugared.Ast.ScopeVarMap.add v Desugared.Ast.WholeVar acc - | states -> Desugared.Ast.ScopeVarMap.add v (Desugared.Ast.States states) acc) - s_context.Name_resolution.var_idmap Desugared.Ast.ScopeVarMap.empty; - Desugared.Ast.scope_sub_scopes = s_context.Name_resolution.sub_scopes; + | [] -> + Desugared.Ast.ScopeVarMap.add v Desugared.Ast.WholeVar + acc + | states -> + Desugared.Ast.ScopeVarMap.add v + (Desugared.Ast.States states) acc) + s_context.Name_resolution.var_idmap + Desugared.Ast.ScopeVarMap.empty; + Desugared.Ast.scope_sub_scopes = + s_context.Name_resolution.sub_scopes; Desugared.Ast.scope_defs = - (* Initializing the definitions of all scopes and subscope vars, with no rules yet - inside *) + (* Initializing the definitions of all scopes and subscope vars, + with no rules yet inside *) (let scope_vars_defs = Desugared.Ast.IdentMap.fold (fun _ v acc -> - let v_sig = Desugared.Ast.ScopeVarMap.find v ctxt.Name_resolution.var_typs in + let v_sig = + Desugared.Ast.ScopeVarMap.find v + ctxt.Name_resolution.var_typs + in match v_sig.var_sig_states_list with | [] -> let def_key = Desugared.Ast.ScopeDef.Var (v, None) in Desugared.Ast.ScopeDefMap.add def_key { - Desugared.Ast.scope_def_rules = Desugared.Ast.RuleMap.empty; + Desugared.Ast.scope_def_rules = + Desugared.Ast.RuleMap.empty; Desugared.Ast.scope_def_typ = v_sig.var_sig_typ; Desugared.Ast.scope_def_label_groups = Name_resolution.label_groups ctxt s_uid def_key; - Desugared.Ast.scope_def_is_condition = v_sig.var_sig_is_condition; - Desugared.Ast.scope_def_io = attribute_to_io v_sig.var_sig_io; + Desugared.Ast.scope_def_is_condition = + v_sig.var_sig_is_condition; + Desugared.Ast.scope_def_io = + attribute_to_io v_sig.var_sig_io; } acc | states -> fst (List.fold_left (fun (acc, i) state -> - let def_key = Desugared.Ast.ScopeDef.Var (v, Some state) in + let def_key = + Desugared.Ast.ScopeDef.Var (v, Some state) + in ( Desugared.Ast.ScopeDefMap.add def_key { - Desugared.Ast.scope_def_rules = Desugared.Ast.RuleMap.empty; - Desugared.Ast.scope_def_typ = v_sig.var_sig_typ; + Desugared.Ast.scope_def_rules = + Desugared.Ast.RuleMap.empty; + Desugared.Ast.scope_def_typ = + v_sig.var_sig_typ; Desugared.Ast.scope_def_label_groups = - Name_resolution.label_groups ctxt s_uid def_key; + Name_resolution.label_groups ctxt + s_uid def_key; Desugared.Ast.scope_def_is_condition = v_sig.var_sig_is_condition; Desugared.Ast.scope_def_io = - (* The first state should have the input I/O of the - original variable, and the last state should have the - output I/O of the original variable. All intermediate - states shall have "internal" I/O.*) - (let original_io = attribute_to_io v_sig.var_sig_io in + (* The first state should have the + input I/O of the original variable, + and the last state should have the + output I/O of the original + variable. All intermediate states + shall have "internal" I/O.*) + (let original_io = + attribute_to_io v_sig.var_sig_io + in let io_input = if i = 0 then original_io.io_input else ( Scopelang.Ast.NoInput, Pos.get_position - (Desugared.Ast.StateName.get_info state) ) + (Desugared.Ast.StateName + .get_info state) ) in let io_output = if i = List.length states - 1 then @@ -1174,14 +1465,16 @@ let desugar_program (ctxt : Name_resolution.context) (prgm : Ast.program) : Desu else ( false, Pos.get_position - (Desugared.Ast.StateName.get_info state) ) + (Desugared.Ast.StateName + .get_info state) ) in { io_input; io_output }); } acc, i + 1 )) (acc, 0) states)) - s_context.Name_resolution.var_idmap Desugared.Ast.ScopeDefMap.empty + s_context.Name_resolution.var_idmap + Desugared.Ast.ScopeDefMap.empty in let scope_and_subscope_vars_defs = Scopelang.Ast.SubScopeMap.fold @@ -1189,20 +1482,29 @@ let desugar_program (ctxt : Name_resolution.context) (prgm : Ast.program) : Desu Desugared.Ast.IdentMap.fold (fun _ v acc -> let v_sig = - Desugared.Ast.ScopeVarMap.find v ctxt.Name_resolution.var_typs + Desugared.Ast.ScopeVarMap.find v + ctxt.Name_resolution.var_typs + in + let def_key = + Desugared.Ast.ScopeDef.SubScopeVar + (subscope_name, v) in - let def_key = Desugared.Ast.ScopeDef.SubScopeVar (subscope_name, v) in Desugared.Ast.ScopeDefMap.add def_key { - Desugared.Ast.scope_def_rules = Desugared.Ast.RuleMap.empty; + Desugared.Ast.scope_def_rules = + Desugared.Ast.RuleMap.empty; Desugared.Ast.scope_def_typ = v_sig.var_sig_typ; Desugared.Ast.scope_def_label_groups = - Name_resolution.label_groups ctxt subscope_uid def_key; - Desugared.Ast.scope_def_is_condition = v_sig.var_sig_is_condition; - Desugared.Ast.scope_def_io = attribute_to_io v_sig.var_sig_io; + Name_resolution.label_groups ctxt subscope_uid + def_key; + Desugared.Ast.scope_def_is_condition = + v_sig.var_sig_is_condition; + Desugared.Ast.scope_def_io = + attribute_to_io v_sig.var_sig_io; } acc) - (Scopelang.Ast.ScopeMap.find subscope_uid ctxt.Name_resolution.scopes) + (Scopelang.Ast.ScopeMap.find subscope_uid + ctxt.Name_resolution.scopes) .Name_resolution.var_idmap acc) s_context.sub_scopes scope_vars_defs in @@ -1214,11 +1516,14 @@ let desugar_program (ctxt : Name_resolution.context) (prgm : Ast.program) : Desu ctxt.Name_resolution.scopes; } in - let rec processer_structure (prgm : Desugared.Ast.program) (item : Ast.law_structure) : + let rec processer_structure + (prgm : Desugared.Ast.program) (item : Ast.law_structure) : Desugared.Ast.program = match item with | LawHeading (_, children) -> - List.fold_left (fun prgm child -> processer_structure prgm child) prgm children + List.fold_left + (fun prgm child -> processer_structure prgm child) + prgm children | CodeBlock (block, _, _) -> List.fold_left (fun prgm item -> diff --git a/compiler/surface/desugaring.mli b/compiler/surface/desugaring.mli index ec0849ab..28f81ce7 100644 --- a/compiler/surface/desugaring.mli +++ b/compiler/surface/desugaring.mli @@ -1,15 +1,18 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020 Inria, contributor: Nicolas Chataing - Denis Merigoux +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, contributor: + Nicolas Chataing Denis Merigoux + - 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 + 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 + 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. *) (** Translation from {!module: Surface.Ast} to {!module: Desugared.Ast}. @@ -17,5 +20,6 @@ - Removes syntactic sugars - Separate code from legislation *) -val desugar_program : Name_resolution.context -> Ast.program -> Desugared.Ast.program +val desugar_program : + Name_resolution.context -> Ast.program -> Desugared.Ast.program (** Main function of this module *) diff --git a/compiler/surface/fill_positions.ml b/compiler/surface/fill_positions.ml index 71c4b7c7..f1caec81 100644 --- a/compiler/surface/fill_positions.ml +++ b/compiler/surface/fill_positions.ml @@ -1,15 +1,17 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux - +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, contributor: + Denis Merigoux - 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 + 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 + 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. *) open Utils @@ -22,12 +24,15 @@ let fill_pos_with_legislative_info (p : Ast.program) : Ast.program = method! visit_marked f env x = (f env (Pos.unmark x), Pos.overwrite_law_info (Pos.get_position x) env) - method! visit_LawHeading (env : string list) (heading : Ast.law_heading) + method! visit_LawHeading + (env : string list) + (heading : Ast.law_heading) (children : Ast.law_structure list) = let env = Pos.unmark heading.law_heading_name :: env in Ast.LawHeading ( super#visit_law_heading env heading, - List.map (fun child -> super#visit_law_structure env child) children ) + List.map (fun child -> super#visit_law_structure env child) children + ) end in visitor#visit_program [] p diff --git a/compiler/surface/fill_positions.mli b/compiler/surface/fill_positions.mli index e8613501..6f5c0267 100644 --- a/compiler/surface/fill_positions.mli +++ b/compiler/surface/fill_positions.mli @@ -1,18 +1,20 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux - +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, contributor: + Denis Merigoux - 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 + 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 + 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. *) -(** Fills the position tags in the AST with info about the legislative article this position belongs - to. *) +(** Fills the position tags in the AST with info about the legislative article + this position belongs to. *) val fill_pos_with_legislative_info : Ast.program -> Ast.program diff --git a/compiler/surface/lexer_common.ml b/compiler/surface/lexer_common.ml index e30a08ec..c081d192 100644 --- a/compiler/surface/lexer_common.ml +++ b/compiler/surface/lexer_common.ml @@ -1,15 +1,18 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020 Inria, contributors: Denis Merigoux - , Emile Rolley +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, + contributors: Denis Merigoux , Emile Rolley + - 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 + 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 + 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. *) open Tokens @@ -17,45 +20,57 @@ open Sedlexing open Utils module R = Re.Pcre -(* Calculates the precedence according a {!val: matched_regex} of the form : '[#]+'. +(* Calculates the precedence according a {!val: matched_regex} of the form : + '[#]+'. - @note -2 because [LAW_HEADING] start with at least "#" and the number of '#' remaining - corresponds to the precedence. *) -let calc_precedence (matched_regex : string) : int = String.length matched_regex - 1 + @note -2 because [LAW_HEADING] start with at least "#" and the number of '#' + remaining corresponds to the precedence. *) +let calc_precedence (matched_regex : string) : int = + String.length matched_regex - 1 (* Gets the [LAW_HEADING] token from the current {!val: lexbuf} *) let get_law_heading (lexbuf : lexbuf) : token = let extract_article_title = - R.regexp "([#]+)\\s*([^\\|]+)(\\|([^\\|]+)|)(\\|\\s*([0-9]{4}\\-[0-9]{2}\\-[0-9]{2})|)" + R.regexp + "([#]+)\\s*([^\\|]+)(\\|([^\\|]+)|)(\\|\\s*([0-9]{4}\\-[0-9]{2}\\-[0-9]{2})|)" + in + let get_substring = + R.get_substring (R.exec ~rex:extract_article_title (Utf8.lexeme lexbuf)) in - let get_substring = R.get_substring (R.exec ~rex:extract_article_title (Utf8.lexeme lexbuf)) in let title = String.trim (get_substring 2) in - let article_id = try Some (String.trim (get_substring 4)) with Not_found -> None in - let article_expiration_date = try Some (String.trim (get_substring 6)) with Not_found -> None in + let article_id = + try Some (String.trim (get_substring 4)) with Not_found -> None + in + let article_expiration_date = + try Some (String.trim (get_substring 6)) with Not_found -> None + in let precedence = calc_precedence (String.trim (get_substring 1)) in LAW_HEADING (title, article_id, article_expiration_date, precedence) type lexing_context = Law | Code | Directive | Directive_args -(** Boolean reference, used by the lexer as the mutable state to distinguish whether it is lexing - code or law. *) +(** Boolean reference, used by the lexer as the mutable state to distinguish + whether it is lexing code or law. *) let context : lexing_context ref = ref Law -(** Mutable string reference that accumulates the string representation of the body of code being - lexed. This string representation is used in the literate programming backends to faithfully - capture the spacing pattern of the original program *) +(** Mutable string reference that accumulates the string representation of the + body of code being lexed. This string representation is used in the literate + programming backends to faithfully capture the spacing pattern of the + original program *) let code_buffer : Buffer.t = Buffer.create 4000 (** Updates {!val:code_buffer} with the current lexeme *) -let update_acc (lexbuf : lexbuf) : unit = Buffer.add_string code_buffer (Utf8.lexeme lexbuf) +let update_acc (lexbuf : lexbuf) : unit = + Buffer.add_string code_buffer (Utf8.lexeme lexbuf) (** Error-generating helper *) let raise_lexer_error (loc : Pos.t) (token : string) = - Errors.raise_spanned_error loc "Parsing error after token \"%s\": what comes after is unknown" - token + Errors.raise_spanned_error loc + "Parsing error after token \"%s\": what comes after is unknown" token -(** Associative list matching each punctuation string part of the Catala syntax with its {!module: - Surface.Parser} token. Same for all the input languages (English, French, etc.) *) +(** Associative list matching each punctuation string part of the Catala syntax + with its {!module: Surface.Parser} token. Same for all the input languages + (English, French, etc.) *) let token_list_language_agnostic : (string * token) list = [ (".", DOT); @@ -83,7 +98,8 @@ let token_list_language_agnostic : (string * token) list = module type LocalisedLexer = sig val token_list : (string * Tokens.token) list - (** Same as {!val: token_list_language_agnostic}, but with tokens specialized to a given language. *) + (** Same as {!val: token_list_language_agnostic}, but with tokens specialized + to a given language. *) val lex_builtin : string -> Ast.builtin_expression option (** Simple lexer for builtins *) @@ -95,6 +111,7 @@ module type LocalisedLexer = sig (** Main lexing function used outside code blocks *) val lexer : Sedlexing.lexbuf -> Tokens.token - (** Entry point of the lexer, distributes to {!val: lex_code} or {!val:lex_law} depending of the - current {!val: Surface.Lexer_common.context}. *) + (** Entry point of the lexer, distributes to {!val: lex_code} or + {!val:lex_law} depending of the current {!val: + Surface.Lexer_common.context}. *) end diff --git a/compiler/surface/lexer_common.mli b/compiler/surface/lexer_common.mli index 95a33a69..47c150c5 100644 --- a/compiler/surface/lexer_common.mli +++ b/compiler/surface/lexer_common.mli @@ -1,15 +1,18 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020 Inria, contributors: Denis Merigoux - , Emile Rolley +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, + contributors: Denis Merigoux , Emile Rolley + - 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 + 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 + 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. *) (** Auxiliary functions used by all lexers. *) @@ -17,13 +20,13 @@ type lexing_context = Law | Code | Directive | Directive_args val context : lexing_context ref -(** Reference, used by the lexer as the mutable state to distinguish whether it is lexing code or - law. *) +(** Reference, used by the lexer as the mutable state to distinguish whether it + is lexing code or law. *) val code_buffer : Buffer.t -(** Buffer that accumulates the string representation of the body of code being lexed. This string - representation is used in the literate programming backends to faithfully capture the spacing - pattern of the original program *) +(** Buffer that accumulates the string representation of the body of code being + lexed. This string representation is used in the literate programming + backends to faithfully capture the spacing pattern of the original program *) val update_acc : Sedlexing.lexbuf -> unit (** Updates {!val:code_buffer} with the current lexeme *) @@ -32,8 +35,9 @@ val raise_lexer_error : Utils.Pos.t -> string -> 'a (** Error-generating helper *) val token_list_language_agnostic : (string * Tokens.token) list -(** Associative list matching each punctuation string part of the Catala syntax with its - {!Surface.Parser} token. Same for all the input languages (English, French, etc.) *) +(** Associative list matching each punctuation string part of the Catala syntax + with its {!Surface.Parser} token. Same for all the input languages (English, + French, etc.) *) val calc_precedence : string -> int (** Calculates the precedence according a matched regex of the form : '[#]+' *) @@ -43,8 +47,8 @@ val get_law_heading : Sedlexing.lexbuf -> Tokens.token module type LocalisedLexer = sig val token_list : (string * Tokens.token) list - (** Same as {!val: Surface.Lexer_common.token_list_language_agnostic}, but with tokens whose - string varies with the input language. *) + (** Same as {!val: Surface.Lexer_common.token_list_language_agnostic}, but + with tokens whose string varies with the input language. *) val lex_builtin : string -> Ast.builtin_expression option (** Simple lexer for builtins *) @@ -56,6 +60,7 @@ module type LocalisedLexer = sig (** Main lexing function used outside code blocks *) val lexer : Sedlexing.lexbuf -> Tokens.token - (** Entry point of the lexer, distributes to {!val: lex_code} or {!val:lex_law} depending of the - current {!val: Surface.Lexer_common.context}. *) + (** Entry point of the lexer, distributes to {!val: lex_code} or + {!val:lex_law} depending of the current {!val: + Surface.Lexer_common.context}. *) end diff --git a/compiler/surface/lexer_en.mli b/compiler/surface/lexer_en.mli index 1cc8cb5a..905888f7 100644 --- a/compiler/surface/lexer_en.mli +++ b/compiler/surface/lexer_en.mli @@ -1,15 +1,18 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020 Inria, contributors: Denis Merigoux - , Emile Rolley +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, + contributors: Denis Merigoux , Emile Rolley + - 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 + 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 + 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. *) include Lexer_common.LocalisedLexer diff --git a/compiler/surface/lexer_fr.mli b/compiler/surface/lexer_fr.mli index 1cc8cb5a..905888f7 100644 --- a/compiler/surface/lexer_fr.mli +++ b/compiler/surface/lexer_fr.mli @@ -1,15 +1,18 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020 Inria, contributors: Denis Merigoux - , Emile Rolley +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, + contributors: Denis Merigoux , Emile Rolley + - 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 + 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 + 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. *) include Lexer_common.LocalisedLexer diff --git a/compiler/surface/lexer_pl.mli b/compiler/surface/lexer_pl.mli index 1cc8cb5a..905888f7 100644 --- a/compiler/surface/lexer_pl.mli +++ b/compiler/surface/lexer_pl.mli @@ -1,15 +1,18 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020 Inria, contributors: Denis Merigoux - , Emile Rolley +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, + contributors: Denis Merigoux , Emile Rolley + - 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 + 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 + 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. *) include Lexer_common.LocalisedLexer diff --git a/compiler/surface/name_resolution.ml b/compiler/surface/name_resolution.ml index 3c6cfdab..f191f230 100644 --- a/compiler/surface/name_resolution.ml +++ b/compiler/surface/name_resolution.ml @@ -1,29 +1,33 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020 Inria, contributor: Nicolas Chataing - Denis Merigoux +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, contributor: + Nicolas Chataing Denis Merigoux + - 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 + 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 + 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. *) -(** Builds a context that allows for mapping each name to a precise uid, taking lexical scopes into - account *) +(** Builds a context that allows for mapping each name to a precise uid, taking + lexical scopes into account *) open Utils (** {1 Name resolution context} *) type ident = string - type typ = Scopelang.Ast.typ -type unique_rulename = Ambiguous of Pos.t list | Unique of Desugared.Ast.RuleName.t Pos.marked +type unique_rulename = + | Ambiguous of Pos.t list + | Unique of Desugared.Ast.RuleName.t Pos.marked type scope_def_context = { default_exception_rulename : unique_rulename option; @@ -32,7 +36,8 @@ type scope_def_context = { } type scope_context = { - var_idmap : Desugared.Ast.ScopeVar.t Desugared.Ast.IdentMap.t; (** Scope variables *) + var_idmap : Desugared.Ast.ScopeVar.t Desugared.Ast.IdentMap.t; + (** Scope variables *) scope_defs_contexts : scope_def_context Desugared.Ast.ScopeDefMap.t; (** What is the default rule to refer to for unnamed exceptions, if any *) sub_scopes_idmap : Scopelang.Ast.SubScopeName.t Desugared.Ast.IdentMap.t; @@ -58,21 +63,30 @@ type var_sig = { type context = { local_var_idmap : Desugared.Ast.Var.t Desugared.Ast.IdentMap.t; - (** Inside a definition, local variables can be introduced by functions arguments or pattern - matching *) - scope_idmap : Scopelang.Ast.ScopeName.t Desugared.Ast.IdentMap.t; (** The names of the scopes *) + (** Inside a definition, local variables can be introduced by functions + arguments or pattern matching *) + scope_idmap : Scopelang.Ast.ScopeName.t Desugared.Ast.IdentMap.t; + (** The names of the scopes *) struct_idmap : Scopelang.Ast.StructName.t Desugared.Ast.IdentMap.t; (** The names of the structs *) - field_idmap : Scopelang.Ast.StructFieldName.t Scopelang.Ast.StructMap.t Desugared.Ast.IdentMap.t; - (** The names of the struct fields. Names of fields can be shared between different structs *) - enum_idmap : Scopelang.Ast.EnumName.t Desugared.Ast.IdentMap.t; (** The names of the enums *) + field_idmap : + Scopelang.Ast.StructFieldName.t Scopelang.Ast.StructMap.t + Desugared.Ast.IdentMap.t; + (** The names of the struct fields. Names of fields can be shared between + different structs *) + enum_idmap : Scopelang.Ast.EnumName.t Desugared.Ast.IdentMap.t; + (** The names of the enums *) constructor_idmap : - Scopelang.Ast.EnumConstructor.t Scopelang.Ast.EnumMap.t Desugared.Ast.IdentMap.t; - (** The names of the enum constructors. Constructor names can be shared between different - enums *) - scopes : scope_context Scopelang.Ast.ScopeMap.t; (** For each scope, its context *) - structs : struct_context Scopelang.Ast.StructMap.t; (** For each struct, its context *) - enums : enum_context Scopelang.Ast.EnumMap.t; (** For each enum, its context *) + Scopelang.Ast.EnumConstructor.t Scopelang.Ast.EnumMap.t + Desugared.Ast.IdentMap.t; + (** The names of the enum constructors. Constructor names can be shared + between different enums *) + scopes : scope_context Scopelang.Ast.ScopeMap.t; + (** For each scope, its context *) + structs : struct_context Scopelang.Ast.StructMap.t; + (** For each struct, its context *) + enums : enum_context Scopelang.Ast.EnumMap.t; + (** For each enum, its context *) var_typs : var_sig Desugared.Ast.ScopeVarMap.t; (** The signatures of each scope variable declared *) } @@ -80,53 +94,67 @@ type context = { (** {1 Helpers} *) -(** Temporary function raising an error message saying that a feature is not supported yet *) +(** Temporary function raising an error message saying that a feature is not + supported yet *) let raise_unsupported_feature (msg : string) (pos : Pos.t) = Errors.raise_spanned_error pos "Unsupported feature: %s" msg -(** Function to call whenever an identifier used somewhere has not been declared in the program - previously *) +(** Function to call whenever an identifier used somewhere has not been declared + in the program previously *) let raise_unknown_identifier (msg : string) (ident : ident Pos.marked) = - Errors.raise_spanned_error (Pos.get_position ident) "\"%s\": unknown identifier %s" + Errors.raise_spanned_error (Pos.get_position ident) + "\"%s\": unknown identifier %s" (Utils.Cli.with_style [ ANSITerminal.yellow ] "%s" (Pos.unmark ident)) msg (** Gets the type associated to an uid *) -let get_var_typ (ctxt : context) (uid : Desugared.Ast.ScopeVar.t) : typ Pos.marked = +let get_var_typ (ctxt : context) (uid : Desugared.Ast.ScopeVar.t) : + typ Pos.marked = (Desugared.Ast.ScopeVarMap.find uid ctxt.var_typs).var_sig_typ let is_var_cond (ctxt : context) (uid : Desugared.Ast.ScopeVar.t) : bool = (Desugared.Ast.ScopeVarMap.find uid ctxt.var_typs).var_sig_is_condition -let get_var_io (ctxt : context) (uid : Desugared.Ast.ScopeVar.t) : Ast.scope_decl_context_io = +let get_var_io (ctxt : context) (uid : Desugared.Ast.ScopeVar.t) : + Ast.scope_decl_context_io = (Desugared.Ast.ScopeVarMap.find uid ctxt.var_typs).var_sig_io (** Get the variable uid inside the scope given in argument *) -let get_var_uid (scope_uid : Scopelang.Ast.ScopeName.t) (ctxt : context) +let get_var_uid + (scope_uid : Scopelang.Ast.ScopeName.t) + (ctxt : context) ((x, pos) : ident Pos.marked) : Desugared.Ast.ScopeVar.t = let scope = Scopelang.Ast.ScopeMap.find scope_uid ctxt.scopes in match Desugared.Ast.IdentMap.find_opt x scope.var_idmap with | None -> raise_unknown_identifier - (Format.asprintf "for a variable of scope %a" Scopelang.Ast.ScopeName.format_t scope_uid) + (Format.asprintf "for a variable of scope %a" + Scopelang.Ast.ScopeName.format_t scope_uid) (x, pos) | Some uid -> uid (** Get the subscope uid inside the scope given in argument *) -let get_subscope_uid (scope_uid : Scopelang.Ast.ScopeName.t) (ctxt : context) +let get_subscope_uid + (scope_uid : Scopelang.Ast.ScopeName.t) + (ctxt : context) ((y, pos) : ident Pos.marked) : Scopelang.Ast.SubScopeName.t = let scope = Scopelang.Ast.ScopeMap.find scope_uid ctxt.scopes in match Desugared.Ast.IdentMap.find_opt y scope.sub_scopes_idmap with | None -> raise_unknown_identifier "for a subscope of this scope" (y, pos) | Some sub_uid -> sub_uid -(** [is_subscope_uid scope_uid ctxt y] returns true if [y] belongs to the subscopes of [scope_uid]. *) -let is_subscope_uid (scope_uid : Scopelang.Ast.ScopeName.t) (ctxt : context) (y : ident) : bool = +(** [is_subscope_uid scope_uid ctxt y] returns true if [y] belongs to the + subscopes of [scope_uid]. *) +let is_subscope_uid + (scope_uid : Scopelang.Ast.ScopeName.t) (ctxt : context) (y : ident) : bool + = let scope = Scopelang.Ast.ScopeMap.find scope_uid ctxt.scopes in Desugared.Ast.IdentMap.mem y scope.sub_scopes_idmap (** Checks if the var_uid belongs to the scope scope_uid *) -let belongs_to (ctxt : context) (uid : Desugared.Ast.ScopeVar.t) +let belongs_to + (ctxt : context) + (uid : Desugared.Ast.ScopeVar.t) (scope_uid : Scopelang.Ast.ScopeName.t) : bool = let scope = Scopelang.Ast.ScopeMap.find scope_uid ctxt.scopes in Desugared.Ast.IdentMap.exists @@ -134,24 +162,28 @@ let belongs_to (ctxt : context) (uid : Desugared.Ast.ScopeVar.t) scope.var_idmap (** Retrieves the type of a scope definition from the context *) -let get_def_typ (ctxt : context) (def : Desugared.Ast.ScopeDef.t) : typ Pos.marked = +let get_def_typ (ctxt : context) (def : Desugared.Ast.ScopeDef.t) : + typ Pos.marked = match def with | Desugared.Ast.ScopeDef.SubScopeVar (_, x) - (* we don't need to look at the subscope prefix because [x] is already the uid referring back to - the original subscope *) + (* we don't need to look at the subscope prefix because [x] is already the uid + referring back to the original subscope *) | Desugared.Ast.ScopeDef.Var (x, _) -> get_var_typ ctxt x let is_def_cond (ctxt : context) (def : Desugared.Ast.ScopeDef.t) : bool = match def with | Desugared.Ast.ScopeDef.SubScopeVar (_, x) - (* we don't need to look at the subscope prefix because [x] is already the uid referring back to - the original subscope *) + (* we don't need to look at the subscope prefix because [x] is already the uid + referring back to the original subscope *) | Desugared.Ast.ScopeDef.Var (x, _) -> is_var_cond ctxt x -let label_groups (ctxt : context) (s_uid : Scopelang.Ast.ScopeName.t) - (def : Desugared.Ast.ScopeDef.t) : Desugared.Ast.RuleSet.t Desugared.Ast.LabelMap.t = +let label_groups + (ctxt : context) + (s_uid : Scopelang.Ast.ScopeName.t) + (def : Desugared.Ast.ScopeDef.t) : + Desugared.Ast.RuleSet.t Desugared.Ast.LabelMap.t = try (Desugared.Ast.ScopeDefMap.find def (Scopelang.Ast.ScopeMap.find s_uid ctxt.scopes).scope_defs_contexts) @@ -161,16 +193,21 @@ let label_groups (ctxt : context) (s_uid : Scopelang.Ast.ScopeName.t) (** {1 Declarations pass} *) (** Process a subscope declaration *) -let process_subscope_decl (scope : Scopelang.Ast.ScopeName.t) (ctxt : context) +let process_subscope_decl + (scope : Scopelang.Ast.ScopeName.t) + (ctxt : context) (decl : Ast.scope_decl_context_scope) : context = let name, name_pos = decl.scope_decl_context_scope_name in let subscope, s_pos = decl.scope_decl_context_scope_sub_scope in let scope_ctxt = Scopelang.Ast.ScopeMap.find scope ctxt.scopes in - match Desugared.Ast.IdentMap.find_opt subscope scope_ctxt.sub_scopes_idmap with + match + Desugared.Ast.IdentMap.find_opt subscope scope_ctxt.sub_scopes_idmap + with | Some use -> Errors.raise_multispanned_error [ - (Some "first use", Pos.get_position (Scopelang.Ast.SubScopeName.get_info use)); + ( Some "first use", + Pos.get_position (Scopelang.Ast.SubScopeName.get_info use) ); (Some "second use", s_pos); ] "Subscope name \"%a\" already used" @@ -187,26 +224,36 @@ let process_subscope_decl (scope : Scopelang.Ast.ScopeName.t) (ctxt : context) { scope_ctxt with sub_scopes_idmap = - Desugared.Ast.IdentMap.add name sub_scope_uid scope_ctxt.sub_scopes_idmap; + Desugared.Ast.IdentMap.add name sub_scope_uid + scope_ctxt.sub_scopes_idmap; sub_scopes = - Scopelang.Ast.SubScopeMap.add sub_scope_uid original_subscope_uid scope_ctxt.sub_scopes; + Scopelang.Ast.SubScopeMap.add sub_scope_uid original_subscope_uid + scope_ctxt.sub_scopes; } in - { ctxt with scopes = Scopelang.Ast.ScopeMap.add scope scope_ctxt ctxt.scopes } + { + ctxt with + scopes = Scopelang.Ast.ScopeMap.add scope scope_ctxt ctxt.scopes; + } let is_type_cond ((typ, _) : Ast.typ Pos.marked) = match typ with - | Ast.Base Ast.Condition | Ast.Func { arg_typ = _; return_typ = Ast.Condition, _ } -> true + | Ast.Base Ast.Condition + | Ast.Func { arg_typ = _; return_typ = Ast.Condition, _ } -> + true | _ -> false (** Process a basic type (all types except function types) *) -let rec process_base_typ (ctxt : context) ((typ, typ_pos) : Ast.base_typ Pos.marked) : +let rec process_base_typ + (ctxt : context) ((typ, typ_pos) : Ast.base_typ Pos.marked) : Scopelang.Ast.typ Pos.marked = match typ with | Ast.Condition -> (Scopelang.Ast.TLit TBool, typ_pos) | Ast.Data (Ast.Collection t) -> ( Scopelang.Ast.TArray - (Pos.unmark (process_base_typ ctxt (Ast.Data (Pos.unmark t), Pos.get_position t))), + (Pos.unmark + (process_base_typ ctxt + (Ast.Data (Pos.unmark t), Pos.get_position t))), typ_pos ) | Ast.Data (Ast.Primitive prim) -> ( match prim with @@ -225,7 +272,8 @@ let rec process_base_typ (ctxt : context) ((typ, typ_pos) : Ast.base_typ Pos.mar | Some e_uid -> (Scopelang.Ast.TEnum e_uid, typ_pos) | None -> Errors.raise_spanned_error typ_pos - "Unknown type \"%a\", not a struct or enum previously declared" + "Unknown type \"%a\", not a struct or enum previously \ + declared" (Utils.Cli.format_with_style [ ANSITerminal.yellow ]) ident))) @@ -235,11 +283,14 @@ let process_type (ctxt : context) ((typ, typ_pos) : Ast.typ Pos.marked) : match typ with | Ast.Base base_typ -> process_base_typ ctxt (base_typ, typ_pos) | Ast.Func { arg_typ; return_typ } -> - ( Scopelang.Ast.TArrow (process_base_typ ctxt arg_typ, process_base_typ ctxt return_typ), + ( Scopelang.Ast.TArrow + (process_base_typ ctxt arg_typ, process_base_typ ctxt return_typ), typ_pos ) (** Process data declaration *) -let process_data_decl (scope : Scopelang.Ast.ScopeName.t) (ctxt : context) +let process_data_decl + (scope : Scopelang.Ast.ScopeName.t) + (ctxt : context) (decl : Ast.scope_decl_context_data) : context = (* First check the type of the context data *) let data_typ = process_type ctxt decl.scope_decl_context_item_typ in @@ -250,7 +301,8 @@ let process_data_decl (scope : Scopelang.Ast.ScopeName.t) (ctxt : context) | Some use -> Errors.raise_multispanned_error [ - (Some "first use", Pos.get_position (Desugared.Ast.ScopeVar.get_info use)); + ( Some "first use", + Pos.get_position (Desugared.Ast.ScopeVar.get_info use) ); (Some "second use", pos); ] "var name \"%a\" already used" @@ -259,13 +311,17 @@ let process_data_decl (scope : Scopelang.Ast.ScopeName.t) (ctxt : context) | None -> let uid = Desugared.Ast.ScopeVar.fresh (name, pos) in let scope_ctxt = - { scope_ctxt with var_idmap = Desugared.Ast.IdentMap.add name uid scope_ctxt.var_idmap } + { + scope_ctxt with + var_idmap = Desugared.Ast.IdentMap.add name uid scope_ctxt.var_idmap; + } in let states_idmap, states_list = List.fold_right (fun state_id (states_idmap, states_list) -> let state_uid = Desugared.Ast.StateName.fresh state_id in - ( Desugared.Ast.IdentMap.add (Pos.unmark state_id) state_uid states_idmap, + ( Desugared.Ast.IdentMap.add (Pos.unmark state_id) state_uid + states_idmap, state_uid :: states_list )) decl.scope_decl_context_item_states (Desugared.Ast.IdentMap.empty, []) @@ -286,20 +342,24 @@ let process_data_decl (scope : Scopelang.Ast.ScopeName.t) (ctxt : context) } (** Process an item declaration *) -let process_item_decl (scope : Scopelang.Ast.ScopeName.t) (ctxt : context) +let process_item_decl + (scope : Scopelang.Ast.ScopeName.t) + (ctxt : context) (decl : Ast.scope_decl_context_item) : context = match decl with | Ast.ContextData data_decl -> process_data_decl scope ctxt data_decl | Ast.ContextScope sub_decl -> process_subscope_decl scope ctxt sub_decl (** Adds a binding to the context *) -let add_def_local_var (ctxt : context) (name : ident Pos.marked) : context * Desugared.Ast.Var.t = +let add_def_local_var (ctxt : context) (name : ident Pos.marked) : + context * Desugared.Ast.Var.t = let local_var_uid = Desugared.Ast.Var.make name in let ctxt = { ctxt with local_var_idmap = - Desugared.Ast.IdentMap.add (Pos.unmark name) local_var_uid ctxt.local_var_idmap; + Desugared.Ast.IdentMap.add (Pos.unmark name) local_var_uid + ctxt.local_var_idmap; } in (ctxt, local_var_uid) @@ -314,10 +374,14 @@ let process_scope_decl (ctxt : context) (decl : Ast.scope_decl) : context = (** Process a struct declaration *) let process_struct_decl (ctxt : context) (sdecl : Ast.struct_decl) : context = - let s_uid = Desugared.Ast.IdentMap.find (fst sdecl.struct_decl_name) ctxt.struct_idmap in + let s_uid = + Desugared.Ast.IdentMap.find (fst sdecl.struct_decl_name) ctxt.struct_idmap + in List.fold_left (fun ctxt (fdecl, _) -> - let f_uid = Scopelang.Ast.StructFieldName.fresh fdecl.Ast.struct_decl_field_name in + let f_uid = + Scopelang.Ast.StructFieldName.fresh fdecl.Ast.struct_decl_field_name + in let ctxt = { ctxt with @@ -327,7 +391,8 @@ let process_struct_decl (ctxt : context) (sdecl : Ast.struct_decl) : context = (fun uids -> match uids with | None -> Some (Scopelang.Ast.StructMap.singleton s_uid f_uid) - | Some uids -> Some (Scopelang.Ast.StructMap.add s_uid f_uid uids)) + | Some uids -> + Some (Scopelang.Ast.StructMap.add s_uid f_uid uids)) ctxt.field_idmap; } in @@ -352,10 +417,14 @@ let process_struct_decl (ctxt : context) (sdecl : Ast.struct_decl) : context = (** Process an enum declaration *) let process_enum_decl (ctxt : context) (edecl : Ast.enum_decl) : context = - let e_uid = Desugared.Ast.IdentMap.find (fst edecl.enum_decl_name) ctxt.enum_idmap in + let e_uid = + Desugared.Ast.IdentMap.find (fst edecl.enum_decl_name) ctxt.enum_idmap + in List.fold_left (fun ctxt (cdecl, cdecl_pos) -> - let c_uid = Scopelang.Ast.EnumConstructor.fresh cdecl.Ast.enum_decl_case_name in + let c_uid = + Scopelang.Ast.EnumConstructor.fresh cdecl.Ast.enum_decl_case_name + in let ctxt = { ctxt with @@ -380,17 +449,23 @@ let process_enum_decl (ctxt : context) (edecl : Ast.enum_decl) : context = | Some typ -> process_type ctxt typ in match cases with - | None -> Some (Scopelang.Ast.EnumConstructorMap.singleton c_uid typ) - | Some fields -> Some (Scopelang.Ast.EnumConstructorMap.add c_uid typ fields)) + | None -> + Some (Scopelang.Ast.EnumConstructorMap.singleton c_uid typ) + | Some fields -> + Some (Scopelang.Ast.EnumConstructorMap.add c_uid typ fields)) ctxt.enums; }) ctxt edecl.enum_decl_cases (** Process the names of all declaration items *) -let process_name_item (ctxt : context) (item : Ast.code_item Pos.marked) : context = +let process_name_item (ctxt : context) (item : Ast.code_item Pos.marked) : + context = let raise_already_defined_error (use : Uid.MarkedString.info) name pos msg = Errors.raise_multispanned_error - [ (Some "First definition:", Pos.get_position use); (Some "Second definition:", pos) ] + [ + (Some "First definition:", Pos.get_position use); + (Some "Second definition:", pos); + ] "%s name \"%a\" already defined" msg (Utils.Cli.format_with_style [ ANSITerminal.yellow ]) name @@ -401,12 +476,15 @@ let process_name_item (ctxt : context) (item : Ast.code_item Pos.marked) : conte (* Checks if the name is already used *) match Desugared.Ast.IdentMap.find_opt name ctxt.scope_idmap with | Some use -> - raise_already_defined_error (Scopelang.Ast.ScopeName.get_info use) name pos "scope" + raise_already_defined_error + (Scopelang.Ast.ScopeName.get_info use) + name pos "scope" | None -> let scope_uid = Scopelang.Ast.ScopeName.fresh (name, pos) in { ctxt with - scope_idmap = Desugared.Ast.IdentMap.add name scope_uid ctxt.scope_idmap; + scope_idmap = + Desugared.Ast.IdentMap.add name scope_uid ctxt.scope_idmap; scopes = Scopelang.Ast.ScopeMap.add scope_uid { @@ -421,31 +499,40 @@ let process_name_item (ctxt : context) (item : Ast.code_item Pos.marked) : conte let name, pos = sdecl.struct_decl_name in match Desugared.Ast.IdentMap.find_opt name ctxt.struct_idmap with | Some use -> - raise_already_defined_error (Scopelang.Ast.StructName.get_info use) name pos "struct" + raise_already_defined_error + (Scopelang.Ast.StructName.get_info use) + name pos "struct" | None -> let s_uid = Scopelang.Ast.StructName.fresh sdecl.struct_decl_name in { ctxt with struct_idmap = - Desugared.Ast.IdentMap.add (Pos.unmark sdecl.struct_decl_name) s_uid ctxt.struct_idmap; + Desugared.Ast.IdentMap.add + (Pos.unmark sdecl.struct_decl_name) + s_uid ctxt.struct_idmap; }) | EnumDecl edecl -> ( let name, pos = edecl.enum_decl_name in match Desugared.Ast.IdentMap.find_opt name ctxt.enum_idmap with | Some use -> - raise_already_defined_error (Scopelang.Ast.EnumName.get_info use) name pos "enum" + raise_already_defined_error + (Scopelang.Ast.EnumName.get_info use) + name pos "enum" | None -> let e_uid = Scopelang.Ast.EnumName.fresh edecl.enum_decl_name in { ctxt with enum_idmap = - Desugared.Ast.IdentMap.add (Pos.unmark edecl.enum_decl_name) e_uid ctxt.enum_idmap; + Desugared.Ast.IdentMap.add + (Pos.unmark edecl.enum_decl_name) + e_uid ctxt.enum_idmap; }) | ScopeUse _ -> ctxt (** Process a code item that is a declaration *) -let process_decl_item (ctxt : context) (item : Ast.code_item Pos.marked) : context = +let process_decl_item (ctxt : context) (item : Ast.code_item Pos.marked) : + context = match Pos.unmark item with | ScopeDecl decl -> process_scope_decl ctxt decl | StructDecl sdecl -> process_struct_decl ctxt sdecl @@ -453,24 +540,33 @@ let process_decl_item (ctxt : context) (item : Ast.code_item Pos.marked) : conte | ScopeUse _ -> ctxt (** Process a code block *) -let process_code_block (ctxt : context) (block : Ast.code_block) +let process_code_block + (ctxt : context) + (block : Ast.code_block) (process_item : context -> Ast.code_item Pos.marked -> context) : context = List.fold_left (fun ctxt decl -> process_item ctxt decl) ctxt block (** Process a law structure, only considering the code blocks *) -let rec process_law_structure (ctxt : context) (s : Ast.law_structure) +let rec process_law_structure + (ctxt : context) + (s : Ast.law_structure) (process_item : context -> Ast.code_item Pos.marked -> context) : context = match s with | Ast.LawHeading (_, children) -> - List.fold_left (fun ctxt child -> process_law_structure ctxt child process_item) ctxt children + List.fold_left + (fun ctxt child -> process_law_structure ctxt child process_item) + ctxt children | Ast.CodeBlock (block, _, _) -> process_code_block ctxt block process_item | Ast.LawInclude _ | Ast.LawText _ -> ctxt (** {1 Scope uses pass} *) -let get_def_key (name : Ast.qident) (state : Ast.ident Pos.marked option) - (scope_uid : Scopelang.Ast.ScopeName.t) (ctxt : context) (default_pos : Pos.t) : - Desugared.Ast.ScopeDef.t = +let get_def_key + (name : Ast.qident) + (state : Ast.ident Pos.marked option) + (scope_uid : Scopelang.Ast.ScopeName.t) + (ctxt : context) + (default_pos : Pos.t) : Desugared.Ast.ScopeDef.t = let scope_ctxt = Scopelang.Ast.ScopeMap.find scope_uid ctxt.scopes in match name with | [ x ] -> @@ -480,30 +576,40 @@ let get_def_key (name : Ast.qident) (state : Ast.ident Pos.marked option) ( x_uid, match state with | Some state -> ( - try Some (Desugared.Ast.IdentMap.find (Pos.unmark state) var_sig.var_sig_states_idmap) + try + Some + (Desugared.Ast.IdentMap.find (Pos.unmark state) + var_sig.var_sig_states_idmap) with Not_found -> Errors.raise_multispanned_error [ (None, Pos.get_position state); ( Some "Variable declaration:", - Pos.get_position (Desugared.Ast.ScopeVar.get_info x_uid) ); + Pos.get_position (Desugared.Ast.ScopeVar.get_info x_uid) + ); ] "This identifier is not a state declared for variable %a." Desugared.Ast.ScopeVar.format_t x_uid) | None -> - if not (Desugared.Ast.IdentMap.is_empty var_sig.var_sig_states_idmap) then + if + not + (Desugared.Ast.IdentMap.is_empty var_sig.var_sig_states_idmap) + then Errors.raise_multispanned_error [ (None, Pos.get_position x); ( Some "Variable declaration:", - Pos.get_position (Desugared.Ast.ScopeVar.get_info x_uid) ); + Pos.get_position (Desugared.Ast.ScopeVar.get_info x_uid) + ); ] - "This definition does not indicate which state has to be considered for variable \ - %a." + "This definition does not indicate which state has to be \ + considered for variable %a." Desugared.Ast.ScopeVar.format_t x_uid else None ) | [ y; x ] -> - let subscope_uid : Scopelang.Ast.SubScopeName.t = get_subscope_uid scope_uid ctxt y in + let subscope_uid : Scopelang.Ast.SubScopeName.t = + get_subscope_uid scope_uid ctxt y + in let subscope_real_uid : Scopelang.Ast.ScopeName.t = Scopelang.Ast.SubScopeMap.find subscope_uid scope_ctxt.sub_scopes in @@ -511,7 +617,8 @@ let get_def_key (name : Ast.qident) (state : Ast.ident Pos.marked option) Desugared.Ast.ScopeDef.SubScopeVar (subscope_uid, x_uid) | _ -> Errors.raise_spanned_error default_pos "Structs are not handled yet" -let process_definition (ctxt : context) (s_name : Scopelang.Ast.ScopeName.t) (d : Ast.definition) : +let process_definition + (ctxt : context) (s_name : Scopelang.Ast.ScopeName.t) (d : Ast.definition) : context = (* We update the definition context inside the big context *) { @@ -520,7 +627,9 @@ let process_definition (ctxt : context) (s_name : Scopelang.Ast.ScopeName.t) (d Scopelang.Ast.ScopeMap.update s_name (fun (s_ctxt : scope_context option) -> let def_key = - get_def_key (Pos.unmark d.definition_name) d.definition_state s_name ctxt + get_def_key + (Pos.unmark d.definition_name) + d.definition_state s_name ctxt (Pos.get_position d.definition_expr) in match s_ctxt with @@ -536,8 +645,8 @@ let process_definition (ctxt : context) (s_name : Scopelang.Ast.ScopeName.t) (d Option.fold ~none: { - (* Here, this is the first time we encounter a definition for this - definition key *) + (* Here, this is the first time we encounter a + definition for this definition key *) default_exception_rulename = None; label_idmap = Desugared.Ast.IdentMap.empty; label_groups = Desugared.Ast.LabelMap.empty; @@ -545,8 +654,8 @@ let process_definition (ctxt : context) (s_name : Scopelang.Ast.ScopeName.t) (d ~some:(fun x -> x) def_key_ctx in - (* First, we update the def key context with information about the - definition's label*) + (* First, we update the def key context with information + about the definition's label*) let def_key_ctx = match d.Ast.definition_label with | None -> def_key_ctx @@ -556,11 +665,14 @@ let process_definition (ctxt : context) (s_name : Scopelang.Ast.ScopeName.t) (d (fun existing_label -> match existing_label with | Some existing_label -> Some existing_label - | None -> Some (Desugared.Ast.LabelName.fresh label)) + | None -> + Some + (Desugared.Ast.LabelName.fresh label)) def_key_ctx.label_idmap in let label_id = - Desugared.Ast.IdentMap.find (Pos.unmark label) new_label_idmap + Desugared.Ast.IdentMap.find (Pos.unmark label) + new_label_idmap in { def_key_ctx with @@ -570,34 +682,39 @@ let process_definition (ctxt : context) (s_name : Scopelang.Ast.ScopeName.t) (d (fun group -> match group with | None -> - Some (Desugared.Ast.RuleSet.singleton d.definition_id) + Some + (Desugared.Ast.RuleSet.singleton + d.definition_id) | Some existing_group -> Some - (Desugared.Ast.RuleSet.add d.definition_id - existing_group)) + (Desugared.Ast.RuleSet.add + d.definition_id existing_group)) def_key_ctx.label_groups; } in - (* And second, we update the map of default rulenames for unlabeled - exceptions *) + (* And second, we update the map of default rulenames + for unlabeled exceptions *) let def_key_ctx = match d.Ast.definition_exception_to with - (* If this definition is an exception, it cannot be a default - definition *) - | UnlabeledException | ExceptionToLabel _ -> def_key_ctx - (* If it is not an exception, we need to distinguish between several - cases *) + (* If this definition is an exception, it cannot be a + default definition *) + | UnlabeledException | ExceptionToLabel _ -> + def_key_ctx + (* If it is not an exception, we need to distinguish + between several cases *) | NotAnException -> ( match def_key_ctx.default_exception_rulename with - (* There was already a default definition for this key. If we need it, - it is ambiguous *) + (* There was already a default definition for this + key. If we need it, it is ambiguous *) | Some old -> { def_key_ctx with default_exception_rulename = Some (Ambiguous - ([ Pos.get_position d.definition_name ] + ([ + Pos.get_position d.definition_name; + ] @ match old with | Ambiguous old -> old @@ -606,23 +723,31 @@ let process_definition (ctxt : context) (s_name : Scopelang.Ast.ScopeName.t) (d (* No definition has been set yet for this key *) | None -> ( match d.Ast.definition_label with - (* This default definition has a label. This is not allowed for - unlabeled exceptions *) + (* This default definition has a label. This + is not allowed for unlabeled exceptions *) | Some _ -> { def_key_ctx with default_exception_rulename = - Some (Ambiguous [ Pos.get_position d.definition_name ]); + Some + (Ambiguous + [ + Pos.get_position + d.definition_name; + ]); } - (* This is a possible default definition for this key. We create - and store a fresh rulename *) + (* This is a possible default definition for + this key. We create and store a fresh + rulename *) | None -> { def_key_ctx with default_exception_rulename = Some (Unique - (d.definition_id, Pos.get_position d.definition_name)); + ( d.definition_id, + Pos.get_position + d.definition_name )); })) in Some def_key_ctx) @@ -631,7 +756,9 @@ let process_definition (ctxt : context) (s_name : Scopelang.Ast.ScopeName.t) (d ctxt.scopes; } -let process_scope_use_item (s_name : Scopelang.Ast.ScopeName.t) (ctxt : context) +let process_scope_use_item + (s_name : Scopelang.Ast.ScopeName.t) + (ctxt : context) (sitem : Ast.scope_use_item Pos.marked) : context = match Pos.unmark sitem with | Rule r -> process_definition ctxt s_name (Ast.rule_to_def r) @@ -640,7 +767,10 @@ let process_scope_use_item (s_name : Scopelang.Ast.ScopeName.t) (ctxt : context) let process_scope_use (ctxt : context) (suse : Ast.scope_use) : context = let s_name = - try Desugared.Ast.IdentMap.find (Pos.unmark suse.Ast.scope_use_name) ctxt.scope_idmap + try + Desugared.Ast.IdentMap.find + (Pos.unmark suse.Ast.scope_use_name) + ctxt.scope_idmap with Not_found -> Errors.raise_spanned_error (Pos.get_position suse.Ast.scope_use_name) @@ -650,7 +780,8 @@ let process_scope_use (ctxt : context) (suse : Ast.scope_use) : context = in List.fold_left (process_scope_use_item s_name) ctxt suse.Ast.scope_use_items -let process_use_item (ctxt : context) (item : Ast.code_item Pos.marked) : context = +let process_use_item (ctxt : context) (item : Ast.code_item Pos.marked) : + context = match Pos.unmark item with | ScopeDecl _ | StructDecl _ | EnumDecl _ -> ctxt | ScopeUse suse -> process_scope_use ctxt suse diff --git a/compiler/surface/name_resolution.mli b/compiler/surface/name_resolution.mli index 82542939..4dd8d9a5 100644 --- a/compiler/surface/name_resolution.mli +++ b/compiler/surface/name_resolution.mli @@ -1,29 +1,33 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020 Inria, contributor: Nicolas Chataing - Denis Merigoux +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, contributor: + Nicolas Chataing Denis Merigoux + - 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 + 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 + 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. *) -(** Builds a context that allows for mapping each name to a precise uid, taking lexical scopes into - account *) +(** Builds a context that allows for mapping each name to a precise uid, taking + lexical scopes into account *) open Utils (** {1 Name resolution context} *) type ident = string - type typ = Scopelang.Ast.typ -type unique_rulename = Ambiguous of Pos.t list | Unique of Desugared.Ast.RuleName.t Pos.marked +type unique_rulename = + | Ambiguous of Pos.t list + | Unique of Desugared.Ast.RuleName.t Pos.marked type scope_def_context = { default_exception_rulename : unique_rulename option; @@ -32,7 +36,8 @@ type scope_def_context = { } type scope_context = { - var_idmap : Desugared.Ast.ScopeVar.t Desugared.Ast.IdentMap.t; (** Scope variables *) + var_idmap : Desugared.Ast.ScopeVar.t Desugared.Ast.IdentMap.t; + (** Scope variables *) scope_defs_contexts : scope_def_context Desugared.Ast.ScopeDefMap.t; (** What is the default rule to refer to for unnamed exceptions, if any *) sub_scopes_idmap : Scopelang.Ast.SubScopeName.t Desugared.Ast.IdentMap.t; @@ -58,21 +63,30 @@ type var_sig = { type context = { local_var_idmap : Desugared.Ast.Var.t Desugared.Ast.IdentMap.t; - (** Inside a definition, local variables can be introduced by functions arguments or pattern - matching *) - scope_idmap : Scopelang.Ast.ScopeName.t Desugared.Ast.IdentMap.t; (** The names of the scopes *) + (** Inside a definition, local variables can be introduced by functions + arguments or pattern matching *) + scope_idmap : Scopelang.Ast.ScopeName.t Desugared.Ast.IdentMap.t; + (** The names of the scopes *) struct_idmap : Scopelang.Ast.StructName.t Desugared.Ast.IdentMap.t; (** The names of the structs *) - field_idmap : Scopelang.Ast.StructFieldName.t Scopelang.Ast.StructMap.t Desugared.Ast.IdentMap.t; - (** The names of the struct fields. Names of fields can be shared between different structs *) - enum_idmap : Scopelang.Ast.EnumName.t Desugared.Ast.IdentMap.t; (** The names of the enums *) + field_idmap : + Scopelang.Ast.StructFieldName.t Scopelang.Ast.StructMap.t + Desugared.Ast.IdentMap.t; + (** The names of the struct fields. Names of fields can be shared between + different structs *) + enum_idmap : Scopelang.Ast.EnumName.t Desugared.Ast.IdentMap.t; + (** The names of the enums *) constructor_idmap : - Scopelang.Ast.EnumConstructor.t Scopelang.Ast.EnumMap.t Desugared.Ast.IdentMap.t; - (** The names of the enum constructors. Constructor names can be shared between different - enums *) - scopes : scope_context Scopelang.Ast.ScopeMap.t; (** For each scope, its context *) - structs : struct_context Scopelang.Ast.StructMap.t; (** For each struct, its context *) - enums : enum_context Scopelang.Ast.EnumMap.t; (** For each enum, its context *) + Scopelang.Ast.EnumConstructor.t Scopelang.Ast.EnumMap.t + Desugared.Ast.IdentMap.t; + (** The names of the enum constructors. Constructor names can be shared + between different enums *) + scopes : scope_context Scopelang.Ast.ScopeMap.t; + (** For each scope, its context *) + structs : struct_context Scopelang.Ast.StructMap.t; + (** For each struct, its context *) + enums : enum_context Scopelang.Ast.EnumMap.t; + (** For each enum, its context *) var_typs : var_sig Desugared.Ast.ScopeVarMap.t; (** The signatures of each scope variable declared *) } @@ -81,31 +95,41 @@ type context = { (** {1 Helpers} *) val raise_unsupported_feature : string -> Pos.t -> 'a -(** Temporary function raising an error message saying that a feature is not supported yet *) +(** Temporary function raising an error message saying that a feature is not + supported yet *) val raise_unknown_identifier : string -> ident Pos.marked -> 'a -(** Function to call whenever an identifier used somewhere has not been declared in the program - previously *) +(** Function to call whenever an identifier used somewhere has not been declared + in the program previously *) val get_var_typ : context -> Desugared.Ast.ScopeVar.t -> typ Pos.marked (** Gets the type associated to an uid *) val is_var_cond : context -> Desugared.Ast.ScopeVar.t -> bool -val get_var_io : context -> Desugared.Ast.ScopeVar.t -> Ast.scope_decl_context_io +val get_var_io : + context -> Desugared.Ast.ScopeVar.t -> Ast.scope_decl_context_io val get_var_uid : - Scopelang.Ast.ScopeName.t -> context -> ident Pos.marked -> Desugared.Ast.ScopeVar.t + Scopelang.Ast.ScopeName.t -> + context -> + ident Pos.marked -> + Desugared.Ast.ScopeVar.t (** Get the variable uid inside the scope given in argument *) val get_subscope_uid : - Scopelang.Ast.ScopeName.t -> context -> ident Pos.marked -> Scopelang.Ast.SubScopeName.t + Scopelang.Ast.ScopeName.t -> + context -> + ident Pos.marked -> + Scopelang.Ast.SubScopeName.t (** Get the subscope uid inside the scope given in argument *) val is_subscope_uid : Scopelang.Ast.ScopeName.t -> context -> ident -> bool -(** [is_subscope_uid scope_uid ctxt y] returns true if [y] belongs to the subscopes of [scope_uid]. *) +(** [is_subscope_uid scope_uid ctxt y] returns true if [y] belongs to the + subscopes of [scope_uid]. *) -val belongs_to : context -> Desugared.Ast.ScopeVar.t -> Scopelang.Ast.ScopeName.t -> bool +val belongs_to : + context -> Desugared.Ast.ScopeVar.t -> Scopelang.Ast.ScopeName.t -> bool (** Checks if the var_uid belongs to the scope scope_uid *) val get_def_typ : context -> Desugared.Ast.ScopeDef.t -> typ Pos.marked @@ -121,7 +145,8 @@ val label_groups : val is_type_cond : Ast.typ Pos.marked -> bool -val add_def_local_var : context -> ident Pos.marked -> context * Desugared.Ast.Var.t +val add_def_local_var : + context -> ident Pos.marked -> context * Desugared.Ast.Var.t (** Adds a binding to the context *) val get_def_key : diff --git a/compiler/surface/parse_utils.ml b/compiler/surface/parse_utils.ml index f6952b5a..408b1cea 100644 --- a/compiler/surface/parse_utils.ml +++ b/compiler/surface/parse_utils.ml @@ -1,15 +1,17 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux - +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, contributor: + Denis Merigoux - 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 + 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 + 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. *) (** Helpers for parsing *) diff --git a/compiler/surface/parse_utils.mli b/compiler/surface/parse_utils.mli index f3a15f1a..4f24dbcc 100644 --- a/compiler/surface/parse_utils.mli +++ b/compiler/surface/parse_utils.mli @@ -1,15 +1,17 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux - +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, contributor: + Denis Merigoux - 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 + 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 + 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. *) (** Helpers for parsing *) diff --git a/compiler/surface/parser_driver.ml b/compiler/surface/parser_driver.ml index 6678b5e6..3787db07 100644 --- a/compiler/surface/parser_driver.ml +++ b/compiler/surface/parser_driver.ml @@ -1,19 +1,22 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020 Inria, contributors: Denis Merigoux - , Emile Rolley +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, + contributors: Denis Merigoux , Emile Rolley + - 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 + 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 + 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. *) -(** Wrapping module around parser and lexer that offers the {!: Parser_driver.parse_source_file} - API. *) +(** Wrapping module around parser and lexer that offers the {!: + Parser_driver.parse_source_file} API. *) open Sedlexing open Utils @@ -23,24 +26,27 @@ open Utils (** Three-way minimum *) let minimum a b c = min a (min b c) -(** Computes the levenshtein distance between two strings, used to provide error messages - suggestions *) +(** Computes the levenshtein distance between two strings, used to provide error + messages suggestions *) let levenshtein_distance (s : string) (t : string) : int = let m = String.length s and n = String.length t in - (* for all i and j, d.(i).(j) will hold the Levenshtein distance between the first i characters of - s and the first j characters of t *) + (* for all i and j, d.(i).(j) will hold the Levenshtein distance between the + first i characters of s and the first j characters of t *) let d = Array.make_matrix (m + 1) (n + 1) 0 in for i = 0 to m do - d.(i).(0) <- i (* the distance of any first string to an empty second string *) + d.(i).(0) <- i + (* the distance of any first string to an empty second string *) done; for j = 0 to n do - d.(0).(j) <- j (* the distance of any second string to an empty first string *) + d.(0).(j) <- j + (* the distance of any second string to an empty first string *) done; for j = 1 to n do for i = 1 to m do - if s.[i - 1] = t.[j - 1] then d.(i).(j) <- d.(i - 1).(j - 1) (* no operation required *) + if s.[i - 1] = t.[j - 1] then d.(i).(j) <- d.(i - 1).(j - 1) + (* no operation required *) else d.(i).(j) <- minimum @@ -52,9 +58,11 @@ let levenshtein_distance (s : string) (t : string) : int = d.(m).(n) -(** After parsing, heading structure is completely flat because of the [source_file_item] rule. We - need to tree-i-fy the flat structure, by looking at the precedence of the law headings. *) -let rec law_struct_list_to_tree (f : Ast.law_structure list) : Ast.law_structure list = +(** After parsing, heading structure is completely flat because of the + [source_file_item] rule. We need to tree-i-fy the flat structure, by looking + at the precedence of the law headings. *) +let rec law_struct_list_to_tree (f : Ast.law_structure list) : + Ast.law_structure list = match f with | [] -> [] | [ item ] -> [ item ] @@ -65,18 +73,20 @@ let rec law_struct_list_to_tree (f : Ast.law_structure list) : Ast.law_structure | rest_head :: rest_tail -> ( match first_item with | CodeBlock _ | LawText _ | LawInclude _ -> - (* if an article or an include is just before a new heading , then we don't merge it - with what comes next *) + (* if an article or an include is just before a new heading , then + we don't merge it with what comes next *) first_item :: rest_head :: rest_tail | LawHeading (heading, _) -> - (* here we have encountered a heading, which is going to "gobble" everything in the - [rest_tree] until it finds a heading of at least the same precedence *) + (* here we have encountered a heading, which is going to "gobble" + everything in the [rest_tree] until it finds a heading of at + least the same precedence *) let rec split_rest_tree (rest_tree : Ast.law_structure list) : Ast.law_structure list * Ast.law_structure list = match rest_tree with | [] -> ([], []) | LawHeading (new_heading, _) :: _ - when new_heading.law_heading_precedence <= heading.law_heading_precedence -> + when new_heading.law_heading_precedence + <= heading.law_heading_precedence -> (* we stop gobbling *) ([], rest_tree) | first :: after -> @@ -92,10 +102,14 @@ let syntax_hints_style = [ ANSITerminal.yellow ] (** Usage: [raise_parser_error error_loc last_good_loc token msg] - Raises an error message featuring the [error_loc] position where the parser has failed, the - [token] on which the parser has failed, and the error message [msg]. If available, displays - [last_good_loc] the location of the last token correctly parsed. *) -let raise_parser_error (error_loc : Pos.t) (last_good_loc : Pos.t option) (token : string) + Raises an error message featuring the [error_loc] position where the parser + has failed, the [token] on which the parser has failed, and the error + message [msg]. If available, displays [last_good_loc] the location of the + last token correctly parsed. *) +let raise_parser_error + (error_loc : Pos.t) + (last_good_loc : Pos.t option) + (token : string) (msg : string) : 'a = Errors.raise_multispanned_error ((Some "Error token:", error_loc) @@ -105,7 +119,8 @@ let raise_parser_error (error_loc : Pos.t) (last_good_loc : Pos.t option) (token | Some last_good_loc -> [ (Some "Last good token:", last_good_loc) ])) "Syntax error at token %a\n%s" (Cli.format_with_style syntax_hints_style) - (Printf.sprintf "\"%s\"" token) msg + (Printf.sprintf "\"%s\"" token) + msg module ParserAux (LocalisedLexer : Lexer_common.LocalisedLexer) = struct include Parser.Make (LocalisedLexer) @@ -119,21 +134,28 @@ module ParserAux (LocalisedLexer : Lexer_common.LocalisedLexer) = struct (** Usage: [fail lexbuf env token_list last_input_needed] - Raises an error with meaningful hints about what the parsing error was. [lexbuf] is the lexing - buffer state at the failure point, [env] is the Menhir environment and [last_input_needed] is - the last checkpoint of a valid Menhir state before the parsing error. [token_list] is provided - by things like {!val: Surface.Lexer_common.token_list_language_agnostic} and is used to - provide suggestions of the tokens acceptable at the failure point *) - let fail (lexbuf : lexbuf) (env : 'semantic_value I.env) - (token_list : (string * Tokens.token) list) (last_input_needed : 'semantic_value I.env option) - : 'a = + Raises an error with meaningful hints about what the parsing error was. + [lexbuf] is the lexing buffer state at the failure point, [env] is the + Menhir environment and [last_input_needed] is the last checkpoint of a + valid Menhir state before the parsing error. [token_list] is provided by + things like {!val: Surface.Lexer_common.token_list_language_agnostic} and + is used to provide suggestions of the tokens acceptable at the failure + point *) + let fail + (lexbuf : lexbuf) + (env : 'semantic_value I.env) + (token_list : (string * Tokens.token) list) + (last_input_needed : 'semantic_value I.env option) : 'a = let wrong_token = Utf8.lexeme lexbuf in let acceptable_tokens, last_positions = match last_input_needed with | Some last_input_needed -> ( List.filter (fun (_, t) -> - I.acceptable (I.input_needed last_input_needed) t (fst (lexing_positions lexbuf))) + I.acceptable + (I.input_needed last_input_needed) + t + (fst (lexing_positions lexbuf))) token_list, Some (I.positions last_input_needed) ) | None -> (token_list, None) @@ -163,23 +185,27 @@ module ParserAux (LocalisedLexer : Lexer_common.LocalisedLexer) = struct (Printf.sprintf "did you mean %s?" (String.concat ", or maybe " (List.map - (fun (ts, _) -> Cli.with_style syntax_hints_style "\"%s\"" ts) + (fun (ts, _) -> + Cli.with_style syntax_hints_style "\"%s\"" ts) similar_acceptable_tokens))) in (* The parser has suspended itself because of a syntax error. Stop. *) let custom_menhir_message = match Parser_errors.message (state env) with | exception Not_found -> - "Message: " ^ Cli.with_style syntax_hints_style "%s" "unexpected token" + "Message: " + ^ Cli.with_style syntax_hints_style "%s" "unexpected token" | msg -> "Message: " - ^ Cli.with_style syntax_hints_style "%s" (String.trim (String.uncapitalize_ascii msg)) + ^ Cli.with_style syntax_hints_style "%s" + (String.trim (String.uncapitalize_ascii msg)) in let msg = match similar_token_msg with | None -> custom_menhir_message | Some similar_token_msg -> - Printf.sprintf "%s\nAutosuggestion: %s" custom_menhir_message similar_token_msg + Printf.sprintf "%s\nAutosuggestion: %s" custom_menhir_message + similar_token_msg in raise_parser_error (Pos.from_lpos (lexing_positions lexbuf)) @@ -187,10 +213,12 @@ module ParserAux (LocalisedLexer : Lexer_common.LocalisedLexer) = struct (Utf8.lexeme lexbuf) msg (** Main parsing loop *) - let rec loop (next_token : unit -> Tokens.token * Lexing.position * Lexing.position) - (token_list : (string * Tokens.token) list) (lexbuf : lexbuf) - (last_input_needed : 'semantic_value I.env option) (checkpoint : 'semantic_value I.checkpoint) - : Ast.source_file = + let rec loop + (next_token : unit -> Tokens.token * Lexing.position * Lexing.position) + (token_list : (string * Tokens.token) list) + (lexbuf : lexbuf) + (last_input_needed : 'semantic_value I.env option) + (checkpoint : 'semantic_value I.checkpoint) : Ast.source_file = match checkpoint with | I.InputNeeded env -> let token = next_token () in @@ -205,21 +233,27 @@ module ParserAux (LocalisedLexer : Lexer_common.LocalisedLexer) = struct (* Cannot happen as we stop at syntax error immediatly *) assert false - (** Stub that wraps the parsing main loop and handles the Menhir/Sedlex type difference for - [lexbuf]. *) - let sedlex_with_menhir (lexer' : lexbuf -> Tokens.token) + (** Stub that wraps the parsing main loop and handles the Menhir/Sedlex type + difference for [lexbuf]. *) + let sedlex_with_menhir + (lexer' : lexbuf -> Tokens.token) (token_list : (string * Tokens.token) list) - (target_rule : Lexing.position -> 'semantic_value I.checkpoint) (lexbuf : lexbuf) : - Ast.source_file = + (target_rule : Lexing.position -> 'semantic_value I.checkpoint) + (lexbuf : lexbuf) : Ast.source_file = let lexer : unit -> Tokens.token * Lexing.position * Lexing.position = with_tokenizer lexer' lexbuf in - try loop lexer token_list lexbuf None (target_rule (fst @@ Sedlexing.lexing_positions lexbuf)) + try + loop lexer token_list lexbuf None + (target_rule (fst @@ Sedlexing.lexing_positions lexbuf)) with Sedlexing.MalFormed | Sedlexing.InvalidCodepoint _ -> - Lexer_common.raise_lexer_error (Pos.from_lpos (lexing_positions lexbuf)) (Utf8.lexeme lexbuf) + Lexer_common.raise_lexer_error + (Pos.from_lpos (lexing_positions lexbuf)) + (Utf8.lexeme lexbuf) let commands_or_includes (lexbuf : lexbuf) : Ast.source_file = - sedlex_with_menhir LocalisedLexer.lexer LocalisedLexer.token_list Incremental.source_file lexbuf + sedlex_with_menhir LocalisedLexer.lexer LocalisedLexer.token_list + Incremental.source_file lexbuf end module Parser_En = ParserAux (Lexer_en) @@ -234,9 +268,10 @@ let localised_parser : Cli.backend_lang -> lexbuf -> Ast.source_file = function (** {1 Parsing multiple files} *) (** Parses a single source file *) -let rec parse_source_file (source_file : Pos.input_file) (language : Cli.backend_lang) : Ast.program - = - Cli.debug_print "Parsing %s" (match source_file with FileName s | Contents s -> s); +let rec parse_source_file + (source_file : Pos.input_file) (language : Cli.backend_lang) : Ast.program = + Cli.debug_print "Parsing %s" + (match source_file with FileName s | Contents s -> s); let lexbuf, input = match source_file with | FileName source_file -> ( @@ -246,7 +281,9 @@ let rec parse_source_file (source_file : Pos.input_file) (language : Cli.backend with Sys_error msg -> Errors.raise_error "%s" msg) | Contents contents -> (Sedlexing.Utf8.from_string contents, None) in - let source_file_name = match source_file with FileName s -> s | Contents _ -> "stdin" in + let source_file_name = + match source_file with FileName s -> s | Contents _ -> "stdin" + in Sedlexing.set_filename lexbuf source_file_name; Parse_utils.current_file := source_file_name; let commands = localised_parser language lexbuf in @@ -257,8 +294,11 @@ let rec parse_source_file (source_file : Pos.input_file) (language : Cli.backend program_source_files = source_file_name :: program.Ast.program_source_files; } -(** Expands the include directives in a parsing result, thus parsing new source files *) -and expand_includes (source_file : string) (commands : Ast.law_structure list) +(** Expands the include directives in a parsing result, thus parsing new source + files *) +and expand_includes + (source_file : string) + (commands : Ast.law_structure list) (language : Cli.backend_lang) : Ast.program = List.fold_left (fun acc command -> @@ -266,19 +306,27 @@ and expand_includes (source_file : string) (commands : Ast.law_structure list) | Ast.LawInclude (Ast.CatalaFile sub_source) -> let source_dir = Filename.dirname source_file in let sub_source = Filename.concat source_dir (Pos.unmark sub_source) in - let includ_program = parse_source_file (FileName sub_source) language in + let includ_program = + parse_source_file (FileName sub_source) language + in { Ast.program_source_files = acc.Ast.program_source_files @ includ_program.program_source_files; - Ast.program_items = acc.Ast.program_items @ includ_program.program_items; + Ast.program_items = + acc.Ast.program_items @ includ_program.program_items; } | Ast.LawHeading (heading, commands') -> - let { Ast.program_items = commands'; Ast.program_source_files = new_sources } = + let { + Ast.program_items = commands'; + Ast.program_source_files = new_sources; + } = expand_includes source_file commands' language in { - Ast.program_source_files = acc.Ast.program_source_files @ new_sources; - Ast.program_items = acc.Ast.program_items @ [ Ast.LawHeading (heading, commands') ]; + Ast.program_source_files = + acc.Ast.program_source_files @ new_sources; + Ast.program_items = + acc.Ast.program_items @ [ Ast.LawHeading (heading, commands') ]; } | i -> { acc with Ast.program_items = acc.Ast.program_items @ [ i ] }) { Ast.program_source_files = []; Ast.program_items = [] } @@ -286,7 +334,10 @@ and expand_includes (source_file : string) (commands : Ast.law_structure list) (** {1 API} *) -let parse_top_level_file (source_file : Pos.input_file) (language : Cli.backend_lang) : Ast.program - = +let parse_top_level_file + (source_file : Pos.input_file) (language : Cli.backend_lang) : Ast.program = let program = parse_source_file source_file language in - { program with Ast.program_items = law_struct_list_to_tree program.Ast.program_items } + { + program with + Ast.program_items = law_struct_list_to_tree program.Ast.program_items; + } diff --git a/compiler/surface/parser_driver.mli b/compiler/surface/parser_driver.mli index 618c473b..922e487e 100644 --- a/compiler/surface/parser_driver.mli +++ b/compiler/surface/parser_driver.mli @@ -1,15 +1,17 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux - +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, contributor: + Denis Merigoux - 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 + 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 + 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. *) (** Wrapping module around parser and lexer that offers the diff --git a/compiler/surface/parser_errors.mli b/compiler/surface/parser_errors.mli index d3cd0f1a..367e94bb 100644 --- a/compiler/surface/parser_errors.mli +++ b/compiler/surface/parser_errors.mli @@ -1,15 +1,17 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux - +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, contributor: + Denis Merigoux - 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 + 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 + 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. *) (** Interface of the module auto-generated based on "parser.messages". *) diff --git a/compiler/surface/print.ml b/compiler/surface/print.ml index 5e7751b4..50a8d183 100644 --- a/compiler/surface/print.ml +++ b/compiler/surface/print.ml @@ -1,15 +1,17 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux - +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, contributor: + Denis Merigoux - 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 + 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 + 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. *) open Ast diff --git a/compiler/surface/print.mli b/compiler/surface/print.mli index 9af37cb3..0f94d48f 100644 --- a/compiler/surface/print.mli +++ b/compiler/surface/print.mli @@ -1,15 +1,17 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux - +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, contributor: + Denis Merigoux - 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 + 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 + 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. *) val format_primitive_typ : Format.formatter -> Ast.primitive_typ -> unit diff --git a/compiler/utils/cli.ml b/compiler/utils/cli.ml index 9c143088..fef4c457 100644 --- a/compiler/utils/cli.ml +++ b/compiler/utils/cli.ml @@ -1,15 +1,18 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020 Inria, contributors: Denis Merigoux - , Emile Rolley +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, + contributors: Denis Merigoux , Emile Rolley + - 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 + 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 + 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. *) type backend_lang = En | Fr | Pl @@ -18,7 +21,6 @@ type backend_lang = En | Fr | Pl let source_files : string list ref = ref [] let locale_lang : backend_lang ref = ref En - let contents : string ref = ref "" (** Prints debug information *) @@ -29,13 +31,9 @@ let style_flag = ref true (* Max number of digits to show for decimal results *) let max_prec_digits = ref 20 - let trace_flag = ref false - let optimize_flag = ref false - let disable_counterexamples = ref false - let avoid_exceptions_flag = ref false open Cmdliner @@ -46,39 +44,46 @@ let file = & pos 1 (some file) None & info [] ~docv:"FILE" ~doc:"Catala master file to be compiled.") -let debug = Arg.(value & flag & info [ "debug"; "d" ] ~doc:"Prints debug information.") +let debug = + Arg.(value & flag & info [ "debug"; "d" ] ~doc:"Prints debug information.") let unstyled = Arg.( value & flag - & info [ "unstyled"; "u" ] ~doc:"Removes styling (colors, etc.) from terminal output.") + & info [ "unstyled"; "u" ] + ~doc:"Removes styling (colors, etc.) from terminal output.") -let optimize = Arg.(value & flag & info [ "optimize"; "O" ] ~doc:"Run compiler optimizations.") +let optimize = + Arg.( + value & flag & info [ "optimize"; "O" ] ~doc:"Run compiler optimizations.") let trace_opt = Arg.( value & flag & info [ "trace"; "t" ] ~doc: - "Displays a trace of the interpreter's computation or generates logging instructions in \ - translate programs.") + "Displays a trace of the interpreter's computation or generates \ + logging instructions in translate programs.") let avoid_exceptions = Arg.( value & flag - & info [ "avoid_exceptions" ] ~doc:"Compiles the default calculus without exceptions") + & info [ "avoid_exceptions" ] + ~doc:"Compiles the default calculus without exceptions") let wrap_weaved_output = Arg.( value & flag - & info [ "wrap"; "w" ] ~doc:"Wraps literate programming output with a minimal preamble.") + & info [ "wrap"; "w" ] + ~doc:"Wraps literate programming output with a minimal preamble.") let backend = Arg.( required & pos 0 (some string) None & info [] ~docv:"COMMAND" - ~doc:"Backend selection (see the list of commands for available options).") + ~doc: + "Backend selection (see the list of commands for available options).") type backend_option = | Dcalc @@ -98,23 +103,29 @@ let language = Arg.( value & opt (some string) None - & info [ "l"; "language" ] ~docv:"LANG" ~doc:"Input language among: en, fr, pl.") + & info [ "l"; "language" ] ~docv:"LANG" + ~doc:"Input language among: en, fr, pl.") let max_prec_digits_opt = Arg.( value & opt (some int) None - & info [ "p"; "max_digits_printed" ] ~docv:"DIGITS" - ~doc:"Maximum number of significant digits printed for decimal results (default 20).") + & info + [ "p"; "max_digits_printed" ] + ~docv:"DIGITS" + ~doc: + "Maximum number of significant digits printed for decimal results \ + (default 20).") let disable_counterexamples_opt = Arg.( value & flag - & info [ "disable_counterexamples" ] + & info + [ "disable_counterexamples" ] ~doc: - "Disables the search for counterexamples in proof mode. Useful when you want a \ - deterministic output from the Catala compiler, since provers can have some randomness \ - in them.") + "Disables the search for counterexamples in proof mode. Useful when \ + you want a deterministic output from the Catala compiler, since \ + provers can have some randomness in them.") let ex_scope = Arg.( @@ -128,8 +139,9 @@ let output = & opt (some string) None & info [ "output"; "o" ] ~docv:"OUTPUT" ~doc: - "$(i, OUTPUT) is the file that will contain the output of the compiler. Defaults to \ - $(i,FILE).$(i,EXT) where $(i,EXT) depends on the chosen backend.") + "$(i, OUTPUT) is the file that will contain the output of the \ + compiler. Defaults to $(i,FILE).$(i,EXT) where $(i,EXT) depends on \ + the chosen backend.") type options = { debug : bool; @@ -147,8 +159,19 @@ type options = { } let options = - let make debug unstyled wrap_weaved_output avoid_exceptions backend language max_prec_digits trace - disable_counterexamples optimize ex_scope output_file : options = + let make + debug + unstyled + wrap_weaved_output + avoid_exceptions + backend + language + max_prec_digits + trace + disable_counterexamples + optimize + ex_scope + output_file : options = { debug; unstyled; @@ -165,8 +188,9 @@ let options = } in Term.( - const make $ debug $ unstyled $ wrap_weaved_output $ avoid_exceptions $ backend $ language - $ max_prec_digits_opt $ trace_opt $ disable_counterexamples_opt $ optimize $ ex_scope $ output) + const make $ debug $ unstyled $ wrap_weaved_output $ avoid_exceptions + $ backend $ language $ max_prec_digits_opt $ trace_opt + $ disable_counterexamples_opt $ optimize $ ex_scope $ output) let catala_t f = Term.(const f $ file $ options) @@ -182,48 +206,60 @@ let version = "0.5.0" let info = let doc = - "Compiler for Catala, a specification language for tax and social benefits computation rules." + "Compiler for Catala, a specification language for tax and social benefits \ + computation rules." in let man = [ `S Manpage.s_description; `P - "Catala is a domain-specific language for deriving faithful-by-construction algorithms \ - from legislative texts."; + "Catala is a domain-specific language for deriving \ + faithful-by-construction algorithms from legislative texts."; `S Manpage.s_commands; `I ( "$(b,Intepret)", - "Runs the interpreter on the Catala program, executing the scope specified by the \ - $(b,-s) option assuming no additional external inputs." ); - `I ("$(b,Typecheck)", "Parses and typechecks a Catala program, without interpreting it."); + "Runs the interpreter on the Catala program, executing the scope \ + specified by the $(b,-s) option assuming no additional external \ + inputs." ); + `I + ( "$(b,Typecheck)", + "Parses and typechecks a Catala program, without interpreting it." ); `I ( "$(b,Proof)", - "Generates and proves verification conditions about the well-behaved execution of the \ - Catala program." ); + "Generates and proves verification conditions about the well-behaved \ + execution of the Catala program." ); `I ("$(b,OCaml)", "Generates an OCaml translation of the Catala program."); `I ("$(b,Python)", "Generates a Python translation of the Catala program."); - `I ("$(b,LaTeX)", "Weaves a LaTeX literate programming output of the Catala program."); - `I ("$(b,HTML)", "Weaves an HTML literate programming output of the Catala program."); + `I + ( "$(b,LaTeX)", + "Weaves a LaTeX literate programming output of the Catala program." ); + `I + ( "$(b,HTML)", + "Weaves an HTML literate programming output of the Catala program." ); `I ( "$(b,Makefile)", - "Generates a Makefile-compatible list of the file dependencies of a Catala program." ); + "Generates a Makefile-compatible list of the file dependencies of a \ + Catala program." ); `I ( "$(b,Scopelang)", - "Prints a debugging verbatim of the scope language intermediate representation of the \ - Catala program. Use the $(b,-s) option to restrict the output to a particular scope." ); + "Prints a debugging verbatim of the scope language intermediate \ + representation of the Catala program. Use the $(b,-s) option to \ + restrict the output to a particular scope." ); `I ( "$(b,Dcalc)", - "Prints a debugging verbatim of the default calculus intermediate representation of the \ - Catala program. Use the $(b,-s) option to restrict the output to a particular scope." ); + "Prints a debugging verbatim of the default calculus intermediate \ + representation of the Catala program. Use the $(b,-s) option to \ + restrict the output to a particular scope." ); `I ( "$(b,Lcalc)", - "Prints a debugging verbatim of the lambda calculus intermediate representation of the \ - Catala program. Use the $(b,-s) option to restrict the output to a particular scope." ); + "Prints a debugging verbatim of the lambda calculus intermediate \ + representation of the Catala program. Use the $(b,-s) option to \ + restrict the output to a particular scope." ); `I ( "$(b,Scalc)", - "Prints a debugging verbatim of the statement calculus intermediate representation of \ - the Catala program. Use the $(b,-s) option to restrict the output to a particular \ - scope." ); + "Prints a debugging verbatim of the statement calculus intermediate \ + representation of the Catala program. Use the $(b,-s) option to \ + restrict the output to a particular scope." ); `S Manpage.s_authors; `P "The authors are listed by alphabetical order."; `P "Nicolas Chataing "; @@ -236,7 +272,8 @@ let info = `Pre "catala Interpret -s Foo file.catala_en"; `Pre "catala Ocaml -o target/file.ml file.catala_en"; `S Manpage.s_bugs; - `P "Please file bug reports at https://github.com/CatalaLang/catala/issues"; + `P + "Please file bug reports at https://github.com/CatalaLang/catala/issues"; ] in let exits = Term.default_exits @ [ Term.exit_info ~doc:"on error." 1 ] in @@ -248,12 +285,14 @@ let info = let time : float ref = ref (Unix.gettimeofday ()) -let with_style (styles : ANSITerminal.style list) (str : ('a, unit, string) format) = +let with_style + (styles : ANSITerminal.style list) (str : ('a, unit, string) format) = if !style_flag then ANSITerminal.sprintf styles str else Printf.sprintf str let format_with_style (styles : ANSITerminal.style list) fmt (str : string) = if !style_flag then - Format.pp_print_as fmt (String.length str) (ANSITerminal.sprintf styles "%s" str) + Format.pp_print_as fmt (String.length str) + (ANSITerminal.sprintf styles "%s" str) else Format.pp_print_string fmt str let time_marker () = @@ -263,7 +302,9 @@ let time_marker () = let delta = (new_time -. old_time) *. 1000. in if delta > 50. then Printf.printf "%s" - (with_style [ ANSITerminal.Bold; ANSITerminal.black ] "[TIME] %.0f ms\n" delta) + (with_style + [ ANSITerminal.Bold; ANSITerminal.black ] + "[TIME] %.0f ms\n" delta) (** Prints [\[DEBUG\]] in purple on the terminal standard output *) let debug_marker () = @@ -271,29 +312,35 @@ let debug_marker () = with_style [ ANSITerminal.Bold; ANSITerminal.magenta ] "[DEBUG] " (** Prints [\[ERROR\]] in red on the terminal error output *) -let error_marker () = with_style [ ANSITerminal.Bold; ANSITerminal.red ] "[ERROR] " +let error_marker () = + with_style [ ANSITerminal.Bold; ANSITerminal.red ] "[ERROR] " (** Prints [\[WARNING\]] in yellow on the terminal standard output *) -let warning_marker () = with_style [ ANSITerminal.Bold; ANSITerminal.yellow ] "[WARNING] " +let warning_marker () = + with_style [ ANSITerminal.Bold; ANSITerminal.yellow ] "[WARNING] " (** Prints [\[RESULT\]] in green on the terminal standard output *) -let result_marker () = with_style [ ANSITerminal.Bold; ANSITerminal.green ] "[RESULT] " +let result_marker () = + with_style [ ANSITerminal.Bold; ANSITerminal.green ] "[RESULT] " (** Prints [\[LOG\]] in red on the terminal error output *) -let log_marker () = with_style [ ANSITerminal.Bold; ANSITerminal.black ] "[LOG] " +let log_marker () = + with_style [ ANSITerminal.Bold; ANSITerminal.black ] "[LOG] " (**{2 Printers}*) (** All the printers below print their argument after the correct marker *) -let concat_with_line_depending_prefix_and_suffix (prefix : int -> string) (suffix : int -> string) - (ss : string list) = +let concat_with_line_depending_prefix_and_suffix + (prefix : int -> string) (suffix : int -> string) (ss : string list) = match ss with | hd :: rest -> let out, _ = List.fold_left (fun (acc, i) s -> - ((acc ^ prefix i ^ s ^ if i = List.length ss - 1 then "" else suffix i), i + 1)) + ( (acc ^ prefix i ^ s + ^ if i = List.length ss - 1 then "" else suffix i), + i + 1 )) ((prefix 0 ^ hd ^ if 0 = List.length ss - 1 then "" else suffix 0), 1) rest in @@ -312,7 +359,8 @@ let debug_print (format : ('a, out_channel, unit) format) = else Printf.ifprintf stdout format let debug_format (format : ('a, Format.formatter, unit) format) = - if !debug_flag then Format.printf ("%s@[" ^^ format ^^ "@]@.") (debug_marker ()) + if !debug_flag then + Format.printf ("%s@[" ^^ format ^^ "@]@.") (debug_marker ()) else Format.ifprintf Format.std_formatter format let error_print (format : ('a, out_channel, unit) format) = diff --git a/compiler/utils/cli.mli b/compiler/utils/cli.mli index b2b87ba7..a25fdbfb 100644 --- a/compiler/utils/cli.mli +++ b/compiler/utils/cli.mli @@ -1,15 +1,18 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020 Inria, contributors: Denis Merigoux - , Emile Rolley +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, + contributors: Denis Merigoux , Emile Rolley + - 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 + 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 + 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. *) type backend_lang = En | Fr | Pl @@ -20,9 +23,7 @@ val source_files : string list ref (** Source files to be compiled *) val locale_lang : backend_lang ref - val contents : string ref - val debug_flag : bool ref val style_flag : bool ref @@ -44,15 +45,10 @@ val avoid_exceptions_flag : bool ref (** {2 CLI terms} *) val file : string Cmdliner.Term.t - val debug : bool Cmdliner.Term.t - val unstyled : bool Cmdliner.Term.t - val trace_opt : bool Cmdliner.Term.t - val wrap_weaved_output : bool Cmdliner.Term.t - val backend : string Cmdliner.Term.t type backend_option = @@ -70,11 +66,8 @@ type backend_option = | Typecheck val language : string option Cmdliner.Term.t - val max_prec_digits_opt : int option Cmdliner.Term.t - val ex_scope : string option Cmdliner.Term.t - val output : string option Cmdliner.Term.t type options = { @@ -99,9 +92,7 @@ val catala_t : (string -> options -> 'a) -> 'a Cmdliner.Term.t (** Main entry point: [catala_t file options] *) val set_option_globals : options -> unit - val version : string - val info : Cmdliner.Term.info (**{1 Terminal formatting}*) @@ -110,16 +101,13 @@ val info : Cmdliner.Term.info val with_style : ANSITerminal.style list -> ('a, unit, string) format -> 'a -val format_with_style : ANSITerminal.style list -> Format.formatter -> string -> unit +val format_with_style : + ANSITerminal.style list -> Format.formatter -> string -> unit val debug_marker : unit -> string - val error_marker : unit -> string - val warning_marker : unit -> string - val result_marker : unit -> string - val log_marker : unit -> string (**{2 Printers}*) @@ -133,17 +121,10 @@ val add_prefix_to_each_line : string -> (int -> string) -> string (** The int argument of the prefix corresponds to the line number, starting at 0 *) val debug_print : ('a, out_channel, unit) format -> 'a - val debug_format : ('a, Format.formatter, unit) format -> 'a - val error_print : ('a, out_channel, unit) format -> 'a - val warning_print : ('a, out_channel, unit) format -> 'a - val result_print : ('a, out_channel, unit) format -> 'a - val result_format : ('a, Format.formatter, unit) format -> 'a - val log_print : ('a, out_channel, unit) format -> 'a - val log_format : ('a, Format.formatter, unit) format -> 'a diff --git a/compiler/utils/errors.ml b/compiler/utils/errors.ml index 8a5643ba..106165dd 100644 --- a/compiler/utils/errors.ml +++ b/compiler/utils/errors.ml @@ -1,15 +1,17 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux - +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, contributor: + Denis Merigoux - 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 + 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 + 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. *) (** Error formatting and helper functions *) @@ -17,11 +19,12 @@ (** {1 Error exception and printing} *) exception StructuredError of (string * (string option * Pos.t) list) -(** The payload of the expression is a main error message, with a list of secondary positions - related to the error, each carrying an optional secondary message to describe what is pointed by - the position. *) +(** The payload of the expression is a main error message, with a list of + secondary positions related to the error, each carrying an optional + secondary message to describe what is pointed by the position. *) -let print_structured_error (msg : string) (pos : (string option * Pos.t) list) : string = +let print_structured_error (msg : string) (pos : (string option * Pos.t) list) : + string = Printf.sprintf "%s%s%s" msg (if List.length pos = 0 then "" else "\n\n") (String.concat "\n\n" @@ -35,17 +38,22 @@ let print_structured_error (msg : string) (pos : (string option * Pos.t) list) : (** {1 Error exception and printing} *) let raise_spanned_error ?(span_msg : string option) (span : Pos.t) format = - Format.kasprintf (fun msg -> raise (StructuredError (msg, [ (span_msg, span) ]))) format + Format.kasprintf + (fun msg -> raise (StructuredError (msg, [ (span_msg, span) ]))) + format let raise_multispanned_error (spans : (string option * Pos.t) list) format = Format.kasprintf (fun msg -> raise (StructuredError (msg, spans))) format -let raise_error format = Format.kasprintf (fun msg -> raise (StructuredError (msg, []))) format +let raise_error format = + Format.kasprintf (fun msg -> raise (StructuredError (msg, []))) format (** {1 Warning printing}*) let format_multispanned_warning (pos : (string option * Pos.t) list) format = - Format.kasprintf (fun msg -> Cli.warning_print "%s" (print_structured_error msg pos)) format + Format.kasprintf + (fun msg -> Cli.warning_print "%s" (print_structured_error msg pos)) + format let format_spanned_warning ?(span_msg : string option) (span : Pos.t) format = format_multispanned_warning [ (span_msg, span) ] format diff --git a/compiler/utils/errors.mli b/compiler/utils/errors.mli index 7f28b153..4a63ea61 100644 --- a/compiler/utils/errors.mli +++ b/compiler/utils/errors.mli @@ -1,15 +1,17 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux - +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, contributor: + Denis Merigoux - 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 + 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 + 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. *) (** Error formatting and helper functions *) @@ -17,9 +19,9 @@ (** {1 Error exception and printing} *) exception StructuredError of (string * (string option * Pos.t) list) -(** The payload of the expression is a main error message, with a list of secondary positions - related to the error, each carrying an optional secondary message to describe what is pointed by - the position. *) +(** The payload of the expression is a main error message, with a list of + secondary positions related to the error, each carrying an optional + secondary message to describe what is pointed by the position. *) val print_structured_error : string -> (string option * Pos.t) list -> string @@ -38,6 +40,7 @@ val raise_error : ('a, Format.formatter, unit, 'b) format4 -> 'a val format_multispanned_warning : (string option * Pos.t) list -> ('a, Format.formatter, unit) format -> 'a -val format_spanned_warning : ?span_msg:string -> Pos.t -> ('a, Format.formatter, unit) format -> 'a +val format_spanned_warning : + ?span_msg:string -> Pos.t -> ('a, Format.formatter, unit) format -> 'a val format_warning : ('a, Format.formatter, unit) format -> 'a diff --git a/compiler/utils/pos.ml b/compiler/utils/pos.ml index ed574cca..6ef3c34e 100644 --- a/compiler/utils/pos.ml +++ b/compiler/utils/pos.ml @@ -1,31 +1,46 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux - +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, contributor: + Denis Merigoux - 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 + 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 + 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. *) type t = { code_pos : Lexing.position * Lexing.position; law_pos : string list } -let from_lpos (p : Lexing.position * Lexing.position) : t = { code_pos = p; law_pos = [] } +let from_lpos (p : Lexing.position * Lexing.position) : t = + { code_pos = p; law_pos = [] } -let from_info (file : string) (sline : int) (scol : int) (eline : int) (ecol : int) : t = +let from_info + (file : string) (sline : int) (scol : int) (eline : int) (ecol : int) : t = let spos = - { Lexing.pos_fname = file; Lexing.pos_lnum = sline; Lexing.pos_cnum = scol; Lexing.pos_bol = 1 } + { + Lexing.pos_fname = file; + Lexing.pos_lnum = sline; + Lexing.pos_cnum = scol; + Lexing.pos_bol = 1; + } in let epos = - { Lexing.pos_fname = file; Lexing.pos_lnum = eline; Lexing.pos_cnum = ecol; Lexing.pos_bol = 1 } + { + Lexing.pos_fname = file; + Lexing.pos_lnum = eline; + Lexing.pos_cnum = ecol; + Lexing.pos_bol = 1; + } in { code_pos = (spos, epos); law_pos = [] } -let overwrite_law_info (pos : t) (law_pos : string list) : t = { pos with law_pos } +let overwrite_law_info (pos : t) (law_pos : string list) : t = + { pos with law_pos } let get_law_info (pos : t) : string list = pos.law_pos @@ -51,7 +66,8 @@ type input_file = FileName of string | Contents of string let to_string (pos : t) : string = let s, e = pos.code_pos in - Printf.sprintf "in file %s, from %d:%d to %d:%d" s.Lexing.pos_fname s.Lexing.pos_lnum + Printf.sprintf "in file %s, from %d:%d to %d:%d" s.Lexing.pos_fname + s.Lexing.pos_lnum (s.Lexing.pos_cnum - s.Lexing.pos_bol + 1) e.Lexing.pos_lnum (e.Lexing.pos_cnum - e.Lexing.pos_bol + 1) @@ -107,11 +123,15 @@ let retrieve_loc_text (pos : t) : string = if line_no = sline && line_no = eline then Cli.with_style error_indicator_style "%*s" (get_end_column pos - 1) - (String.make (max (get_end_column pos - get_start_column pos) 0) '^') + (String.make + (max (get_end_column pos - get_start_column pos) 0) + '^') else if line_no = sline && line_no <> eline then Cli.with_style error_indicator_style "%*s" (String.length line - 1) - (String.make (max (String.length line - get_start_column pos) 0) '^') + (String.make + (max (String.length line - get_start_column pos) 0) + '^') else if line_no <> sline && line_no <> eline then Cli.with_style error_indicator_style "%*s%s" line_indent "" (String.make (max (String.length line - line_indent) 0) '^') @@ -127,8 +147,10 @@ let retrieve_loc_text (pos : t) : string = match input_line_opt () with | Some line -> if n < sline - include_extra_count then get_lines (n + 1) - else if n >= sline - include_extra_count && n <= eline + include_extra_count then - print_matched_line line n :: get_lines (n + 1) + else if + n >= sline - include_extra_count + && n <= eline + include_extra_count + then print_matched_line line n :: get_lines (n + 1) else [] | None -> [] in @@ -137,7 +159,10 @@ let retrieve_loc_text (pos : t) : string = let legal_pos_lines = List.rev (List.map - (fun s -> Re.Pcre.substitute ~rex:(Re.Pcre.regexp "\n\\s*") ~subst:(fun _ -> " ") s) + (fun s -> + Re.Pcre.substitute ~rex:(Re.Pcre.regexp "\n\\s*") + ~subst:(fun _ -> " ") + s) pos.law_pos) in (match oc with None -> () | Some oc -> close_in oc); @@ -150,20 +175,28 @@ let retrieve_loc_text (pos : t) : string = cur_line >= sline && cur_line <= sline + (2 * (eline - sline)) && cur_line mod 2 = sline mod 2 - then Cli.with_style blue_style "%*d | " spaces (sline + ((cur_line - sline) / 2)) - else if cur_line >= sline - include_extra_count && cur_line < sline then - Cli.with_style blue_style "%*d | " spaces cur_line + then + Cli.with_style blue_style "%*d | " spaces + (sline + ((cur_line - sline) / 2)) + else if cur_line >= sline - include_extra_count && cur_line < sline + then Cli.with_style blue_style "%*d | " spaces cur_line else if - cur_line <= sline + (2 * (eline - sline)) + 1 + include_extra_count + cur_line + <= sline + (2 * (eline - sline)) + 1 + include_extra_count && cur_line > sline + (2 * (eline - sline)) + 1 - then Cli.with_style blue_style "%*d | " spaces (cur_line - (eline - sline + 1)) + then + Cli.with_style blue_style "%*d | " spaces + (cur_line - (eline - sline + 1)) else Cli.with_style blue_style "%*s | " spaces "")) (Cli.add_prefix_to_each_line (Printf.sprintf "%s" (String.concat "\n" - (List.map (fun l -> Cli.with_style blue_style "%s" l) legal_pos_lines))) + (List.map + (fun l -> Cli.with_style blue_style "%s" l) + legal_pos_lines))) (fun i -> - if i = 0 then Cli.with_style blue_style "%*s + " (spaces + (2 * i)) "" + if i = 0 then + Cli.with_style blue_style "%*s + " (spaces + (2 * i)) "" else Cli.with_style blue_style "%*s+-+ " (spaces + (2 * i) - 1) "")) with Sys_error _ -> "Location:" ^ to_string pos @@ -171,18 +204,19 @@ type 'a marked = 'a * t let no_pos : t = let zero_pos = - { Lexing.pos_fname = ""; Lexing.pos_lnum = 0; Lexing.pos_cnum = 0; Lexing.pos_bol = 0 } + { + Lexing.pos_fname = ""; + Lexing.pos_lnum = 0; + Lexing.pos_cnum = 0; + Lexing.pos_bol = 0; + } in { code_pos = (zero_pos, zero_pos); law_pos = [] } let mark pos e : 'a marked = (e, pos) - let unmark ((x, _) : 'a marked) : 'a = x - let get_position ((_, x) : 'a marked) : t = x - let map_under_mark (f : 'a -> 'b) ((x, y) : 'a marked) : 'b marked = (f x, y) - let same_pos_as (x : 'a) ((_, y) : 'b marked) : 'a marked = (x, y) let unmark_option (x : 'a marked option) : 'a option = @@ -191,16 +225,23 @@ let unmark_option (x : 'a marked option) : 'a option = class ['self] marked_map = object (_self : 'self) constraint - 'self = < visit_marked : 'a. ('env -> 'a -> 'a) -> 'env -> 'a marked -> 'a marked ; .. > + 'self = < visit_marked : + 'a. ('env -> 'a -> 'a) -> 'env -> 'a marked -> 'a marked + ; .. > - method visit_marked : 'a. ('env -> 'a -> 'a) -> 'env -> 'a marked -> 'a marked = + method visit_marked + : 'a. ('env -> 'a -> 'a) -> 'env -> 'a marked -> 'a marked = fun f env x -> same_pos_as (f env (unmark x)) x end class ['self] marked_iter = object (_self : 'self) - constraint 'self = < visit_marked : 'a. ('env -> 'a -> unit) -> 'env -> 'a marked -> unit ; .. > + constraint + 'self = < visit_marked : + 'a. ('env -> 'a -> unit) -> 'env -> 'a marked -> unit + ; .. > - method visit_marked : 'a. ('env -> 'a -> unit) -> 'env -> 'a marked -> unit = + method visit_marked : 'a. ('env -> 'a -> unit) -> 'env -> 'a marked -> unit + = fun f env x -> f env (unmark x) end diff --git a/compiler/utils/pos.mli b/compiler/utils/pos.mli index b1f3d519..ade01d25 100644 --- a/compiler/utils/pos.mli +++ b/compiler/utils/pos.mli @@ -1,42 +1,37 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux - +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, contributor: + Denis Merigoux - 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 + 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 + 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. *) (** Source code position *) type t -(** A position in the source code is a file, as well as begin and end location of the form col:line *) +(** A position in the source code is a file, as well as begin and end location + of the form col:line *) (** Custom visitor for the [Pos.marked] type *) (**{2 Constructor and getters}*) val from_lpos : Lexing.position * Lexing.position -> t - val from_info : string -> int -> int -> int -> int -> t - val overwrite_law_info : t -> string list -> t - val get_law_info : t -> string list - val get_start_line : t -> int - val get_start_column : t -> int - val get_end_line : t -> int - val get_end_column : t -> int - val get_file : t -> string type input_file = FileName of string | Contents of string @@ -54,26 +49,23 @@ val to_string_short : t -> string {v ;:--: v} *) val retrieve_loc_text : t -> string -(** Open the file corresponding to the position and retrieves the text concerned by the position *) +(** Open the file corresponding to the position and retrieves the text concerned + by the position *) (**{2 AST markings}*) type 'a marked = 'a * t -(** Everything related to the source code should keep its position stored, to improve error messages *) +(** Everything related to the source code should keep its position stored, to + improve error messages *) val no_pos : t (** Placeholder position *) val mark : t -> 'a -> 'a marked - val unmark : 'a marked -> 'a - val get_position : 'a marked -> t - val map_under_mark : ('a -> 'b) -> 'a marked -> 'b marked - val same_pos_as : 'a -> 'b marked -> 'a marked - val unmark_option : 'a marked option -> 'a option (** Visitors *) @@ -81,14 +73,20 @@ val unmark_option : 'a marked option -> 'a option class ['self] marked_map : object ('self) constraint - 'self = < visit_marked : 'a. ('env -> 'a -> 'a) -> 'env -> 'a marked -> 'a marked ; .. > + 'self = < visit_marked : + 'a. ('env -> 'a -> 'a) -> 'env -> 'a marked -> 'a marked + ; .. > - method visit_marked : 'a. ('env -> 'a -> 'a) -> 'env -> 'a marked -> 'a marked + method visit_marked : + 'a. ('env -> 'a -> 'a) -> 'env -> 'a marked -> 'a marked end class ['self] marked_iter : object ('self) - constraint 'self = < visit_marked : 'a. ('env -> 'a -> unit) -> 'env -> 'a marked -> unit ; .. > + constraint + 'self = < visit_marked : + 'a. ('env -> 'a -> unit) -> 'env -> 'a marked -> unit + ; .. > method visit_marked : 'a. ('env -> 'a -> unit) -> 'env -> 'a marked -> unit end diff --git a/compiler/utils/uid.ml b/compiler/utils/uid.ml index ad5580db..60577ab1 100644 --- a/compiler/utils/uid.ml +++ b/compiler/utils/uid.ml @@ -1,15 +1,17 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux - +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, contributor: + Denis Merigoux - 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 + 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 + 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. *) module type Info = sig @@ -20,23 +22,17 @@ end module type Id = sig type t - type info val fresh : info -> t - val get_info : t -> info - val compare : t -> t -> int - val format_t : Format.formatter -> t -> unit - val hash : t -> int end module Make (X : Info) () : Id with type info = X.info = struct type t = { id : int; info : X.info } - type info = X.info let counter = ref 0 @@ -46,7 +42,6 @@ module Make (X : Info) () : Id with type info = X.info = struct { id = !counter; info } let get_info (uid : t) : X.info = uid.info - let compare (x : t) (y : t) : int = compare x.id y.id let format_t (fmt : Format.formatter) (x : t) : unit = diff --git a/compiler/utils/uid.mli b/compiler/utils/uid.mli index f8ec123c..f7d9bc8f 100644 --- a/compiler/utils/uid.mli +++ b/compiler/utils/uid.mli @@ -1,15 +1,17 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2020 Inria, contributor: Denis Merigoux - +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2020 Inria, contributor: + Denis Merigoux - 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 + 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 + 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. *) (** Global identifiers factories using a generative functor *) @@ -22,28 +24,25 @@ module type Info = sig end module MarkedString : Info with type info = string Pos.marked -(** The only kind of information carried in Catala identifiers is the original string of the - identifier annotated with the position where it is declared or used. *) +(** The only kind of information carried in Catala identifiers is the original + string of the identifier annotated with the position where it is declared or + used. *) -(** Identifiers have abstract types, but are comparable so they can be used as keys in maps or sets. - Their underlying information can be retrieved at any time. *) +(** Identifiers have abstract types, but are comparable so they can be used as + keys in maps or sets. Their underlying information can be retrieved at any + time. *) module type Id = sig type t - type info val fresh : info -> t - val get_info : t -> info - val compare : t -> t -> int - val format_t : Format.formatter -> t -> unit - val hash : t -> int end -(** This is the generative functor that ensures that two modules resulting from two different calls - to [Make] will be viewed as different types [t] by the OCaml typechecker. Prevents mixing up - different sorts of identifiers. *) +(** This is the generative functor that ensures that two modules resulting from + two different calls to [Make] will be viewed as different types [t] by the + OCaml typechecker. Prevents mixing up different sorts of identifiers. *) module Make (X : Info) () : Id with type info = X.info diff --git a/compiler/verification/conditions.ml b/compiler/verification/conditions.ml index 86716df8..958a4ee1 100644 --- a/compiler/verification/conditions.ml +++ b/compiler/verification/conditions.ml @@ -1,15 +1,18 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2022 Inria, contributor: Denis Merigoux - , Alain Delaët +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2022 Inria, contributor: + Denis Merigoux , Alain Delaët + - 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 + 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 + 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. *) open Utils @@ -19,19 +22,22 @@ open Ast (** {1 Helpers and type definitions}*) type vc_return = expr Pos.marked * typ Pos.marked VarMap.t -(** The return type of VC generators is the VC expression plus the types of any locally free - variable inside that expression. *) +(** The return type of VC generators is the VC expression plus the types of any + locally free variable inside that expression. *) type ctx = { decl : decl_ctx; input_vars : Var.t list } let conjunction (args : vc_return list) (pos : Pos.t) : vc_return = let acc, list = - match args with hd :: tl -> (hd, tl) | [] -> (((ELit (LBool true), pos), VarMap.empty), []) + match args with + | hd :: tl -> (hd, tl) + | [] -> (((ELit (LBool true), pos), VarMap.empty), []) in List.fold_left (fun (acc, acc_ty) (arg, arg_ty) -> ( (EApp ((EOp (Binop And), pos), [ arg; acc ]), pos), - VarMap.union (fun _ _ _ -> failwith "should not happen") acc_ty arg_ty )) + VarMap.union (fun _ _ _ -> failwith "should not happen") acc_ty arg_ty + )) acc list let negation ((arg, arg_ty) : vc_return) (pos : Pos.t) : vc_return = @@ -39,26 +45,31 @@ let negation ((arg, arg_ty) : vc_return) (pos : Pos.t) : vc_return = let disjunction (args : vc_return list) (pos : Pos.t) : vc_return = let acc, list = - match args with hd :: tl -> (hd, tl) | [] -> (((ELit (LBool false), pos), VarMap.empty), []) + match args with + | hd :: tl -> (hd, tl) + | [] -> (((ELit (LBool false), pos), VarMap.empty), []) in List.fold_left (fun ((acc, acc_ty) : vc_return) (arg, arg_ty) -> ( (EApp ((EOp (Binop Or), pos), [ arg; acc ]), pos), - VarMap.union (fun _ _ _ -> failwith "should not happen") acc_ty arg_ty )) + VarMap.union (fun _ _ _ -> failwith "should not happen") acc_ty arg_ty + )) acc list (** [half_product \[a1,...,an\] \[b1,...,bm\] returns \[(a1,b1),...(a1,bn),...(an,b1),...(an,bm)\]] *) let half_product (l1 : 'a list) (l2 : 'b list) : ('a * 'b) list = l1 - |> List.mapi (fun i ei -> List.filteri (fun j _ -> i < j) l2 |> List.map (fun ej -> (ei, ej))) + |> List.mapi (fun i ei -> + List.filteri (fun j _ -> i < j) l2 |> List.map (fun ej -> (ei, ej))) |> List.concat (** This code skims through the topmost layers of the terms like this: - [log (error_on_empty < reentrant_variable () | true :- e1 >)] for scope variables, or - [fun () -> e1] for subscope variables. But what we really want to analyze is only [e1], so we - match this outermost structure explicitely and have a clean verification condition generator - that only runs on [e1] *) -let match_and_ignore_outer_reentrant_default (ctx : ctx) (e : expr Pos.marked) : expr Pos.marked = + [log (error_on_empty < reentrant_variable () | true :- e1 >)] for scope + variables, or [fun () -> e1] for subscope variables. But what we really want + to analyze is only [e1], so we match this outermost structure explicitely + and have a clean verification condition generator that only runs on [e1] *) +let match_and_ignore_outer_reentrant_default (ctx : ctx) (e : expr Pos.marked) : + expr Pos.marked = match Pos.unmark e with | EApp ( (EOp (Unop (Log _)), _), @@ -81,8 +92,8 @@ let match_and_ignore_outer_reentrant_default (ctx : ctx) (e : expr Pos.marked) : | EApp ((EOp (Unop (Log _)), _), [ arg ]) -> arg | _ -> Errors.raise_spanned_error (Pos.get_position e) - "Internal error: this expression does not have the structure expected by the VC \ - generator:\n\ + "Internal error: this expression does not have the structure \ + expected by the VC generator:\n\ %a" (Print.format_expr ~debug:true ctx.decl) e) @@ -91,33 +102,43 @@ let match_and_ignore_outer_reentrant_default (ctx : ctx) (e : expr Pos.marked) : d (* input subscope variables and non-input scope variable *) | _ -> Errors.raise_spanned_error (Pos.get_position e) - "Internal error: this expression does not have the structure expected by the VC generator:\n\ + "Internal error: this expression does not have the structure expected \ + by the VC generator:\n\ %a" (Print.format_expr ~debug:true ctx.decl) e (** {1 Verification conditions generator}*) -(** [generate_vc_must_not_return_empty e] returns the dcalc boolean expression [b] such that if [b] - is true, then [e] will never return an empty error. It also returns a map of all the types of - locally free variables inside the expression. *) -let rec generate_vc_must_not_return_empty (ctx : ctx) (e : expr Pos.marked) : vc_return = +(** [generate_vc_must_not_return_empty e] returns the dcalc boolean expression + [b] such that if [b] is true, then [e] will never return an empty error. It + also returns a map of all the types of locally free variables inside the + expression. *) +let rec generate_vc_must_not_return_empty (ctx : ctx) (e : expr Pos.marked) : + vc_return = let out = match Pos.unmark e with | ETuple (args, _) | EArray args -> - conjunction (List.map (generate_vc_must_not_return_empty ctx) args) (Pos.get_position e) + conjunction + (List.map (generate_vc_must_not_return_empty ctx) args) + (Pos.get_position e) | EMatch (arg, arms, _) -> conjunction (List.map (generate_vc_must_not_return_empty ctx) (arg :: arms)) (Pos.get_position e) - | ETupleAccess (e1, _, _, _) | EInj (e1, _, _, _) | EAssert e1 | ErrorOnEmpty e1 -> + | ETupleAccess (e1, _, _, _) + | EInj (e1, _, _, _) + | EAssert e1 + | ErrorOnEmpty e1 -> (generate_vc_must_not_return_empty ctx) e1 | EAbs (binder, typs) -> (* Hot take: for a function never to return an empty error when called, it has to do so whatever its input. So we universally quantify over the variable of the function when inspecting the body, resulting in simply traversing through in the code here. *) let vars, body = Bindlib.unmbind (Pos.unmark binder) in - let vc_body_expr, vc_body_ty = (generate_vc_must_not_return_empty ctx) body in + let vc_body_expr, vc_body_ty = + (generate_vc_must_not_return_empty ctx) body + in ( vc_body_expr, List.fold_left (fun acc (var, ty) -> VarMap.add var ty acc) @@ -137,7 +158,9 @@ let rec generate_vc_must_not_return_empty (ctx : ctx) (e : expr Pos.marked) : vc [ (e1_vc, vc_typ1); ( (EIfThenElse (e1, e2_vc, e3_vc), Pos.get_position e), - VarMap.union (fun _ _ _ -> failwith "should not happen") vc_typ2 vc_typ3 ); + VarMap.union + (fun _ _ _ -> failwith "should not happen") + vc_typ2 vc_typ3 ); ] (Pos.get_position e) | ELit LEmptyError -> (Pos.same_pos_as (ELit (LBool false)) e, VarMap.empty) @@ -157,7 +180,9 @@ let rec generate_vc_must_not_return_empty (ctx : ctx) (e : expr Pos.marked) : vc conjunction [ generate_vc_must_not_return_empty ctx just; - (let vc_just_expr, vc_just_ty = generate_vc_must_not_return_empty ctx cons in + (let vc_just_expr, vc_just_ty = + generate_vc_must_not_return_empty ctx cons + in ( ( EIfThenElse ( just, (* Comment from Alain: the justification is not checked for holding an default term. @@ -178,25 +203,34 @@ let rec generate_vc_must_not_return_empty (ctx : ctx) (e : expr Pos.marked) : vc out [@@ocamlformat "wrap-comments=false"] -(** [generate_vs_must_not_return_confict e] returns the dcalc boolean expression [b] such that if - [b] is true, then [e] will never return a conflict error. It also returns a map of all the types - of locally free variables inside the expression. *) -let rec generate_vs_must_not_return_confict (ctx : ctx) (e : expr Pos.marked) : vc_return = +(** [generate_vs_must_not_return_confict e] returns the dcalc boolean expression + [b] such that if [b] is true, then [e] will never return a conflict error. + It also returns a map of all the types of locally free variables inside the + expression. *) +let rec generate_vs_must_not_return_confict (ctx : ctx) (e : expr Pos.marked) : + vc_return = let out = (* See the code of [generate_vc_must_not_return_empty] for a list of invariants on which this function relies on. *) match Pos.unmark e with | ETuple (args, _) | EArray args -> - conjunction (List.map (generate_vs_must_not_return_confict ctx) args) (Pos.get_position e) + conjunction + (List.map (generate_vs_must_not_return_confict ctx) args) + (Pos.get_position e) | EMatch (arg, arms, _) -> conjunction (List.map (generate_vs_must_not_return_confict ctx) (arg :: arms)) (Pos.get_position e) - | ETupleAccess (e1, _, _, _) | EInj (e1, _, _, _) | EAssert e1 | ErrorOnEmpty e1 -> + | ETupleAccess (e1, _, _, _) + | EInj (e1, _, _, _) + | EAssert e1 + | ErrorOnEmpty e1 -> generate_vs_must_not_return_confict ctx e1 | EAbs (binder, typs) -> let vars, body = Bindlib.unmbind (Pos.unmark binder) in - let vc_body_expr, vc_body_ty = (generate_vs_must_not_return_confict ctx) body in + let vc_body_expr, vc_body_ty = + (generate_vs_must_not_return_confict ctx) body + in ( vc_body_expr, List.fold_left (fun acc (var, ty) -> VarMap.add var ty acc) @@ -214,10 +248,13 @@ let rec generate_vs_must_not_return_confict (ctx : ctx) (e : expr Pos.marked) : [ (e1_vc, vc_typ1); ( (EIfThenElse (e1, e2_vc, e3_vc), Pos.get_position e), - VarMap.union (fun _ _ _ -> failwith "should not happen") vc_typ2 vc_typ3 ); + VarMap.union + (fun _ _ _ -> failwith "should not happen") + vc_typ2 vc_typ3 ); ] (Pos.get_position e) - | EVar _ | ELit _ | EOp _ -> (Pos.same_pos_as (ELit (LBool true)) e, VarMap.empty) + | EVar _ | ELit _ | EOp _ -> + (Pos.same_pos_as (ELit (LBool true)) e, VarMap.empty) | EDefault (exceptions, just, cons) -> (* never returns conflict if and only if: - neither e1 nor ... nor en nor ejust nor econs return conflict @@ -238,7 +275,9 @@ let rec generate_vs_must_not_return_confict (ctx : ctx) (e : expr Pos.marked) : (Pos.get_position e) in let others = - List.map (generate_vs_must_not_return_confict ctx) (just :: cons :: exceptions) + List.map + (generate_vs_must_not_return_confict ctx) + (just :: cons :: exceptions) in let out = conjunction (quadratic :: others) (Pos.get_position e) in out @@ -259,7 +298,8 @@ type verification_condition = { vc_free_vars_typ : typ Pos.marked VarMap.t; } -let generate_verification_conditions (p : program) : verification_condition list = +let generate_verification_conditions (p : program) : verification_condition list + = List.fold_left (fun acc (s_name, _s_var, s_body) -> let ctx = { decl = p.decl_ctx; input_vars = [] } in @@ -268,19 +308,29 @@ let generate_verification_conditions (p : program) : verification_condition list (fun (acc, ctx) s_let -> match s_let.scope_let_kind with | DestructuringInputStruct -> - (acc, { ctx with input_vars = Pos.unmark s_let.scope_let_var :: ctx.input_vars }) + ( acc, + { + ctx with + input_vars = + Pos.unmark s_let.scope_let_var :: ctx.input_vars; + } ) | ScopeVarDefinition | SubScopeVarDefinition -> - (* For scope variables, we should check both that they never evaluate to emptyError - nor conflictError. But for subscope variable definitions, what we're really doing - is adding exceptions to something defined in the subscope so we just ought to - verify only that the exceptions overlap. *) + (* For scope variables, we should check both that they never + evaluate to emptyError nor conflictError. But for subscope + variable definitions, what we're really doing is adding + exceptions to something defined in the subscope so we just + ought to verify only that the exceptions overlap. *) let e = - match_and_ignore_outer_reentrant_default ctx (Bindlib.unbox s_let.scope_let_expr) + match_and_ignore_outer_reentrant_default ctx + (Bindlib.unbox s_let.scope_let_expr) + in + let vc_confl, vc_confl_typs = + generate_vs_must_not_return_confict ctx e in - let vc_confl, vc_confl_typs = generate_vs_must_not_return_confict ctx e in let vc_confl = if !Cli.optimize_flag then - Bindlib.unbox (Optimizations.optimize_expr p.decl_ctx vc_confl) + Bindlib.unbox + (Optimizations.optimize_expr p.decl_ctx vc_confl) else vc_confl in let vc_list = @@ -297,10 +347,13 @@ let generate_verification_conditions (p : program) : verification_condition list let vc_list = match s_let.scope_let_kind with | ScopeVarDefinition -> - let vc_empty, vc_empty_typs = generate_vc_must_not_return_empty ctx e in + let vc_empty, vc_empty_typs = + generate_vc_must_not_return_empty ctx e + in let vc_empty = if !Cli.optimize_flag then - Bindlib.unbox (Optimizations.optimize_expr p.decl_ctx vc_empty) + Bindlib.unbox + (Optimizations.optimize_expr p.decl_ctx vc_empty) else vc_empty in { diff --git a/compiler/verification/conditions.mli b/compiler/verification/conditions.mli index b62c964f..d08c3300 100644 --- a/compiler/verification/conditions.mli +++ b/compiler/verification/conditions.mli @@ -1,33 +1,41 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2022 Inria, contributor: Denis Merigoux - , Alain Delaët +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2022 Inria, contributor: + Denis Merigoux , Alain Delaët + - 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 + 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 + 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. *) (** Generates verification conditions from scope definitions *) type verification_condition_kind = | NoEmptyError - (** This verification condition checks whether a definition never returns an empty error *) + (** This verification condition checks whether a definition never returns + an empty error *) | NoOverlappingExceptions - (** This verification condition checks whether a definition never returns a conflict error *) + (** This verification condition checks whether a definition never returns + a conflict error *) type verification_condition = { - vc_guard : Dcalc.Ast.expr Utils.Pos.marked; (** This expression should have type [bool]*) + vc_guard : Dcalc.Ast.expr Utils.Pos.marked; + (** This expression should have type [bool]*) vc_kind : verification_condition_kind; vc_scope : Dcalc.Ast.ScopeName.t; vc_variable : Dcalc.Ast.Var.t Utils.Pos.marked; vc_free_vars_typ : Dcalc.Ast.typ Utils.Pos.marked Dcalc.Ast.VarMap.t; - (** Types of the locally free variables in [vc_guard]. The types of other free variables - linked to scope variables can be obtained with [Dcalc.Ast.variable_types]. *) + (** Types of the locally free variables in [vc_guard]. The types of other + free variables linked to scope variables can be obtained with + [Dcalc.Ast.variable_types]. *) } -val generate_verification_conditions : Dcalc.Ast.program -> verification_condition list +val generate_verification_conditions : + Dcalc.Ast.program -> verification_condition list diff --git a/compiler/verification/io.ml b/compiler/verification/io.ml index 5d2221d7..981306c7 100644 --- a/compiler/verification/io.ml +++ b/compiler/verification/io.ml @@ -1,15 +1,18 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2022 Inria, contributor: Aymeric Fromherz - , Denis Merigoux +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2022 Inria, contributor: + Aymeric Fromherz , Denis Merigoux + - 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 + 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 + 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. *) open Utils @@ -27,17 +30,16 @@ module type Backend = sig val print_encoding : vc_encoding -> string type model - type solver_result = ProvenTrue | ProvenFalse of model option | Unknown val solve_vc_encoding : backend_context -> vc_encoding -> solver_result - val print_model : backend_context -> model -> string - val is_model_empty : model -> bool val translate_expr : - backend_context -> Dcalc.Ast.expr Utils.Pos.marked -> backend_context * vc_encoding + backend_context -> + Dcalc.Ast.expr Utils.Pos.marked -> + backend_context * vc_encoding end module type BackendIO = sig @@ -50,19 +52,28 @@ module type BackendIO = sig type vc_encoding val translate_expr : - backend_context -> Dcalc.Ast.expr Utils.Pos.marked -> backend_context * vc_encoding + backend_context -> + Dcalc.Ast.expr Utils.Pos.marked -> + backend_context * vc_encoding type model - type vc_encoding_result = Success of vc_encoding * backend_context | Fail of string + type vc_encoding_result = + | Success of vc_encoding * backend_context + | Fail of string val print_positive_result : Conditions.verification_condition -> string val print_negative_result : - Conditions.verification_condition -> backend_context -> model option -> string + Conditions.verification_condition -> + backend_context -> + model option -> + string val encode_and_check_vc : - Dcalc.Ast.decl_ctx -> Conditions.verification_condition * vc_encoding_result -> unit + Dcalc.Ast.decl_ctx -> + Conditions.verification_condition * vc_encoding_result -> + unit end module MakeBackendIO (B : Backend) = struct @@ -78,7 +89,9 @@ module MakeBackendIO (B : Backend) = struct type model = B.model - type vc_encoding_result = Success of B.vc_encoding * B.backend_context | Fail of string + type vc_encoding_result = + | Success of B.vc_encoding * B.backend_context + | Fail of string let print_positive_result (vc : Conditions.verification_condition) : string = match vc.Conditions.vc_kind with @@ -93,7 +106,9 @@ module MakeBackendIO (B : Backend) = struct (Format.asprintf "%a" ScopeName.format_t vc.vc_scope) (Bindlib.name_of (Pos.unmark vc.vc_variable))) - let print_negative_result (vc : Conditions.verification_condition) (ctx : B.backend_context) + let print_negative_result + (vc : Conditions.verification_condition) + (ctx : B.backend_context) (model : B.model option) : string = let var_and_pos = match vc.Conditions.vc_kind with @@ -104,7 +119,8 @@ module MakeBackendIO (B : Backend) = struct (Bindlib.name_of (Pos.unmark vc.vc_variable))) (Pos.retrieve_loc_text (Pos.get_position vc.vc_variable)) | Conditions.NoOverlappingExceptions -> - Format.asprintf "%s At least two exceptions overlap for this variable:\n%s" + Format.asprintf + "%s At least two exceptions overlap for this variable:\n%s" (Cli.with_style [ ANSITerminal.yellow ] "[%s.%s]" (Format.asprintf "%a" ScopeName.format_t vc.vc_scope) (Bindlib.name_of (Pos.unmark vc.vc_variable))) @@ -117,23 +133,28 @@ module MakeBackendIO (B : Backend) = struct match model with | None -> Some - "The solver did not manage to generate a counterexample to explain the faulty \ - behavior." + "The solver did not manage to generate a counterexample to \ + explain the faulty behavior." | Some model -> if B.is_model_empty model then None else Some (Format.asprintf - "The solver generated the following counterexample to explain the faulty \ - behavior:\n\ + "The solver generated the following counterexample to \ + explain the faulty behavior:\n\ %s" (B.print_model ctx model)) in var_and_pos - ^ match counterexample with None -> "" | Some counterexample -> "\n" ^ counterexample + ^ + match counterexample with + | None -> "" + | Some counterexample -> "\n" ^ counterexample - (** [encode_and_check_vc] spawns a new Z3 solver and tries to solve the expression [vc] **) - let encode_and_check_vc (decl_ctx : decl_ctx) + (** [encode_and_check_vc] spawns a new Z3 solver and tries to solve the + expression [vc] **) + let encode_and_check_vc + (decl_ctx : decl_ctx) (vc : Conditions.verification_condition * vc_encoding_result) : unit = let vc, z3_vc = vc in @@ -142,17 +163,21 @@ module MakeBackendIO (B : Backend) = struct Cli.debug_format "This verification condition was generated for %a:@\n%a" (Cli.format_with_style [ ANSITerminal.yellow ]) (match vc.vc_kind with - | Conditions.NoEmptyError -> "the variable definition never to return an empty error" + | Conditions.NoEmptyError -> + "the variable definition never to return an empty error" | NoOverlappingExceptions -> "no two exceptions to ever overlap") (Dcalc.Print.format_expr decl_ctx) vc.vc_guard; match z3_vc with | Success (encoding, backend_ctx) -> ( - Cli.debug_print "The translation to Z3 is the following:@\n%s" (B.print_encoding encoding); + Cli.debug_print "The translation to Z3 is the following:@\n%s" + (B.print_encoding encoding); match B.solve_vc_encoding backend_ctx encoding with | ProvenTrue -> Cli.result_print "%s" (print_positive_result vc) - | ProvenFalse model -> Cli.error_print "%s" (print_negative_result vc backend_ctx model) - | Unknown -> failwith "The solver failed at proving or disproving the VC") + | ProvenFalse model -> + Cli.error_print "%s" (print_negative_result vc backend_ctx model) + | Unknown -> + failwith "The solver failed at proving or disproving the VC") | Fail msg -> Cli.error_print "The translation to Z3 failed:@\n%s" msg end diff --git a/compiler/verification/io.mli b/compiler/verification/io.mli index 6fe134ed..1364835b 100644 --- a/compiler/verification/io.mli +++ b/compiler/verification/io.mli @@ -1,15 +1,18 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2022 Inria, contributor: Aymeric Fromherz - , Denis Merigoux +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2022 Inria, contributor: + Aymeric Fromherz , Denis Merigoux + - 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 + 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 + 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. *) (** Common code for handling the IO of all proof backends supported *) @@ -20,24 +23,25 @@ module type Backend = sig type backend_context val make_context : - Dcalc.Ast.decl_ctx -> Dcalc.Ast.typ Utils.Pos.marked Dcalc.Ast.VarMap.t -> backend_context + Dcalc.Ast.decl_ctx -> + Dcalc.Ast.typ Utils.Pos.marked Dcalc.Ast.VarMap.t -> + backend_context type vc_encoding val print_encoding : vc_encoding -> string type model - type solver_result = ProvenTrue | ProvenFalse of model option | Unknown val solve_vc_encoding : backend_context -> vc_encoding -> solver_result - val print_model : backend_context -> model -> string - val is_model_empty : model -> bool val translate_expr : - backend_context -> Dcalc.Ast.expr Utils.Pos.marked -> backend_context * vc_encoding + backend_context -> + Dcalc.Ast.expr Utils.Pos.marked -> + backend_context * vc_encoding end module type BackendIO = sig @@ -46,24 +50,35 @@ module type BackendIO = sig type backend_context val make_context : - Dcalc.Ast.decl_ctx -> Dcalc.Ast.typ Utils.Pos.marked Dcalc.Ast.VarMap.t -> backend_context + Dcalc.Ast.decl_ctx -> + Dcalc.Ast.typ Utils.Pos.marked Dcalc.Ast.VarMap.t -> + backend_context type vc_encoding val translate_expr : - backend_context -> Dcalc.Ast.expr Utils.Pos.marked -> backend_context * vc_encoding + backend_context -> + Dcalc.Ast.expr Utils.Pos.marked -> + backend_context * vc_encoding type model - type vc_encoding_result = Success of vc_encoding * backend_context | Fail of string + type vc_encoding_result = + | Success of vc_encoding * backend_context + | Fail of string val print_positive_result : Conditions.verification_condition -> string val print_negative_result : - Conditions.verification_condition -> backend_context -> model option -> string + Conditions.verification_condition -> + backend_context -> + model option -> + string val encode_and_check_vc : - Dcalc.Ast.decl_ctx -> Conditions.verification_condition * vc_encoding_result -> unit + Dcalc.Ast.decl_ctx -> + Conditions.verification_condition * vc_encoding_result -> + unit end module MakeBackendIO : functor (B : Backend) -> diff --git a/compiler/verification/solver.ml b/compiler/verification/solver.ml index 881d94d2..d32376d2 100644 --- a/compiler/verification/solver.ml +++ b/compiler/verification/solver.ml @@ -1,26 +1,30 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2022 Inria, contributor: Aymeric Fromherz - +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2022 Inria, contributor: + Aymeric Fromherz - 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 + 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 + 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. *) open Dcalc.Ast -(** [solve_vc] is the main entry point of this module. It takes a list of expressions [vcs] - corresponding to verification conditions that must be discharged by Z3, and attempts to solve - them **) -let solve_vc (prgm : program) (decl_ctx : decl_ctx) (vcs : Conditions.verification_condition list) : - unit = - (* Right now we only use the Z3 backend but the functorial interface should make it easy to mix - and match different proof backends. *) +(** [solve_vc] is the main entry point of this module. It takes a list of + expressions [vcs] corresponding to verification conditions that must be + discharged by Z3, and attempts to solve them **) +let solve_vc + (prgm : program) + (decl_ctx : decl_ctx) + (vcs : Conditions.verification_condition list) : unit = + (* Right now we only use the Z3 backend but the functorial interface should + make it easy to mix and match different proof backends. *) Z3backend.Io.init_backend (); let z3_vcs = List.map @@ -32,9 +36,12 @@ let solve_vc (prgm : program) (decl_ctx : decl_ctx) (vcs : Conditions.verificati (Z3backend.Io.make_context decl_ctx (VarMap.union (fun _ _ _ -> - failwith "[Proof encoding]: A Variable cannot be both free and bound") + failwith + "[Proof encoding]: A Variable cannot be both free \ + and bound") (variable_types prgm) vc.Conditions.vc_free_vars_typ)) - (Bindlib.unbox (Dcalc.Optimizations.remove_all_logs vc.Conditions.vc_guard)) + (Bindlib.unbox + (Dcalc.Optimizations.remove_all_logs vc.Conditions.vc_guard)) in Z3backend.Io.Success (z3_vc, ctx) with Failure msg -> Fail msg )) diff --git a/compiler/verification/solver.mli b/compiler/verification/solver.mli index 29627173..a9ea66cb 100644 --- a/compiler/verification/solver.mli +++ b/compiler/verification/solver.mli @@ -1,18 +1,23 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2022 Inria, contributor: Aymeric Fromherz - +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2022 Inria, contributor: + Aymeric Fromherz - 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 + 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 + 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. *) (** Solves verification conditions using various proof backends *) val solve_vc : - Dcalc.Ast.program -> Dcalc.Ast.decl_ctx -> Conditions.verification_condition list -> unit + Dcalc.Ast.program -> + Dcalc.Ast.decl_ctx -> + Conditions.verification_condition list -> + unit diff --git a/compiler/verification/z3backend.ml b/compiler/verification/z3backend.ml index 99369780..79aa238d 100644 --- a/compiler/verification/z3backend.ml +++ b/compiler/verification/z3backend.ml @@ -1,135 +1,154 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2022 Inria, contributor: Aymeric Fromherz - +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2022 Inria, contributor: + Aymeric Fromherz - 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 + 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 + 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. *) open Utils open Dcalc open Ast open Z3 - module StringMap : Map.S with type key = String.t = Map.Make (String) type context = { ctx_z3 : Z3.context; (* The Z3 context, used to create symbols and expressions *) ctx_decl : decl_ctx; - (* The declaration context from the Catala program, containing information to precisely pretty - print Catala expressions *) + (* The declaration context from the Catala program, containing information to + precisely pretty print Catala expressions *) ctx_var : typ Pos.marked VarMap.t; - (* A map from Catala variables to their types, needed to create Z3 expressions of the right - sort *) + (* A map from Catala variables to their types, needed to create Z3 expressions + of the right sort *) ctx_funcdecl : FuncDecl.func_decl VarMap.t; - (* A map from Catala function names (represented as variables) to Z3 function declarations, used - to only define once functions in Z3 queries *) + (* A map from Catala function names (represented as variables) to Z3 function + declarations, used to only define once functions in Z3 queries *) ctx_z3vars : Var.t StringMap.t; - (* A map from strings, corresponding to Z3 symbol names, to the Catala variable they represent. - Used when to pretty-print Z3 models when a counterexample is generated *) + (* A map from strings, corresponding to Z3 symbol names, to the Catala + variable they represent. Used when to pretty-print Z3 models when a + counterexample is generated *) ctx_z3datatypes : Sort.sort EnumMap.t; - (* A map from Catala enumeration names to the corresponding Z3 sort, from which we can retrieve - constructors and accessors *) + (* A map from Catala enumeration names to the corresponding Z3 sort, from + which we can retrieve constructors and accessors *) ctx_z3matchsubsts : Expr.expr VarMap.t; - (* A map from Catala temporary variables, generated when translating a match, to the corresponding - enum accessor call as a Z3 expression *) + (* A map from Catala temporary variables, generated when translating a match, + to the corresponding enum accessor call as a Z3 expression *) ctx_z3structs : Sort.sort StructMap.t; - (* A map from Catala struct names to the corresponding Z3 sort, from which we can retrieve the - constructor and the accessors *) + (* A map from Catala struct names to the corresponding Z3 sort, from which we + can retrieve the constructor and the accessors *) ctx_z3unit : Sort.sort * Expr.expr; - (* A pair containing the Z3 encodings of the unit type, encoded as a tuple of 0 elements, and - the unit value *) + (* A pair containing the Z3 encodings of the unit type, encoded as a tuple + of 0 elements, and the unit value *) } -(** The context contains all the required information to encode a VC represented as a Catala term to - Z3. The fields [ctx_decl] and [ctx_var] are computed before starting the translation to Z3, and - are thus unmodified throughout the translation. The [ctx_z3] context is an OCaml abstraction on - top of an underlying C++ imperative implementation, it is therefore only created once. - Unfortunately, the maps [ctx_funcdecl], [ctx_z3vars], and [ctx_z3datatypes] are computed - dynamically during the translation requiring us to pass the context around in a functional way **) +(** The context contains all the required information to encode a VC represented + as a Catala term to Z3. The fields [ctx_decl] and [ctx_var] are computed + before starting the translation to Z3, and are thus unmodified throughout + the translation. The [ctx_z3] context is an OCaml abstraction on top of an + underlying C++ imperative implementation, it is therefore only created once. + Unfortunately, the maps [ctx_funcdecl], [ctx_z3vars], and [ctx_z3datatypes] + are computed dynamically during the translation requiring us to pass the + context around in a functional way **) -(** [add_funcdecl] adds the mapping between the Catala variable [v] and the Z3 function declaration - [fd] to the context **) -let add_funcdecl (v : Var.t) (fd : FuncDecl.func_decl) (ctx : context) : context = +(** [add_funcdecl] adds the mapping between the Catala variable [v] and the Z3 + function declaration [fd] to the context **) +let add_funcdecl (v : Var.t) (fd : FuncDecl.func_decl) (ctx : context) : context + = { ctx with ctx_funcdecl = VarMap.add v fd ctx.ctx_funcdecl } -(** [add_z3var] adds the mapping between [name] and the Catala variable [v] to the context **) +(** [add_z3var] adds the mapping between [name] and the Catala variable [v] to + the context **) let add_z3var (name : string) (v : Var.t) (ctx : context) : context = { ctx with ctx_z3vars = StringMap.add name v ctx.ctx_z3vars } -(** [add_z3enum] adds the mapping between the Catala enumeration [enum] and the corresponding Z3 - datatype [sort] to the context **) -let add_z3enum (enum : EnumName.t) (sort : Sort.sort) (ctx : context) : context = +(** [add_z3enum] adds the mapping between the Catala enumeration [enum] and the + corresponding Z3 datatype [sort] to the context **) +let add_z3enum (enum : EnumName.t) (sort : Sort.sort) (ctx : context) : context + = { ctx with ctx_z3datatypes = EnumMap.add enum sort ctx.ctx_z3datatypes } -(** [add_z3var] adds the mapping between temporary variable [v] and the Z3 expression [e] - representing an accessor application to the context **) +(** [add_z3var] adds the mapping between temporary variable [v] and the Z3 + expression [e] representing an accessor application to the context **) let add_z3matchsubst (v : Var.t) (e : Expr.expr) (ctx : context) : context = { ctx with ctx_z3matchsubsts = VarMap.add v e ctx.ctx_z3matchsubsts } -(** [add_z3struct] adds the mapping between the Catala struct [s] and the corresponding Z3 datatype - [sort] to the context **) -let add_z3struct (s : StructName.t) (sort : Sort.sort) (ctx : context) : context = +(** [add_z3struct] adds the mapping between the Catala struct [s] and the + corresponding Z3 datatype [sort] to the context **) +let add_z3struct (s : StructName.t) (sort : Sort.sort) (ctx : context) : context + = { ctx with ctx_z3structs = StructMap.add s sort ctx.ctx_z3structs } -(** For the Z3 encoding of Catala programs, we define the "day 0" as Jan 1, 1900 **) +(** For the Z3 encoding of Catala programs, we define the "day 0" as Jan 1, 1900 + **) let base_day = CalendarLib.Date.make 1900 1 1 -(** [unique_name] returns the full, unique name corresponding to variable [v], as given by Bindlib **) +(** [unique_name] returns the full, unique name corresponding to variable [v], + as given by Bindlib **) let unique_name (v : Var.t) : string = Format.asprintf "%s_%d" (Bindlib.name_of v) (Bindlib.uid_of v) -(** [date_to_int] translates [date] to an integer corresponding to the number of days since Jan 1, - 1900 **) +(** [date_to_int] translates [date] to an integer corresponding to the number of + days since Jan 1, 1900 **) let date_to_int (d : Runtime.date) : int = - (* Alternatively, could expose this from Runtime as a (noop) coercion, but would allow to break - abstraction more easily elsewhere *) - let date : CalendarLib.Date.t = CalendarLib.Printer.Date.from_string (Runtime.date_to_string d) in + (* Alternatively, could expose this from Runtime as a (noop) coercion, but + would allow to break abstraction more easily elsewhere *) + let date : CalendarLib.Date.t = + CalendarLib.Printer.Date.from_string (Runtime.date_to_string d) + in let period = CalendarLib.Date.sub date base_day in CalendarLib.Date.Period.nb_days period -(** [date_of_year] translates a [year], represented as an integer into an OCaml date corresponding - to Jan 1st of the same year *) +(** [date_of_year] translates a [year], represented as an integer into an OCaml + date corresponding to Jan 1st of the same year *) let date_of_year (year : int) = Runtime.date_of_numbers year 1 1 -(** Returns the date (as a string) corresponding to nb days after the base day, defined here as Jan - 1, 1900 **) +(** Returns the date (as a string) corresponding to nb days after the base day, + defined here as Jan 1, 1900 **) let nb_days_to_date (nb : int) : string = CalendarLib.Printer.Date.to_string (CalendarLib.Date.add base_day (CalendarLib.Date.Period.day nb)) -(** [print_z3model_expr] pretty-prints the value [e] given by a Z3 model according to the Catala - type [ty], corresponding to [e] **) -let rec print_z3model_expr (ctx : context) (ty : typ Pos.marked) (e : Expr.expr) : string = +(** [print_z3model_expr] pretty-prints the value [e] given by a Z3 model + according to the Catala type [ty], corresponding to [e] **) +let rec print_z3model_expr (ctx : context) (ty : typ Pos.marked) (e : Expr.expr) + : string = let print_lit (ty : typ_lit) = match ty with (* TODO: Print boolean according to current language *) | TBool -> Expr.to_string e - (* TUnit is only used for the absence of an enum constructor argument. Hence, when - pretty-printing, we print nothing to remain closer from Catala sources *) + (* TUnit is only used for the absence of an enum constructor argument. + Hence, when pretty-printing, we print nothing to remain closer from + Catala sources *) | TUnit -> "" | TInt -> Expr.to_string e | TRat -> Arithmetic.Real.to_decimal_string e !Cli.max_prec_digits (* TODO: Print the right money symbol according to language *) | TMoney -> let z3_str = Expr.to_string e in - (* The Z3 model returns an integer corresponding to the amount of cents. We reformat it as - dollars *) - let to_dollars s = Runtime.money_to_string (Runtime.money_of_cents_string s) in + (* The Z3 model returns an integer corresponding to the amount of cents. + We reformat it as dollars *) + let to_dollars s = + Runtime.money_to_string (Runtime.money_of_cents_string s) + in if String.contains z3_str '-' then - Format.asprintf "-%s $" (to_dollars (String.sub z3_str 3 (String.length z3_str - 4))) + Format.asprintf "-%s $" + (to_dollars (String.sub z3_str 3 (String.length z3_str - 4))) else Format.asprintf "%s $" (to_dollars z3_str) - (* The Z3 date representation corresponds to the number of days since Jan 1, 1900. We - pretty-print it as the actual date *) + (* The Z3 date representation corresponds to the number of days since Jan 1, + 1900. We pretty-print it as the actual date *) (* TODO: Use differnt dates conventions depending on the language ? *) | TDate -> nb_days_to_date (int_of_string (Expr.to_string e)) - | TDuration -> failwith "[Z3 model]: Pretty-printing of duration literals not supported" + | TDuration -> + failwith + "[Z3 model]: Pretty-printing of duration literals not supported" in match Pos.unmark ty with @@ -142,14 +161,18 @@ let rec print_z3model_expr (ctx : context) (ty : typ Pos.marked) (e : Expr.expr) let fields = List.map2 (fun (fn, ty) e -> - Format.asprintf "-- %s : %s" (get_fieldname fn) (print_z3model_expr ctx ty e)) + Format.asprintf "-- %s : %s" (get_fieldname fn) + (print_z3model_expr ctx ty e)) s (Expr.get_args e) in let fields_str = String.concat " " fields in - Format.asprintf "%s { %s }" (Pos.unmark (StructName.get_info name)) fields_str - | TTuple (_, None) -> failwith "[Z3 model]: Pretty-printing of unnamed structs not supported" + Format.asprintf "%s { %s }" + (Pos.unmark (StructName.get_info name)) + fields_str + | TTuple (_, None) -> + failwith "[Z3 model]: Pretty-printing of unnamed structs not supported" | TEnum (_tys, name) -> (* The value associated to the enum is a single argument *) let e' = List.hd (Expr.get_args e) in @@ -159,7 +182,8 @@ let rec print_z3model_expr (ctx : context) (ty : typ Pos.marked) (e : Expr.expr) let enum_ctrs = EnumMap.find name ctx.ctx_decl.ctx_enums in let case = List.find - (fun (ctr, _) -> String.equal fd_name (Pos.unmark (EnumConstructor.get_info ctr))) + (fun (ctr, _) -> + String.equal fd_name (Pos.unmark (EnumConstructor.get_info ctr))) enum_ctrs in @@ -168,10 +192,11 @@ let rec print_z3model_expr (ctx : context) (ty : typ Pos.marked) (e : Expr.expr) | TArray _ -> failwith "[Z3 model]: Pretty-printing of arrays not supported" | TAny -> failwith "[Z3 model]: Pretty-printing of Any not supported" -(** [print_model] pretty prints a Z3 model, used to exhibit counter examples where verification - conditions are not satisfied. The context [ctx] is useful to retrieve the mapping between Z3 - variables and Catala variables, and to retrieve type information about the variables that was - lost during the translation (e.g., by translating a date to an integer) **) +(** [print_model] pretty prints a Z3 model, used to exhibit counter examples + where verification conditions are not satisfied. The context [ctx] is useful + to retrieve the mapping between Z3 variables and Catala variables, and to + retrieve type information about the variables that was lost during the + translation (e.g., by translating a date to an integer) **) let print_model (ctx : context) (model : Model.model) : string = let decls = Model.get_decls model in Format.asprintf "%a" @@ -182,32 +207,41 @@ let print_model (ctx : context) (model : Model.model) : string = (* Constant case *) match Model.get_const_interp model d with (* TODO: Better handling of this case *) - | None -> failwith "[Z3 model]: A variable does not have an associated Z3 solution" + | None -> + failwith + "[Z3 model]: A variable does not have an associated Z3 \ + solution" (* Print "name : value\n" *) | Some e -> let symbol_name = Symbol.to_string (FuncDecl.get_name d) in let v = StringMap.find symbol_name ctx.ctx_z3vars in Format.fprintf fmt "%s %s : %s" (Cli.with_style [ ANSITerminal.blue ] "%s" "-->") - (Cli.with_style [ ANSITerminal.yellow ] "%s" (Bindlib.name_of v)) + (Cli.with_style [ ANSITerminal.yellow ] "%s" + (Bindlib.name_of v)) (print_z3model_expr ctx (VarMap.find v ctx.ctx_var) e) else (* Declaration d is a function *) match Model.get_func_interp model d with (* TODO: Better handling of this case *) - | None -> failwith "[Z3 model]: A variable does not have an associated Z3 solution" + | None -> + failwith + "[Z3 model]: A variable does not have an associated Z3 \ + solution" (* Print "name : value\n" *) | Some f -> let symbol_name = Symbol.to_string (FuncDecl.get_name d) in let v = StringMap.find symbol_name ctx.ctx_z3vars in Format.fprintf fmt "%s %s : %s" (Cli.with_style [ ANSITerminal.blue ] "%s" "-->") - (Cli.with_style [ ANSITerminal.yellow ] "%s" (Bindlib.name_of v)) + (Cli.with_style [ ANSITerminal.yellow ] "%s" + (Bindlib.name_of v)) (* TODO: Model of a Z3 function should be pretty-printed *) (Model.FuncInterp.to_string f))) decls -(** [translate_typ_lit] returns the Z3 sort corresponding to the Catala literal type [t] **) +(** [translate_typ_lit] returns the Z3 sort corresponding to the Catala literal + type [t] **) let translate_typ_lit (ctx : context) (t : typ_lit) : Sort.sort = match t with | TBool -> Boolean.mk_sort ctx.ctx_z3 @@ -215,7 +249,8 @@ let translate_typ_lit (ctx : context) (t : typ_lit) : Sort.sort = | TInt -> Arithmetic.Integer.mk_sort ctx.ctx_z3 | TRat -> Arithmetic.Real.mk_sort ctx.ctx_z3 | TMoney -> Arithmetic.Integer.mk_sort ctx.ctx_z3 - (* Dates are encoded as integers, corresponding to the number of days since Jan 1, 1900 *) + (* Dates are encoded as integers, corresponding to the number of days since + Jan 1, 1900 *) | TDate -> Arithmetic.Integer.mk_sort ctx.ctx_z3 | TDuration -> failwith "[Z3 encoding] TDuration type not supported" @@ -224,34 +259,40 @@ let rec translate_typ (ctx : context) (t : typ) : context * Sort.sort = match t with | TLit t -> (ctx, translate_typ_lit ctx t) | TTuple (_, Some name) -> find_or_create_struct ctx name - | TTuple (_, None) -> failwith "[Z3 encoding] TTuple type of unnamed struct not supported" + | TTuple (_, None) -> + failwith "[Z3 encoding] TTuple type of unnamed struct not supported" | TEnum (_, e) -> find_or_create_enum ctx e | TArrow _ -> failwith "[Z3 encoding] TArrow type not supported" | TArray _ -> failwith "[Z3 encoding] TArray type not supported" | TAny -> failwith "[Z3 encoding] TAny type not supported" -(** [find_or_create_enum] attempts to retrieve the Z3 sort corresponding to the Catala enumeration - [enum]. If no such sort exists yet, it constructs it by creating a Z3 constructor for each - Catala constructor of [enum], and adds it to the context *) -and find_or_create_enum (ctx : context) (enum : EnumName.t) : context * Sort.sort = +(** [find_or_create_enum] attempts to retrieve the Z3 sort corresponding to the + Catala enumeration [enum]. If no such sort exists yet, it constructs it by + creating a Z3 constructor for each Catala constructor of [enum], and adds it + to the context *) +and find_or_create_enum (ctx : context) (enum : EnumName.t) : + context * Sort.sort = (* Creates a Z3 constructor corresponding to the Catala constructor [c] *) - let create_constructor (ctx : context) (c : EnumConstructor.t * typ Pos.marked) : + let create_constructor + (ctx : context) (c : EnumConstructor.t * typ Pos.marked) : context * Datatype.Constructor.constructor = let name, ty = c in let name = Pos.unmark (EnumConstructor.get_info name) in let ctx, arg_z3_ty = translate_typ ctx (Pos.unmark ty) in - (* The mk_constructor_s Z3 function is not so well documented. From my understanding, its - argument are: - a string corresponding to the name of the constructor - a recognizer as a - symbol corresponding to the name (unsure why) - a list of symbols corresponding to the - arguments of the constructor - a list of types, that must be of the same length as the list - of arguments - a list of sort_refs, of the same length as the list of arguments. I'm unsure - what this corresponds to *) + (* The mk_constructor_s Z3 function is not so well documented. From my + understanding, its argument are: - a string corresponding to the name of + the constructor - a recognizer as a symbol corresponding to the name + (unsure why) - a list of symbols corresponding to the arguments of the + constructor - a list of types, that must be of the same length as the + list of arguments - a list of sort_refs, of the same length as the list + of arguments. I'm unsure what this corresponds to *) ( ctx, Datatype.mk_constructor_s ctx.ctx_z3 name (Symbol.mk_string ctx.ctx_z3 name) - (* We need a name for the argument of the constructor, we arbitrary pick the name of the - constructor to which we append the special character "!" and the integer 0 *) + (* We need a name for the argument of the constructor, we arbitrary pick + the name of the constructor to which we append the special character + "!" and the integer 0 *) [ Symbol.mk_string ctx.ctx_z3 (name ^ "!0") ] (* The type of the argument, translated to a Z3 sort *) [ Some arg_z3_ty ] @@ -263,13 +304,19 @@ and find_or_create_enum (ctx : context) (enum : EnumName.t) : context * Sort.sor | None -> let ctrs = EnumMap.find enum ctx.ctx_decl.ctx_enums in let ctx, z3_ctrs = List.fold_left_map create_constructor ctx ctrs in - let z3_enum = Datatype.mk_sort_s ctx.ctx_z3 (Pos.unmark (EnumName.get_info enum)) z3_ctrs in + let z3_enum = + Datatype.mk_sort_s ctx.ctx_z3 + (Pos.unmark (EnumName.get_info enum)) + z3_ctrs + in (add_z3enum enum z3_enum ctx, z3_enum) -(** [find_or_create_struct] attemps to retrieve the Z3 sort corresponding to the struct [s]. If no - such sort exists yet, we construct it as a datatype with one constructor taking all the fields - as arguments, and add it to the context *) -and find_or_create_struct (ctx : context) (s : StructName.t) : context * Sort.sort = +(** [find_or_create_struct] attemps to retrieve the Z3 sort corresponding to the + struct [s]. If no such sort exists yet, we construct it as a datatype with + one constructor taking all the fields as arguments, and add it to the + context *) +and find_or_create_struct (ctx : context) (s : StructName.t) : + context * Sort.sort = match StructMap.find_opt s ctx.ctx_z3structs with | Some s -> (ctx, s) | None -> @@ -277,11 +324,15 @@ and find_or_create_struct (ctx : context) (s : StructName.t) : context * Sort.so let fields = StructMap.find s ctx.ctx_decl.ctx_structs in let z3_fieldnames = List.map - (fun f -> Pos.unmark (StructFieldName.get_info (fst f)) |> Symbol.mk_string ctx.ctx_z3) + (fun f -> + Pos.unmark (StructFieldName.get_info (fst f)) + |> Symbol.mk_string ctx.ctx_z3) fields in let ctx, z3_fieldtypes = - List.fold_left_map (fun ctx f -> Pos.unmark (snd f) |> translate_typ ctx) ctx fields + List.fold_left_map + (fun ctx f -> Pos.unmark (snd f) |> translate_typ ctx) + ctx fields in let z3_sortrefs = List.map Sort.get_id z3_fieldtypes in let mk_struct_s = "mk!" ^ s_name in @@ -296,25 +347,33 @@ and find_or_create_struct (ctx : context) (s : StructName.t) : context * Sort.so let z3_struct = Datatype.mk_sort_s ctx.ctx_z3 s_name [ z3_mk_struct ] in (add_z3struct s z3_struct ctx, z3_struct) -(** [translate_lit] returns the Z3 expression as a literal corresponding to [lit] **) +(** [translate_lit] returns the Z3 expression as a literal corresponding to + [lit] **) let translate_lit (ctx : context) (l : lit) : Expr.expr = match l with - | LBool b -> if b then Boolean.mk_true ctx.ctx_z3 else Boolean.mk_false ctx.ctx_z3 + | LBool b -> + if b then Boolean.mk_true ctx.ctx_z3 else Boolean.mk_false ctx.ctx_z3 | LEmptyError -> failwith "[Z3 encoding] LEmptyError literals not supported" - | LInt n -> Arithmetic.Integer.mk_numeral_i ctx.ctx_z3 (Runtime.integer_to_int n) - | LRat r -> Arithmetic.Real.mk_numeral_s ctx.ctx_z3 (string_of_float (Runtime.decimal_to_float r)) + | LInt n -> + Arithmetic.Integer.mk_numeral_i ctx.ctx_z3 (Runtime.integer_to_int n) + | LRat r -> + Arithmetic.Real.mk_numeral_s ctx.ctx_z3 + (string_of_float (Runtime.decimal_to_float r)) | LMoney m -> let z3_m = Runtime.integer_to_int (Runtime.money_to_cents m) in Arithmetic.Integer.mk_numeral_i ctx.ctx_z3 z3_m | LUnit -> failwith "[Z3 encoding] LUnit literals not supported" - (* Encoding a date as an integer corresponding to the number of days since Jan 1, 1900 *) + (* Encoding a date as an integer corresponding to the number of days since Jan + 1, 1900 *) | LDate d -> Arithmetic.Integer.mk_numeral_i ctx.ctx_z3 (date_to_int d) | LDuration _ -> failwith "[Z3 encoding] LDuration literals not supported" -(** [find_or_create_funcdecl] attempts to retrieve the Z3 function declaration corresponding to the - variable [v]. If no such function declaration exists yet, we construct it and add it to the - context, thus requiring to return a new context *) -let find_or_create_funcdecl (ctx : context) (v : Var.t) : context * FuncDecl.func_decl = +(** [find_or_create_funcdecl] attempts to retrieve the Z3 function declaration + corresponding to the variable [v]. If no such function declaration exists + yet, we construct it and add it to the context, thus requiring to return a + new context *) +let find_or_create_funcdecl (ctx : context) (v : Var.t) : + context * FuncDecl.func_decl = match VarMap.find_opt v ctx.ctx_funcdecl with | Some fd -> (ctx, fd) | None -> ( @@ -331,14 +390,17 @@ let find_or_create_funcdecl (ctx : context) (v : Var.t) : context * FuncDecl.fun (ctx, fd) | TAny -> failwith - "[Z3 Encoding] A function being applied has type TAny, the type was not fully inferred" + "[Z3 Encoding] A function being applied has type TAny, the type \ + was not fully inferred" | _ -> failwith - "[Z3 Encoding] Ill-formed VC, a function application does not have a function type") + "[Z3 Encoding] Ill-formed VC, a function application does not have \ + a function type") -(** [translate_op] returns the Z3 expression corresponding to the application of [op] to the - arguments [args] **) -let rec translate_op (ctx : context) (op : operator) (args : expr Pos.marked list) : +(** [translate_op] returns the Z3 expression corresponding to the application of + [op] to the arguments [args] **) +let rec translate_op + (ctx : context) (op : operator) (args : expr Pos.marked list) : context * Expr.expr = match op with | Ternop _top -> @@ -347,7 +409,8 @@ let rec translate_op (ctx : context) (op : operator) (args : expr Pos.marked lis | [ e1; e2; e3 ] -> (e1, e2, e3) | _ -> failwith - (Format.asprintf "[Z3 encoding] Ill-formed ternary operator application: %a" + (Format.asprintf + "[Z3 encoding] Ill-formed ternary operator application: %a" (Print.format_expr ctx.ctx_decl) (EApp ((EOp op, Pos.no_pos), args), Pos.no_pos)) in @@ -356,41 +419,61 @@ let rec translate_op (ctx : context) (op : operator) (args : expr Pos.marked lis | Binop bop -> ( (* Special case for GetYear comparisons *) match (bop, args) with - | Lt KInt, [ (EApp ((EOp (Unop GetYear), _), [ e1 ]), _); (ELit (LInt n), _) ] -> + | ( Lt KInt, + [ (EApp ((EOp (Unop GetYear), _), [ e1 ]), _); (ELit (LInt n), _) ] ) + -> let n = Runtime.integer_to_int n in let ctx, e1 = translate_expr ctx e1 in - let e2 = Arithmetic.Integer.mk_numeral_i ctx.ctx_z3 (date_to_int (date_of_year n)) in - (* e2 corresponds to the first day of the year n. GetYear e1 < e2 can thus be directly - translated as < in the Z3 encoding using the number of days *) + let e2 = + Arithmetic.Integer.mk_numeral_i ctx.ctx_z3 + (date_to_int (date_of_year n)) + in + (* e2 corresponds to the first day of the year n. GetYear e1 < e2 can + thus be directly translated as < in the Z3 encoding using the + number of days *) (ctx, Arithmetic.mk_lt ctx.ctx_z3 e1 e2) - | Lte KInt, [ (EApp ((EOp (Unop GetYear), _), [ e1 ]), _); (ELit (LInt n), _) ] -> + | ( Lte KInt, + [ (EApp ((EOp (Unop GetYear), _), [ e1 ]), _); (ELit (LInt n), _) ] ) + -> let n = Runtime.integer_to_int n in let ctx, e1 = translate_expr ctx e1 in let nb_days = if CalendarLib.Date.is_leap_year n then 365 else 364 in - (* We want that the year corresponding to e1 is smaller or equal to n. We encode this as - the day corresponding to e1 is smaller or equal than the last day of the year [n], - which is Jan 1st + 365 days if [n] is a leap year, Jan 1st + 364 else *) + (* We want that the year corresponding to e1 is smaller or equal to n. + We encode this as the day corresponding to e1 is smaller or equal + than the last day of the year [n], which is Jan 1st + 365 days if + [n] is a leap year, Jan 1st + 364 else *) let e2 = - Arithmetic.Integer.mk_numeral_i ctx.ctx_z3 (date_to_int (date_of_year n) + nb_days) + Arithmetic.Integer.mk_numeral_i ctx.ctx_z3 + (date_to_int (date_of_year n) + nb_days) in (ctx, Arithmetic.mk_le ctx.ctx_z3 e1 e2) - | Gt KInt, [ (EApp ((EOp (Unop GetYear), _), [ e1 ]), _); (ELit (LInt n), _) ] -> + | ( Gt KInt, + [ (EApp ((EOp (Unop GetYear), _), [ e1 ]), _); (ELit (LInt n), _) ] ) + -> let n = Runtime.integer_to_int n in let ctx, e1 = translate_expr ctx e1 in let nb_days = if CalendarLib.Date.is_leap_year n then 365 else 364 in - (* We want that the year corresponding to e1 is greater to n. We encode this as the day - corresponding to e1 is greater than the last day of the year [n], which is Jan 1st + - 365 days if [n] is a leap year, Jan 1st + 364 else *) + (* We want that the year corresponding to e1 is greater to n. We + encode this as the day corresponding to e1 is greater than the last + day of the year [n], which is Jan 1st + 365 days if [n] is a leap + year, Jan 1st + 364 else *) let e2 = - Arithmetic.Integer.mk_numeral_i ctx.ctx_z3 (date_to_int (date_of_year n) + nb_days) + Arithmetic.Integer.mk_numeral_i ctx.ctx_z3 + (date_to_int (date_of_year n) + nb_days) in (ctx, Arithmetic.mk_gt ctx.ctx_z3 e1 e2) - | Gte KInt, [ (EApp ((EOp (Unop GetYear), _), [ e1 ]), _); (ELit (LInt n), _) ] -> + | ( Gte KInt, + [ (EApp ((EOp (Unop GetYear), _), [ e1 ]), _); (ELit (LInt n), _) ] ) + -> let n = Runtime.integer_to_int n in let ctx, e1 = translate_expr ctx e1 in - let e2 = Arithmetic.Integer.mk_numeral_i ctx.ctx_z3 (date_to_int (date_of_year n)) in - (* e2 corresponds to the first day of the year n. GetYear e1 >= e2 can thus be directly - translated as >= in the Z3 encoding using the number of days *) + let e2 = + Arithmetic.Integer.mk_numeral_i ctx.ctx_z3 + (date_to_int (date_of_year n)) + in + (* e2 corresponds to the first day of the year n. GetYear e1 >= e2 can + thus be directly translated as >= in the Z3 encoding using the + number of days *) (ctx, Arithmetic.mk_ge ctx.ctx_z3 e1 e2) | _ -> ( let ctx, e1, e2 = @@ -401,7 +484,8 @@ let rec translate_op (ctx : context) (op : operator) (args : expr Pos.marked lis (ctx, e1, e2) | _ -> failwith - (Format.asprintf "[Z3 encoding] Ill-formed binary operator application: %a" + (Format.asprintf + "[Z3 encoding] Ill-formed binary operator application: %a" (Print.format_expr ctx.ctx_decl) (EApp ((EOp op, Pos.no_pos), args), Pos.no_pos)) in @@ -410,67 +494,111 @@ let rec translate_op (ctx : context) (op : operator) (args : expr Pos.marked lis | And -> (ctx, Boolean.mk_and ctx.ctx_z3 [ e1; e2 ]) | Or -> (ctx, Boolean.mk_or ctx.ctx_z3 [ e1; e2 ]) | Xor -> (ctx, Boolean.mk_xor ctx.ctx_z3 e1 e2) - | Add KInt | Add KRat | Add KMoney -> (ctx, Arithmetic.mk_add ctx.ctx_z3 [ e1; e2 ]) + | Add KInt | Add KRat | Add KMoney -> + (ctx, Arithmetic.mk_add ctx.ctx_z3 [ e1; e2 ]) | Add _ -> - failwith "[Z3 encoding] application of non-integer binary operator Add not supported" - | Sub KInt | Sub KRat | Sub KMoney -> (ctx, Arithmetic.mk_sub ctx.ctx_z3 [ e1; e2 ]) + failwith + "[Z3 encoding] application of non-integer binary operator Add \ + not supported" + | Sub KInt | Sub KRat | Sub KMoney -> + (ctx, Arithmetic.mk_sub ctx.ctx_z3 [ e1; e2 ]) | Sub _ -> - failwith "[Z3 encoding] application of non-integer binary operator Sub not supported" - | Mult KInt | Mult KRat | Mult KMoney -> (ctx, Arithmetic.mk_mul ctx.ctx_z3 [ e1; e2 ]) + failwith + "[Z3 encoding] application of non-integer binary operator Sub \ + not supported" + | Mult KInt | Mult KRat | Mult KMoney -> + (ctx, Arithmetic.mk_mul ctx.ctx_z3 [ e1; e2 ]) | Mult _ -> - failwith "[Z3 encoding] application of non-integer binary operator Mult not supported" - | Div KInt | Div KRat | Div KMoney -> (ctx, Arithmetic.mk_div ctx.ctx_z3 e1 e2) + failwith + "[Z3 encoding] application of non-integer binary operator Mult \ + not supported" + | Div KInt | Div KRat | Div KMoney -> + (ctx, Arithmetic.mk_div ctx.ctx_z3 e1 e2) | Div _ -> - failwith "[Z3 encoding] application of non-integer binary operator Div not supported" - | Lt KInt | Lt KRat | Lt KMoney | Lt KDate -> (ctx, Arithmetic.mk_lt ctx.ctx_z3 e1 e2) + failwith + "[Z3 encoding] application of non-integer binary operator Div \ + not supported" + | Lt KInt | Lt KRat | Lt KMoney | Lt KDate -> + (ctx, Arithmetic.mk_lt ctx.ctx_z3 e1 e2) | Lt _ -> failwith - "[Z3 encoding] application of non-integer or money binary operator Lt not supported" - | Lte KInt | Lte KRat | Lte KMoney | Lte KDate -> (ctx, Arithmetic.mk_le ctx.ctx_z3 e1 e2) + "[Z3 encoding] application of non-integer or money binary \ + operator Lt not supported" + | Lte KInt | Lte KRat | Lte KMoney | Lte KDate -> + (ctx, Arithmetic.mk_le ctx.ctx_z3 e1 e2) | Lte _ -> failwith - "[Z3 encoding] application of non-integer or money binary operator Lte not \ - supported" - | Gt KInt | Gt KRat | Gt KMoney | Gt KDate -> (ctx, Arithmetic.mk_gt ctx.ctx_z3 e1 e2) + "[Z3 encoding] application of non-integer or money binary \ + operator Lte not supported" + | Gt KInt | Gt KRat | Gt KMoney | Gt KDate -> + (ctx, Arithmetic.mk_gt ctx.ctx_z3 e1 e2) | Gt _ -> failwith - "[Z3 encoding] application of non-integer or money binary operator Gt not supported" - | Gte KInt | Gte KRat | Gte KMoney | Gte KDate -> (ctx, Arithmetic.mk_ge ctx.ctx_z3 e1 e2) + "[Z3 encoding] application of non-integer or money binary \ + operator Gt not supported" + | Gte KInt | Gte KRat | Gte KMoney | Gte KDate -> + (ctx, Arithmetic.mk_ge ctx.ctx_z3 e1 e2) | Gte _ -> failwith - "[Z3 encoding] application of non-integer or money binary operator Gte not \ - supported" + "[Z3 encoding] application of non-integer or money binary \ + operator Gte not supported" | Eq -> (ctx, Boolean.mk_eq ctx.ctx_z3 e1 e2) - | Neq -> (ctx, Boolean.mk_not ctx.ctx_z3 (Boolean.mk_eq ctx.ctx_z3 e1 e2)) - | Map -> failwith "[Z3 encoding] application of binary operator Map not supported" - | Concat -> failwith "[Z3 encoding] application of binary operator Concat not supported" - | Filter -> failwith "[Z3 encoding] application of binary operator Filter not supported")) + | Neq -> + (ctx, Boolean.mk_not ctx.ctx_z3 (Boolean.mk_eq ctx.ctx_z3 e1 e2)) + | Map -> + failwith + "[Z3 encoding] application of binary operator Map not supported" + | Concat -> + failwith + "[Z3 encoding] application of binary operator Concat not \ + supported" + | Filter -> + failwith + "[Z3 encoding] application of binary operator Filter not \ + supported")) | Unop uop -> ( let ctx, e1 = match args with | [ e1 ] -> translate_expr ctx e1 | _ -> failwith - (Format.asprintf "[Z3 encoding] Ill-formed unary operator application: %a" + (Format.asprintf + "[Z3 encoding] Ill-formed unary operator application: %a" (Print.format_expr ctx.ctx_decl) (EApp ((EOp op, Pos.no_pos), args), Pos.no_pos)) in match uop with | Not -> (ctx, Boolean.mk_not ctx.ctx_z3 e1) - | Minus _ -> failwith "[Z3 encoding] application of unary operator Minus not supported" + | Minus _ -> + failwith + "[Z3 encoding] application of unary operator Minus not supported" (* Omitting the log from the VC *) | Log _ -> (ctx, e1) - | Length -> failwith "[Z3 encoding] application of unary operator Length not supported" - | IntToRat -> failwith "[Z3 encoding] application of unary operator IntToRat not supported" - | GetDay -> failwith "[Z3 encoding] application of unary operator GetDay not supported" - | GetMonth -> failwith "[Z3 encoding] application of unary operator GetMonth not supported" + | Length -> + failwith + "[Z3 encoding] application of unary operator Length not supported" + | IntToRat -> + failwith + "[Z3 encoding] application of unary operator IntToRat not supported" + | GetDay -> + failwith + "[Z3 encoding] application of unary operator GetDay not supported" + | GetMonth -> + failwith + "[Z3 encoding] application of unary operator GetMonth not supported" | GetYear -> - failwith "[Z3 encoding] GetYear operator only supported in comparisons with literal") + failwith + "[Z3 encoding] GetYear operator only supported in comparisons with \ + literal") -(** [translate_expr] translate the expression [vc] to its corresponding Z3 expression **) -and translate_expr (ctx : context) (vc : expr Pos.marked) : context * Expr.expr = - let translate_match_arm (head : Expr.expr) (ctx : context) +(** [translate_expr] translate the expression [vc] to its corresponding Z3 + expression **) +and translate_expr (ctx : context) (vc : expr Pos.marked) : context * Expr.expr + = + let translate_match_arm + (head : Expr.expr) + (ctx : context) (e : expr Pos.marked * FuncDecl.func_decl list) : context * Expr.expr = let e, accessors = e in match Pos.unmark e with @@ -482,8 +610,8 @@ and translate_expr (ctx : context) (vc : expr Pos.marked) : context * Expr.expr (* Invariant: Catala enums always have exactly one argument *) let accessor = List.hd accessors in let proj = Expr.mk_app ctx.ctx_z3 accessor [ head ] in - (* The fresh variable should be substituted by a projection into the enum in the body, we - add this to the context *) + (* The fresh variable should be substituted by a projection into the + enum in the body, we add this to the context *) let ctx = add_z3matchsubst fresh_v proj ctx in let body = Bindlib.msubst (Pos.unmark e) [| fresh_e |] in @@ -496,7 +624,8 @@ and translate_expr (ctx : context) (vc : expr Pos.marked) : context * Expr.expr | EVar v -> ( match VarMap.find_opt (Pos.unmark v) ctx.ctx_z3matchsubsts with | None -> - (* We are in the standard case, where this is a true Catala variable *) + (* We are in the standard case, where this is a true Catala + variable *) let v = Pos.unmark v in let t = VarMap.find v ctx.ctx_var in let name = unique_name v in @@ -504,20 +633,23 @@ and translate_expr (ctx : context) (vc : expr Pos.marked) : context * Expr.expr let ctx, ty = translate_typ ctx (Pos.unmark t) in (ctx, Expr.mk_const_s ctx.ctx_z3 name ty) | Some e -> - (* This variable is a temporary variable generated during VC translation of a match. It - actually corresponds to applying an accessor to an enum, the corresponding Z3 - expression was previously stored in the context *) + (* This variable is a temporary variable generated during VC + translation of a match. It actually corresponds to applying an + accessor to an enum, the corresponding Z3 expression was previously + stored in the context *) (ctx, e)) | ETuple _ -> failwith "[Z3 encoding] ETuple unsupported" | ETupleAccess (s, idx, oname, _tys) -> let name = match oname with - | None -> failwith "[Z3 encoding]: ETupleAccess of unnamed struct unsupported" + | None -> + failwith "[Z3 encoding]: ETupleAccess of unnamed struct unsupported" | Some n -> n in let ctx, z3_struct = find_or_create_struct ctx name in - (* This datatype should have only one constructor, corresponding to mk_struct. The accessors - of this constructor correspond to the field accesses *) + (* This datatype should have only one constructor, corresponding to + mk_struct. The accessors of this constructor correspond to the field + accesses *) let accessors = List.hd (Datatype.get_accessors z3_struct) in let accessor = List.nth accessors idx in let ctx, s = translate_expr ctx s in @@ -527,7 +659,9 @@ and translate_expr (ctx : context) (vc : expr Pos.marked) : context * Expr.expr let ctx, z3_enum = find_or_create_enum ctx enum in let ctx, z3_arg = translate_expr ctx arg in let _ctx, z3_arms = - List.fold_left_map (translate_match_arm z3_arg) ctx + List.fold_left_map + (translate_match_arm z3_arg) + ctx (List.combine arms (Datatype.get_accessors z3_enum)) in let z3_arms = @@ -548,8 +682,8 @@ and translate_expr (ctx : context) (vc : expr Pos.marked) : context * Expr.expr | EOp op -> translate_op ctx op args | EVar v -> let ctx, fd = find_or_create_funcdecl ctx (Pos.unmark v) in - (* Fold_right to preserve the order of the arguments: The head argument is appended at the - head *) + (* Fold_right to preserve the order of the arguments: The head + argument is appended at the head *) let ctx, z3_args = List.fold_right (fun arg (ctx, acc) -> @@ -560,8 +694,8 @@ and translate_expr (ctx : context) (vc : expr Pos.marked) : context * Expr.expr (ctx, Expr.mk_app ctx.ctx_z3 fd z3_args) | _ -> failwith - "[Z3 encoding] EApp node: Catala function calls should only include operators or \ - function names") + "[Z3 encoding] EApp node: Catala function calls should only \ + include operators or function names") | EAssert _ -> failwith "[Z3 encoding] EAssert unsupported" | EOp _ -> failwith "[Z3 encoding] EOp unsupported" | EDefault _ -> failwith "[Z3 encoding] EDefault unsupported" @@ -574,12 +708,15 @@ and translate_expr (ctx : context) (vc : expr Pos.marked) : context * Expr.expr Boolean.mk_and ctx.ctx_z3 [ Boolean.mk_implies ctx.ctx_z3 z3_if z3_then; - Boolean.mk_implies ctx.ctx_z3 (Boolean.mk_not ctx.ctx_z3 z3_if) z3_else; + Boolean.mk_implies ctx.ctx_z3 + (Boolean.mk_not ctx.ctx_z3 z3_if) + z3_else; ] ) | ErrorOnEmpty _ -> failwith "[Z3 encoding] ErrorOnEmpty unsupported" -(** [create_z3unit] creates a Z3 sort and expression corresponding to the unit type and value - respectively. Concretely, we represent unit as a tuple with 0 elements **) +(** [create_z3unit] creates a Z3 sort and expression corresponding to the unit + type and value respectively. Concretely, we represent unit as a tuple with 0 + elements **) let create_z3unit (ctx : Z3.context) : Z3.context * (Sort.sort * Expr.expr) = let unit_sort = Tuple.mk_sort ctx (Symbol.mk_string ctx "unit") [] [] in let mk_unit = Tuple.get_mk_decl unit_sort in @@ -588,16 +725,15 @@ let create_z3unit (ctx : Z3.context) : Z3.context * (Sort.sort * Expr.expr) = module Backend = struct type backend_context = context - type vc_encoding = Z3.Expr.expr let print_encoding (vc : vc_encoding) : string = Expr.to_string vc type model = Z3.Model.model - type solver_result = ProvenTrue | ProvenFalse of model option | Unknown - let solve_vc_encoding (ctx : backend_context) (encoding : vc_encoding) : solver_result = + let solve_vc_encoding (ctx : backend_context) (encoding : vc_encoding) : + solver_result = let solver = Z3.Solver.mk_solver ctx.ctx_z3 None in Z3.Solver.add solver [ Boolean.mk_not ctx.ctx_z3 encoding ]; match Z3.Solver.check solver [] with @@ -605,18 +741,23 @@ module Backend = struct | SATISFIABLE -> ProvenFalse (Z3.Solver.get_model solver) | UNKNOWN -> Unknown - let print_model (ctx : backend_context) (m : model) : string = print_model ctx m + let print_model (ctx : backend_context) (m : model) : string = + print_model ctx m let is_model_empty (m : model) : bool = List.length (Z3.Model.get_decls m) = 0 - let translate_expr (ctx : backend_context) (e : Dcalc.Ast.expr Pos.marked) = translate_expr ctx e + let translate_expr (ctx : backend_context) (e : Dcalc.Ast.expr Pos.marked) = + translate_expr ctx e - let init_backend () = Cli.debug_print "Running Z3 version %s" Version.to_string + let init_backend () = + Cli.debug_print "Running Z3 version %s" Version.to_string - let make_context (decl_ctx : decl_ctx) (free_vars_typ : typ Pos.marked VarMap.t) : backend_context - = + let make_context + (decl_ctx : decl_ctx) (free_vars_typ : typ Pos.marked VarMap.t) : + backend_context = let cfg = - (if !Cli.disable_counterexamples then [] else [ ("model", "true") ]) @ [ ("proof", "false") ] + (if !Cli.disable_counterexamples then [] else [ ("model", "true") ]) + @ [ ("proof", "false") ] in let z3_ctx = mk_context cfg in let z3_ctx, z3unit = create_z3unit z3_ctx in diff --git a/compiler/verification/z3backend.mli b/compiler/verification/z3backend.mli index 6bc1eb04..e43807b0 100644 --- a/compiler/verification/z3backend.mli +++ b/compiler/verification/z3backend.mli @@ -1,15 +1,18 @@ -(* This file is part of the Catala compiler, a specification language for tax and social benefits - computation rules. Copyright (C) 2022 Inria, contributor: Aymeric Fromherz - , Denis Merigoux +(* This file is part of the Catala compiler, a specification language for tax + and social benefits computation rules. Copyright (C) 2022 Inria, contributor: + Aymeric Fromherz , Denis Merigoux + - 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 + 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 + 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. *) (** Interfacing with the Z3 SMT solver *) diff --git a/french_law/ocaml/api.ml b/french_law/ocaml/api.ml index 46814c97..c588048d 100644 --- a/french_law/ocaml/api.ml +++ b/french_law/ocaml/api.ml @@ -1,24 +1,31 @@ -(* This file is part of the French law library, a collection of functions for computing French taxes - and benefits derived from Catala programs. Copyright (C) 2021 Inria, contributor: Denis Merigoux - +(* This file is part of the French law library, a collection of functions for + computing French taxes and benefits derived from Catala programs. Copyright + (C) 2021 Inria, contributor: Denis Merigoux - 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 + 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 + 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. *) module Allocations_familiales = Law_source.Allocations_familiales module AF = Allocations_familiales open Runtime -let compute_allocations_familiales ~(current_date : Runtime.date) - ~(children : AF.enfant_entree array) ~(income : int) ~(residence : AF.collectivite) - ~(is_parent : bool) ~(fills_title_I : bool) ~(had_rights_open_before_2012 : bool) : float = +let compute_allocations_familiales + ~(current_date : Runtime.date) + ~(children : AF.enfant_entree array) + ~(income : int) + ~(residence : AF.collectivite) + ~(is_parent : bool) + ~(fills_title_I : bool) + ~(had_rights_open_before_2012 : bool) : float = let result = AF.interface_allocations_familiales { @@ -27,8 +34,10 @@ let compute_allocations_familiales ~(current_date : Runtime.date) AF.i_ressources_menage_in = money_of_units_int income; AF.i_residence_in = residence; AF.i_personne_charge_effective_permanente_est_parent_in = is_parent; - AF.i_personne_charge_effective_permanente_remplit_titre_I_in = fills_title_I; - AF.i_avait_enfant_a_charge_avant_1er_janvier_2012_in = had_rights_open_before_2012; + AF.i_personne_charge_effective_permanente_remplit_titre_I_in = + fills_title_I; + AF.i_avait_enfant_a_charge_avant_1er_janvier_2012_in = + had_rights_open_before_2012; } in money_to_float result.AF.i_montant_verse_out diff --git a/french_law/ocaml/api.mli b/french_law/ocaml/api.mli index daa4fa99..550a64e2 100644 --- a/french_law/ocaml/api.mli +++ b/french_law/ocaml/api.mli @@ -1,15 +1,17 @@ -(* This file is part of the French law library, a collection of functions for computing French taxes - and benefits derived from Catala programs. Copyright (C) 2021 Inria, contributor: Denis Merigoux - +(* This file is part of the French law library, a collection of functions for + computing French taxes and benefits derived from Catala programs. Copyright + (C) 2021 Inria, contributor: Denis Merigoux - 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 + 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 + 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. *) module Allocations_familiales = Law_source.Allocations_familiales diff --git a/french_law/ocaml/api_web.ml b/french_law/ocaml/api_web.ml index bd086c3c..c7f99369 100644 --- a/french_law/ocaml/api_web.ml +++ b/french_law/ocaml/api_web.ml @@ -1,15 +1,17 @@ -(* This file is part of the French law library, a collection of functions for computing French taxes - and benefits derived from Catala programs. Copyright (C) 2021 Inria, contributor: Denis Merigoux - +(* This file is part of the French law library, a collection of functions for + computing French taxes and benefits derived from Catala programs. Copyright + (C) 2021 Inria, contributor: Denis Merigoux - 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 + 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 + 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. *) module Allocations_familiales = Law_source.Allocations_familiales @@ -20,13 +22,9 @@ open Js_of_ocaml class type enfant_entree = object method id : int Js.readonly_prop - method remunerationMensuelle : int Js.readonly_prop - method dateNaissance : Js.date Js.t Js.readonly_prop - method gardeAlternee : bool Js.t Js.readonly_prop - method gardeAlterneePartageAllocation : bool Js.t Js.readonly_prop method priseEnCharge : Js.js_string Js.t Js.readonly_prop @@ -44,42 +42,33 @@ class type enfant_entree = class type allocations_familiales_input = object method currentDate : Js.date Js.t Js.readonly_prop - method children : enfant_entree Js.t Js.js_array Js.t Js.readonly_prop - method income : int Js.readonly_prop - method residence : Js.js_string Js.t Js.readonly_prop - method personneQuiAssumeLaChargeEffectivePermanenteEstParent : bool Js.t Js.readonly_prop + method personneQuiAssumeLaChargeEffectivePermanenteEstParent : + bool Js.t Js.readonly_prop - method personneQuiAssumeLaChargeEffectivePermanenteRemplitConditionsTitreISecuriteSociale : + method + personneQuiAssumeLaChargeEffectivePermanenteRemplitConditionsTitreISecuriteSociale : bool Js.t Js.readonly_prop end class type source_position = object method fileName : Js.js_string Js.t Js.prop - method startLine : int Js.prop - method endLine : int Js.prop - method startColumn : int Js.prop - method endColumn : int Js.prop - method lawHeadings : Js.js_string Js.t Js.js_array Js.t Js.prop end class type log_event = object method eventType : Js.js_string Js.t Js.prop - method information : Js.js_string Js.t Js.js_array Js.t Js.prop - method sourcePosition : source_position Js.t Js.optdef Js.prop - method loggedValue : Js.Unsafe.any Js.prop end @@ -102,13 +91,17 @@ let rec embed_to_js (v : runtime_value) : Js.Unsafe.any = Js.Unsafe.inject date | Duration d -> let days, months, years = duration_to_years_months_days d in - Js.Unsafe.inject (Js.string (Printf.sprintf "%dD%dM%dY" days months years)) + Js.Unsafe.inject + (Js.string (Printf.sprintf "%dD%dM%dY" days months years)) | Struct (name, fields) -> Js.Unsafe.inject (object%js val mutable structName = - if List.length name = 1 then Js.Unsafe.inject (Js.string (List.hd name)) - else Js.Unsafe.inject (Js.array (Array.of_list (List.map Js.string name))) + if List.length name = 1 then + Js.Unsafe.inject (Js.string (List.hd name)) + else + Js.Unsafe.inject + (Js.array (Array.of_list (List.map Js.string name))) val mutable structFields = Js.Unsafe.inject @@ -117,9 +110,11 @@ let rec embed_to_js (v : runtime_value) : Js.Unsafe.any = (List.map (fun (name, v) -> object%js - val mutable fieldName = Js.Unsafe.inject (Js.string name) + val mutable fieldName = + Js.Unsafe.inject (Js.string name) - val mutable fieldValue = Js.Unsafe.inject (embed_to_js v) + val mutable fieldValue = + Js.Unsafe.inject (embed_to_js v) end) fields))) end) @@ -127,11 +122,13 @@ let rec embed_to_js (v : runtime_value) : Js.Unsafe.any = Js.Unsafe.inject (object%js val mutable enumName = - if List.length name = 1 then Js.Unsafe.inject (Js.string (List.hd name)) - else Js.Unsafe.inject (Js.array (Array.of_list (List.map Js.string name))) + if List.length name = 1 then + Js.Unsafe.inject (Js.string (List.hd name)) + else + Js.Unsafe.inject + (Js.array (Array.of_list (List.map Js.string name))) val mutable enumCase = Js.Unsafe.inject (Js.string case) - val mutable enumPayload = Js.Unsafe.inject (embed_to_js v) end) | Array vs -> Js.Unsafe.inject (Js.array (Array.map embed_to_js vs)) @@ -142,7 +139,8 @@ let _ = (object%js method resetLog : (unit -> unit) Js.callback = Js.wrap_callback reset_log - method retrieveLog : (unit -> log_event Js.t Js.js_array Js.t) Js.callback = + method retrieveLog + : (unit -> log_event Js.t Js.js_array Js.t) Js.callback = Js.wrap_callback (fun () -> Js.array (Array.of_list @@ -161,7 +159,9 @@ let _ = Js.array (Array.of_list (match evt with - | BeginCall info | EndCall info | VariableDefinition (info, _) -> + | BeginCall info + | EndCall info + | VariableDefinition (info, _) -> List.map Js.string info | DecisionTaken _ -> [])) @@ -176,18 +176,18 @@ let _ = | DecisionTaken pos -> Js.def (object%js - val mutable fileName = Js.string pos.filename + val mutable fileName = + Js.string pos.filename val mutable startLine = pos.start_line - val mutable endLine = pos.end_line - val mutable startColumn = pos.start_column - val mutable endColumn = pos.end_column val mutable lawHeadings = - Js.array (Array.of_list (List.map Js.string pos.law_headings)) + Js.array + (Array.of_list + (List.map Js.string pos.law_headings)) end) | _ -> Js.undefined end) @@ -200,7 +200,8 @@ let _ = AF.interface_allocations_familiales { AF.i_personne_charge_effective_permanente_est_parent_in = - Js.to_bool input##.personneQuiAssumeLaChargeEffectivePermanenteEstParent; + Js.to_bool + input##.personneQuiAssumeLaChargeEffectivePermanenteEstParent; AF.i_personne_charge_effective_permanente_remplit_titre_I_in = Js.to_bool input##.personneQuiAssumeLaChargeEffectivePermanenteRemplitConditionsTitreISecuriteSociale; @@ -214,7 +215,8 @@ let _ = (fun (child : enfant_entree Js.t) -> { AF.d_a_deja_ouvert_droit_aux_allocations_familiales = - Js.to_bool child##.aDejaOuvertDroitAuxAllocationsFamiliales; + Js.to_bool + child##.aDejaOuvertDroitAuxAllocationsFamiliales; AF.d_identifiant = integer_of_int child##.id; AF.d_date_de_naissance = date_of_numbers @@ -223,16 +225,19 @@ let _ = child##.dateNaissance##getUTCDate; AF.d_prise_en_charge = (match Js.to_string child##.priseEnCharge with - | "Effective et permanente" -> EffectiveEtPermanente () + | "Effective et permanente" -> + EffectiveEtPermanente () | "Garde alternée, allocataire unique" -> GardeAlterneeAllocataireUnique () | "Garde alternée, partage des allocations" -> GardeAlterneePartageAllocations () - | "Confié aux service sociaux, allocation versée à la famille" -> + | "Confié aux service sociaux, allocation versée \ + à la famille" -> ServicesSociauxAllocationVerseeALaFamille () - | "Confié aux service sociaux, allocation versée aux services sociaux" - -> - ServicesSociauxAllocationVerseeAuxServicesSociaux () + | "Confié aux service sociaux, allocation versée \ + aux services sociaux" -> + ServicesSociauxAllocationVerseeAuxServicesSociaux + () | _ -> failwith "Unknown prise en charge"); AF.d_remuneration_mensuelle = money_of_units_int child##.remunerationMensuelle; diff --git a/french_law/ocaml/bench.ml b/french_law/ocaml/bench.ml index 14663438..c520f535 100644 --- a/french_law/ocaml/bench.ml +++ b/french_law/ocaml/bench.ml @@ -1,15 +1,17 @@ -(* This file is part of the French law library, a collection of functions for computing French taxes - and benefits derived from Catala programs. Copyright (C) 2021 Inria, contributor: Denis Merigoux - +(* This file is part of the French law library, a collection of functions for + computing French taxes and benefits derived from Catala programs. Copyright + (C) 2021 Inria, contributor: Denis Merigoux - 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 + 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 + 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. *) module AF = Api.Allocations_familiales @@ -20,7 +22,10 @@ let random_children (id : int) = AF.d_identifiant = integer_of_int id; d_remuneration_mensuelle = money_of_units_int (Random.int 2000); d_date_de_naissance = - date_of_numbers (2020 - Random.int 22) (1 + Random.int 12) (1 + Random.int 28); + date_of_numbers + (2020 - Random.int 22) + (1 + Random.int 12) + (1 + Random.int 28); d_prise_en_charge = (match Random.int 5 with | 0 -> AF.EffectiveEtPermanente () @@ -44,18 +49,21 @@ let format_residence (fmt : Format.formatter) (r : AF.collectivite) : unit = | AF.SaintMartin _ -> "Saint Martin" | AF.Mayotte _ -> "Mayotte") -let format_prise_en_charge (fmt : Format.formatter) (g : AF.prise_en_charge) : unit = +let format_prise_en_charge (fmt : Format.formatter) (g : AF.prise_en_charge) : + unit = Format.fprintf fmt "%s" (match g with | AF.EffectiveEtPermanente _ -> "Effective et permanente" - | AF.GardeAlterneePartageAllocations _ -> "Garde alternée, allocations partagée" - | AF.GardeAlterneeAllocataireUnique _ -> "Garde alternée, allocataire unique" - | AF.ServicesSociauxAllocationVerseeALaFamille _ -> "Oui, allocations versée à la famille" + | AF.GardeAlterneePartageAllocations _ -> + "Garde alternée, allocations partagée" + | AF.GardeAlterneeAllocataireUnique _ -> + "Garde alternée, allocataire unique" + | AF.ServicesSociauxAllocationVerseeALaFamille _ -> + "Oui, allocations versée à la famille" | AF.ServicesSociauxAllocationVerseeAuxServicesSociaux _ -> "Oui, allocations versée aux services sociaux") let num_successful = ref 0 - let total_amount = ref 0. let run_test () = @@ -65,12 +73,16 @@ let run_test () = let current_date = Runtime.date_of_numbers 2020 05 01 in let residence = let x = Random.int 2 in - match x with 0 -> AF.Metropole () | 1 -> AF.Guadeloupe () | _ -> AF.Mayotte () + match x with + | 0 -> AF.Metropole () + | 1 -> AF.Guadeloupe () + | _ -> AF.Mayotte () in try let amount = - Api.compute_allocations_familiales ~current_date ~income ~residence ~children ~is_parent:true - ~fills_title_I:true ~had_rights_open_before_2012:(Random.bool ()) + Api.compute_allocations_familiales ~current_date ~income ~residence + ~children ~is_parent:true ~fills_title_I:true + ~had_rights_open_before_2012:(Random.bool ()) in incr num_successful; total_amount := Float.add !total_amount amount @@ -82,7 +94,11 @@ let run_test () = | ConflictError -> "Conflict error!" | _ -> failwith "impossible") (Format.pp_print_list (fun fmt child -> - Format.fprintf fmt "Child %d:\n income: %.2f\n birth date: %s\n prise en charge: %a" + Format.fprintf fmt + "Child %d:\n\ + \ income: %.2f\n\ + \ birth date: %s\n\ + \ prise en charge: %a" (integer_to_int child.AF.d_identifiant) (money_to_float child.AF.d_remuneration_mensuelle) (Runtime.date_to_string child.AF.d_date_de_naissance) @@ -97,11 +113,15 @@ let bench = Random.init (int_of_float (Unix.time ())); let num_iter = 10000 in let _ = - Benchmark.latency1 ~style:Auto ~name:"Allocations familiales" (Int64.of_int num_iter) run_test - () + Benchmark.latency1 ~style:Auto ~name:"Allocations familiales" + (Int64.of_int num_iter) run_test () in - Printf.printf "Successful computations: %d (%.2f%%)\nTotal benefits awarded: %.2f€ (mean %.2f€)\n" + Printf.printf + "Successful computations: %d (%.2f%%)\n\ + Total benefits awarded: %.2f€ (mean %.2f€)\n" !num_successful - (Float.mul (Float.div (float_of_int !num_successful) (float_of_int num_iter)) 100.) + (Float.mul + (Float.div (float_of_int !num_successful) (float_of_int num_iter)) + 100.) !total_amount (Float.div !total_amount (float_of_int !num_successful)) diff --git a/french_law/ocaml/law_source/allocations_familiales.ml b/french_law/ocaml/law_source/allocations_familiales.ml index 9f1ac8bf..03f37b13 100644 --- a/french_law/ocaml/law_source/allocations_familiales.ml +++ b/french_law/ocaml/law_source/allocations_familiales.ml @@ -15,17 +15,23 @@ let embed_prise_en_charge (x : prise_en_charge) : runtime_value = Enum ( [ "PriseEnCharge" ], match x with - | GardeAlterneePartageAllocations x -> ("GardeAlternéePartageAllocations", embed_unit x) - | GardeAlterneeAllocataireUnique x -> ("GardeAlternéeAllocataireUnique", embed_unit x) + | GardeAlterneePartageAllocations x -> + ("GardeAlternéePartageAllocations", embed_unit x) + | GardeAlterneeAllocataireUnique x -> + ("GardeAlternéeAllocataireUnique", embed_unit x) | EffectiveEtPermanente x -> ("EffectiveEtPermanente", embed_unit x) | ServicesSociauxAllocationVerseeALaFamille x -> ("ServicesSociauxAllocationVerséeÀLaFamille", embed_unit x) | ServicesSociauxAllocationVerseeAuxServicesSociaux x -> ("ServicesSociauxAllocationVerséeAuxServicesSociaux", embed_unit x) ) -type situation_obligation_scolaire = Avant of unit | Pendant of unit | Apres of unit +type situation_obligation_scolaire = + | Avant of unit + | Pendant of unit + | Apres of unit -let embed_situation_obligation_scolaire (x : situation_obligation_scolaire) : runtime_value = +let embed_situation_obligation_scolaire (x : situation_obligation_scolaire) : + runtime_value = Enum ( [ "SituationObligationScolaire" ], match x with @@ -68,15 +74,17 @@ let embed_prise_en_compte (x : prise_en_compte) : runtime_value = | Partagee x -> ("Partagée", embed_unit x) | Zero x -> ("Zéro", embed_unit x) ) -type versement_allocations = Normal of unit | AllocationVerseeAuxServicesSociaux of unit +type versement_allocations = + | Normal of unit + | AllocationVerseeAuxServicesSociaux of unit let embed_versement_allocations (x : versement_allocations) : runtime_value = Enum ( [ "VersementAllocations" ], match x with | Normal x -> ("Normal", embed_unit x) - | AllocationVerseeAuxServicesSociaux x -> ("AllocationVerséeAuxServicesSociaux", embed_unit x) - ) + | AllocationVerseeAuxServicesSociaux x -> + ("AllocationVerséeAuxServicesSociaux", embed_unit x) ) type element_prestations_familiales = | PrestationAccueilJeuneEnfant of unit @@ -88,17 +96,22 @@ type element_prestations_familiales = | AllocationRentreeScolaire of unit | AllocationJournalierePresenceParentale of unit -let embed_element_prestations_familiales (x : element_prestations_familiales) : runtime_value = +let embed_element_prestations_familiales (x : element_prestations_familiales) : + runtime_value = Enum ( [ "ÉlémentPrestationsFamiliales" ], match x with - | PrestationAccueilJeuneEnfant x -> ("PrestationAccueilJeuneEnfant", embed_unit x) + | PrestationAccueilJeuneEnfant x -> + ("PrestationAccueilJeuneEnfant", embed_unit x) | AllocationsFamiliales x -> ("AllocationsFamiliales", embed_unit x) | ComplementFamilial x -> ("ComplémentFamilial", embed_unit x) | AllocationLogement x -> ("AllocationLogement", embed_unit x) - | AllocationEducationEnfantHandicape x -> ("AllocationÉducationEnfantHandicapé", embed_unit x) - | AllocationSoutienFamilial x -> ("AllocationSoutienFamilial", embed_unit x) - | AllocationRentreeScolaire x -> ("AllocationRentréeScolaire", embed_unit x) + | AllocationEducationEnfantHandicape x -> + ("AllocationÉducationEnfantHandicapé", embed_unit x) + | AllocationSoutienFamilial x -> + ("AllocationSoutienFamilial", embed_unit x) + | AllocationRentreeScolaire x -> + ("AllocationRentréeScolaire", embed_unit x) | AllocationJournalierePresenceParentale x -> ("AllocationJournalièrePresenceParentale", embed_unit x) ) @@ -137,7 +150,8 @@ let embed_enfant (x : enfant) : runtime_value = ( [ "Enfant" ], [ ("identifiant", embed_integer x.identifiant); - ("obligation_scolaire", embed_situation_obligation_scolaire x.obligation_scolaire); + ( "obligation_scolaire", + embed_situation_obligation_scolaire x.obligation_scolaire ); ("rémuneration_mensuelle", embed_money x.remuneration_mensuelle); ("date_de_naissance", embed_date x.date_de_naissance); ("âge", embed_integer x.age); @@ -149,7 +163,8 @@ let embed_enfant (x : enfant) : runtime_value = type smic_out = { brut_horaire_out : money } let embed_smic_out (x : smic_out) : runtime_value = - Struct ([ "Smic_out" ], [ ("brut_horaire_out", embed_money x.brut_horaire_out) ]) + Struct + ([ "Smic_out" ], [ ("brut_horaire_out", embed_money x.brut_horaire_out) ]) type smic_in = { date_courante_in : date; residence_in : collectivite } @@ -169,7 +184,8 @@ type prestations_familiales_out = { base_mensuelle_out : money; } -let embed_prestations_familiales_out (x : prestations_familiales_out) : runtime_value = +let embed_prestations_familiales_out (x : prestations_familiales_out) : + runtime_value = Struct ( [ "PrestationsFamiliales_out" ], [ @@ -186,44 +202,57 @@ type prestations_familiales_in = { residence_in : collectivite; } -let embed_prestations_familiales_in (x : prestations_familiales_in) : runtime_value = +let embed_prestations_familiales_in (x : prestations_familiales_in) : + runtime_value = Struct ( [ "PrestationsFamiliales_in" ], [ ("date_courante_in", embed_date x.date_courante_in); - ("prestation_courante_in", embed_element_prestations_familiales x.prestation_courante_in); + ( "prestation_courante_in", + embed_element_prestations_familiales x.prestation_courante_in ); ("résidence_in", embed_collectivite x.residence_in); ] ) -type allocation_familiales_avril2008_out = { age_minimum_alinea_1_l521_3_out : integer } +type allocation_familiales_avril2008_out = { + age_minimum_alinea_1_l521_3_out : integer; +} -let embed_allocation_familiales_avril2008_out (x : allocation_familiales_avril2008_out) : - runtime_value = +let embed_allocation_familiales_avril2008_out + (x : allocation_familiales_avril2008_out) : runtime_value = Struct ( [ "AllocationFamilialesAvril2008_out" ], - [ ("âge_minimum_alinéa_1_l521_3_out", embed_integer x.age_minimum_alinea_1_l521_3_out) ] ) + [ + ( "âge_minimum_alinéa_1_l521_3_out", + embed_integer x.age_minimum_alinea_1_l521_3_out ); + ] ) type allocation_familiales_avril2008_in = unit -let embed_allocation_familiales_avril2008_in (_ : allocation_familiales_avril2008_in) : - runtime_value = +let embed_allocation_familiales_avril2008_in + (_ : allocation_familiales_avril2008_in) : runtime_value = Unit type enfant_le_plus_age_out = { le_plus_age_out : enfant } let embed_enfant_le_plus_age_out (x : enfant_le_plus_age_out) : runtime_value = - Struct ([ "EnfantLePlusÂgé_out" ], [ ("le_plus_âgé_out", embed_enfant x.le_plus_age_out) ]) + Struct + ( [ "EnfantLePlusÂgé_out" ], + [ ("le_plus_âgé_out", embed_enfant x.le_plus_age_out) ] ) type enfant_le_plus_age_in = { enfants_in : enfant array } let embed_enfant_le_plus_age_in (x : enfant_le_plus_age_in) : runtime_value = - Struct ([ "EnfantLePlusÂgé_in" ], [ ("enfants_in", embed_array embed_enfant x.enfants_in) ]) + Struct + ( [ "EnfantLePlusÂgé_in" ], + [ ("enfants_in", embed_array embed_enfant x.enfants_in) ] ) type allocations_familiales_out = { montant_verse_out : money } -let embed_allocations_familiales_out (x : allocations_familiales_out) : runtime_value = +let embed_allocations_familiales_out (x : allocations_familiales_out) : + runtime_value = Struct - ([ "AllocationsFamiliales_out" ], [ ("montant_versé_out", embed_money x.montant_verse_out) ]) + ( [ "AllocationsFamiliales_out" ], + [ ("montant_versé_out", embed_money x.montant_verse_out) ] ) type allocations_familiales_in = { personne_charge_effective_permanente_est_parent_in : bool; @@ -235,14 +264,16 @@ type allocations_familiales_in = { avait_enfant_a_charge_avant_1er_janvier_2012_in : bool; } -let embed_allocations_familiales_in (x : allocations_familiales_in) : runtime_value = +let embed_allocations_familiales_in (x : allocations_familiales_in) : + runtime_value = Struct ( [ "AllocationsFamiliales_in" ], [ ( "personne_charge_effective_permanente_est_parent_in", embed_bool x.personne_charge_effective_permanente_est_parent_in ); ( "personne_charge_effective_permanente_remplit_titre_I_in", - embed_bool x.personne_charge_effective_permanente_remplit_titre_I_in ); + embed_bool x.personne_charge_effective_permanente_remplit_titre_I_in + ); ("ressources_ménage_in", embed_money x.ressources_menage_in); ("résidence_in", embed_collectivite x.residence_in); ("date_courante_in", embed_date x.date_courante_in); @@ -253,8 +284,8 @@ let embed_allocations_familiales_in (x : allocations_familiales_in) : runtime_va type interface_allocations_familiales_out = { i_montant_verse_out : money } -let embed_interface_allocations_familiales_out (x : interface_allocations_familiales_out) : - runtime_value = +let embed_interface_allocations_familiales_out + (x : interface_allocations_familiales_out) : runtime_value = Struct ( [ "InterfaceAllocationsFamiliales_out" ], [ ("i_montant_versé_out", embed_money x.i_montant_verse_out) ] ) @@ -269,8 +300,8 @@ type interface_allocations_familiales_in = { i_avait_enfant_a_charge_avant_1er_janvier_2012_in : bool; } -let embed_interface_allocations_familiales_in (x : interface_allocations_familiales_in) : - runtime_value = +let embed_interface_allocations_familiales_in + (x : interface_allocations_familiales_in) : runtime_value = Struct ( [ "InterfaceAllocationsFamiliales_in" ], [ @@ -281,7 +312,8 @@ let embed_interface_allocations_familiales_in (x : interface_allocations_familia ( "i_personne_charge_effective_permanente_est_parent_in", embed_bool x.i_personne_charge_effective_permanente_est_parent_in ); ( "i_personne_charge_effective_permanente_remplit_titre_I_in", - embed_bool x.i_personne_charge_effective_permanente_remplit_titre_I_in ); + embed_bool x.i_personne_charge_effective_permanente_remplit_titre_I_in + ); ( "i_avait_enfant_à_charge_avant_1er_janvier_2012_in", embed_bool x.i_avait_enfant_a_charge_avant_1er_janvier_2012_in ); ] ) @@ -307,8 +339,8 @@ let smic (smic_in : smic_in) = law_headings = [ "Article 1"; - "Décret n° 2020-1598 du 16 décembre 2020 portant relèvement du salaire \ - minimum de croissance"; + "Décret n° 2020-1598 du 16 décembre 2020 portant \ + relèvement du salaire minimum de croissance"; "Montant du salaire minimum de croissance"; "Décrets divers"; ]; @@ -332,8 +364,8 @@ let smic (smic_in : smic_in) = law_headings = [ "Article 1"; - "Décret n° 2020-1598 du 16 décembre 2020 portant relèvement du salaire \ - minimum de croissance"; + "Décret n° 2020-1598 du 16 décembre 2020 portant \ + relèvement du salaire minimum de croissance"; "Montant du salaire minimum de croissance"; "Décrets divers"; ]; @@ -342,8 +374,9 @@ let smic (smic_in : smic_in) = && date_courante_ <=@ date_of_numbers 2021 12 31 && (residence_ = Metropole () || residence_ = Guadeloupe () || residence_ = Guyane () || residence_ = Martinique () - || residence_ = LaReunion () || residence_ = SaintBarthelemy () - || residence_ = SaintMartin () + || residence_ = LaReunion () + || residence_ = SaintBarthelemy () + || residence_ = SaintMartin () || residence_ = SaintPierreEtMiquelon ())) then money_of_cents_string "1025" else raise EmptyError @@ -361,8 +394,8 @@ let smic (smic_in : smic_in) = law_headings = [ "Article 1"; - "Décret n° 2019-1387 du 18 décembre 2019 portant relèvement du salaire \ - minimum de croissance"; + "Décret n° 2019-1387 du 18 décembre 2019 portant \ + relèvement du salaire minimum de croissance"; "Montant du salaire minimum de croissance"; "Décrets divers"; ]; @@ -386,8 +419,8 @@ let smic (smic_in : smic_in) = law_headings = [ "Article 1"; - "Décret n° 2019-1387 du 18 décembre 2019 portant relèvement du salaire \ - minimum de croissance"; + "Décret n° 2019-1387 du 18 décembre 2019 portant \ + relèvement du salaire minimum de croissance"; "Montant du salaire minimum de croissance"; "Décrets divers"; ]; @@ -396,8 +429,9 @@ let smic (smic_in : smic_in) = && date_courante_ <=@ date_of_numbers 2020 12 31 && (residence_ = Metropole () || residence_ = Guadeloupe () || residence_ = Guyane () || residence_ = Martinique () - || residence_ = LaReunion () || residence_ = SaintBarthelemy () - || residence_ = SaintMartin () + || residence_ = LaReunion () + || residence_ = SaintBarthelemy () + || residence_ = SaintMartin () || residence_ = SaintPierreEtMiquelon ())) then money_of_cents_string "1015" else raise EmptyError @@ -415,8 +449,8 @@ let smic (smic_in : smic_in) = law_headings = [ "Article 1"; - "Décret n° 2018-1173 du 19 décembre 2018 portant relèvement du salaire \ - minimum de croissance"; + "Décret n° 2018-1173 du 19 décembre 2018 portant \ + relèvement du salaire minimum de croissance"; "Montant du salaire minimum de croissance"; "Décrets divers"; ]; @@ -440,8 +474,8 @@ let smic (smic_in : smic_in) = law_headings = [ "Article 1"; - "Décret n° 2018-1173 du 19 décembre 2018 portant relèvement du salaire \ - minimum de croissance"; + "Décret n° 2018-1173 du 19 décembre 2018 portant \ + relèvement du salaire minimum de croissance"; "Montant du salaire minimum de croissance"; "Décrets divers"; ]; @@ -450,8 +484,9 @@ let smic (smic_in : smic_in) = && date_courante_ <=@ date_of_numbers 2019 12 31 && (residence_ = Metropole () || residence_ = Guadeloupe () || residence_ = Guyane () || residence_ = Martinique () - || residence_ = LaReunion () || residence_ = SaintBarthelemy () - || residence_ = SaintMartin () + || residence_ = LaReunion () + || residence_ = SaintBarthelemy () + || residence_ = SaintMartin () || residence_ = SaintPierreEtMiquelon ())) then money_of_cents_string "1003" else raise EmptyError @@ -514,7 +549,8 @@ let enfant_le_plus_age (enfant_le_plus_age_in : enfant_le_plus_age_in) = try try Array.fold_left - (fun (acc_ : _) (item_ : _) -> if acc_.age >! item_.age then acc_ else item_) + (fun (acc_ : _) (item_ : _) -> + if acc_.age >! item_.age then acc_ else item_) { identifiant = ~-!(integer_of_string "1"); obligation_scolaire = Pendant (); @@ -541,7 +577,8 @@ let enfant_le_plus_age (enfant_le_plus_age_in : enfant_le_plus_age_in) = in { le_plus_age_out = le_plus_age_ } -let prestations_familiales (prestations_familiales_in : prestations_familiales_in) = +let prestations_familiales + (prestations_familiales_in : prestations_familiales_in) = let date_courante_ : date = prestations_familiales_in.date_courante_in in let prestation_courante_ : element_prestations_familiales = prestations_familiales_in.prestation_courante_in @@ -583,12 +620,14 @@ let prestations_familiales (prestations_familiales_in : prestations_familiales_i end_column = 34; law_headings = [ - "Instruction interministérielle n°DSS/2B/2021/65 du 19 mars 2021 \ - relative à la revalorisation au 1er avril 2021 des prestations \ - familiales servies en métropole, en Guadeloupe, en Guyane, en \ - Martinique, à la Réunion, à Saint-Barthélemy, à Saint-Martin et dans \ - le département de Mayotte"; - "Montant de la base mensuelle des allocations familiales"; + "Instruction interministérielle n°DSS/2B/2021/65 du \ + 19 mars 2021 relative à la revalorisation au 1er \ + avril 2021 des prestations familiales servies en \ + métropole, en Guadeloupe, en Guyane, en \ + Martinique, à la Réunion, à Saint-Barthélemy, à \ + Saint-Martin et dans le département de Mayotte"; + "Montant de la base mensuelle des allocations \ + familiales"; "Décrets divers"; ]; } @@ -609,12 +648,14 @@ let prestations_familiales (prestations_familiales_in : prestations_familiales_i end_column = 34; law_headings = [ - "Instruction interministérielle no DSS/SD2B/2020/33 du 18 février 2020 \ - relative à la revalorisation au 1er avril 2020 des prestations \ - familiales servies en métropole, en Guadeloupe, en Guyane, en \ - Martinique, à La Réunion, à Saint-Barthélemy, à Saint-Martin et dans \ - le département de Mayotte"; - "Montant de la base mensuelle des allocations familiales"; + "Instruction interministérielle no DSS/SD2B/2020/33 \ + du 18 février 2020 relative à la revalorisation au \ + 1er avril 2020 des prestations familiales servies \ + en métropole, en Guadeloupe, en Guyane, en \ + Martinique, à La Réunion, à Saint-Barthélemy, à \ + Saint-Martin et dans le département de Mayotte"; + "Montant de la base mensuelle des allocations \ + familiales"; "Décrets divers"; ]; } @@ -635,10 +676,12 @@ let prestations_familiales (prestations_familiales_in : prestations_familiales_i end_column = 34; law_headings = [ - "Instruction ministérielle N°DSS/SD2B/2019/65 du 25 mars 2019 relative \ - à la revalorisation au 1er avril 2019 des prestations familiales \ - servies en métropole"; - "Montant de la base mensuelle des allocations familiales"; + "Instruction ministérielle N°DSS/SD2B/2019/65 du 25 \ + mars 2019 relative à la revalorisation au 1er \ + avril 2019 des prestations familiales servies en \ + métropole"; + "Montant de la base mensuelle des allocations \ + familiales"; "Décrets divers"; ]; } @@ -716,7 +759,10 @@ let prestations_familiales (prestations_familiales_in : prestations_familiales_i (log_begin_call [ "PrestationsFamiliales"; "smic"; "Smic" ] smic - { date_courante_in = smic_dot_date_courante_; residence_in = smic_dot_residence_ }) + { + date_courante_in = smic_dot_date_courante_; + residence_in = smic_dot_residence_; + }) in let smic_dot_brut_horaire_ : money = result_.brut_horaire_out in let regime_outre_mer_l751_1_ : bool = @@ -738,16 +784,18 @@ let prestations_familiales (prestations_familiales_in : prestations_familiales_i [ "Article L751-1"; "Chapitre 1er : Généralités"; - "Titre 5 : Dispositions particulières à la Guadeloupe, à la Guyane, à la \ - Martinique, à La Réunion, à Saint-Barthélemy et à Saint-Martin"; + "Titre 5 : Dispositions particulières à la Guadeloupe, \ + à la Guyane, à la Martinique, à La Réunion, à \ + Saint-Barthélemy et à Saint-Martin"; "Livre 7 : Régimes divers - Dispositions diverses"; "Partie législative"; "Code de la sécurité sociale"; ]; } - (residence_ = Guadeloupe () || residence_ = Guyane () || residence_ = Martinique () - || residence_ = LaReunion () || residence_ = SaintBarthelemy () - || residence_ = SaintMartin ()) + (residence_ = Guadeloupe () || residence_ = Guyane () + || residence_ = Martinique () || residence_ = LaReunion () + || residence_ = SaintBarthelemy () + || residence_ = SaintMartin ()) then true else raise EmptyError with EmptyError -> raise EmptyError @@ -783,7 +831,8 @@ let prestations_familiales (prestations_familiales_in : prestations_familiales_i law_headings = [ "Article R755-0-2"; - "Chapitre 5 : Prestations familiales et prestations assimilées"; + "Chapitre 5 : Prestations familiales et prestations \ + assimilées"; "Titre 5 : Départements d'outre-mer"; "Livre 7 : Régimes divers - Dispositions diverses"; "Partie réglementaire - Décrets en Conseil d'Etat"; @@ -791,11 +840,15 @@ let prestations_familiales (prestations_familiales_in : prestations_familiales_i ]; } regime_outre_mer_l751_1_ - then smic_dot_brut_horaire_ *$ decimal_of_string "0.55" *$ decimal_of_string "169." + then + smic_dot_brut_horaire_ *$ decimal_of_string "0.55" + *$ decimal_of_string "169." else raise EmptyError with EmptyError -> raise EmptyError with EmptyError -> ( - try smic_dot_brut_horaire_ *$ decimal_of_string "0.55" *$ decimal_of_string "169." + try + smic_dot_brut_horaire_ *$ decimal_of_string "0.55" + *$ decimal_of_string "169." with EmptyError -> raise EmptyError) with EmptyError -> raise EmptyError with EmptyError -> @@ -832,7 +885,8 @@ let prestations_familiales (prestations_familiales_in : prestations_familiales_i "Article L512-3"; "Chapitre 2 : Champ d'application"; "Titre 1 : Champ d'application - Généralités"; - "Livre 5 : Prestations familiales et prestations assimilées"; + "Livre 5 : Prestations familiales et prestations \ + assimilées"; "Partie législative"; "Code de la sécurité sociale"; ]; @@ -902,7 +956,8 @@ let prestations_familiales (prestations_familiales_in : prestations_familiales_i "Article L512-3"; "Chapitre 2 : Champ d'application"; "Titre 1 : Champ d'application - Généralités"; - "Livre 5 : Prestations familiales et prestations assimilées"; + "Livre 5 : Prestations familiales et \ + prestations assimilées"; "Partie législative"; "Code de la sécurité sociale"; ]; @@ -931,7 +986,8 @@ let prestations_familiales (prestations_familiales_in : prestations_familiales_i "Article L512-3"; "Chapitre 2 : Champ d'application"; "Titre 1 : Champ d'application - Généralités"; - "Livre 5 : Prestations familiales et prestations assimilées"; + "Livre 5 : Prestations familiales et \ + prestations assimilées"; "Partie législative"; "Code de la sécurité sociale"; ]; @@ -992,17 +1048,23 @@ let prestations_familiales (prestations_familiales_in : prestations_familiales_i base_mensuelle_out = base_mensuelle_; } -let allocations_familiales (allocations_familiales_in : allocations_familiales_in) = +let allocations_familiales + (allocations_familiales_in : allocations_familiales_in) = let personne_charge_effective_permanente_est_parent_ : bool = allocations_familiales_in.personne_charge_effective_permanente_est_parent_in in let personne_charge_effective_permanente_remplit_titre__i_ : bool = - allocations_familiales_in.personne_charge_effective_permanente_remplit_titre_I_in + allocations_familiales_in + .personne_charge_effective_permanente_remplit_titre_I_in + in + let ressources_menage_ : money = + allocations_familiales_in.ressources_menage_in in - let ressources_menage_ : money = allocations_familiales_in.ressources_menage_in in let residence_ : collectivite = allocations_familiales_in.residence_in in let date_courante_ : date = allocations_familiales_in.date_courante_in in - let enfants_a_charge_ : enfant array = allocations_familiales_in.enfants_a_charge_in in + let enfants_a_charge_ : enfant array = + allocations_familiales_in.enfants_a_charge_in + in let avait_enfant_a_charge_avant_1er_janvier_2012_ : bool = allocations_familiales_in.avait_enfant_a_charge_avant_1er_janvier_2012_in in @@ -1030,7 +1092,8 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i "Article L521-2"; "Chapitre 1er : Allocations familiales"; "Titre 2 : Prestations générales d'entretien"; - "Livre 5 : Prestations familiales et prestations assimilées"; + "Livre 5 : Prestations familiales et \ + prestations assimilées"; "Partie législative"; "Code de la sécurité sociale"; ]; @@ -1040,7 +1103,9 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i | GardeAlterneeAllocataireUnique _ -> false | EffectiveEtPermanente _ -> false | ServicesSociauxAllocationVerseeALaFamille _ -> true - | ServicesSociauxAllocationVerseeAuxServicesSociaux _ -> false) + | ServicesSociauxAllocationVerseeAuxServicesSociaux _ + -> + false) then Complete () else raise EmptyError with EmptyError -> raise EmptyError); @@ -1059,7 +1124,8 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i "Article L521-2"; "Chapitre 1er : Allocations familiales"; "Titre 2 : Prestations générales d'entretien"; - "Livre 5 : Prestations familiales et prestations assimilées"; + "Livre 5 : Prestations familiales et \ + prestations assimilées"; "Partie législative"; "Code de la sécurité sociale"; ]; @@ -1069,7 +1135,9 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i | GardeAlterneeAllocataireUnique _ -> false | EffectiveEtPermanente _ -> false | ServicesSociauxAllocationVerseeALaFamille _ -> false - | ServicesSociauxAllocationVerseeAuxServicesSociaux _ -> true) + | ServicesSociauxAllocationVerseeAuxServicesSociaux _ + -> + true) then Zero () else raise EmptyError with EmptyError -> raise EmptyError); @@ -1088,7 +1156,8 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i "Article L521-2"; "Chapitre 1er : Allocations familiales"; "Titre 2 : Prestations générales d'entretien"; - "Livre 5 : Prestations familiales et prestations assimilées"; + "Livre 5 : Prestations familiales et \ + prestations assimilées"; "Partie législative"; "Code de la sécurité sociale"; ]; @@ -1098,7 +1167,9 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i | GardeAlterneeAllocataireUnique _ -> false | EffectiveEtPermanente _ -> false | ServicesSociauxAllocationVerseeALaFamille _ -> false - | ServicesSociauxAllocationVerseeAuxServicesSociaux _ -> false) + | ServicesSociauxAllocationVerseeAuxServicesSociaux _ + -> + false) then Partagee () else raise EmptyError with EmptyError -> raise EmptyError); @@ -1117,7 +1188,8 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i "Article L521-2"; "Chapitre 1er : Allocations familiales"; "Titre 2 : Prestations générales d'entretien"; - "Livre 5 : Prestations familiales et prestations assimilées"; + "Livre 5 : Prestations familiales et \ + prestations assimilées"; "Partie législative"; "Code de la sécurité sociale"; ]; @@ -1127,7 +1199,9 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i | GardeAlterneeAllocataireUnique _ -> true | EffectiveEtPermanente _ -> false | ServicesSociauxAllocationVerseeALaFamille _ -> false - | ServicesSociauxAllocationVerseeAuxServicesSociaux _ -> false) + | ServicesSociauxAllocationVerseeAuxServicesSociaux _ + -> + false) then Complete () else raise EmptyError with EmptyError -> raise EmptyError); @@ -1146,7 +1220,8 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i "Article L521-2"; "Chapitre 1er : Allocations familiales"; "Titre 2 : Prestations générales d'entretien"; - "Livre 5 : Prestations familiales et prestations assimilées"; + "Livre 5 : Prestations familiales et \ + prestations assimilées"; "Partie législative"; "Code de la sécurité sociale"; ]; @@ -1156,7 +1231,9 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i | GardeAlterneeAllocataireUnique _ -> false | EffectiveEtPermanente _ -> true | ServicesSociauxAllocationVerseeALaFamille _ -> false - | ServicesSociauxAllocationVerseeAuxServicesSociaux _ -> false) + | ServicesSociauxAllocationVerseeAuxServicesSociaux _ + -> + false) then Complete () else raise EmptyError with EmptyError -> raise EmptyError); @@ -1220,7 +1297,8 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i "Article L521-2"; "Chapitre 1er : Allocations familiales"; "Titre 2 : Prestations générales d'entretien"; - "Livre 5 : Prestations familiales et prestations assimilées"; + "Livre 5 : Prestations familiales et \ + prestations assimilées"; "Partie législative"; "Code de la sécurité sociale"; ]; @@ -1230,7 +1308,9 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i | GardeAlterneeAllocataireUnique _ -> false | EffectiveEtPermanente _ -> false | ServicesSociauxAllocationVerseeALaFamille _ -> true - | ServicesSociauxAllocationVerseeAuxServicesSociaux _ -> false) + | ServicesSociauxAllocationVerseeAuxServicesSociaux _ + -> + false) then Normal () else raise EmptyError with EmptyError -> raise EmptyError); @@ -1249,7 +1329,8 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i "Article L521-2"; "Chapitre 1er : Allocations familiales"; "Titre 2 : Prestations générales d'entretien"; - "Livre 5 : Prestations familiales et prestations assimilées"; + "Livre 5 : Prestations familiales et \ + prestations assimilées"; "Partie législative"; "Code de la sécurité sociale"; ]; @@ -1259,7 +1340,9 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i | GardeAlterneeAllocataireUnique _ -> false | EffectiveEtPermanente _ -> false | ServicesSociauxAllocationVerseeALaFamille _ -> false - | ServicesSociauxAllocationVerseeAuxServicesSociaux _ -> true) + | ServicesSociauxAllocationVerseeAuxServicesSociaux _ + -> + true) then AllocationVerseeAuxServicesSociaux () else raise EmptyError with EmptyError -> raise EmptyError); @@ -1278,7 +1361,8 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i "Article L521-2"; "Chapitre 1er : Allocations familiales"; "Titre 2 : Prestations générales d'entretien"; - "Livre 5 : Prestations familiales et prestations assimilées"; + "Livre 5 : Prestations familiales et \ + prestations assimilées"; "Partie législative"; "Code de la sécurité sociale"; ]; @@ -1288,7 +1372,9 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i | GardeAlterneeAllocataireUnique _ -> false | EffectiveEtPermanente _ -> false | ServicesSociauxAllocationVerseeALaFamille _ -> false - | ServicesSociauxAllocationVerseeAuxServicesSociaux _ -> false) + | ServicesSociauxAllocationVerseeAuxServicesSociaux _ + -> + false) then Normal () else raise EmptyError with EmptyError -> raise EmptyError); @@ -1307,7 +1393,8 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i "Article L521-2"; "Chapitre 1er : Allocations familiales"; "Titre 2 : Prestations générales d'entretien"; - "Livre 5 : Prestations familiales et prestations assimilées"; + "Livre 5 : Prestations familiales et \ + prestations assimilées"; "Partie législative"; "Code de la sécurité sociale"; ]; @@ -1317,7 +1404,9 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i | GardeAlterneeAllocataireUnique _ -> true | EffectiveEtPermanente _ -> false | ServicesSociauxAllocationVerseeALaFamille _ -> false - | ServicesSociauxAllocationVerseeAuxServicesSociaux _ -> false) + | ServicesSociauxAllocationVerseeAuxServicesSociaux _ + -> + false) then Normal () else raise EmptyError with EmptyError -> raise EmptyError); @@ -1336,7 +1425,8 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i "Article L521-2"; "Chapitre 1er : Allocations familiales"; "Titre 2 : Prestations générales d'entretien"; - "Livre 5 : Prestations familiales et prestations assimilées"; + "Livre 5 : Prestations familiales et \ + prestations assimilées"; "Partie législative"; "Code de la sécurité sociale"; ]; @@ -1346,7 +1436,9 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i | GardeAlterneeAllocataireUnique _ -> false | EffectiveEtPermanente _ -> true | ServicesSociauxAllocationVerseeALaFamille _ -> false - | ServicesSociauxAllocationVerseeAuxServicesSociaux _ -> false) + | ServicesSociauxAllocationVerseeAuxServicesSociaux _ + -> + false) then Normal () else raise EmptyError with EmptyError -> raise EmptyError); @@ -1422,9 +1514,17 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i in let result_ : allocation_familiales_avril2008_out = log_end_call - [ "AllocationsFamiliales"; "version_avril_2008"; "AllocationFamilialesAvril2008" ] + [ + "AllocationsFamiliales"; + "version_avril_2008"; + "AllocationFamilialesAvril2008"; + ] (log_begin_call - [ "AllocationsFamiliales"; "version_avril_2008"; "AllocationFamilialesAvril2008" ] + [ + "AllocationsFamiliales"; + "version_avril_2008"; + "AllocationFamilialesAvril2008"; + ] allocation_familiales_avril2008 ()) in let version_avril_2008_dot_age_minimum_alinea_1_l521_3_ : integer = @@ -1449,10 +1549,13 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i law_headings = [ "Prologue" ]; }) in - let prestations_familiales_dot_prestation_courante_ : element_prestations_familiales = + let prestations_familiales_dot_prestation_courante_ : + element_prestations_familiales = try log_variable_definition - [ "AllocationsFamiliales"; "prestations_familiales.prestation_courante" ] + [ + "AllocationsFamiliales"; "prestations_familiales.prestation_courante"; + ] embed_element_prestations_familiales (try try AllocationsFamiliales () with EmptyError -> raise EmptyError with EmptyError -> raise EmptyError) @@ -1489,25 +1592,40 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i in let result_ : prestations_familiales_out = log_end_call - [ "AllocationsFamiliales"; "prestations_familiales"; "PrestationsFamiliales" ] + [ + "AllocationsFamiliales"; + "prestations_familiales"; + "PrestationsFamiliales"; + ] (log_begin_call - [ "AllocationsFamiliales"; "prestations_familiales"; "PrestationsFamiliales" ] + [ + "AllocationsFamiliales"; + "prestations_familiales"; + "PrestationsFamiliales"; + ] prestations_familiales { date_courante_in = prestations_familiales_dot_date_courante_; - prestation_courante_in = prestations_familiales_dot_prestation_courante_; + prestation_courante_in = + prestations_familiales_dot_prestation_courante_; residence_in = prestations_familiales_dot_residence_; }) in - let prestations_familiales_dot_droit_ouvert_ : enfant -> bool = result_.droit_ouvert_out in + let prestations_familiales_dot_droit_ouvert_ : enfant -> bool = + result_.droit_ouvert_out + in let prestations_familiales_dot_conditions_hors_age_ : enfant -> bool = result_.conditions_hors_age_out in - let prestations_familiales_dot_age_l512_3_2_ : integer = result_.age_l512_3_2_out in + let prestations_familiales_dot_age_l512_3_2_ : integer = + result_.age_l512_3_2_out + in let prestations_familiales_dot_regime_outre_mer_l751_1_ : bool = result_.regime_outre_mer_l751_1_out in - let prestations_familiales_dot_base_mensuelle_ : money = result_.base_mensuelle_out in + let prestations_familiales_dot_base_mensuelle_ : money = + result_.base_mensuelle_out + in let enfant_le_plus_age_dot_enfants_ : enfant array = try log_variable_definition @@ -1559,7 +1677,8 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i "Article R521-1"; "Chapitre 1er : Allocations familiales"; "Titre 2 : Prestations générales d'entretien"; - "Livre 5 : Prestations familiales et prestations assimilées"; + "Livre 5 : Prestations familiales et prestations \ + assimilées"; "Partie réglementaire - Décrets en Conseil d'Etat"; "Code de la sécurité sociale"; ]; @@ -1596,7 +1715,10 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i in let enfants_a_charge_droit_ouvert_prestation_familiale_ : enfant array = log_variable_definition - [ "AllocationsFamiliales"; "enfants_à_charge_droit_ouvert_prestation_familiale" ] + [ + "AllocationsFamiliales"; + "enfants_à_charge_droit_ouvert_prestation_familiale"; + ] (embed_array embed_enfant) (try try @@ -1684,10 +1806,11 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i law_headings = [ "Article 1"; - "Arrêté du 14 décembre 2020 relatif au montant des plafonds de \ - ressources de certaines prestations familiales et aux tranches du \ - barème applicable au recouvrement des indus et à la saisie des \ - prestations"; + "Arrêté du 14 décembre 2020 relatif au montant \ + des plafonds de ressources de certaines \ + prestations familiales et aux tranches du barème \ + applicable au recouvrement des indus et à la \ + saisie des prestations"; "Montant des plafonds de ressources"; "Décrets divers"; ]; @@ -1698,7 +1821,8 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i money_of_cents_string "8155800" +$ money_of_cents_string "582700" *$ decimal_of_integer - (array_length enfants_a_charge_droit_ouvert_prestation_familiale_) + (array_length + enfants_a_charge_droit_ouvert_prestation_familiale_) else raise EmptyError with EmptyError -> raise EmptyError); (fun (_ : _) -> @@ -1713,11 +1837,14 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i end_column = 69; law_headings = [ - "Instruction interministerielle no DSS/SD2B/2019/261 du 18 décembre \ - 2019 relative à la revalorisation au 1er janvier 2020 des plafonds \ - de ressources d’attribution de certaines prestations familiales \ - servies en métropole, en Guadeloupe, en Guyane, en Martinique, à La \ - Réunion, à Saint-Barthélemy, à Saint-Martin et à Mayotte"; + "Instruction interministerielle no \ + DSS/SD2B/2019/261 du 18 décembre 2019 relative à \ + la revalorisation au 1er janvier 2020 des \ + plafonds de ressources d’attribution de \ + certaines prestations familiales servies en \ + métropole, en Guadeloupe, en Guyane, en \ + Martinique, à La Réunion, à Saint-Barthélemy, à \ + Saint-Martin et à Mayotte"; "Montant des plafonds de ressources"; "Décrets divers"; ]; @@ -1728,7 +1855,8 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i money_of_cents_string "8083100" +$ money_of_cents_string "577500" *$ decimal_of_integer - (array_length enfants_a_charge_droit_ouvert_prestation_familiale_) + (array_length + enfants_a_charge_droit_ouvert_prestation_familiale_) else raise EmptyError with EmptyError -> raise EmptyError); (fun (_ : _) -> @@ -1743,11 +1871,14 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i end_column = 69; law_headings = [ - "Instruction interministérielle n° DSS/SD2B/2018/279 du 17 décembre \ - 2018 relative à la revalorisation au 1er janvier 2019 des plafonds \ - de ressources d’attribution de certaines prestations familiales \ - servies en métropole, en Guadeloupe, en Guyane, en Martinique, à la \ - Réunion, à Saint-Barthélemy, à Saint-Martin et à Mayotte"; + "Instruction interministérielle n° \ + DSS/SD2B/2018/279 du 17 décembre 2018 relative à \ + la revalorisation au 1er janvier 2019 des \ + plafonds de ressources d’attribution de \ + certaines prestations familiales servies en \ + métropole, en Guadeloupe, en Guyane, en \ + Martinique, à la Réunion, à Saint-Barthélemy, à \ + Saint-Martin et à Mayotte"; "Montant des plafonds de ressources"; "Décrets divers"; ]; @@ -1758,7 +1889,8 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i money_of_cents_string "7955800" +$ money_of_cents_string "568400" *$ decimal_of_integer - (array_length enfants_a_charge_droit_ouvert_prestation_familiale_) + (array_length + enfants_a_charge_droit_ouvert_prestation_familiale_) else raise EmptyError with EmptyError -> raise EmptyError); (fun (_ : _) -> @@ -1773,11 +1905,14 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i end_column = 69; law_headings = [ - "Circulaire interministérielle N° DSS/SD2B/2017/352 du 22 décembre \ - 2017 relative à la revalorisation au 1er janvier 2018 des plafonds \ - de ressources d’attribution de certaines prestations familiales \ - servies en métropole, en Guadeloupe, en Guyane, en Martinique, à la \ - Réunion, à Saint-Barthélemy, à Saint-Martin et à Mayotte"; + "Circulaire interministérielle N° \ + DSS/SD2B/2017/352 du 22 décembre 2017 relative à \ + la revalorisation au 1er janvier 2018 des \ + plafonds de ressources d’attribution de \ + certaines prestations familiales servies en \ + métropole, en Guadeloupe, en Guyane, en \ + Martinique, à la Réunion, à Saint-Barthélemy, à \ + Saint-Martin et à Mayotte"; "Montant des plafonds de ressources"; "Décrets divers"; ]; @@ -1788,7 +1923,8 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i money_of_cents_string "7877000" +$ money_of_cents_string "562800" *$ decimal_of_integer - (array_length enfants_a_charge_droit_ouvert_prestation_familiale_) + (array_length + enfants_a_charge_droit_ouvert_prestation_familiale_) else raise EmptyError with EmptyError -> raise EmptyError); |] @@ -1808,7 +1944,8 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i money_of_cents_string "7830000" +$ money_of_cents_string "559500" *$ decimal_of_integer - (array_length enfants_a_charge_droit_ouvert_prestation_familiale_) + (array_length + enfants_a_charge_droit_ouvert_prestation_familiale_) with EmptyError -> raise EmptyError) with EmptyError -> raise EmptyError with EmptyError -> @@ -1844,10 +1981,11 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i law_headings = [ "Article 1"; - "Arrêté du 14 décembre 2020 relatif au montant des plafonds de \ - ressources de certaines prestations familiales et aux tranches du \ - barème applicable au recouvrement des indus et à la saisie des \ - prestations"; + "Arrêté du 14 décembre 2020 relatif au montant \ + des plafonds de ressources de certaines \ + prestations familiales et aux tranches du barème \ + applicable au recouvrement des indus et à la \ + saisie des prestations"; "Montant des plafonds de ressources"; "Décrets divers"; ]; @@ -1858,7 +1996,8 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i money_of_cents_string "5827900" +$ money_of_cents_string "582700" *$ decimal_of_integer - (array_length enfants_a_charge_droit_ouvert_prestation_familiale_) + (array_length + enfants_a_charge_droit_ouvert_prestation_familiale_) else raise EmptyError with EmptyError -> raise EmptyError); (fun (_ : _) -> @@ -1873,11 +2012,14 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i end_column = 69; law_headings = [ - "Instruction interministerielle no DSS/SD2B/2019/261 du 18 décembre \ - 2019 relative à la revalorisation au 1er janvier 2020 des plafonds \ - de ressources d’attribution de certaines prestations familiales \ - servies en métropole, en Guadeloupe, en Guyane, en Martinique, à La \ - Réunion, à Saint-Barthélemy, à Saint-Martin et à Mayotte"; + "Instruction interministerielle no \ + DSS/SD2B/2019/261 du 18 décembre 2019 relative à \ + la revalorisation au 1er janvier 2020 des \ + plafonds de ressources d’attribution de \ + certaines prestations familiales servies en \ + métropole, en Guadeloupe, en Guyane, en \ + Martinique, à La Réunion, à Saint-Barthélemy, à \ + Saint-Martin et à Mayotte"; "Montant des plafonds de ressources"; "Décrets divers"; ]; @@ -1888,7 +2030,8 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i money_of_cents_string "5775900" +$ money_of_cents_string "577500" *$ decimal_of_integer - (array_length enfants_a_charge_droit_ouvert_prestation_familiale_) + (array_length + enfants_a_charge_droit_ouvert_prestation_familiale_) else raise EmptyError with EmptyError -> raise EmptyError); (fun (_ : _) -> @@ -1903,11 +2046,14 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i end_column = 69; law_headings = [ - "Instruction interministérielle n° DSS/SD2B/2018/279 du 17 décembre \ - 2018 relative à la revalorisation au 1er janvier 2019 des plafonds \ - de ressources d’attribution de certaines prestations familiales \ - servies en métropole, en Guadeloupe, en Guyane, en Martinique, à la \ - Réunion, à Saint-Barthélemy, à Saint-Martin et à Mayotte"; + "Instruction interministérielle n° \ + DSS/SD2B/2018/279 du 17 décembre 2018 relative à \ + la revalorisation au 1er janvier 2019 des \ + plafonds de ressources d’attribution de \ + certaines prestations familiales servies en \ + métropole, en Guadeloupe, en Guyane, en \ + Martinique, à la Réunion, à Saint-Barthélemy, à \ + Saint-Martin et à Mayotte"; "Montant des plafonds de ressources"; "Décrets divers"; ]; @@ -1918,7 +2064,8 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i money_of_cents_string "5684900" +$ money_of_cents_string "568400" *$ decimal_of_integer - (array_length enfants_a_charge_droit_ouvert_prestation_familiale_) + (array_length + enfants_a_charge_droit_ouvert_prestation_familiale_) else raise EmptyError with EmptyError -> raise EmptyError); (fun (_ : _) -> @@ -1933,11 +2080,14 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i end_column = 69; law_headings = [ - "Circulaire interministérielle N° DSS/SD2B/2017/352 du 22 décembre \ - 2017 relative à la revalorisation au 1er janvier 2018 des plafonds \ - de ressources d’attribution de certaines prestations familiales \ - servies en métropole, en Guadeloupe, en Guyane, en Martinique, à la \ - Réunion, à Saint-Barthélemy, à Saint-Martin et à Mayotte"; + "Circulaire interministérielle N° \ + DSS/SD2B/2017/352 du 22 décembre 2017 relative à \ + la revalorisation au 1er janvier 2018 des \ + plafonds de ressources d’attribution de \ + certaines prestations familiales servies en \ + métropole, en Guadeloupe, en Guyane, en \ + Martinique, à la Réunion, à Saint-Barthélemy, à \ + Saint-Martin et à Mayotte"; "Montant des plafonds de ressources"; "Décrets divers"; ]; @@ -1948,7 +2098,8 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i money_of_cents_string "5628600" +$ money_of_cents_string "562800" *$ decimal_of_integer - (array_length enfants_a_charge_droit_ouvert_prestation_familiale_) + (array_length + enfants_a_charge_droit_ouvert_prestation_familiale_) else raise EmptyError with EmptyError -> raise EmptyError); |] @@ -1968,7 +2119,8 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i money_of_cents_string "5595000" +$ money_of_cents_string "559500" *$ decimal_of_integer - (array_length enfants_a_charge_droit_ouvert_prestation_familiale_) + (array_length + enfants_a_charge_droit_ouvert_prestation_familiale_) with EmptyError -> raise EmptyError) with EmptyError -> raise EmptyError with EmptyError -> @@ -2002,16 +2154,19 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i law_headings = [ "Article L755-12"; - "Chapitre 5 : Prestations familiales et prestations assimilées"; - "Titre 5 : Dispositions particulières à la Guadeloupe, à la Guyane, à la \ - Martinique, à La Réunion, à Saint-Barthélemy et à Saint-Martin"; + "Chapitre 5 : Prestations familiales et prestations \ + assimilées"; + "Titre 5 : Dispositions particulières à la \ + Guadeloupe, à la Guyane, à la Martinique, à La \ + Réunion, à Saint-Barthélemy et à Saint-Martin"; "Livre 7 : Régimes divers - Dispositions diverses"; "Partie législative"; "Code de la sécurité sociale"; ]; } (prestations_familiales_dot_regime_outre_mer_l751_1_ - && array_length enfants_a_charge_droit_ouvert_prestation_familiale_ + && array_length + enfants_a_charge_droit_ouvert_prestation_familiale_ = integer_of_string "1") then false else raise EmptyError @@ -2051,16 +2206,19 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i law_headings = [ "Article L755-12"; - "Chapitre 5 : Prestations familiales et prestations assimilées"; - "Titre 5 : Dispositions particulières à la Guadeloupe, à la Guyane, à \ - la Martinique, à La Réunion, à Saint-Barthélemy et à Saint-Martin"; + "Chapitre 5 : Prestations familiales et \ + prestations assimilées"; + "Titre 5 : Dispositions particulières à la \ + Guadeloupe, à la Guyane, à la Martinique, à La \ + Réunion, à Saint-Barthélemy et à Saint-Martin"; "Livre 7 : Régimes divers - Dispositions diverses"; "Partie législative"; "Code de la sécurité sociale"; ]; } (prestations_familiales_dot_regime_outre_mer_l751_1_ - && array_length enfants_a_charge_droit_ouvert_prestation_familiale_ + && array_length + enfants_a_charge_droit_ouvert_prestation_familiale_ = integer_of_string "1") then false else raise EmptyError @@ -2080,24 +2238,37 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i "Article L521-1"; "Chapitre 1er : Allocations familiales"; "Titre 2 : Prestations générales d'entretien"; - "Livre 5 : Prestations familiales et prestations assimilées"; + "Livre 5 : Prestations familiales et prestations \ + assimilées"; "Partie législative"; "Code de la sécurité sociale"; ]; } - (array_length enfants_a_charge_ >=! nombre_enfants_alinea_2_l521_3_ + (array_length enfants_a_charge_ + >=! nombre_enfants_alinea_2_l521_3_ && param_.age = prestations_familiales_dot_age_l512_3_2_ && param_.a_deja_ouvert_droit_aux_allocations_familiales && log_end_call [ "PrestationsFamiliales"; "conditions_hors_âge" ] (log_variable_definition - [ "PrestationsFamiliales"; "conditions_hors_âge"; "output" ] + [ + "PrestationsFamiliales"; + "conditions_hors_âge"; + "output"; + ] unembeddable (log_begin_call - [ "PrestationsFamiliales"; "conditions_hors_âge" ] + [ + "PrestationsFamiliales"; + "conditions_hors_âge"; + ] prestations_familiales_dot_conditions_hors_age_ (log_variable_definition - [ "PrestationsFamiliales"; "conditions_hors_âge"; "input" ] + [ + "PrestationsFamiliales"; + "conditions_hors_âge"; + "input"; + ] unembeddable param_)))) then true else raise EmptyError @@ -2128,7 +2299,10 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i in let montant_initial_base_quatrieme_enfant_et_plus_mayotte_ : money = log_variable_definition - [ "AllocationsFamiliales"; "montant_initial_base_quatrième_enfant_et_plus_mayotte" ] + [ + "AllocationsFamiliales"; + "montant_initial_base_quatrième_enfant_et_plus_mayotte"; + ] embed_money (try try @@ -2137,9 +2311,11 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i array_length enfants_a_charge_droit_ouvert_prestation_familiale_ >! integer_of_string "3" then - prestations_familiales_dot_base_mensuelle_ *$ decimal_of_string "0.0463" + prestations_familiales_dot_base_mensuelle_ + *$ decimal_of_string "0.0463" *$ decimal_of_integer - (array_length enfants_a_charge_droit_ouvert_prestation_familiale_ + (array_length + enfants_a_charge_droit_ouvert_prestation_familiale_ -! integer_of_string "3") else money_of_cents_string "0" with EmptyError -> raise EmptyError @@ -2158,7 +2334,9 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i in let montant_initial_base_troisieme_enfant_mayotte_ : money = log_variable_definition - [ "AllocationsFamiliales"; "montant_initial_base_troisième_enfant_mayotte" ] + [ + "AllocationsFamiliales"; "montant_initial_base_troisième_enfant_mayotte"; + ] embed_money (try try @@ -2177,8 +2355,8 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i law_headings = [ "Annexe"; - "Décret n°2002-423 du 29 mars 2002 relatif aux prestations familiales \ - à Mayotte"; + "Décret n°2002-423 du 29 mars 2002 relatif aux \ + prestations familiales à Mayotte"; "Dispositions spéciales relatives à Mayotte"; "Décrets divers"; ]; @@ -2187,9 +2365,12 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i && date_courante_ <=@ date_of_numbers 2020 12 31) then if - array_length enfants_a_charge_droit_ouvert_prestation_familiale_ + array_length + enfants_a_charge_droit_ouvert_prestation_familiale_ >! integer_of_string "2" - then prestations_familiales_dot_base_mensuelle_ *$ decimal_of_string "0.143" + then + prestations_familiales_dot_base_mensuelle_ + *$ decimal_of_string "0.143" else money_of_cents_string "0" else raise EmptyError with EmptyError -> raise EmptyError); @@ -2206,8 +2387,8 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i law_headings = [ "Annexe"; - "Décret n°2002-423 du 29 mars 2002 relatif aux prestations familiales \ - à Mayotte"; + "Décret n°2002-423 du 29 mars 2002 relatif aux \ + prestations familiales à Mayotte"; "Dispositions spéciales relatives à Mayotte"; "Décrets divers"; ]; @@ -2216,9 +2397,12 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i && date_courante_ <=@ date_of_numbers 2019 12 31) then if - array_length enfants_a_charge_droit_ouvert_prestation_familiale_ + array_length + enfants_a_charge_droit_ouvert_prestation_familiale_ >! integer_of_string "2" - then prestations_familiales_dot_base_mensuelle_ *$ decimal_of_string "0.1259" + then + prestations_familiales_dot_base_mensuelle_ + *$ decimal_of_string "0.1259" else money_of_cents_string "0" else raise EmptyError with EmptyError -> raise EmptyError); @@ -2235,8 +2419,8 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i law_headings = [ "Annexe"; - "Décret n°2002-423 du 29 mars 2002 relatif aux prestations familiales \ - à Mayotte"; + "Décret n°2002-423 du 29 mars 2002 relatif aux \ + prestations familiales à Mayotte"; "Dispositions spéciales relatives à Mayotte"; "Décrets divers"; ]; @@ -2245,9 +2429,12 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i && date_courante_ <=@ date_of_numbers 2018 12 31) then if - array_length enfants_a_charge_droit_ouvert_prestation_familiale_ + array_length + enfants_a_charge_droit_ouvert_prestation_familiale_ >! integer_of_string "2" - then prestations_familiales_dot_base_mensuelle_ *$ decimal_of_string "0.1089" + then + prestations_familiales_dot_base_mensuelle_ + *$ decimal_of_string "0.1089" else money_of_cents_string "0" else raise EmptyError with EmptyError -> raise EmptyError); @@ -2264,8 +2451,8 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i law_headings = [ "Annexe"; - "Décret n°2002-423 du 29 mars 2002 relatif aux prestations familiales \ - à Mayotte"; + "Décret n°2002-423 du 29 mars 2002 relatif aux \ + prestations familiales à Mayotte"; "Dispositions spéciales relatives à Mayotte"; "Décrets divers"; ]; @@ -2274,9 +2461,12 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i && date_courante_ <=@ date_of_numbers 2017 12 31) then if - array_length enfants_a_charge_droit_ouvert_prestation_familiale_ + array_length + enfants_a_charge_droit_ouvert_prestation_familiale_ >! integer_of_string "2" - then prestations_familiales_dot_base_mensuelle_ *$ decimal_of_string "0.0918" + then + prestations_familiales_dot_base_mensuelle_ + *$ decimal_of_string "0.0918" else money_of_cents_string "0" else raise EmptyError with EmptyError -> raise EmptyError); @@ -2293,8 +2483,8 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i law_headings = [ "Annexe"; - "Décret n°2002-423 du 29 mars 2002 relatif aux prestations familiales \ - à Mayotte"; + "Décret n°2002-423 du 29 mars 2002 relatif aux \ + prestations familiales à Mayotte"; "Dispositions spéciales relatives à Mayotte"; "Décrets divers"; ]; @@ -2303,9 +2493,12 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i && date_courante_ <=@ date_of_numbers 2016 12 31) then if - array_length enfants_a_charge_droit_ouvert_prestation_familiale_ + array_length + enfants_a_charge_droit_ouvert_prestation_familiale_ >! integer_of_string "2" - then prestations_familiales_dot_base_mensuelle_ *$ decimal_of_string "0.0842" + then + prestations_familiales_dot_base_mensuelle_ + *$ decimal_of_string "0.0842" else money_of_cents_string "0" else raise EmptyError with EmptyError -> raise EmptyError); @@ -2322,8 +2515,8 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i law_headings = [ "Annexe"; - "Décret n°2002-423 du 29 mars 2002 relatif aux prestations familiales \ - à Mayotte"; + "Décret n°2002-423 du 29 mars 2002 relatif aux \ + prestations familiales à Mayotte"; "Dispositions spéciales relatives à Mayotte"; "Décrets divers"; ]; @@ -2332,9 +2525,12 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i && date_courante_ <=@ date_of_numbers 2015 12 31) then if - array_length enfants_a_charge_droit_ouvert_prestation_familiale_ + array_length + enfants_a_charge_droit_ouvert_prestation_familiale_ >! integer_of_string "2" - then prestations_familiales_dot_base_mensuelle_ *$ decimal_of_string "0.0766" + then + prestations_familiales_dot_base_mensuelle_ + *$ decimal_of_string "0.0766" else money_of_cents_string "0" else raise EmptyError with EmptyError -> raise EmptyError); @@ -2351,8 +2547,8 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i law_headings = [ "Annexe"; - "Décret n°2002-423 du 29 mars 2002 relatif aux prestations familiales \ - à Mayotte"; + "Décret n°2002-423 du 29 mars 2002 relatif aux \ + prestations familiales à Mayotte"; "Dispositions spéciales relatives à Mayotte"; "Décrets divers"; ]; @@ -2361,9 +2557,12 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i && date_courante_ <=@ date_of_numbers 2014 12 31) then if - array_length enfants_a_charge_droit_ouvert_prestation_familiale_ + array_length + enfants_a_charge_droit_ouvert_prestation_familiale_ >! integer_of_string "2" - then prestations_familiales_dot_base_mensuelle_ *$ decimal_of_string "0.069" + then + prestations_familiales_dot_base_mensuelle_ + *$ decimal_of_string "0.069" else money_of_cents_string "0" else raise EmptyError with EmptyError -> raise EmptyError); @@ -2380,8 +2579,8 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i law_headings = [ "Annexe"; - "Décret n°2002-423 du 29 mars 2002 relatif aux prestations familiales \ - à Mayotte"; + "Décret n°2002-423 du 29 mars 2002 relatif aux \ + prestations familiales à Mayotte"; "Dispositions spéciales relatives à Mayotte"; "Décrets divers"; ]; @@ -2390,9 +2589,12 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i && date_courante_ <=@ date_of_numbers 2013 12 31) then if - array_length enfants_a_charge_droit_ouvert_prestation_familiale_ + array_length + enfants_a_charge_droit_ouvert_prestation_familiale_ >! integer_of_string "2" - then prestations_familiales_dot_base_mensuelle_ *$ decimal_of_string "0.075" + then + prestations_familiales_dot_base_mensuelle_ + *$ decimal_of_string "0.075" else money_of_cents_string "0" else raise EmptyError with EmptyError -> raise EmptyError); @@ -2409,8 +2611,8 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i law_headings = [ "Annexe"; - "Décret n°2002-423 du 29 mars 2002 relatif aux prestations familiales \ - à Mayotte"; + "Décret n°2002-423 du 29 mars 2002 relatif aux \ + prestations familiales à Mayotte"; "Dispositions spéciales relatives à Mayotte"; "Décrets divers"; ]; @@ -2419,9 +2621,12 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i && date_courante_ <=@ date_of_numbers 2012 12 31) then if - array_length enfants_a_charge_droit_ouvert_prestation_familiale_ + array_length + enfants_a_charge_droit_ouvert_prestation_familiale_ >! integer_of_string "2" - then prestations_familiales_dot_base_mensuelle_ *$ decimal_of_string "0.0539" + then + prestations_familiales_dot_base_mensuelle_ + *$ decimal_of_string "0.0539" else money_of_cents_string "0" else raise EmptyError with EmptyError -> raise EmptyError); @@ -2438,8 +2643,8 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i law_headings = [ "Annexe"; - "Décret n°2002-423 du 29 mars 2002 relatif aux prestations familiales \ - à Mayotte"; + "Décret n°2002-423 du 29 mars 2002 relatif aux \ + prestations familiales à Mayotte"; "Dispositions spéciales relatives à Mayotte"; "Décrets divers"; ]; @@ -2448,9 +2653,12 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i && date_courante_ <=@ date_of_numbers 2011 12 31) then if - array_length enfants_a_charge_droit_ouvert_prestation_familiale_ + array_length + enfants_a_charge_droit_ouvert_prestation_familiale_ >! integer_of_string "2" - then prestations_familiales_dot_base_mensuelle_ *$ decimal_of_string "0.0463" + then + prestations_familiales_dot_base_mensuelle_ + *$ decimal_of_string "0.0463" else money_of_cents_string "0" else raise EmptyError with EmptyError -> raise EmptyError); @@ -2469,9 +2677,12 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i (fun (_ : _) -> try if - array_length enfants_a_charge_droit_ouvert_prestation_familiale_ + array_length + enfants_a_charge_droit_ouvert_prestation_familiale_ >! integer_of_string "2" - then prestations_familiales_dot_base_mensuelle_ *$ decimal_of_string "0.16" + then + prestations_familiales_dot_base_mensuelle_ + *$ decimal_of_string "0.16" else money_of_cents_string "0" with EmptyError -> raise EmptyError) with EmptyError -> raise EmptyError @@ -2489,7 +2700,9 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i in let montant_initial_base_deuxieme_enfant_mayotte_ : money = log_variable_definition - [ "AllocationsFamiliales"; "montant_initial_base_deuxième_enfant_mayotte" ] + [ + "AllocationsFamiliales"; "montant_initial_base_deuxième_enfant_mayotte"; + ] embed_money (try try @@ -2508,8 +2721,8 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i law_headings = [ "Annexe"; - "Décret n°2002-423 du 29 mars 2002 relatif aux prestations familiales \ - à Mayotte"; + "Décret n°2002-423 du 29 mars 2002 relatif aux \ + prestations familiales à Mayotte"; "Dispositions spéciales relatives à Mayotte"; "Décrets divers"; ]; @@ -2518,9 +2731,12 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i && date_courante_ <=@ date_of_numbers 2020 12 31) then if - array_length enfants_a_charge_droit_ouvert_prestation_familiale_ + array_length + enfants_a_charge_droit_ouvert_prestation_familiale_ >! integer_of_string "1" - then prestations_familiales_dot_base_mensuelle_ *$ decimal_of_string "0.3068" + then + prestations_familiales_dot_base_mensuelle_ + *$ decimal_of_string "0.3068" else money_of_cents_string "0" else raise EmptyError with EmptyError -> raise EmptyError); @@ -2537,8 +2753,8 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i law_headings = [ "Annexe"; - "Décret n°2002-423 du 29 mars 2002 relatif aux prestations familiales \ - à Mayotte"; + "Décret n°2002-423 du 29 mars 2002 relatif aux \ + prestations familiales à Mayotte"; "Dispositions spéciales relatives à Mayotte"; "Décrets divers"; ]; @@ -2547,9 +2763,12 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i && date_courante_ <=@ date_of_numbers 2019 12 31) then if - array_length enfants_a_charge_droit_ouvert_prestation_familiale_ + array_length + enfants_a_charge_droit_ouvert_prestation_familiale_ >! integer_of_string "1" - then prestations_familiales_dot_base_mensuelle_ *$ decimal_of_string "0.2936" + then + prestations_familiales_dot_base_mensuelle_ + *$ decimal_of_string "0.2936" else money_of_cents_string "0" else raise EmptyError with EmptyError -> raise EmptyError); @@ -2566,8 +2785,8 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i law_headings = [ "Annexe"; - "Décret n°2002-423 du 29 mars 2002 relatif aux prestations familiales \ - à Mayotte"; + "Décret n°2002-423 du 29 mars 2002 relatif aux \ + prestations familiales à Mayotte"; "Dispositions spéciales relatives à Mayotte"; "Décrets divers"; ]; @@ -2576,9 +2795,12 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i && date_courante_ <=@ date_of_numbers 2018 12 31) then if - array_length enfants_a_charge_droit_ouvert_prestation_familiale_ + array_length + enfants_a_charge_droit_ouvert_prestation_familiale_ >! integer_of_string "1" - then prestations_familiales_dot_base_mensuelle_ *$ decimal_of_string "0.284" + then + prestations_familiales_dot_base_mensuelle_ + *$ decimal_of_string "0.284" else money_of_cents_string "0" else raise EmptyError with EmptyError -> raise EmptyError); @@ -2595,8 +2817,8 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i law_headings = [ "Annexe"; - "Décret n°2002-423 du 29 mars 2002 relatif aux prestations familiales \ - à Mayotte"; + "Décret n°2002-423 du 29 mars 2002 relatif aux \ + prestations familiales à Mayotte"; "Dispositions spéciales relatives à Mayotte"; "Décrets divers"; ]; @@ -2605,9 +2827,12 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i && date_courante_ <=@ date_of_numbers 2017 12 31) then if - array_length enfants_a_charge_droit_ouvert_prestation_familiale_ + array_length + enfants_a_charge_droit_ouvert_prestation_familiale_ >! integer_of_string "1" - then prestations_familiales_dot_base_mensuelle_ *$ decimal_of_string "0.2672" + then + prestations_familiales_dot_base_mensuelle_ + *$ decimal_of_string "0.2672" else money_of_cents_string "0" else raise EmptyError with EmptyError -> raise EmptyError); @@ -2624,8 +2849,8 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i law_headings = [ "Annexe"; - "Décret n°2002-423 du 29 mars 2002 relatif aux prestations familiales \ - à Mayotte"; + "Décret n°2002-423 du 29 mars 2002 relatif aux \ + prestations familiales à Mayotte"; "Dispositions spéciales relatives à Mayotte"; "Décrets divers"; ]; @@ -2634,9 +2859,12 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i && date_courante_ <=@ date_of_numbers 2016 12 31) then if - array_length enfants_a_charge_droit_ouvert_prestation_familiale_ + array_length + enfants_a_charge_droit_ouvert_prestation_familiale_ >! integer_of_string "1" - then prestations_familiales_dot_base_mensuelle_ *$ decimal_of_string "0.273" + then + prestations_familiales_dot_base_mensuelle_ + *$ decimal_of_string "0.273" else money_of_cents_string "0" else raise EmptyError with EmptyError -> raise EmptyError); @@ -2653,8 +2881,8 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i law_headings = [ "Annexe"; - "Décret n°2002-423 du 29 mars 2002 relatif aux prestations familiales \ - à Mayotte"; + "Décret n°2002-423 du 29 mars 2002 relatif aux \ + prestations familiales à Mayotte"; "Dispositions spéciales relatives à Mayotte"; "Décrets divers"; ]; @@ -2663,9 +2891,12 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i && date_courante_ <=@ date_of_numbers 2015 12 31) then if - array_length enfants_a_charge_droit_ouvert_prestation_familiale_ + array_length + enfants_a_charge_droit_ouvert_prestation_familiale_ >! integer_of_string "1" - then prestations_familiales_dot_base_mensuelle_ *$ decimal_of_string "0.2555" + then + prestations_familiales_dot_base_mensuelle_ + *$ decimal_of_string "0.2555" else money_of_cents_string "0" else raise EmptyError with EmptyError -> raise EmptyError); @@ -2682,8 +2913,8 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i law_headings = [ "Annexe"; - "Décret n°2002-423 du 29 mars 2002 relatif aux prestations familiales \ - à Mayotte"; + "Décret n°2002-423 du 29 mars 2002 relatif aux \ + prestations familiales à Mayotte"; "Dispositions spéciales relatives à Mayotte"; "Décrets divers"; ]; @@ -2692,9 +2923,12 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i && date_courante_ <=@ date_of_numbers 2014 12 31) then if - array_length enfants_a_charge_droit_ouvert_prestation_familiale_ + array_length + enfants_a_charge_droit_ouvert_prestation_familiale_ >! integer_of_string "1" - then prestations_familiales_dot_base_mensuelle_ *$ decimal_of_string "0.2496" + then + prestations_familiales_dot_base_mensuelle_ + *$ decimal_of_string "0.2496" else money_of_cents_string "0" else raise EmptyError with EmptyError -> raise EmptyError); @@ -2711,8 +2945,8 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i law_headings = [ "Annexe"; - "Décret n°2002-423 du 29 mars 2002 relatif aux prestations familiales \ - à Mayotte"; + "Décret n°2002-423 du 29 mars 2002 relatif aux \ + prestations familiales à Mayotte"; "Dispositions spéciales relatives à Mayotte"; "Décrets divers"; ]; @@ -2721,9 +2955,12 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i && date_courante_ <=@ date_of_numbers 2013 12 31) then if - array_length enfants_a_charge_droit_ouvert_prestation_familiale_ + array_length + enfants_a_charge_droit_ouvert_prestation_familiale_ >! integer_of_string "1" - then prestations_familiales_dot_base_mensuelle_ *$ decimal_of_string "0.2437" + then + prestations_familiales_dot_base_mensuelle_ + *$ decimal_of_string "0.2437" else money_of_cents_string "0" else raise EmptyError with EmptyError -> raise EmptyError); @@ -2740,8 +2977,8 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i law_headings = [ "Annexe"; - "Décret n°2002-423 du 29 mars 2002 relatif aux prestations familiales \ - à Mayotte"; + "Décret n°2002-423 du 29 mars 2002 relatif aux \ + prestations familiales à Mayotte"; "Dispositions spéciales relatives à Mayotte"; "Décrets divers"; ]; @@ -2750,9 +2987,12 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i && date_courante_ <=@ date_of_numbers 2012 12 31) then if - array_length enfants_a_charge_droit_ouvert_prestation_familiale_ + array_length + enfants_a_charge_droit_ouvert_prestation_familiale_ >! integer_of_string "1" - then prestations_familiales_dot_base_mensuelle_ *$ decimal_of_string "0.2379" + then + prestations_familiales_dot_base_mensuelle_ + *$ decimal_of_string "0.2379" else money_of_cents_string "0" else raise EmptyError with EmptyError -> raise EmptyError); @@ -2769,8 +3009,8 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i law_headings = [ "Annexe"; - "Décret n°2002-423 du 29 mars 2002 relatif aux prestations familiales \ - à Mayotte"; + "Décret n°2002-423 du 29 mars 2002 relatif aux \ + prestations familiales à Mayotte"; "Dispositions spéciales relatives à Mayotte"; "Décrets divers"; ]; @@ -2779,9 +3019,12 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i && date_courante_ <=@ date_of_numbers 2011 12 31) then if - array_length enfants_a_charge_droit_ouvert_prestation_familiale_ + array_length + enfants_a_charge_droit_ouvert_prestation_familiale_ >! integer_of_string "1" - then prestations_familiales_dot_base_mensuelle_ *$ decimal_of_string "0.232" + then + prestations_familiales_dot_base_mensuelle_ + *$ decimal_of_string "0.232" else money_of_cents_string "0" else raise EmptyError with EmptyError -> raise EmptyError); @@ -2800,9 +3043,12 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i (fun (_ : _) -> try if - array_length enfants_a_charge_droit_ouvert_prestation_familiale_ + array_length + enfants_a_charge_droit_ouvert_prestation_familiale_ >! integer_of_string "1" - then prestations_familiales_dot_base_mensuelle_ *$ decimal_of_string "0.32" + then + prestations_familiales_dot_base_mensuelle_ + *$ decimal_of_string "0.32" else money_of_cents_string "0" with EmptyError -> raise EmptyError) with EmptyError -> raise EmptyError @@ -2839,8 +3085,8 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i law_headings = [ "Annexe"; - "Décret n°2002-423 du 29 mars 2002 relatif aux prestations familiales \ - à Mayotte"; + "Décret n°2002-423 du 29 mars 2002 relatif aux \ + prestations familiales à Mayotte"; "Dispositions spéciales relatives à Mayotte"; "Décrets divers"; ]; @@ -2848,7 +3094,8 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i avait_enfant_a_charge_avant_1er_janvier_2012_ then if - array_length enfants_a_charge_droit_ouvert_prestation_familiale_ + array_length + enfants_a_charge_droit_ouvert_prestation_familiale_ >! integer_of_string "0" then money_of_cents_string "5728" else money_of_cents_string "0" @@ -2867,8 +3114,8 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i law_headings = [ "Annexe"; - "Décret n°2002-423 du 29 mars 2002 relatif aux prestations familiales \ - à Mayotte"; + "Décret n°2002-423 du 29 mars 2002 relatif aux \ + prestations familiales à Mayotte"; "Dispositions spéciales relatives à Mayotte"; "Décrets divers"; ]; @@ -2878,9 +3125,12 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i && not avait_enfant_a_charge_avant_1er_janvier_2012_) then if - array_length enfants_a_charge_droit_ouvert_prestation_familiale_ + array_length + enfants_a_charge_droit_ouvert_prestation_familiale_ >! integer_of_string "0" - then prestations_familiales_dot_base_mensuelle_ *$ decimal_of_string "0.0717" + then + prestations_familiales_dot_base_mensuelle_ + *$ decimal_of_string "0.0717" else money_of_cents_string "0" else raise EmptyError with EmptyError -> raise EmptyError); @@ -2897,8 +3147,8 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i law_headings = [ "Annexe"; - "Décret n°2002-423 du 29 mars 2002 relatif aux prestations familiales \ - à Mayotte"; + "Décret n°2002-423 du 29 mars 2002 relatif aux \ + prestations familiales à Mayotte"; "Dispositions spéciales relatives à Mayotte"; "Décrets divers"; ]; @@ -2908,9 +3158,12 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i && not avait_enfant_a_charge_avant_1er_janvier_2012_) then if - array_length enfants_a_charge_droit_ouvert_prestation_familiale_ + array_length + enfants_a_charge_droit_ouvert_prestation_familiale_ >! integer_of_string "0" - then prestations_familiales_dot_base_mensuelle_ *$ decimal_of_string "0.0847" + then + prestations_familiales_dot_base_mensuelle_ + *$ decimal_of_string "0.0847" else money_of_cents_string "0" else raise EmptyError with EmptyError -> raise EmptyError); @@ -2927,8 +3180,8 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i law_headings = [ "Annexe"; - "Décret n°2002-423 du 29 mars 2002 relatif aux prestations familiales \ - à Mayotte"; + "Décret n°2002-423 du 29 mars 2002 relatif aux \ + prestations familiales à Mayotte"; "Dispositions spéciales relatives à Mayotte"; "Décrets divers"; ]; @@ -2938,9 +3191,12 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i && not avait_enfant_a_charge_avant_1er_janvier_2012_) then if - array_length enfants_a_charge_droit_ouvert_prestation_familiale_ + array_length + enfants_a_charge_droit_ouvert_prestation_familiale_ >! integer_of_string "0" - then prestations_familiales_dot_base_mensuelle_ *$ decimal_of_string "0.0976" + then + prestations_familiales_dot_base_mensuelle_ + *$ decimal_of_string "0.0976" else money_of_cents_string "0" else raise EmptyError with EmptyError -> raise EmptyError); @@ -2957,8 +3213,8 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i law_headings = [ "Annexe"; - "Décret n°2002-423 du 29 mars 2002 relatif aux prestations familiales \ - à Mayotte"; + "Décret n°2002-423 du 29 mars 2002 relatif aux \ + prestations familiales à Mayotte"; "Dispositions spéciales relatives à Mayotte"; "Décrets divers"; ]; @@ -2968,9 +3224,12 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i && not avait_enfant_a_charge_avant_1er_janvier_2012_) then if - array_length enfants_a_charge_droit_ouvert_prestation_familiale_ + array_length + enfants_a_charge_droit_ouvert_prestation_familiale_ >! integer_of_string "0" - then prestations_familiales_dot_base_mensuelle_ *$ decimal_of_string "0.115" + then + prestations_familiales_dot_base_mensuelle_ + *$ decimal_of_string "0.115" else money_of_cents_string "0" else raise EmptyError with EmptyError -> raise EmptyError); @@ -2987,8 +3246,8 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i law_headings = [ "Annexe"; - "Décret n°2002-423 du 29 mars 2002 relatif aux prestations familiales \ - à Mayotte"; + "Décret n°2002-423 du 29 mars 2002 relatif aux \ + prestations familiales à Mayotte"; "Dispositions spéciales relatives à Mayotte"; "Décrets divers"; ]; @@ -2998,9 +3257,12 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i && not avait_enfant_a_charge_avant_1er_janvier_2012_) then if - array_length enfants_a_charge_droit_ouvert_prestation_familiale_ + array_length + enfants_a_charge_droit_ouvert_prestation_familiale_ >! integer_of_string "0" - then prestations_familiales_dot_base_mensuelle_ *$ decimal_of_string "0.1163" + then + prestations_familiales_dot_base_mensuelle_ + *$ decimal_of_string "0.1163" else money_of_cents_string "0" else raise EmptyError with EmptyError -> raise EmptyError); @@ -3017,8 +3279,8 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i law_headings = [ "Annexe"; - "Décret n°2002-423 du 29 mars 2002 relatif aux prestations familiales \ - à Mayotte"; + "Décret n°2002-423 du 29 mars 2002 relatif aux \ + prestations familiales à Mayotte"; "Dispositions spéciales relatives à Mayotte"; "Décrets divers"; ]; @@ -3028,9 +3290,12 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i && not avait_enfant_a_charge_avant_1er_janvier_2012_) then if - array_length enfants_a_charge_droit_ouvert_prestation_familiale_ + array_length + enfants_a_charge_droit_ouvert_prestation_familiale_ >! integer_of_string "0" - then prestations_familiales_dot_base_mensuelle_ *$ decimal_of_string "0.122" + then + prestations_familiales_dot_base_mensuelle_ + *$ decimal_of_string "0.122" else money_of_cents_string "0" else raise EmptyError with EmptyError -> raise EmptyError); @@ -3047,8 +3312,8 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i law_headings = [ "Annexe"; - "Décret n°2002-423 du 29 mars 2002 relatif aux prestations familiales \ - à Mayotte"; + "Décret n°2002-423 du 29 mars 2002 relatif aux \ + prestations familiales à Mayotte"; "Dispositions spéciales relatives à Mayotte"; "Décrets divers"; ]; @@ -3058,9 +3323,12 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i && not avait_enfant_a_charge_avant_1er_janvier_2012_) then if - array_length enfants_a_charge_droit_ouvert_prestation_familiale_ + array_length + enfants_a_charge_droit_ouvert_prestation_familiale_ >! integer_of_string "0" - then prestations_familiales_dot_base_mensuelle_ *$ decimal_of_string "0.1278" + then + prestations_familiales_dot_base_mensuelle_ + *$ decimal_of_string "0.1278" else money_of_cents_string "0" else raise EmptyError with EmptyError -> raise EmptyError); @@ -3077,8 +3345,8 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i law_headings = [ "Annexe"; - "Décret n°2002-423 du 29 mars 2002 relatif aux prestations familiales \ - à Mayotte"; + "Décret n°2002-423 du 29 mars 2002 relatif aux \ + prestations familiales à Mayotte"; "Dispositions spéciales relatives à Mayotte"; "Décrets divers"; ]; @@ -3088,9 +3356,12 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i && not avait_enfant_a_charge_avant_1er_janvier_2012_) then if - array_length enfants_a_charge_droit_ouvert_prestation_familiale_ + array_length + enfants_a_charge_droit_ouvert_prestation_familiale_ >! integer_of_string "0" - then prestations_familiales_dot_base_mensuelle_ *$ decimal_of_string "0.1335" + then + prestations_familiales_dot_base_mensuelle_ + *$ decimal_of_string "0.1335" else money_of_cents_string "0" else raise EmptyError with EmptyError -> raise EmptyError); @@ -3107,8 +3378,8 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i law_headings = [ "Annexe"; - "Décret n°2002-423 du 29 mars 2002 relatif aux prestations familiales \ - à Mayotte"; + "Décret n°2002-423 du 29 mars 2002 relatif aux \ + prestations familiales à Mayotte"; "Dispositions spéciales relatives à Mayotte"; "Décrets divers"; ]; @@ -3118,9 +3389,12 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i && not avait_enfant_a_charge_avant_1er_janvier_2012_) then if - array_length enfants_a_charge_droit_ouvert_prestation_familiale_ + array_length + enfants_a_charge_droit_ouvert_prestation_familiale_ >! integer_of_string "0" - then prestations_familiales_dot_base_mensuelle_ *$ decimal_of_string "0.1393" + then + prestations_familiales_dot_base_mensuelle_ + *$ decimal_of_string "0.1393" else money_of_cents_string "0" else raise EmptyError with EmptyError -> raise EmptyError); @@ -3137,8 +3411,8 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i law_headings = [ "Annexe"; - "Décret n°2002-423 du 29 mars 2002 relatif aux prestations familiales \ - à Mayotte"; + "Décret n°2002-423 du 29 mars 2002 relatif aux \ + prestations familiales à Mayotte"; "Dispositions spéciales relatives à Mayotte"; "Décrets divers"; ]; @@ -3148,9 +3422,12 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i && not avait_enfant_a_charge_avant_1er_janvier_2012_) then if - array_length enfants_a_charge_droit_ouvert_prestation_familiale_ + array_length + enfants_a_charge_droit_ouvert_prestation_familiale_ >! integer_of_string "0" - then prestations_familiales_dot_base_mensuelle_ *$ decimal_of_string "0.145" + then + prestations_familiales_dot_base_mensuelle_ + *$ decimal_of_string "0.145" else money_of_cents_string "0" else raise EmptyError with EmptyError -> raise EmptyError); @@ -3169,9 +3446,12 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i (fun (_ : _) -> try if - array_length enfants_a_charge_droit_ouvert_prestation_familiale_ + array_length + enfants_a_charge_droit_ouvert_prestation_familiale_ >! integer_of_string "0" - then prestations_familiales_dot_base_mensuelle_ *$ decimal_of_string "0.0588" + then + prestations_familiales_dot_base_mensuelle_ + *$ decimal_of_string "0.0588" else money_of_cents_string "0" with EmptyError -> raise EmptyError) with EmptyError -> raise EmptyError @@ -3193,7 +3473,9 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i embed_decimal (try try - try decimal_of_integer (array_length enfants_a_charge_droit_ouvert_prestation_familiale_) + try + decimal_of_integer + (array_length enfants_a_charge_droit_ouvert_prestation_familiale_) with EmptyError -> raise EmptyError with EmptyError -> raise EmptyError with EmptyError -> @@ -3229,13 +3511,18 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i [ "AllocationsFamiliales"; "prise_en_compte" ] prise_en_compte_ (log_variable_definition - [ "AllocationsFamiliales"; "prise_en_compte"; "input" ] + [ + "AllocationsFamiliales"; + "prise_en_compte"; + "input"; + ] unembeddable enfant_))) with | Complete _ -> decimal_of_string "1." | Partagee _ -> decimal_of_string "0.5" | Zero _ -> decimal_of_string "0.") - (decimal_of_string "0.") enfants_a_charge_droit_ouvert_prestation_familiale_ + (decimal_of_string "0.") + enfants_a_charge_droit_ouvert_prestation_familiale_ with EmptyError -> raise EmptyError with EmptyError -> raise EmptyError with EmptyError -> @@ -3269,7 +3556,8 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i law_headings = [ "Article D755-5"; - "Chapitre 5 : Prestations familiales et prestations assimilées"; + "Chapitre 5 : Prestations familiales et prestations \ + assimilées"; "Titre 5 : Départements d'outre-mer"; "Livre 7 : Régimes divers - Dispositions diverses"; "Partie réglementaire - Décrets simples"; @@ -3277,9 +3565,12 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i ]; } (prestations_familiales_dot_regime_outre_mer_l751_1_ - && array_length enfants_a_charge_droit_ouvert_prestation_familiale_ + && array_length + enfants_a_charge_droit_ouvert_prestation_familiale_ = integer_of_string "1") - then prestations_familiales_dot_base_mensuelle_ *$ decimal_of_string "0.0588" + then + prestations_familiales_dot_base_mensuelle_ + *$ decimal_of_string "0.0588" else raise EmptyError with EmptyError -> raise EmptyError with EmptyError -> money_of_cents_string "0" @@ -3317,14 +3608,15 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i law_headings = [ "Article 7"; - "Décret n°2002-423 du 29 mars 2002 relatif aux prestations familiales \ - à Mayotte"; + "Décret n°2002-423 du 29 mars 2002 relatif aux \ + prestations familiales à Mayotte"; "Dispositions spéciales relatives à Mayotte"; "Décrets divers"; ]; } (residence_ = Mayotte () - && array_length enfants_a_charge_droit_ouvert_prestation_familiale_ + && array_length + enfants_a_charge_droit_ouvert_prestation_familiale_ >=! integer_of_string "1") then true else raise EmptyError @@ -3342,16 +3634,19 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i law_headings = [ "Article L755-12"; - "Chapitre 5 : Prestations familiales et prestations assimilées"; - "Titre 5 : Dispositions particulières à la Guadeloupe, à la Guyane, à \ - la Martinique, à La Réunion, à Saint-Barthélemy et à Saint-Martin"; + "Chapitre 5 : Prestations familiales et \ + prestations assimilées"; + "Titre 5 : Dispositions particulières à la \ + Guadeloupe, à la Guyane, à la Martinique, à La \ + Réunion, à Saint-Barthélemy et à Saint-Martin"; "Livre 7 : Régimes divers - Dispositions diverses"; "Partie législative"; "Code de la sécurité sociale"; ]; } (prestations_familiales_dot_regime_outre_mer_l751_1_ - && array_length enfants_a_charge_droit_ouvert_prestation_familiale_ + && array_length + enfants_a_charge_droit_ouvert_prestation_familiale_ >=! integer_of_string "1") then true else raise EmptyError @@ -3383,12 +3678,14 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i "Article L521-1"; "Chapitre 1er : Allocations familiales"; "Titre 2 : Prestations générales d'entretien"; - "Livre 5 : Prestations familiales et prestations assimilées"; + "Livre 5 : Prestations familiales et prestations \ + assimilées"; "Partie législative"; "Code de la sécurité sociale"; ]; } - (array_length enfants_a_charge_droit_ouvert_prestation_familiale_ + (array_length + enfants_a_charge_droit_ouvert_prestation_familiale_ >=! integer_of_string "2") then true else raise EmptyError @@ -3429,16 +3726,21 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i "Article L521-3"; "Chapitre 1er : Allocations familiales"; "Titre 2 : Prestations générales d'entretien"; - "Livre 5 : Prestations familiales et prestations assimilées"; + "Livre 5 : Prestations familiales et prestations \ + assimilées"; "Partie législative"; "Code de la sécurité sociale"; ]; } - (array_length enfants_a_charge_droit_ouvert_prestation_familiale_ + (array_length + enfants_a_charge_droit_ouvert_prestation_familiale_ >=! nombre_enfants_alinea_2_l521_3_ && param_.age >=! log_end_call - [ "AllocationsFamiliales"; "âge_minimum_alinéa_1_l521_3" ] + [ + "AllocationsFamiliales"; + "âge_minimum_alinéa_1_l521_3"; + ] (log_variable_definition [ "AllocationsFamiliales"; @@ -3447,7 +3749,10 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i ] unembeddable (log_begin_call - [ "AllocationsFamiliales"; "âge_minimum_alinéa_1_l521_3" ] + [ + "AllocationsFamiliales"; + "âge_minimum_alinéa_1_l521_3"; + ] age_minimum_alinea_1_l521_3_ (log_variable_definition [ @@ -3474,28 +3779,44 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i "Article L521-3"; "Chapitre 1er : Allocations familiales"; "Titre 2 : Prestations générales d'entretien"; - "Livre 5 : Prestations familiales et prestations assimilées"; + "Livre 5 : Prestations familiales et prestations \ + assimilées"; "Partie législative"; "Code de la sécurité sociale"; ]; } ((not (log_end_call - [ "AllocationsFamiliales"; "est_enfant_le_plus_âgé" ] + [ + "AllocationsFamiliales"; + "est_enfant_le_plus_âgé"; + ] (log_variable_definition - [ "AllocationsFamiliales"; "est_enfant_le_plus_âgé"; "output" ] + [ + "AllocationsFamiliales"; + "est_enfant_le_plus_âgé"; + "output"; + ] unembeddable (log_begin_call - [ "AllocationsFamiliales"; "est_enfant_le_plus_âgé" ] + [ + "AllocationsFamiliales"; + "est_enfant_le_plus_âgé"; + ] est_enfant_le_plus_age_ (log_variable_definition [ - "AllocationsFamiliales"; "est_enfant_le_plus_âgé"; "input"; + "AllocationsFamiliales"; + "est_enfant_le_plus_âgé"; + "input"; ] unembeddable param_))))) && param_.age >=! log_end_call - [ "AllocationsFamiliales"; "âge_minimum_alinéa_1_l521_3" ] + [ + "AllocationsFamiliales"; + "âge_minimum_alinéa_1_l521_3"; + ] (log_variable_definition [ "AllocationsFamiliales"; @@ -3504,7 +3825,10 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i ] unembeddable (log_begin_call - [ "AllocationsFamiliales"; "âge_minimum_alinéa_1_l521_3" ] + [ + "AllocationsFamiliales"; + "âge_minimum_alinéa_1_l521_3"; + ] age_minimum_alinea_1_l521_3_ (log_variable_definition [ @@ -3565,17 +3889,20 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i "Article D521-1"; "Chapitre 1er : Allocations familiales"; "Titre 2 : Prestations générales d'entretien"; - "Livre 5 : Prestations familiales et prestations assimilées"; + "Livre 5 : Prestations familiales et \ + prestations assimilées"; "Partie réglementaire - Décrets simples"; "Code de la sécurité sociale"; ]; } (ressources_menage_ >$ plafond__i_i_d521_3_ && ressources_menage_ - <=$ plafond__i_i_d521_3_ +$ (param_ *$ decimal_of_string "12.")) + <=$ plafond__i_i_d521_3_ + +$ (param_ *$ decimal_of_string "12.")) then (plafond__i_i_d521_3_ - +$ ((param_ *$ decimal_of_string "12.") -$ ressources_menage_)) + +$ ((param_ *$ decimal_of_string "12.") + -$ ressources_menage_)) *$ (decimal_of_string "1." /& decimal_of_string "12.") else raise EmptyError with EmptyError -> raise EmptyError); @@ -3594,17 +3921,20 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i "Article D521-1"; "Chapitre 1er : Allocations familiales"; "Titre 2 : Prestations générales d'entretien"; - "Livre 5 : Prestations familiales et prestations assimilées"; + "Livre 5 : Prestations familiales et \ + prestations assimilées"; "Partie réglementaire - Décrets simples"; "Code de la sécurité sociale"; ]; } (ressources_menage_ >$ plafond__i_d521_3_ && ressources_menage_ - <=$ plafond__i_d521_3_ +$ (param_ *$ decimal_of_string "12.")) + <=$ plafond__i_d521_3_ + +$ (param_ *$ decimal_of_string "12.")) then (plafond__i_d521_3_ - +$ ((param_ *$ decimal_of_string "12.") -$ ressources_menage_)) + +$ ((param_ *$ decimal_of_string "12.") + -$ ressources_menage_)) *$ (decimal_of_string "1." /& decimal_of_string "12.") else raise EmptyError with EmptyError -> raise EmptyError); @@ -3667,13 +3997,16 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i "Article D521-2"; "Chapitre 1er : Allocations familiales"; "Titre 2 : Prestations générales d'entretien"; - "Livre 5 : Prestations familiales et prestations assimilées"; + "Livre 5 : Prestations familiales et prestations \ + assimilées"; "Partie réglementaire - Décrets simples"; "Code de la sécurité sociale"; ]; } (ressources_menage_ >$ plafond__i_i_d521_3_) - then prestations_familiales_dot_base_mensuelle_ *$ decimal_of_string "0.0559" + then + prestations_familiales_dot_base_mensuelle_ + *$ decimal_of_string "0.0559" else raise EmptyError with EmptyError -> raise EmptyError); (fun (_ : _) -> @@ -3691,14 +4024,17 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i "Article D521-2"; "Chapitre 1er : Allocations familiales"; "Titre 2 : Prestations générales d'entretien"; - "Livre 5 : Prestations familiales et prestations assimilées"; + "Livre 5 : Prestations familiales et prestations \ + assimilées"; "Partie réglementaire - Décrets simples"; "Code de la sécurité sociale"; ]; } (ressources_menage_ >$ plafond__i_d521_3_ && ressources_menage_ <=$ plafond__i_i_d521_3_) - then prestations_familiales_dot_base_mensuelle_ *$ decimal_of_string "0.1117" + then + prestations_familiales_dot_base_mensuelle_ + *$ decimal_of_string "0.1117" else raise EmptyError with EmptyError -> raise EmptyError); (fun (_ : _) -> @@ -3716,13 +4052,16 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i "Article D521-2"; "Chapitre 1er : Allocations familiales"; "Titre 2 : Prestations générales d'entretien"; - "Livre 5 : Prestations familiales et prestations assimilées"; + "Livre 5 : Prestations familiales et prestations \ + assimilées"; "Partie réglementaire - Décrets simples"; "Code de la sécurité sociale"; ]; } (ressources_menage_ <=$ plafond__i_d521_3_) - then prestations_familiales_dot_base_mensuelle_ *$ decimal_of_string "0.20234" + then + prestations_familiales_dot_base_mensuelle_ + *$ decimal_of_string "0.20234" else raise EmptyError with EmptyError -> raise EmptyError); |] @@ -3752,7 +4091,9 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i in let montant_initial_base_troisieme_enfant_et_plus_ : money = log_variable_definition - [ "AllocationsFamiliales"; "montant_initial_base_troisième_enfant_et_plus" ] + [ + "AllocationsFamiliales"; "montant_initial_base_troisième_enfant_et_plus"; + ] embed_money (try handle_default @@ -3772,7 +4113,8 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i "Article D521-1"; "Chapitre 1er : Allocations familiales"; "Titre 2 : Prestations générales d'entretien"; - "Livre 5 : Prestations familiales et prestations assimilées"; + "Livre 5 : Prestations familiales et prestations \ + assimilées"; "Partie réglementaire - Décrets simples"; "Code de la sécurité sociale"; ]; @@ -3780,12 +4122,15 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i (ressources_menage_ >$ plafond__i_i_d521_3_) then if - array_length enfants_a_charge_droit_ouvert_prestation_familiale_ + array_length + enfants_a_charge_droit_ouvert_prestation_familiale_ >! integer_of_string "2" then - prestations_familiales_dot_base_mensuelle_ *$ decimal_of_string "0.1025" + prestations_familiales_dot_base_mensuelle_ + *$ decimal_of_string "0.1025" *$ decimal_of_integer - (array_length enfants_a_charge_droit_ouvert_prestation_familiale_ + (array_length + enfants_a_charge_droit_ouvert_prestation_familiale_ -! integer_of_string "2") else money_of_cents_string "0" else raise EmptyError @@ -3805,7 +4150,8 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i "Article D521-1"; "Chapitre 1er : Allocations familiales"; "Titre 2 : Prestations générales d'entretien"; - "Livre 5 : Prestations familiales et prestations assimilées"; + "Livre 5 : Prestations familiales et prestations \ + assimilées"; "Partie réglementaire - Décrets simples"; "Code de la sécurité sociale"; ]; @@ -3814,12 +4160,15 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i && ressources_menage_ <=$ plafond__i_i_d521_3_) then if - array_length enfants_a_charge_droit_ouvert_prestation_familiale_ + array_length + enfants_a_charge_droit_ouvert_prestation_familiale_ >! integer_of_string "2" then - prestations_familiales_dot_base_mensuelle_ *$ decimal_of_string "0.205" + prestations_familiales_dot_base_mensuelle_ + *$ decimal_of_string "0.205" *$ decimal_of_integer - (array_length enfants_a_charge_droit_ouvert_prestation_familiale_ + (array_length + enfants_a_charge_droit_ouvert_prestation_familiale_ -! integer_of_string "2") else money_of_cents_string "0" else raise EmptyError @@ -3839,7 +4188,8 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i "Article D521-1"; "Chapitre 1er : Allocations familiales"; "Titre 2 : Prestations générales d'entretien"; - "Livre 5 : Prestations familiales et prestations assimilées"; + "Livre 5 : Prestations familiales et prestations \ + assimilées"; "Partie réglementaire - Décrets simples"; "Code de la sécurité sociale"; ]; @@ -3847,12 +4197,15 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i (ressources_menage_ <=$ plafond__i_d521_3_) then if - array_length enfants_a_charge_droit_ouvert_prestation_familiale_ + array_length + enfants_a_charge_droit_ouvert_prestation_familiale_ >! integer_of_string "2" then - prestations_familiales_dot_base_mensuelle_ *$ decimal_of_string "0.41" + prestations_familiales_dot_base_mensuelle_ + *$ decimal_of_string "0.41" *$ decimal_of_integer - (array_length enfants_a_charge_droit_ouvert_prestation_familiale_ + (array_length + enfants_a_charge_droit_ouvert_prestation_familiale_ -! integer_of_string "2") else money_of_cents_string "0" else raise EmptyError @@ -3904,7 +4257,8 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i "Article D521-1"; "Chapitre 1er : Allocations familiales"; "Titre 2 : Prestations générales d'entretien"; - "Livre 5 : Prestations familiales et prestations assimilées"; + "Livre 5 : Prestations familiales et prestations \ + assimilées"; "Partie réglementaire - Décrets simples"; "Code de la sécurité sociale"; ]; @@ -3912,9 +4266,12 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i (ressources_menage_ >$ plafond__i_i_d521_3_) then if - array_length enfants_a_charge_droit_ouvert_prestation_familiale_ + array_length + enfants_a_charge_droit_ouvert_prestation_familiale_ >! integer_of_string "1" - then prestations_familiales_dot_base_mensuelle_ *$ decimal_of_string "0.08" + then + prestations_familiales_dot_base_mensuelle_ + *$ decimal_of_string "0.08" else money_of_cents_string "0" else raise EmptyError with EmptyError -> raise EmptyError); @@ -3933,7 +4290,8 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i "Article D521-1"; "Chapitre 1er : Allocations familiales"; "Titre 2 : Prestations générales d'entretien"; - "Livre 5 : Prestations familiales et prestations assimilées"; + "Livre 5 : Prestations familiales et prestations \ + assimilées"; "Partie réglementaire - Décrets simples"; "Code de la sécurité sociale"; ]; @@ -3942,9 +4300,12 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i && ressources_menage_ <=$ plafond__i_i_d521_3_) then if - array_length enfants_a_charge_droit_ouvert_prestation_familiale_ + array_length + enfants_a_charge_droit_ouvert_prestation_familiale_ >! integer_of_string "1" - then prestations_familiales_dot_base_mensuelle_ *$ decimal_of_string "0.16" + then + prestations_familiales_dot_base_mensuelle_ + *$ decimal_of_string "0.16" else money_of_cents_string "0" else raise EmptyError with EmptyError -> raise EmptyError); @@ -3963,7 +4324,8 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i "Article D521-1"; "Chapitre 1er : Allocations familiales"; "Titre 2 : Prestations générales d'entretien"; - "Livre 5 : Prestations familiales et prestations assimilées"; + "Livre 5 : Prestations familiales et prestations \ + assimilées"; "Partie réglementaire - Décrets simples"; "Code de la sécurité sociale"; ]; @@ -3971,9 +4333,12 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i (ressources_menage_ <=$ plafond__i_d521_3_) then if - array_length enfants_a_charge_droit_ouvert_prestation_familiale_ + array_length + enfants_a_charge_droit_ouvert_prestation_familiale_ >! integer_of_string "1" - then prestations_familiales_dot_base_mensuelle_ *$ decimal_of_string "0.32" + then + prestations_familiales_dot_base_mensuelle_ + *$ decimal_of_string "0.32" else money_of_cents_string "0" else raise EmptyError with EmptyError -> raise EmptyError); @@ -4009,7 +4374,8 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i (try try try - if nombre_total_enfants_ = decimal_of_string "0." then decimal_of_string "0." + if nombre_total_enfants_ = decimal_of_string "0." then + decimal_of_string "0." else nombre_moyen_enfants_ /& nombre_total_enfants_ with EmptyError -> raise EmptyError with EmptyError -> raise EmptyError @@ -4044,16 +4410,27 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i start_column = 5; end_line = 27; end_column = 44; - law_headings = [ "Règles diverses"; "Épilogue"; "Décrets divers" ]; + law_headings = + [ "Règles diverses"; "Épilogue"; "Décrets divers" ]; } (not (log_end_call - [ "AllocationsFamiliales"; "droit_ouvert_majoration" ] + [ + "AllocationsFamiliales"; + "droit_ouvert_majoration"; + ] (log_variable_definition - [ "AllocationsFamiliales"; "droit_ouvert_majoration"; "output" ] + [ + "AllocationsFamiliales"; + "droit_ouvert_majoration"; + "output"; + ] unembeddable (log_begin_call - [ "AllocationsFamiliales"; "droit_ouvert_majoration" ] + [ + "AllocationsFamiliales"; + "droit_ouvert_majoration"; + ] droit_ouvert_majoration_ (log_variable_definition [ @@ -4080,26 +4457,41 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i "Article D521-1"; "Chapitre 1er : Allocations familiales"; "Titre 2 : Prestations générales d'entretien"; - "Livre 5 : Prestations familiales et prestations assimilées"; + "Livre 5 : Prestations familiales et \ + prestations assimilées"; "Partie réglementaire - Décrets simples"; "Code de la sécurité sociale"; ]; } (ressources_menage_ >$ plafond__i_i_d521_3_ && log_end_call - [ "AllocationsFamiliales"; "droit_ouvert_majoration" ] + [ + "AllocationsFamiliales"; + "droit_ouvert_majoration"; + ] (log_variable_definition - [ "AllocationsFamiliales"; "droit_ouvert_majoration"; "output" ] + [ + "AllocationsFamiliales"; + "droit_ouvert_majoration"; + "output"; + ] unembeddable (log_begin_call - [ "AllocationsFamiliales"; "droit_ouvert_majoration" ] + [ + "AllocationsFamiliales"; + "droit_ouvert_majoration"; + ] droit_ouvert_majoration_ (log_variable_definition [ - "AllocationsFamiliales"; "droit_ouvert_majoration"; "input"; + "AllocationsFamiliales"; + "droit_ouvert_majoration"; + "input"; ] unembeddable param_)))) - then prestations_familiales_dot_base_mensuelle_ *$ decimal_of_string "0.04" + then + prestations_familiales_dot_base_mensuelle_ + *$ decimal_of_string "0.04" else raise EmptyError with EmptyError -> raise EmptyError); (fun (_ : _) -> @@ -4117,7 +4509,8 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i "Article D521-1"; "Chapitre 1er : Allocations familiales"; "Titre 2 : Prestations générales d'entretien"; - "Livre 5 : Prestations familiales et prestations assimilées"; + "Livre 5 : Prestations familiales et \ + prestations assimilées"; "Partie réglementaire - Décrets simples"; "Code de la sécurité sociale"; ]; @@ -4125,19 +4518,33 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i ((ressources_menage_ >$ plafond__i_d521_3_ && ressources_menage_ <=$ plafond__i_i_d521_3_) && log_end_call - [ "AllocationsFamiliales"; "droit_ouvert_majoration" ] + [ + "AllocationsFamiliales"; + "droit_ouvert_majoration"; + ] (log_variable_definition - [ "AllocationsFamiliales"; "droit_ouvert_majoration"; "output" ] + [ + "AllocationsFamiliales"; + "droit_ouvert_majoration"; + "output"; + ] unembeddable (log_begin_call - [ "AllocationsFamiliales"; "droit_ouvert_majoration" ] + [ + "AllocationsFamiliales"; + "droit_ouvert_majoration"; + ] droit_ouvert_majoration_ (log_variable_definition [ - "AllocationsFamiliales"; "droit_ouvert_majoration"; "input"; + "AllocationsFamiliales"; + "droit_ouvert_majoration"; + "input"; ] unembeddable param_)))) - then prestations_familiales_dot_base_mensuelle_ *$ decimal_of_string "0.08" + then + prestations_familiales_dot_base_mensuelle_ + *$ decimal_of_string "0.08" else raise EmptyError with EmptyError -> raise EmptyError); (fun (_ : _) -> @@ -4155,26 +4562,41 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i "Article D521-1"; "Chapitre 1er : Allocations familiales"; "Titre 2 : Prestations générales d'entretien"; - "Livre 5 : Prestations familiales et prestations assimilées"; + "Livre 5 : Prestations familiales et \ + prestations assimilées"; "Partie réglementaire - Décrets simples"; "Code de la sécurité sociale"; ]; } (ressources_menage_ <=$ plafond__i_d521_3_ && log_end_call - [ "AllocationsFamiliales"; "droit_ouvert_majoration" ] + [ + "AllocationsFamiliales"; + "droit_ouvert_majoration"; + ] (log_variable_definition - [ "AllocationsFamiliales"; "droit_ouvert_majoration"; "output" ] + [ + "AllocationsFamiliales"; + "droit_ouvert_majoration"; + "output"; + ] unembeddable (log_begin_call - [ "AllocationsFamiliales"; "droit_ouvert_majoration" ] + [ + "AllocationsFamiliales"; + "droit_ouvert_majoration"; + ] droit_ouvert_majoration_ (log_variable_definition [ - "AllocationsFamiliales"; "droit_ouvert_majoration"; "input"; + "AllocationsFamiliales"; + "droit_ouvert_majoration"; + "input"; ] unembeddable param_)))) - then prestations_familiales_dot_base_mensuelle_ *$ decimal_of_string "0.16" + then + prestations_familiales_dot_base_mensuelle_ + *$ decimal_of_string "0.16" else raise EmptyError with EmptyError -> raise EmptyError); |] @@ -4226,15 +4648,28 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i (fun (acc_ : integer) (enfant_ : _) -> if log_end_call - [ "AllocationsFamiliales"; "droit_ouvert_forfaitaire" ] + [ + "AllocationsFamiliales"; "droit_ouvert_forfaitaire"; + ] (log_variable_definition - [ "AllocationsFamiliales"; "droit_ouvert_forfaitaire"; "output" ] + [ + "AllocationsFamiliales"; + "droit_ouvert_forfaitaire"; + "output"; + ] unembeddable (log_begin_call - [ "AllocationsFamiliales"; "droit_ouvert_forfaitaire" ] + [ + "AllocationsFamiliales"; + "droit_ouvert_forfaitaire"; + ] droit_ouvert_forfaitaire_ (log_variable_definition - [ "AllocationsFamiliales"; "droit_ouvert_forfaitaire"; "input" ] + [ + "AllocationsFamiliales"; + "droit_ouvert_forfaitaire"; + "input"; + ] unembeddable enfant_))) then acc_ +! integer_of_string "1" else acc_) @@ -4274,8 +4709,8 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i law_headings = [ "Article 7"; - "Décret n°2002-423 du 29 mars 2002 relatif aux prestations familiales \ - à Mayotte"; + "Décret n°2002-423 du 29 mars 2002 relatif aux \ + prestations familiales à Mayotte"; "Dispositions spéciales relatives à Mayotte"; "Décrets divers"; ]; @@ -4285,7 +4720,8 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i montant_initial_base_premier_enfant_mayotte_ +$ (montant_initial_base_deuxieme_enfant_mayotte_ +$ (montant_initial_base_troisieme_enfant_mayotte_ - +$ montant_initial_base_quatrieme_enfant_et_plus_mayotte_)) + +$ montant_initial_base_quatrieme_enfant_et_plus_mayotte_ + )) else raise EmptyError with EmptyError -> raise EmptyError); (fun (_ : _) -> @@ -4301,7 +4737,8 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i law_headings = [ "Article D755-5"; - "Chapitre 5 : Prestations familiales et prestations assimilées"; + "Chapitre 5 : Prestations familiales et \ + prestations assimilées"; "Titre 5 : Départements d'outre-mer"; "Livre 7 : Régimes divers - Dispositions diverses"; "Partie réglementaire - Décrets simples"; @@ -4309,7 +4746,8 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i ]; } (prestations_familiales_dot_regime_outre_mer_l751_1_ - && array_length enfants_a_charge_droit_ouvert_prestation_familiale_ + && array_length + enfants_a_charge_droit_ouvert_prestation_familiale_ = integer_of_string "1") then montant_initial_base_premier_enfant_ else raise EmptyError @@ -4367,31 +4805,48 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i law_headings = [ "Article D755-5"; - "Chapitre 5 : Prestations familiales et prestations assimilées"; + "Chapitre 5 : Prestations familiales et \ + prestations assimilées"; "Titre 5 : Départements d'outre-mer"; - "Livre 7 : Régimes divers - Dispositions diverses"; + "Livre 7 : Régimes divers - Dispositions \ + diverses"; "Partie réglementaire - Décrets simples"; "Code de la sécurité sociale"; ]; } (log_end_call - [ "AllocationsFamiliales"; "droit_ouvert_majoration" ] + [ + "AllocationsFamiliales"; + "droit_ouvert_majoration"; + ] (log_variable_definition - [ "AllocationsFamiliales"; "droit_ouvert_majoration"; "output" ] + [ + "AllocationsFamiliales"; + "droit_ouvert_majoration"; + "output"; + ] unembeddable (log_begin_call - [ "AllocationsFamiliales"; "droit_ouvert_majoration" ] + [ + "AllocationsFamiliales"; + "droit_ouvert_majoration"; + ] droit_ouvert_majoration_ (log_variable_definition [ - "AllocationsFamiliales"; "droit_ouvert_majoration"; "input"; + "AllocationsFamiliales"; + "droit_ouvert_majoration"; + "input"; ] unembeddable param_))) && prestations_familiales_dot_regime_outre_mer_l751_1_ - && array_length enfants_a_charge_droit_ouvert_prestation_familiale_ + && array_length + enfants_a_charge_droit_ouvert_prestation_familiale_ = integer_of_string "1" && param_.age >=! integer_of_string "16") - then prestations_familiales_dot_base_mensuelle_ *$ decimal_of_string "0.0567" + then + prestations_familiales_dot_base_mensuelle_ + *$ decimal_of_string "0.0567" else raise EmptyError with EmptyError -> raise EmptyError); (fun (_ : _) -> @@ -4407,32 +4862,49 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i law_headings = [ "Article D755-5"; - "Chapitre 5 : Prestations familiales et prestations assimilées"; + "Chapitre 5 : Prestations familiales et \ + prestations assimilées"; "Titre 5 : Départements d'outre-mer"; - "Livre 7 : Régimes divers - Dispositions diverses"; + "Livre 7 : Régimes divers - Dispositions \ + diverses"; "Partie réglementaire - Décrets simples"; "Code de la sécurité sociale"; ]; } (log_end_call - [ "AllocationsFamiliales"; "droit_ouvert_majoration" ] + [ + "AllocationsFamiliales"; + "droit_ouvert_majoration"; + ] (log_variable_definition - [ "AllocationsFamiliales"; "droit_ouvert_majoration"; "output" ] + [ + "AllocationsFamiliales"; + "droit_ouvert_majoration"; + "output"; + ] unembeddable (log_begin_call - [ "AllocationsFamiliales"; "droit_ouvert_majoration" ] + [ + "AllocationsFamiliales"; + "droit_ouvert_majoration"; + ] droit_ouvert_majoration_ (log_variable_definition [ - "AllocationsFamiliales"; "droit_ouvert_majoration"; "input"; + "AllocationsFamiliales"; + "droit_ouvert_majoration"; + "input"; ] unembeddable param_))) && prestations_familiales_dot_regime_outre_mer_l751_1_ - && array_length enfants_a_charge_droit_ouvert_prestation_familiale_ + && array_length + enfants_a_charge_droit_ouvert_prestation_familiale_ = integer_of_string "1" && param_.age >=! integer_of_string "11" && param_.age raise EmptyError); |] @@ -4450,7 +4922,10 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i (fun (_ : _) -> try log_end_call - [ "AllocationsFamiliales"; "montant_initial_métropole_majoration" ] + [ + "AllocationsFamiliales"; + "montant_initial_métropole_majoration"; + ] (log_variable_definition [ "AllocationsFamiliales"; @@ -4459,7 +4934,10 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i ] unembeddable (log_begin_call - [ "AllocationsFamiliales"; "montant_initial_métropole_majoration" ] + [ + "AllocationsFamiliales"; + "montant_initial_métropole_majoration"; + ] montant_initial_metropole_majoration_ (log_variable_definition [ @@ -4516,7 +4994,8 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i "Article D521-2"; "Chapitre 1er : Allocations familiales"; "Titre 2 : Prestations générales d'entretien"; - "Livre 5 : Prestations familiales et prestations assimilées"; + "Livre 5 : Prestations familiales et prestations \ + assimilées"; "Partie réglementaire - Décrets simples"; "Code de la sécurité sociale"; ]; @@ -4524,7 +5003,8 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i (ressources_menage_ >$ plafond__i_i_d521_3_ && ressources_menage_ <=$ plafond__i_i_d521_3_ - +$ (montant_verse_forfaitaire_ *$ decimal_of_string "12.")) + +$ montant_verse_forfaitaire_ + *$ decimal_of_string "12.") then (plafond__i_i_d521_3_ +$ ((montant_verse_forfaitaire_ *$ decimal_of_string "12.") @@ -4547,7 +5027,8 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i "Article D521-2"; "Chapitre 1er : Allocations familiales"; "Titre 2 : Prestations générales d'entretien"; - "Livre 5 : Prestations familiales et prestations assimilées"; + "Livre 5 : Prestations familiales et prestations \ + assimilées"; "Partie réglementaire - Décrets simples"; "Code de la sécurité sociale"; ]; @@ -4555,7 +5036,8 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i (ressources_menage_ >$ plafond__i_d521_3_ && ressources_menage_ <=$ plafond__i_d521_3_ - +$ (montant_verse_forfaitaire_ *$ decimal_of_string "12.")) + +$ montant_verse_forfaitaire_ + *$ decimal_of_string "12.") then (plafond__i_d521_3_ +$ ((montant_verse_forfaitaire_ *$ decimal_of_string "12.") @@ -4622,13 +5104,23 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i log_end_call [ "AllocationsFamiliales"; "montant_initial_majoration" ] (log_variable_definition - [ "AllocationsFamiliales"; "montant_initial_majoration"; "output" ] + [ + "AllocationsFamiliales"; + "montant_initial_majoration"; + "output"; + ] unembeddable (log_begin_call - [ "AllocationsFamiliales"; "montant_initial_majoration" ] + [ + "AllocationsFamiliales"; "montant_initial_majoration"; + ] montant_initial_majoration_ (log_variable_definition - [ "AllocationsFamiliales"; "montant_initial_majoration"; "input" ] + [ + "AllocationsFamiliales"; + "montant_initial_majoration"; + "input"; + ] unembeddable param_))) *$ match @@ -4641,7 +5133,11 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i [ "AllocationsFamiliales"; "prise_en_compte" ] prise_en_compte_ (log_variable_definition - [ "AllocationsFamiliales"; "prise_en_compte"; "input" ] + [ + "AllocationsFamiliales"; + "prise_en_compte"; + "input"; + ] unembeddable param_))) with | Complete _ -> decimal_of_string "1." @@ -4707,7 +5203,10 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i (fun (acc_ : money) (enfant_ : _) -> acc_ +$ log_end_call - [ "AllocationsFamiliales"; "montant_avec_garde_alternée_majoration" ] + [ + "AllocationsFamiliales"; + "montant_avec_garde_alternée_majoration"; + ] (log_variable_definition [ "AllocationsFamiliales"; @@ -4716,7 +5215,10 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i ] unembeddable (log_begin_call - [ "AllocationsFamiliales"; "montant_avec_garde_alternée_majoration" ] + [ + "AllocationsFamiliales"; + "montant_avec_garde_alternée_majoration"; + ] montant_avec_garde_alternee_majoration_ (log_variable_definition [ @@ -4725,7 +5227,8 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i "input"; ] unembeddable enfant_)))) - (money_of_cents_string "0") enfants_a_charge_ + (money_of_cents_string "0") + enfants_a_charge_ else money_of_cents_string "0" with EmptyError -> raise EmptyError with EmptyError -> raise EmptyError @@ -4743,7 +5246,10 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i in let montant_base_complement_pour_base_et_majoration_ : money = log_variable_definition - [ "AllocationsFamiliales"; "montant_base_complément_pour_base_et_majoration" ] + [ + "AllocationsFamiliales"; + "montant_base_complément_pour_base_et_majoration"; + ] embed_money (try try @@ -4764,7 +5270,10 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i in let montant_verse_complement_pour_base_et_majoration_ : money = log_variable_definition - [ "AllocationsFamiliales"; "montant_versé_complément_pour_base_et_majoration" ] + [ + "AllocationsFamiliales"; + "montant_versé_complément_pour_base_et_majoration"; + ] embed_money (try try @@ -4773,14 +5282,21 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i log_end_call [ "AllocationsFamiliales"; "complément_dégressif" ] (log_variable_definition - [ "AllocationsFamiliales"; "complément_dégressif"; "output" ] + [ + "AllocationsFamiliales"; "complément_dégressif"; "output"; + ] unembeddable (log_begin_call [ "AllocationsFamiliales"; "complément_dégressif" ] complement_degressif_ (log_variable_definition - [ "AllocationsFamiliales"; "complément_dégressif"; "input" ] - unembeddable montant_base_complement_pour_base_et_majoration_))) + [ + "AllocationsFamiliales"; + "complément_dégressif"; + "input"; + ] + unembeddable + montant_base_complement_pour_base_et_majoration_))) else money_of_cents_string "0" with EmptyError -> raise EmptyError with EmptyError -> raise EmptyError @@ -4855,19 +5371,31 @@ let allocations_familiales (allocations_familiales_in : allocations_familiales_i { montant_verse_out = montant_verse_ } let interface_allocations_familiales - (interface_allocations_familiales_in : interface_allocations_familiales_in) = - let i_date_courante_ : date = interface_allocations_familiales_in.i_date_courante_in in - let i_enfants_ : enfant_entree array = interface_allocations_familiales_in.i_enfants_in in - let i_ressources_menage_ : money = interface_allocations_familiales_in.i_ressources_menage_in in - let i_residence_ : collectivite = interface_allocations_familiales_in.i_residence_in in + (interface_allocations_familiales_in : interface_allocations_familiales_in) + = + let i_date_courante_ : date = + interface_allocations_familiales_in.i_date_courante_in + in + let i_enfants_ : enfant_entree array = + interface_allocations_familiales_in.i_enfants_in + in + let i_ressources_menage_ : money = + interface_allocations_familiales_in.i_ressources_menage_in + in + let i_residence_ : collectivite = + interface_allocations_familiales_in.i_residence_in + in let i_personne_charge_effective_permanente_est_parent_ : bool = - interface_allocations_familiales_in.i_personne_charge_effective_permanente_est_parent_in + interface_allocations_familiales_in + .i_personne_charge_effective_permanente_est_parent_in in let i_personne_charge_effective_permanente_remplit_titre__i_ : bool = - interface_allocations_familiales_in.i_personne_charge_effective_permanente_remplit_titre_I_in + interface_allocations_familiales_in + .i_personne_charge_effective_permanente_remplit_titre_I_in in let i_avait_enfant_a_charge_avant_1er_janvier_2012_ : bool = - interface_allocations_familiales_in.i_avait_enfant_a_charge_avant_1er_janvier_2012_in + interface_allocations_familiales_in + .i_avait_enfant_a_charge_avant_1er_janvier_2012_in in let enfants_a_charge_ : enfant array = log_variable_definition @@ -4882,17 +5410,20 @@ let interface_allocations_familiales identifiant = enfant_.d_identifiant; obligation_scolaire = (if - enfant_.d_date_de_naissance +@ duration_of_numbers 3 0 0 >=@ i_date_courante_ + enfant_.d_date_de_naissance +@ duration_of_numbers 3 0 0 + >=@ i_date_courante_ then Avant () else if - enfant_.d_date_de_naissance +@ duration_of_numbers 16 0 0 >=@ i_date_courante_ + enfant_.d_date_de_naissance +@ duration_of_numbers 16 0 0 + >=@ i_date_courante_ then Pendant () else Apres ()); remuneration_mensuelle = enfant_.d_remuneration_mensuelle; date_de_naissance = enfant_.d_date_de_naissance; age = year_of_date - (date_of_numbers 0 1 1 +@ (i_date_courante_ -@ enfant_.d_date_de_naissance)); + (date_of_numbers 0 1 1 + +@ (i_date_courante_ -@ enfant_.d_date_de_naissance)); prise_en_charge = enfant_.d_prise_en_charge; a_deja_ouvert_droit_aux_allocations_familiales = enfant_.d_a_deja_ouvert_droit_aux_allocations_familiales; @@ -4909,10 +5440,12 @@ let interface_allocations_familiales start_column = 11; end_line = 74; end_column = 27; - law_headings = [ "Interface du programme"; "Épilogue"; "Décrets divers" ]; + law_headings = + [ "Interface du programme"; "Épilogue"; "Décrets divers" ]; })) in - let allocations_familiales_dot_personne_charge_effective_permanente_est_parent_ : bool = + let allocations_familiales_dot_personne_charge_effective_permanente_est_parent_ + : bool = try log_variable_definition [ @@ -4930,7 +5463,8 @@ let interface_allocations_familiales start_column = 20; end_line = 90; end_column = 69; - law_headings = [ "Interface du programme"; "Épilogue"; "Décrets divers" ]; + law_headings = + [ "Interface du programme"; "Épilogue"; "Décrets divers" ]; } i_personne_charge_effective_permanente_est_parent_ then true @@ -4949,7 +5483,8 @@ let interface_allocations_familiales law_headings = [ "Prologue" ]; }) in - let allocations_familiales_dot_personne_charge_effective_permanente_remplit_titre__i_ : bool = + let allocations_familiales_dot_personne_charge_effective_permanente_remplit_titre__i_ + : bool = try log_variable_definition [ @@ -4967,7 +5502,8 @@ let interface_allocations_familiales start_column = 20; end_line = 93; end_column = 74; - law_headings = [ "Interface du programme"; "Épilogue"; "Décrets divers" ]; + law_headings = + [ "Interface du programme"; "Épilogue"; "Décrets divers" ]; } i_personne_charge_effective_permanente_remplit_titre__i_ then true @@ -4989,7 +5525,10 @@ let interface_allocations_familiales let allocations_familiales_dot_ressources_menage_ : money = try log_variable_definition - [ "InterfaceAllocationsFamiliales"; "allocations_familiales.ressources_ménage" ] + [ + "InterfaceAllocationsFamiliales"; + "allocations_familiales.ressources_ménage"; + ] embed_money (try try i_ressources_menage_ with EmptyError -> raise EmptyError with EmptyError -> raise EmptyError) @@ -5027,7 +5566,10 @@ let interface_allocations_familiales let allocations_familiales_dot_date_courante_ : date = try log_variable_definition - [ "InterfaceAllocationsFamiliales"; "allocations_familiales.date_courante" ] + [ + "InterfaceAllocationsFamiliales"; + "allocations_familiales.date_courante"; + ] embed_date (try try i_date_courante_ with EmptyError -> raise EmptyError with EmptyError -> raise EmptyError) @@ -5046,7 +5588,10 @@ let interface_allocations_familiales let allocations_familiales_dot_enfants_a_charge_ : enfant array = try log_variable_definition - [ "InterfaceAllocationsFamiliales"; "allocations_familiales.enfants_à_charge" ] + [ + "InterfaceAllocationsFamiliales"; + "allocations_familiales.enfants_à_charge"; + ] (embed_array embed_enfant) (try try enfants_a_charge_ with EmptyError -> raise EmptyError with EmptyError -> raise EmptyError) @@ -5062,7 +5607,8 @@ let interface_allocations_familiales law_headings = [ "Prologue" ]; }) in - let allocations_familiales_dot_avait_enfant_a_charge_avant_1er_janvier_2012_ : bool = + let allocations_familiales_dot_avait_enfant_a_charge_avant_1er_janvier_2012_ : + bool = try log_variable_definition [ @@ -5080,7 +5626,8 @@ let interface_allocations_familiales start_column = 20; end_line = 96; end_column = 66; - law_headings = [ "Interface du programme"; "Épilogue"; "Décrets divers" ]; + law_headings = + [ "Interface du programme"; "Épilogue"; "Décrets divers" ]; } i_avait_enfant_a_charge_avant_1er_janvier_2012_ then true @@ -5101,9 +5648,17 @@ let interface_allocations_familiales in let result_ : allocations_familiales_out = log_end_call - [ "InterfaceAllocationsFamiliales"; "allocations_familiales"; "AllocationsFamiliales" ] + [ + "InterfaceAllocationsFamiliales"; + "allocations_familiales"; + "AllocationsFamiliales"; + ] (log_begin_call - [ "InterfaceAllocationsFamiliales"; "allocations_familiales"; "AllocationsFamiliales" ] + [ + "InterfaceAllocationsFamiliales"; + "allocations_familiales"; + "AllocationsFamiliales"; + ] allocations_familiales { personne_charge_effective_permanente_est_parent_in = @@ -5118,13 +5673,17 @@ let interface_allocations_familiales allocations_familiales_dot_avait_enfant_a_charge_avant_1er_janvier_2012_; }) in - let allocations_familiales_dot_montant_verse_ : money = result_.montant_verse_out in + let allocations_familiales_dot_montant_verse_ : money = + result_.montant_verse_out + in let i_montant_verse_ : money = log_variable_definition [ "InterfaceAllocationsFamiliales"; "i_montant_versé" ] embed_money (try - try try allocations_familiales_dot_montant_verse_ with EmptyError -> raise EmptyError + try + try allocations_familiales_dot_montant_verse_ + with EmptyError -> raise EmptyError with EmptyError -> raise EmptyError with EmptyError -> raise @@ -5135,7 +5694,8 @@ let interface_allocations_familiales start_column = 10; end_line = 78; end_column = 25; - law_headings = [ "Interface du programme"; "Épilogue"; "Décrets divers" ]; + law_headings = + [ "Interface du programme"; "Épilogue"; "Décrets divers" ]; })) in { i_montant_verse_out = i_montant_verse_ } diff --git a/french_law/ocaml/law_source/allocations_familiales.mli b/french_law/ocaml/law_source/allocations_familiales.mli index caad300b..0e1955b8 100644 --- a/french_law/ocaml/law_source/allocations_familiales.mli +++ b/french_law/ocaml/law_source/allocations_familiales.mli @@ -1,15 +1,17 @@ -(* This file is part of the French law library, a collection of functions for computing French taxes - and benefits derived from Catala programs. Copyright (C) 2021 Inria, contributor: Denis Merigoux - +(* This file is part of the French law library, a collection of functions for + computing French taxes and benefits derived from Catala programs. Copyright + (C) 2021 Inria, contributor: Denis Merigoux - 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 + 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 + 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. *) open Runtime @@ -21,7 +23,10 @@ type prise_en_charge = | ServicesSociauxAllocationVerseeALaFamille of unit | ServicesSociauxAllocationVerseeAuxServicesSociaux of unit -type situation_obligation_scolaire = Avant of unit | Pendant of unit | Apres of unit +type situation_obligation_scolaire = + | Avant of unit + | Pendant of unit + | Apres of unit type collectivite = | Guadeloupe of unit From b4b6d5d648e06f7cf966c004a70b35f6b48a647c Mon Sep 17 00:00:00 2001 From: Louis Gesbert Date: Tue, 8 Mar 2022 17:35:57 +0100 Subject: [PATCH 4/4] Fix compilation catala_web_interpreter oops I overlooked that one --- compiler/catala_web_interpreter.ml | 1 - compiler/driver.ml | 2 +- 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/compiler/catala_web_interpreter.ml b/compiler/catala_web_interpreter.ml index 16128c59..cc842a5d 100644 --- a/compiler/catala_web_interpreter.ml +++ b/compiler/catala_web_interpreter.ml @@ -17,7 +17,6 @@ let _ = wrap_weaved_output = false; avoid_exceptions = false; backend = "Interpret"; - plugins_dirs = []; language = Some (Js.to_string language); max_prec_digits = None; trace = false; diff --git a/compiler/driver.ml b/compiler/driver.ml index 7e6ce0ac..d0fd7213 100644 --- a/compiler/driver.ml +++ b/compiler/driver.ml @@ -29,7 +29,7 @@ let extensions = (** Entry function for the executable. Returns a negative number in case of error. Usage: - [driver source_file debug dcalc unstyled wrap_weaved_output backend plugins_dirs language max_prec_digits trace optimize scope_to_execute output_file]*) + [driver source_file options]*) let driver source_file (options : Cli.options) : int = try Cli.set_option_globals options;