CatalaLang/catala
1
1
Fork 0
mirror of https://github.com/CatalaLang/catala.git synced 2024-11-08 07:51:43 +03:00
Code Issues Projects Releases Wiki Activity

Merge branch 'master' into adelaett-withoutexceptionsfix

Browse Source
This commit is contained in:
Denis Merigoux 2023-04-18 14:34:20 +02:00
commit 0ec75ad589
No known key found for this signature in database
GPG Key ID: EE99DCFA365C3EE3
28 changed files with 1059 additions and 227 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
compiler/catala_utils/cli.ml
View File

@ -22,6 +22,7 @@ type backend_option_builtin =
| `Makefile
| `Html
| `Interpret
| `Interpret_Lcalc
| `Typecheck
| `OCaml
| `Python
@ -29,8 +30,8 @@ type backend_option_builtin =
| `Lcalc
| `Dcalc
| `Scopelang
| `Proof
| `Interpret_Lcalc ]
| `Exceptions
| `Proof ]
type 'a backend_option = [ backend_option_builtin | `Plugin of 'a ]
@ -55,6 +56,7 @@ let backend_option_to_string = function
| `Typecheck -> "Typecheck"
| `Scalc -> "Scalc"
| `Lcalc -> "Lcalc"
| `Exceptions -> "Exceptions"
| `Plugin s -> s
let backend_option_of_string backend =
@ -72,6 +74,7 @@ let backend_option_of_string backend =
| "typecheck" -> `Typecheck
| "scalc" -> `Scalc
| "lcalc" -> `Lcalc
| "exceptions" -> `Exceptions
| s -> `Plugin s
(** Source files to be compiled *)
@ -241,6 +244,12 @@ let ex_scope =
& opt (some string) None
& info ["s"; "scope"] ~docv:"SCOPE" ~doc:"Scope to be focused on.")
let ex_variable =
Arg.(
value
& opt (some string) None
& info ["v"; "variable"] ~docv:"VARIABLE" ~doc:"Variable to be focused on.")
let output =
Arg.(
value
@ -266,6 +275,7 @@ type options = {
check_invariants : bool;
optimize : bool;
ex_scope : string option;
ex_variable : string option;
output_file : string option;
closure_conversion : bool;
print_only_law : bool;
@ -289,6 +299,7 @@ let options =
optimize
check_invariants
ex_scope
ex_variable
output_file
print_only_law : options =
{
@ -306,6 +317,7 @@ let options =
optimize;
check_invariants;
ex_scope;
ex_variable;
output_file;
closure_conversion;
print_only_law;
@ -329,6 +341,7 @@ let options =
$ optimize
$ check_invariants_opt
$ ex_scope
$ ex_variable
$ output
$ print_only_law)
@ -414,6 +427,13 @@ let info =
"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." );
`I
( "$(b,Exceptions)",
"Prints the exception tree for the definitions of a particular \
variable, for debugging purposes. Use the $(b,-s) option to select \
the scope and the $(b,-v) option to select the variable. Use \
foo.bar to access state bar of variable foo or variable bar of \
subscope foo." );
`I
( "$(b,pygmentize)",
"This special command is a wrapper around the $(b,pygmentize) \

2
compiler/catala_utils/cli.mli
View File

@ -30,6 +30,7 @@ type backend_option_builtin =
| `Lcalc
| `Dcalc
| `Scopelang
| `Exceptions
| `Proof ]
type 'a backend_option = [ backend_option_builtin | `Plugin of 'a ]
@ -110,6 +111,7 @@ type options = {
check_invariants : bool;
optimize : bool;
ex_scope : string option;
ex_variable : string option;
output_file : string option;
closure_conversion : bool;
print_only_law : bool;

1
compiler/catala_web_interpreter.ml
View File

@ -28,6 +28,7 @@ let _ =
optimize = false;
check_invariants = false;
ex_scope = Some (Js.to_string scope);
ex_variable = None;
output_file = None;
print_only_law = false;
}

93
compiler/desugared/ast.ml
View File

@ -24,48 +24,53 @@ open Shared_ast
(** 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 SubScopeName.t * ScopeVar.t * Pos.t
(** In this case, the [ScopeVar.t] lives inside the context of the
subscope's original declaration *)
module Base = struct
type t =
| Var of ScopeVar.t * StateName.t option
| SubScopeVar of SubScopeName.t * ScopeVar.t * Pos.t
(** In this case, the [ScopeVar.t] lives inside the context of the
subscope's original declaration *)
let compare x y =
match x, y with
| Var (x, stx), Var (y, sty) -> (
match ScopeVar.compare x y with
| 0 -> Option.compare StateName.compare stx sty
| n -> n)
| SubScopeVar (x', x, _), SubScopeVar (y', y, _) -> (
match SubScopeName.compare x' y' with 0 -> ScopeVar.compare x y | n -> n)
| Var _, _ -> -1
| _, Var _ -> 1
let compare x y =
match x, y with
| Var (x, stx), Var (y, sty) -> (
match ScopeVar.compare x y with
| 0 -> Option.compare StateName.compare stx sty
| n -> n)
| SubScopeVar (x', x, _), SubScopeVar (y', y, _) -> (
match SubScopeName.compare x' y' with
| 0 -> ScopeVar.compare x y
| n -> n)
| Var _, _ -> -1
| _, Var _ -> 1
let get_position x =
match x with
| Var (x, None) -> Marked.get_mark (ScopeVar.get_info x)
| Var (_, Some sx) -> Marked.get_mark (StateName.get_info sx)
| SubScopeVar (_, _, pos) -> pos
let get_position x =
match x with
| Var (x, None) -> Marked.get_mark (ScopeVar.get_info x)
| Var (_, Some sx) -> Marked.get_mark (StateName.get_info sx)
| SubScopeVar (_, _, pos) -> pos
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
| SubScopeVar (s, v, _) ->
Format.fprintf fmt "%a.%a" SubScopeName.format_t s ScopeVar.format_t v
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
| SubScopeVar (s, v, _) ->
Format.fprintf fmt "%a.%a" 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 (SubScopeName.hash w) (ScopeVar.hash 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 (SubScopeName.hash w) (ScopeVar.hash v)
end
include Base
module Map = Map.Make (Base)
module Set = Set.Make (Base)
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} *)
type location = desugared glocation
@ -195,7 +200,7 @@ type scope = {
scope_vars : var_or_states ScopeVar.Map.t;
scope_sub_scopes : ScopeName.t SubScopeName.Map.t;
scope_uid : ScopeName.t;
scope_defs : scope_def ScopeDefMap.t;
scope_defs : scope_def ScopeDef.Map.t;
scope_assertions : assertion list;
scope_options : catala_option Marked.pos list;
scope_meta_assertions : meta_assertion list;
@ -218,9 +223,9 @@ let rec locations_used e : LocationSet.t =
(fun e -> LocationSet.union (locations_used e))
e LocationSet.empty
let free_variables (def : rule RuleName.Map.t) : Pos.t ScopeDefMap.t =
let add_locs (acc : Pos.t ScopeDefMap.t) (locs : LocationSet.t) :
Pos.t ScopeDefMap.t =
let free_variables (def : rule RuleName.Map.t) : Pos.t ScopeDef.Map.t =
let add_locs (acc : Pos.t ScopeDef.Map.t) (locs : LocationSet.t) :
Pos.t ScopeDef.Map.t =
LocationSet.fold
(fun (loc, loc_pos) acc ->
let usage =
@ -235,7 +240,9 @@ let free_variables (def : rule RuleName.Map.t) : Pos.t ScopeDefMap.t =
Marked.get_mark sub_index ))
| ToplevelVar _ -> None
in
match usage with Some u -> ScopeDefMap.add u loc_pos acc | None -> acc)
match usage with
| Some u -> ScopeDef.Map.add u loc_pos acc
| None -> acc)
locs acc
in
RuleName.Map.fold
@ -246,14 +253,14 @@ let free_variables (def : rule RuleName.Map.t) : Pos.t ScopeDefMap.t =
(locations_used (Expr.unbox rule.rule_cons))
in
add_locs acc locs)
def ScopeDefMap.empty
def ScopeDef.Map.empty
let fold_exprs ~(f : 'a -> expr -> 'a) ~(init : 'a) (p : program) : 'a =
let acc =
ScopeName.Map.fold
(fun _ scope acc ->
let acc =
ScopeDefMap.fold
ScopeDef.Map.fold
(fun _ scope_def acc ->
RuleName.Map.fold
(fun _ rule acc ->

10
compiler/desugared/ast.mli
View File

@ -30,10 +30,10 @@ module ScopeDef : sig
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
module Map : Map.S with type key = t
module Set : Set.S with type elt = t
end
(** {1 AST} *)
@ -118,7 +118,7 @@ type scope = {
scope_vars : var_or_states ScopeVar.Map.t;
scope_sub_scopes : ScopeName.t SubScopeName.Map.t;
scope_uid : ScopeName.t;
scope_defs : scope_def ScopeDefMap.t;
scope_defs : scope_def ScopeDef.Map.t;
scope_assertions : assertion list;
scope_options : catala_option Marked.pos list;
scope_meta_assertions : meta_assertion list;
@ -133,7 +133,7 @@ type program = {
(** {1 Helpers} *)
val locations_used : expr -> LocationSet.t
val free_variables : rule RuleName.Map.t -> Pos.t ScopeDefMap.t
val free_variables : rule RuleName.Map.t -> Pos.t ScopeDef.Map.t
val fold_exprs : f:('a -> expr -> 'a) -> init:'a -> program -> 'a
(** Usage: [fold_exprs ~f ~init program] applies ~f to all the expressions

53
compiler/desugared/dependency.ml
View File

@ -173,11 +173,11 @@ let build_scope_dependencies (scope : Ast.scope) : ScopeDependencies.t =
scope.scope_sub_scopes g
in
let g =
Ast.ScopeDefMap.fold
Ast.ScopeDef.Map.fold
(fun def_key scope_def g ->
let def = scope_def.Ast.scope_def_rules in
let fv = Ast.free_variables def in
Ast.ScopeDefMap.fold
Ast.ScopeDef.Map.fold
(fun fv_def fv_def_pos g ->
match def_key, fv_def with
| ( Ast.ScopeDef.Var (v_defined, s_defined),
@ -244,10 +244,17 @@ let build_scope_dependencies (scope : Ast.scope) : ScopeDependencies.t =
(** {2 Graph declaration} *)
module ExceptionVertex = struct
include RuleName.Set
type t = { rules : Pos.t RuleName.Map.t; label : LabelName.t }
let compare x y =
RuleName.Map.compare
(fun _ _ -> 0 (* we don't care about positions here*))
x.rules y.rules
let hash (x : t) : int =
RuleName.Set.fold (fun r acc -> Int.logxor (RuleName.hash r) acc) x 0
RuleName.Map.fold
(fun r _ acc -> Int.logxor (RuleName.hash r) acc)
x.rules 0
let equal x y = compare x y = 0
end
@ -353,9 +360,20 @@ let build_exceptions_graph
in
LabelName.Map.update label_of_rule
(fun rule_set ->
let pos =
(* We have to overwrite the law info on tis position because the
pass at the surface AST level that fills the law info on
positions only does it for positions inside expressions, the
visitor in [surface/fill_positions.ml] does not go into the
info of [RuleName.t], etc. Related issue:
https://github.com/CatalaLang/catala/issues/194 *)
Pos.overwrite_law_info
(snd (RuleName.get_info rule.rule_id))
(Pos.get_law_info (Expr.pos rule.rule_just))
in
match rule_set with
| None -> Some (RuleName.Set.singleton rule_name)
| Some rule_set -> Some (RuleName.Set.add rule_name rule_set))
| None -> Some (RuleName.Map.singleton rule_name pos)
| Some rule_set -> Some (RuleName.Map.add rule_name pos rule_set))
rule_sets)
def LabelName.Map.empty
in
@ -363,7 +381,7 @@ let build_exceptions_graph
fst
(LabelName.Map.choose
(LabelName.Map.filter
(fun _ rule_set -> RuleName.Set.mem r rule_set)
(fun _ rule_set -> RuleName.Map.mem r rule_set)
label_to_rule_sets))
in
(* Next, we collect the exception edges between those groups of rules referred
@ -431,7 +449,8 @@ let build_exceptions_graph
(* We've got the vertices and the edges, let's build the graph! *)
let g =
LabelName.Map.fold
(fun _label rule_set g -> ExceptionsDependencies.add_vertex g rule_set)
(fun label rule_set g ->
ExceptionsDependencies.add_vertex g { rules = rule_set; label })
label_to_rule_sets ExceptionsDependencies.empty
in
(* then we add the edges *)
@ -439,10 +458,18 @@ let build_exceptions_graph
List.fold_left
(fun g edge ->
let rule_group_from =
LabelName.Map.find edge.label_from label_to_rule_sets
{
ExceptionVertex.rules =
LabelName.Map.find edge.label_from label_to_rule_sets;
label = edge.label_from;
}
in
let rule_group_to =
LabelName.Map.find edge.label_to label_to_rule_sets
{
ExceptionVertex.rules =
LabelName.Map.find edge.label_to label_to_rule_sets;
label = edge.label_to;
}
in
let edge =
ExceptionsDependencies.E.create rule_group_from edge.edge_positions
@ -464,14 +491,14 @@ let check_for_exception_cycle
let scc = List.find (fun scc -> List.length scc > 1) sccs in
let spans =
List.rev_map
(fun (vs : RuleName.Set.t) ->
let v = RuleName.Set.choose vs in
(fun (vs : ExceptionVertex.t) ->
let v, _ = RuleName.Map.choose vs.rules in
let rule = RuleName.Map.find v def in
let pos = Marked.get_mark (RuleName.get_info rule.Ast.rule_id) in
None, pos)
scc
in
let v = RuleName.Set.choose (List.hd scc) in
let v, _ = RuleName.Map.choose (List.hd scc).rules in
Errors.raise_multispanned_error spans
"Exception cycle detected when defining %a: each of these %d exceptions \
applies over the previous one, and the first applies over the last"

8
compiler/desugared/dependency.mli
View File

@ -72,8 +72,14 @@ val build_scope_dependencies : Ast.scope -> ScopeDependencies.t
module EdgeExceptions : Graph.Sig.ORDERED_TYPE_DFT with type t = Pos.t list
module ExceptionVertex : sig
type t = { rules : Pos.t RuleName.Map.t; label : LabelName.t }
end
module ExceptionsDependencies :
Graph.Sig.P with type V.t = RuleName.Set.t and type E.label = EdgeExceptions.t
Graph.Sig.P
with type V.t = ExceptionVertex.t
and type E.label = EdgeExceptions.t
val build_exceptions_graph :
Ast.rule RuleName.Map.t -> Ast.ScopeDef.t -> ExceptionsDependencies.t

4
compiler/desugared/disambiguate.ml
View File

@ -45,7 +45,7 @@ let rule ctx env rule =
let scope ctx env scope =
let env = Typing.Env.open_scope scope.scope_uid env in
let scope_defs =
ScopeDefMap.map
ScopeDef.Map.map
(fun def ->
let scope_def_rules =
(* Note: ordering in file order might be better for error reporting ?
@ -75,7 +75,7 @@ let program prg =
ScopeName.Map.fold
(fun scope_name scope env ->
let vars =
ScopeDefMap.fold
ScopeDef.Map.fold
(fun var def vars ->
match var with
| Var (v, _states) -> ScopeVar.Map.add v def.scope_def_typ vars

18
compiler/desugared/from_surface.ml
View File

@ -1019,7 +1019,7 @@ let process_def
(Marked.get_mark def.definition_name)
in
let scope_def_ctxt =
Ast.ScopeDefMap.find def_key scope_ctxt.scope_defs_contexts
Ast.ScopeDef.Map.find def_key scope_ctxt.scope_defs_contexts
in
(* We add to the name resolution context the name of the parameter variable *)
let new_ctxt, param_uids =
@ -1028,7 +1028,7 @@ let process_def
def
in
let scope_updated =
let scope_def = Ast.ScopeDefMap.find def_key scope.scope_defs in
let scope_def = Ast.ScopeDef.Map.find def_key scope.scope_defs in
let rule_name = def.definition_id in
let label_situation =
match def.definition_label with
@ -1075,7 +1075,7 @@ let process_def
in
{
scope with
scope_defs = Ast.ScopeDefMap.add def_key scope_def scope.scope_defs;
scope_defs = Ast.ScopeDef.Map.add def_key scope_def scope.scope_defs;
}
in
{
@ -1204,7 +1204,7 @@ let check_unlabeled_exception
(* should not happen *)
in
let scope_def_ctxt =
Ast.ScopeDefMap.find def_key scope_ctxt.scope_defs_contexts
Ast.ScopeDef.Map.find def_key scope_ctxt.scope_defs_contexts
in
match exception_to with
| Surface.Ast.NotAnException | Surface.Ast.ExceptionToLabel _ -> ()
@ -1296,7 +1296,7 @@ let attribute_to_io (attr : Surface.Ast.scope_decl_context_io) : Ast.io =
let init_scope_defs
(ctxt : Name_resolution.context)
(scope_idmap : Name_resolution.scope_var_or_subscope IdentName.Map.t) :
Ast.scope_def Ast.ScopeDefMap.t =
Ast.scope_def Ast.ScopeDef.Map.t =
(* Initializing the definitions of all scopes and subscope vars, with no rules
yet inside *)
let add_def _ v scope_def_map =
@ -1306,7 +1306,7 @@ let init_scope_defs
match v_sig.var_sig_states_list with
| [] ->
let def_key = Ast.ScopeDef.Var (v, None) in
Ast.ScopeDefMap.add def_key
Ast.ScopeDef.Map.add def_key
{
Ast.scope_def_rules = RuleName.Map.empty;
Ast.scope_def_typ = v_sig.var_sig_typ;
@ -1344,7 +1344,7 @@ let init_scope_defs
{ io_input; io_output });
}
in
Ast.ScopeDefMap.add def_key def acc, i + 1)
Ast.ScopeDef.Map.add def_key def acc, i + 1)
(scope_def_map, 0) states
in
scope_def)
@ -1364,7 +1364,7 @@ let init_scope_defs
Ast.ScopeDef.SubScopeVar
(v0, v, Marked.get_mark (ScopeVar.get_info v))
in
Ast.ScopeDefMap.add def_key
Ast.ScopeDef.Map.add def_key
{
Ast.scope_def_rules = RuleName.Map.empty;
Ast.scope_def_typ = v_sig.var_sig_typ;
@ -1375,7 +1375,7 @@ let init_scope_defs
scope_def_map)
sub_scope_def.Name_resolution.var_idmap scope_def_map
in
IdentName.Map.fold add_def scope_idmap Ast.ScopeDefMap.empty
IdentName.Map.fold add_def scope_idmap Ast.ScopeDef.Map.empty
(** Main function of this module *)
let translate_program

4
compiler/desugared/linting.ml
View File

@ -22,7 +22,7 @@ open Catala_utils
let detect_empty_definitions (p : program) : unit =
ScopeName.Map.iter
(fun (scope_name : ScopeName.t) scope ->
ScopeDefMap.iter
ScopeDef.Map.iter
(fun scope_def_key scope_def ->
if
(match scope_def_key with ScopeDef.Var _ -> true | _ -> false)
@ -59,7 +59,7 @@ let detect_unused_scope_vars (p : program) : unit =
in
ScopeName.Map.iter
(fun (scope_name : ScopeName.t) scope ->
ScopeDefMap.iter
ScopeDef.Map.iter
(fun scope_def_key scope_def ->
match scope_def_key with
| ScopeDef.Var (v, _)

6
compiler/desugared/name_resolution.ml
View File

@ -39,7 +39,7 @@ type scope_var_or_subscope =
type scope_context = {
var_idmap : scope_var_or_subscope IdentName.Map.t;
(** All variables, including scope variables and subscopes *)
scope_defs_contexts : scope_def_context Ast.ScopeDefMap.t;
scope_defs_contexts : scope_def_context Ast.ScopeDef.Map.t;
(** What is the default rule to refer to for unnamed exceptions, if any *)
sub_scopes : ScopeName.Set.t;
(** Other scopes referred to by this scope. Used for dependency analysis *)
@ -624,7 +624,7 @@ let process_name_item (ctxt : context) (item : Surface.Ast.code_item Marked.pos)
ScopeName.Map.add scope_uid
{
var_idmap = IdentName.Map.empty;
scope_defs_contexts = Ast.ScopeDefMap.empty;
scope_defs_contexts = Ast.ScopeDef.Map.empty;
sub_scopes = ScopeName.Set.empty;
}
ctxt.scopes;
@ -853,7 +853,7 @@ let process_definition
{
s_ctxt with
scope_defs_contexts =
Ast.ScopeDefMap.update def_key
Ast.ScopeDef.Map.update def_key
(fun def_key_ctx ->
Some
(update_def_key_ctx d

2
compiler/desugared/name_resolution.mli
View File

@ -39,7 +39,7 @@ type scope_var_or_subscope =
type scope_context = {
var_idmap : scope_var_or_subscope IdentName.Map.t;
(** All variables, including scope variables and subscopes *)
scope_defs_contexts : scope_def_context Ast.ScopeDefMap.t;
scope_defs_contexts : scope_def_context Ast.ScopeDef.Map.t;
(** What is the default rule to refer to for unnamed exceptions, if any *)
sub_scopes : ScopeName.Set.t;
(** Other scopes referred to by this scope. Used for dependency analysis *)

117
compiler/desugared/print.ml Normal file
View File

@ -0,0 +1,117 @@
(* This file is part of the Catala compiler, a specification language for tax
and social benefits computation rules. Copyright (C) 2023 Inria, contributor:
Denis Merigoux <denis.merigoux@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not
use this file except in compliance with the License. You may obtain a copy of
the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS, WITHOUT
WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the
License for the specific language governing permissions and limitations under
the License. *)
open Shared_ast
open Catala_utils
type exception_tree =
| Leaf of Dependency.ExceptionVertex.t
| Node of exception_tree list * Dependency.ExceptionVertex.t
open Format
(* Original credits for this printing code: Jean-Christophe Filiâtre *)
let format_exception_tree (fmt : Format.formatter) (t : exception_tree) =
let blue s =
Format.asprintf "%a" (Cli.format_with_style [ANSITerminal.blue]) s
in
let rec print_node pref (t : exception_tree) =
let (s, w), sons =
let print_s s =
( Format.asprintf "%a"
(Cli.format_with_style [ANSITerminal.yellow])
(Format.asprintf "\"%a\"" LabelName.format_t
s.Dependency.ExceptionVertex.label),
String.length
(Format.asprintf "\"%a\"" LabelName.format_t
s.Dependency.ExceptionVertex.label) )
in
match t with Leaf s -> print_s s, [] | Node (sons, s) -> print_s s, sons
in
pp_print_string fmt s;
if sons != [] then
let pref' = pref ^ String.make (w + 1) ' ' in
match sons with
| [t'] ->
pp_print_string fmt (blue "───");
print_node (pref' ^ " ") t'
| _ ->
pp_print_string fmt (blue "──");
print_sons pref' "┬──" sons
and print_sons pref start = function
| [] -> assert false
| [s] ->
pp_print_string fmt (blue " └──");
print_node (pref ^ " ") s
| s :: sons ->
pp_print_string fmt (blue start);
print_node (pref ^ "| ") s;
pp_force_newline fmt ();
pp_print_string fmt (blue (pref ^ " │"));
pp_force_newline fmt ();
pp_print_string fmt (blue pref);
print_sons pref "├──" sons
in
print_node "" t
let build_exception_tree exc_graph =
let base_cases =
Dependency.ExceptionsDependencies.fold_vertex
(fun 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 : Dependency.ExceptionVertex.t) =
let exceptions =
Dependency.ExceptionsDependencies.pred exc_graph base_cases
in
match exceptions with
| [] -> Leaf base_cases
| _ -> Node (List.map build_tree exceptions, base_cases)
in
List.map build_tree base_cases
let print_exceptions_graph
(scope : ScopeName.t)
(var : Ast.ScopeDef.t)
(g : Dependency.ExceptionsDependencies.t) =
Cli.result_format
"Printing the tree of exceptions for the definitions of variable %a of \
scope %a."
(Cli.format_with_style [ANSITerminal.yellow])
(Format.asprintf "\"%a\"" Ast.ScopeDef.format_t var)
(Cli.format_with_style [ANSITerminal.yellow])
(Format.asprintf "\"%a\"" ScopeName.format_t scope);
Dependency.ExceptionsDependencies.iter_vertex
(fun ex ->
Cli.result_format "Definitions with label %a:\n%a"
(Cli.format_with_style [ANSITerminal.yellow])
(Format.asprintf "\"%a\"" LabelName.format_t
ex.Dependency.ExceptionVertex.label)
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "\n")
(fun fmt (_, pos) ->
Format.fprintf fmt "%s" (Pos.retrieve_loc_text pos)))
(RuleName.Map.bindings ex.Dependency.ExceptionVertex.rules))
g;
let tree = build_exception_tree g in
Cli.result_format "The exception tree structure is as follows:\n\n%a"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "\n\n")
(fun fmt tree -> format_exception_tree fmt tree))
tree

22
compiler/desugared/print.mli Normal file
View File

@ -0,0 +1,22 @@
(* This file is part of the Catala compiler, a specification language for tax
and social benefits computation rules. Copyright (C) 2023 Inria, contributor:
Denis Merigoux <denis.merigoux@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not
use this file except in compliance with the License. You may obtain a copy of
the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS, WITHOUT
WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the
License for the specific language governing permissions and limitations under
the License. *)
val print_exceptions_graph :
Shared_ast.ScopeName.t ->
Ast.ScopeDef.t ->
Dependency.ExceptionsDependencies.t ->
unit
(** Prints the exception graph of a variable to the terminal *)

194
compiler/driver.ml
View File

@ -21,6 +21,127 @@ open Catala_utils
string representation. *)
let extensions = [".catala_fr", "fr"; ".catala_en", "en"; ".catala_pl", "pl"]
let get_scope_uid
(options : Cli.options)
(backend : Plugin.t Cli.backend_option)
(ctxt : Desugared.Name_resolution.context) =
match options.ex_scope, backend with
| None, `Interpret ->
Errors.raise_error "No scope was provided for execution."
| None, _ ->
let _, scope =
try
Shared_ast.IdentName.Map.filter_map
(fun _ -> function
| Desugared.Name_resolution.TScope (uid, _) -> Some uid
| _ -> None)
ctxt.typedefs
|> Shared_ast.IdentName.Map.choose
with Not_found ->
Errors.raise_error "There isn't any scope inside the program."
in
scope
| Some name, _ -> (
match Shared_ast.IdentName.Map.find_opt name ctxt.typedefs with
| Some (Desugared.Name_resolution.TScope (uid, _)) -> uid
| _ ->
Errors.raise_error "There is no scope %a inside the program."
(Cli.format_with_style [ANSITerminal.yellow])
("\"" ^ name ^ "\""))
let get_variable_uid
(options : Cli.options)
(backend : Plugin.t Cli.backend_option)
(ctxt : Desugared.Name_resolution.context)
(scope_uid : Shared_ast.ScopeName.t) =
match options.ex_variable, backend with
| None, `Exceptions ->
Errors.raise_error
"Please specify a variable with the -v option to print its exception \
tree."
| None, _ -> None
| Some name, _ -> (
(* Sometimes the variable selected is of the form [a.b]*)
let first_part, second_part =
match
Re.(
exec_opt
(compile
@@ whole_string
@@ seq [group (rep1 (compl [char '.'])); char '.'; group (rep1 any)]
)
name)
with
| None -> name, None
| Some groups -> Re.Group.get groups 1, Some (Re.Group.get groups 2)
in
match
Shared_ast.IdentName.Map.find_opt first_part
(Shared_ast.ScopeName.Map.find scope_uid ctxt.scopes).var_idmap
with
| None ->
Errors.raise_error "Variable %a not found inside scope %a"
(Cli.format_with_style [ANSITerminal.yellow])
("\"" ^ name ^ "\"")
(Cli.format_with_style [ANSITerminal.yellow])
(Format.asprintf "\"%a\"" Shared_ast.ScopeName.format_t scope_uid)
| Some
(Desugared.Name_resolution.SubScope (subscope_var_name, subscope_name))
-> (
match second_part with
| None ->
Errors.raise_error
"Subscope %a of scope %a cannot be selected by itself, please add \
\".<var>\" where <var> is a subscope variable."
(Cli.format_with_style [ANSITerminal.yellow])
(Format.asprintf "\"%a\"" Shared_ast.SubScopeName.format_t
subscope_var_name)
(Cli.format_with_style [ANSITerminal.yellow])
(Format.asprintf "\"%a\"" Shared_ast.ScopeName.format_t scope_uid)
| Some second_part -> (
match
Shared_ast.IdentName.Map.find_opt second_part
(Shared_ast.ScopeName.Map.find subscope_name ctxt.scopes).var_idmap
with
| Some (Desugared.Name_resolution.ScopeVar v) ->
Some
(Desugared.Ast.ScopeDef.SubScopeVar
(subscope_var_name, v, Pos.no_pos))
| _ ->
Errors.raise_error
"Var %a of subscope %a in scope %a does not exist, please check \
your command line arguments."
(Cli.format_with_style [ANSITerminal.yellow])
("\"" ^ second_part ^ "\"")
(Cli.format_with_style [ANSITerminal.yellow])
(Format.asprintf "\"%a\"" Shared_ast.SubScopeName.format_t
subscope_var_name)
(Cli.format_with_style [ANSITerminal.yellow])
(Format.asprintf "\"%a\"" Shared_ast.ScopeName.format_t scope_uid)))
| Some (Desugared.Name_resolution.ScopeVar v) ->
Some
(Desugared.Ast.ScopeDef.Var
( v,
Option.map
(fun second_part ->
let var_sig = Shared_ast.ScopeVar.Map.find v ctxt.var_typs in
match
Shared_ast.IdentName.Map.find_opt second_part
var_sig.var_sig_states_idmap
with
| Some state -> state
| None ->
Errors.raise_error
"State %a is not found for variable %a of scope %a"
(Cli.format_with_style [ANSITerminal.yellow])
("\"" ^ second_part ^ "\"")
(Cli.format_with_style [ANSITerminal.yellow])
("\"" ^ first_part ^ "\"")
(Cli.format_with_style [ANSITerminal.yellow])
(Format.asprintf "\"%a\"" Shared_ast.ScopeName.format_t
scope_uid))
second_part )))
(** Entry function for the executable. Returns a negative number in case of
error. Usage: [driver source_file options]*)
let driver source_file (options : Cli.options) : int =
@ -140,33 +261,13 @@ let driver source_file (options : Cli.options) : int =
language fmt (fun fmt -> weave_output fmt prgm)
else weave_output fmt prgm)
| ( `Interpret | `Interpret_Lcalc | `Typecheck | `OCaml | `Python | `Scalc
| `Lcalc | `Dcalc | `Scopelang | `Proof | `Plugin _ ) as backend -> (
| `Lcalc | `Dcalc | `Scopelang | `Exceptions | `Proof | `Plugin _ ) as
backend -> (
Cli.debug_print "Name resolution...";
let ctxt = Desugared.Name_resolution.form_context prgm in
let scope_uid =
match options.ex_scope, backend with
| None, `Interpret ->
Errors.raise_error "No scope was provided for execution."
| None, _ ->
let _, scope =
try
Shared_ast.IdentName.Map.filter_map
(fun _ -> function
| Desugared.Name_resolution.TScope (uid, _) -> Some uid
| _ -> None)
ctxt.typedefs
|> Shared_ast.IdentName.Map.choose
with Not_found ->
Errors.raise_error "There isn't any scope inside the program."
in
scope
| Some name, _ -> (
match Shared_ast.IdentName.Map.find_opt name ctxt.typedefs with
| Some (Desugared.Name_resolution.TScope (uid, _)) -> uid
| _ ->
Errors.raise_error "There is no scope \"%s\" inside the program."
name)
in
let scope_uid = get_scope_uid options backend ctxt in
(* This uid is a Desugared identifier *)
let variable_uid = get_variable_uid options backend ctxt scope_uid in
Cli.debug_print "Desugaring...";
let prgm = Desugared.From_surface.translate_program ctxt prgm in
Cli.debug_print "Disambiguating...";
@ -174,8 +275,23 @@ let driver source_file (options : Cli.options) : int =
Cli.debug_print "Linting...";
Desugared.Linting.lint_program prgm;
Cli.debug_print "Collecting rules...";
let prgm = Scopelang.From_desugared.translate_program prgm in
let exceptions_graphs =
Scopelang.From_desugared.build_exceptions_graph prgm
in
let prgm =
Scopelang.From_desugared.translate_program prgm exceptions_graphs
in
match backend with
| `Exceptions ->
let variable_uid =
match variable_uid with
| Some variable_uid -> variable_uid
| None ->
Errors.raise_error
"Please provide a scope variable to analyze with the -v option."
in
Desugared.Print.print_exceptions_graph scope_uid variable_uid
(Desugared.Ast.ScopeDef.Map.find variable_uid exceptions_graphs)
| `Scopelang ->
let _output_file, with_output = get_output_format () in
with_output
@ -295,6 +411,17 @@ let driver source_file (options : Cli.options) : int =
(Shared_ast.Expr.format ~debug:options.debug prgm.decl_ctx)
result)
results
| `Plugin (Plugin.Dcalc p) ->
let output_file, _ = get_output_format ~ext:p.Plugin.extension () in
Cli.debug_print "Compiling program through backend \"%s\"..."
p.Plugin.name;
p.Plugin.apply ~source_file ~output_file
~scope:
(match options.ex_scope with
| None -> None
| Some _ -> Some scope_uid)
(Shared_ast.Program.untype prgm)
type_ordering
| (`OCaml | `Interpret_Lcalc | `Python | `Lcalc | `Scalc | `Plugin _)
as backend -> (
Cli.debug_print "Compiling program into lambda calculus...";
@ -380,13 +507,18 @@ let driver source_file (options : Cli.options) : int =
Cli.debug_print "Writing to %s..."
(Option.value ~default:"stdout" output_file);
Lcalc.To_ocaml.format_program fmt prgm type_ordering
| `Plugin (Plugin.Dcalc _) -> assert false
| `Plugin (Plugin.Lcalc p) ->
let output_file, _ =
get_output_format ~ext:p.Plugin.extension ()
in
Cli.debug_print "Compiling program through backend \"%s\"..."
p.Plugin.name;
p.Plugin.apply ~source_file ~output_file ~scope:options.ex_scope
p.Plugin.apply ~source_file ~output_file
~scope:
(match options.ex_scope with
| None -> None
| Some _ -> Some scope_uid)
prgm type_ordering
| (`Python | `Scalc | `Plugin (Plugin.Scalc _)) as backend -> (
let prgm = Scalc.From_lcalc.translate_program prgm in
@ -416,7 +548,7 @@ let driver source_file (options : Cli.options) : int =
with_output
@@ fun fmt ->
Scalc.To_python.format_program fmt prgm type_ordering
| `Plugin (Plugin.Lcalc _) -> assert false
| `Plugin (Plugin.Dcalc _ | Plugin.Lcalc _) -> assert false
| `Plugin (Plugin.Scalc p) ->
let output_file, _ = get_output ~ext:p.Plugin.extension () in
Cli.debug_print "Compiling program through backend \"%s\"..."
@ -424,7 +556,11 @@ let driver source_file (options : Cli.options) : int =
Cli.debug_print "Writing to %s..."
(Option.value ~default:"stdout" output_file);
p.Plugin.apply ~source_file ~output_file
~scope:options.ex_scope prgm type_ordering)))))));
~scope:
(match options.ex_scope with
| None -> None
| Some _ -> Some scope_uid)
prgm type_ordering)))))));
0
with
| Errors.StructuredError (msg, pos) ->

10
compiler/plugin.ml
View File

@ -19,7 +19,7 @@ open Catala_utils
type 'ast plugin_apply_fun_typ =
source_file:Pos.input_file ->
output_file:string option ->
scope:string option ->
scope:Shared_ast.ScopeName.t option ->
'ast ->
Scopelang.Dependency.TVertex.t list ->
unit
@ -31,16 +31,22 @@ type 'ast gen = {
}
type t =
| Dcalc of Shared_ast.untyped Dcalc.Ast.program gen
| Lcalc of Shared_ast.untyped Lcalc.Ast.program gen
| Scalc of Scalc.Ast.program gen
let name = function Lcalc { name; _ } | Scalc { name; _ } -> name
let name = function
| Dcalc { name; _ } | Lcalc { name; _ } | Scalc { name; _ } -> name
let backend_plugins : (string, t) Hashtbl.t = Hashtbl.create 17
let register t =
Hashtbl.replace backend_plugins (String.lowercase_ascii (name t)) t
module PluginAPI = struct
let register_dcalc ~name ~extension apply =
register (Dcalc { name; extension; apply })
let register_lcalc ~name ~extension apply =
register (Lcalc { name; extension; apply })

9
compiler/plugin.mli
View File

@ -21,7 +21,7 @@ open Catala_utils
type 'ast plugin_apply_fun_typ =
source_file:Pos.input_file ->
output_file:string option ->
scope:string option ->
scope:Shared_ast.ScopeName.t option ->
'ast ->
Scopelang.Dependency.TVertex.t list ->
unit
@ -33,6 +33,7 @@ type 'ast gen = {
}
type t =
| Dcalc of Shared_ast.untyped Dcalc.Ast.program gen
| Lcalc of Shared_ast.untyped Lcalc.Ast.program gen
| Scalc of Scalc.Ast.program gen
@ -48,6 +49,12 @@ val load_dir : string -> unit
(** {2 plugin-facing API} *)
module PluginAPI : sig
val register_dcalc :
name:string ->
extension:string ->
Shared_ast.untyped Dcalc.Ast.program plugin_apply_fun_typ ->
unit
val register_lcalc :
name:string ->
extension:string ->

8
compiler/plugins/dune
View File

@ -20,6 +20,14 @@
(modules json_schema)
(libraries catala.driver))
(library
(name lazy_interpreter)
(public_name catala.plugins.lazy-interpreter)
(synopsis
"Catala plugin that implements a different, experimental interpreter, featuring lazy and partial evaluation")
(modules lazy_interp)
(libraries shared_ast catala.driver))
(documentation
(package catala)
(mld_files plugins))

52
compiler/plugins/json_schema.ml
View File

@ -22,7 +22,6 @@ let extension = "_schema.json"
open Catala_utils
open Shared_ast
open Lcalc.Ast
open Lcalc.To_ocaml
module D = Dcalc.Ast
@ -47,17 +46,6 @@ module To_json = struct
in
Format.fprintf fmt "%s" s
let rec find_scope_def (target_name : string) :
'm expr code_item_list -> (ScopeName.t * 'm expr scope_body) option =
function
| Nil -> None
| Cons (ScopeDef (name, body), _)
when String.equal target_name (Marked.unmark (ScopeName.get_info name)) ->
Some (name, body)
| Cons (_, next_bind) ->
let _, next_scope = Bindlib.unbind next_bind in
find_scope_def target_name next_scope
let fmt_tlit fmt (tlit : typ_lit) =
match tlit with
| TUnit -> Format.fprintf fmt "\"type\": \"null\",@\n\"default\": null"
@ -203,31 +191,29 @@ module To_json = struct
let format_program
(fmt : Format.formatter)
(scope : string)
(scope : ScopeName.t)
(prgm : 'm Lcalc.Ast.program) =
match find_scope_def scope prgm.code_items with
| None -> Cli.error_print "Internal error: scope '%s' not found." scope
| Some scope_def ->
Cli.call_unstyled (fun _ ->
Format.fprintf fmt
"{@[<hov 2>@\n\
\"type\": \"object\",@\n\
\"@[<hov 2>definitions\": {%a@]@\n\
},@\n\
\"@[<hov 2>properties\": {@\n\
%a@]@\n\
}@]@\n\
}"
(fmt_definitions prgm.decl_ctx)
scope_def
(fmt_struct_properties prgm.decl_ctx)
(snd scope_def).scope_body_input_struct)
let scope_body = Program.get_scope_body prgm scope in
Cli.call_unstyled (fun _ ->
Format.fprintf fmt
"{@[<hov 2>@\n\
\"type\": \"object\",@\n\
\"@[<hov 2>definitions\": {%a@]@\n\
},@\n\
\"@[<hov 2>properties\": {@\n\
%a@]@\n\
}@]@\n\
}"
(fmt_definitions prgm.decl_ctx)
(scope, scope_body)
(fmt_struct_properties prgm.decl_ctx)
scope_body.scope_body_input_struct)
end
let apply
~(source_file : Pos.input_file)
~(output_file : string option)
~(scope : string option)
~(scope : Shared_ast.ScopeName.t option)
(prgm : 'm Lcalc.Ast.program)
(type_ordering : Scopelang.Dependency.TVertex.t list) =
ignore source_file;
@ -236,9 +222,9 @@ let apply
| Some s ->
File.with_formatter_of_opt_file output_file (fun fmt ->
Cli.debug_print
"Writing JSON schema corresponding to the scope '%s' to the file \
"Writing JSON schema corresponding to the scope '%a' to the file \
%s..."
s
ScopeName.format_t s
(Option.value ~default:"stdout" output_file);
To_json.format_program fmt s prgm)
| None -> Cli.error_print "A scope must be specified for the plugin: %s" name

273
compiler/plugins/lazy_interp.ml Normal file
View File

@ -0,0 +1,273 @@
(* This file is part of the Catala compiler, a specification language for tax
and social benefits computation rules. Copyright (C) 2023 Inria, contributor:
Louis Gesbert <louis.gesbert@inria.fr>.
Licensed under the Apache License, Version 2.0 (the "License"); you may not
use this file except in compliance with the License. You may obtain a copy of
the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS, WITHOUT
WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the
License for the specific language governing permissions and limitations under
the License. *)
open Catala_utils
open Shared_ast
(* -- Definition of the lazy interpreter -- *)
let log fmt = Format.ifprintf Format.err_formatter (fmt ^^ "@\n")
let error e = Errors.raise_spanned_error (Expr.pos e)
let noassert = true
type laziness_level = {
eval_struct : bool;
(* if true, evaluate members of structures, tuples, etc. *)
eval_op : bool;
(* if false, evaluate the operands but keep e.g. `3 + 4` as is *)
eval_default : bool;
(* if false, stop evaluating as soon as you can discriminate with
`EEmptyError` *)
}
let value_level = { eval_struct = false; eval_op = true; eval_default = true }
module Env = struct
type 'm t =
| Env of
((dcalc, 'm mark) gexpr, ((dcalc, 'm mark) gexpr * 'm t) ref) Var.Map.t
let find v (Env t) = Var.Map.find v t
let add v e e_env (Env t) = Env (Var.Map.add v (ref (e, e_env)) t)
let empty = Env Var.Map.empty
let join (Env t1) (Env t2) =
Env
(Var.Map.union
(fun _ x1 x2 ->
assert (x1 == x2);
Some x1)
t1 t2)
let print ppf (Env t) =
Format.pp_print_list ~pp_sep:Format.pp_print_space
(fun ppf (v, { contents = _e, _env }) -> Print.var_debug ppf v)
ppf (Var.Map.bindings t)
end
let rec lazy_eval :
decl_ctx ->
'm Env.t ->
laziness_level ->
(dcalc, 'm mark) gexpr ->
(dcalc, 'm mark) gexpr * 'm Env.t =
fun ctx env llevel e0 ->
let eval_to_value ?(eval_default = true) env e =
lazy_eval ctx env { value_level with eval_default } e
in
match e0 with
| EVar v, _ ->
if not llevel.eval_default then e0, env
else
(* Variables reducing to EEmpty should not propagate to parent EDefault
(?) *)
let v_env =
try Env.find v env
with Not_found ->
error e0 "Variable %a undefined [@[<hv>%a@]]" Print.var_debug v
Env.print env
in
let e, env1 = !v_env in
let r, env1 = lazy_eval ctx env1 llevel e in
if not (Expr.equal e r) then (
log "@[<hv 2>{{%a =@ [%a]@ ==> [%a]}}@]" Print.var_debug v
(Print.expr ~debug:true ctx)
e
(Print.expr ~debug:true ctx)
r;
v_env := r, env1);
r, Env.join env env1
| EApp { f; args }, m -> (
if
(not llevel.eval_default)
&& not (List.equal Expr.equal args [ELit LUnit, m])
(* Applications to () encode thunked default terms *)
then e0, env
else
match eval_to_value env f with
| (EAbs { binder; _ }, _), env ->
let vars, body = Bindlib.unmbind binder in
log "@[<v 2>@[<hov 4>{";
let env =
Seq.fold_left2
(fun env1 var e ->
log "@[<hov 2>LET %a = %a@]@ " Print.var_debug var
(Print.expr ~debug:true ctx)
e;
Env.add var e env env1)
env (Array.to_seq vars) (List.to_seq args)
in
log "@]@[<hov 4>IN [%a]@]" (Print.expr ~debug:true ctx) body;
let e, env = lazy_eval ctx env llevel body in
log "@]}";
e, env
| ((EOp { op; _ }, m) as f), env ->
let env, args =
List.fold_left_map
(fun env e ->
let e, env = lazy_eval ctx env llevel e in
env, e)
env args
in
if not llevel.eval_op then (EApp { f; args }, m), env
else
let renv = ref env in
(* Dirty workaround returning env from evaluate_operator *)
let eval e =
let e, env = lazy_eval ctx !renv llevel e in
renv := env;
e
in
Interpreter.evaluate_operator eval ctx op m args, !renv
(* fixme: this forwards eempty *)
| e, _ -> error e "Invalid apply on %a" (Print.expr ctx) e)
| (EAbs _ | ELit _ | EOp _ | EEmptyError), _ -> e0, env (* these are values *)
| (EStruct _ | ETuple _ | EInj _ | EArray _), _ ->
if not llevel.eval_struct then e0, env
else
let env, e =
Expr.map_gather ~acc:env ~join:Env.join
~f:(fun e ->
let e, env = lazy_eval ctx env llevel e in
env, Expr.box e)
e0
in
Expr.unbox e, env
| EStructAccess { e; name; field }, _ -> (
if not llevel.eval_default then e0, env
else
match eval_to_value env e with
| (EStruct { name = n; fields }, _), env when StructName.equal name n ->
lazy_eval ctx env llevel (StructField.Map.find field fields)
| e, _ -> error e "Invalid field access on %a" (Print.expr ctx) e)
| ETupleAccess { e; index; size }, _ -> (
if not llevel.eval_default then e0, env
else
match eval_to_value env e with
| (ETuple es, _), env when List.length es = size ->
lazy_eval ctx env llevel (List.nth es index)
| e, _ -> error e "Invalid tuple access on %a" (Print.expr ctx) e)
| EMatch { e; name; cases }, _ -> (
if not llevel.eval_default then e0, env
else
match eval_to_value env e with
| (EInj { name = n; cons; e }, m), env when EnumName.equal name n ->
lazy_eval ctx env llevel
(EApp { f = EnumConstructor.Map.find cons cases; args = [e] }, m)
| e, _ -> error e "Invalid match argument %a" (Print.expr ctx) e)
| EDefault { excepts; just; cons }, m -> (
let excs =
List.filter_map
(fun e ->
match eval_to_value env e ~eval_default:false with
| (EEmptyError, _), _ -> None
| e -> Some e)
excepts
in
match excs with
| [] -> (
match eval_to_value env just with
| (ELit (LBool true), _), _ -> lazy_eval ctx env llevel cons
| (ELit (LBool false), _), _ -> (EEmptyError, m), env
| e, _ -> error e "Invalid exception justification %a" (Print.expr ctx) e)
| [(e, env)] ->
log "@[<hov 5>EVAL %a@]" (Print.expr ctx) e;
lazy_eval ctx env llevel e
| _ :: _ :: _ ->
Errors.raise_multispanned_error
((None, Expr.mark_pos m)
:: List.map (fun (e, _) -> None, Expr.pos e) excs)
"Conflicting exceptions")
| EIfThenElse { cond; etrue; efalse }, _ -> (
match eval_to_value env cond with
| (ELit (LBool true), _), _ -> lazy_eval ctx env llevel etrue
| (ELit (LBool false), _), _ -> lazy_eval ctx env llevel efalse
| e, _ -> error e "Invalid condition %a" (Print.expr ctx) e)
| EErrorOnEmpty e, _ -> (
match eval_to_value env e ~eval_default:false with
| ((EEmptyError, _) as e'), _ ->
(* This does _not_ match the eager semantics ! *)
error e' "This value is undefined %a" (Print.expr ctx) e
| e, env -> lazy_eval ctx env llevel e)
| EAssert e, m -> (
if noassert then (ELit LUnit, m), env
else
match eval_to_value env e with
| (ELit (LBool true), m), env -> (ELit LUnit, m), env
| (ELit (LBool false), _), _ ->
error e "Assert failure (%a)" (Print.expr ctx) e
| _ -> error e "Invalid assertion condition %a" (Print.expr ctx) e)
| _ -> .
let interpret_program
(prg : ('dcalc, 'm mark) gexpr program)
(scope : ScopeName.t) : ('t, 'm mark) gexpr * 'm Env.t =
let ctx = prg.decl_ctx in
let all_env, scopes =
Scope.fold_left prg.code_items ~init:(Env.empty, ScopeName.Map.empty)
~f:(fun (env, scopes) item v ->
match item with
| ScopeDef (name, body) ->
let e = Scope.to_expr ctx body (Scope.get_body_mark body) in
( Env.add v (Expr.unbox e) env env,
ScopeName.Map.add name (v, body.scope_body_input_struct) scopes )
| Topdef (_, _, e) -> Env.add v e env env, scopes)
in
let scope_v, scope_arg_struct = ScopeName.Map.find scope scopes in
let { contents = e, env } = Env.find scope_v all_env in
let e = Expr.unbox (Expr.remove_logging_calls e) in
log "=====================";
log "%a" (Print.expr ~debug:true ctx) e;
log "=====================";
let m = Marked.get_mark e in
let application_arg =
Expr.estruct scope_arg_struct
(StructField.Map.map
(function
| TArrow (ty_in, ty_out), _ ->
Expr.make_abs
[| Var.make "_" |]
(Bindlib.box EEmptyError, Expr.with_ty m ty_out)
ty_in (Expr.mark_pos m)
| ty -> Expr.evar (Var.make "undefined_input") (Expr.with_ty m ty))
(StructName.Map.find scope_arg_struct ctx.ctx_structs))
m
in
let e_app = Expr.eapp (Expr.box e) [application_arg] m in
lazy_eval ctx env
{ value_level with eval_struct = true; eval_op = false }
(Expr.unbox e_app)
(* -- Plugin registration -- *)
let name = "lazy"
let extension = ".out" (* unused *)
let apply ~source_file ~output_file ~scope prg _type_ordering =
let scope =
match scope with
| None -> Errors.raise_error "A scope must be specified"
| Some s -> s
in
ignore source_file;
(* File.with_formatter_of_opt_file output_file
* @@ fun fmt -> *)
ignore output_file;
let fmt = Format.std_formatter in
let result_expr, _env = interpret_program prg scope in
Print.expr prg.decl_ctx fmt result_expr
let () = Driver.Plugin.register_dcalc ~name ~extension apply

257
compiler/scopelang/from_desugared.ml
View File

@ -180,11 +180,149 @@ type rule_tree =
(** Transforms a flat list of rules into a tree, taking into account the
priorities declared between rules *)
let def_map_to_tree
let def_to_exception_graph
(def_info : Desugared.Ast.ScopeDef.t)
(def : Desugared.Ast.rule RuleName.Map.t) : rule_tree list =
(def : Desugared.Ast.rule RuleName.Map.t) :
Desugared.Dependency.ExceptionsDependencies.t =
let exc_graph = Desugared.Dependency.build_exceptions_graph def def_info in
Desugared.Dependency.check_for_exception_cycle def exc_graph;
exc_graph
let rule_to_exception_graph (scope : Desugared.Ast.scope) = function
| Desugared.Dependency.Vertex.Var (var, state) -> (
let scope_def =
Desugared.Ast.ScopeDef.Map.find
(Desugared.Ast.ScopeDef.Var (var, state))
scope.scope_defs
in
let var_def = scope_def.D.scope_def_rules in
match Marked.unmark scope_def.Desugared.Ast.scope_def_io.io_input with
| OnlyInput when not (RuleName.Map.is_empty var_def) ->
(* If the variable is tagged as input, then it shall not be redefined. *)
Errors.raise_multispanned_error
((Some "Incriminated variable:", Marked.get_mark (ScopeVar.get_info var))
:: List.map
(fun (rule, _) ->
( Some "Incriminated variable definition:",
Marked.get_mark (RuleName.get_info rule) ))
(RuleName.Map.bindings var_def))
"It is impossible to give a definition to a scope variable tagged as \
input."
| OnlyInput -> Desugared.Ast.ScopeDef.Map.empty
(* we do not provide any definition for an input-only variable *)
| _ ->
Desugared.Ast.ScopeDef.Map.singleton
(Desugared.Ast.ScopeDef.Var (var, state))
(def_to_exception_graph
(Desugared.Ast.ScopeDef.Var (var, state))
var_def))
| Desugared.Dependency.Vertex.SubScope sub_scope_index ->
(* Before calling the sub_scope, we need to include all the re-definitions
of subscope parameters*)
let sub_scope_vars_redefs_candidates =
Desugared.Ast.ScopeDef.Map.filter
(fun def_key scope_def ->
match def_key with
| Desugared.Ast.ScopeDef.Var _ -> false
| Desugared.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 *)
&& not
((match
Marked.unmark scope_def.Desugared.Ast.scope_def_io.io_input
with
| Desugared.Ast.NoInput -> true
| _ -> false)
&& RuleName.Map.is_empty scope_def.scope_def_rules))
scope.scope_defs
in
let sub_scope_vars_redefs =
Desugared.Ast.ScopeDef.Map.mapi
(fun def_key scope_def ->
let def = scope_def.Desugared.Ast.scope_def_rules in
let is_cond = scope_def.scope_def_is_condition in
match def_key with
| Desugared.Ast.ScopeDef.Var _ -> assert false (* should not happen *)
| Desugared.Ast.ScopeDef.SubScopeVar (sscope, sub_scope_var, pos) ->
(* 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
Marked.unmark scope_def.Desugared.Ast.scope_def_io.io_input
with
| Desugared.Ast.NoInput ->
Errors.raise_multispanned_error
(( Some "Incriminated subscope:",
Marked.get_mark (SubScopeName.get_info sscope) )
:: ( Some "Incriminated variable:",
Marked.get_mark (ScopeVar.get_info sub_scope_var) )
:: List.map
(fun (rule, _) ->
( Some "Incriminated subscope variable definition:",
Marked.get_mark (RuleName.get_info rule) ))
(RuleName.Map.bindings def))
"It is impossible to give a definition to a subscope variable \
not tagged as input or context."
| OnlyInput when RuleName.Map.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:",
Marked.get_mark (SubScopeName.get_info sscope) );
Some "Incriminated variable:", pos;
]
"This subscope variable is a mandatory input but no definition \
was provided."
| _ -> ());
let exc_graph = def_to_exception_graph def_key def in
let var_pos = Desugared.Ast.ScopeDef.get_position def_key in
exc_graph, sub_scope_var, var_pos)
sub_scope_vars_redefs_candidates
in
List.fold_left
(fun exc_graphs (new_exc_graph, subscope_var, var_pos) ->
Desugared.Ast.ScopeDef.Map.add
(Desugared.Ast.ScopeDef.SubScopeVar
(sub_scope_index, subscope_var, var_pos))
new_exc_graph exc_graphs)
Desugared.Ast.ScopeDef.Map.empty
(List.map snd (Desugared.Ast.ScopeDef.Map.bindings sub_scope_vars_redefs))
let scope_to_exception_graphs (scope : Desugared.Ast.scope) :
Desugared.Dependency.ExceptionsDependencies.t Desugared.Ast.ScopeDef.Map.t =
let scope_dependencies =
Desugared.Dependency.build_scope_dependencies scope
in
Desugared.Dependency.check_for_cycle scope scope_dependencies;
let scope_ordering =
Desugared.Dependency.correct_computation_ordering scope_dependencies
in
List.fold_left
(fun exceptions_graphs scope_def_key ->
let new_exceptions_graphs = rule_to_exception_graph scope scope_def_key in
Desugared.Ast.ScopeDef.Map.union
(fun _ _ _ -> assert false (* there should not be key conflicts *))
new_exceptions_graphs exceptions_graphs)
Desugared.Ast.ScopeDef.Map.empty scope_ordering
let build_exceptions_graph (pgrm : Desugared.Ast.program) :
Desugared.Dependency.ExceptionsDependencies.t Desugared.Ast.ScopeDef.Map.t =
ScopeName.Map.fold
(fun _ scope exceptions_graph ->
let new_exceptions_graphs = scope_to_exception_graphs scope in
Desugared.Ast.ScopeDef.Map.union
(fun _ _ _ -> assert false (* key conflicts should not happen*))
new_exceptions_graphs exceptions_graph)
pgrm.program_scopes Desugared.Ast.ScopeDef.Map.empty
(** Transforms a flat list of rules into a tree, taking into account the
priorities declared between rules *)
let def_map_to_tree
(def : Desugared.Ast.rule RuleName.Map.t)
(exc_graph : Desugared.Dependency.ExceptionsDependencies.t) : rule_tree list
=
(* we start by the base cases: they are the vertices which have no
successors *)
let base_cases =
@ -196,14 +334,15 @@ let def_map_to_tree
else base_cases)
exc_graph []
in
let rec build_tree (base_cases : RuleName.Set.t) : rule_tree =
let rec build_tree (base_cases : Desugared.Dependency.ExceptionVertex.t) :
rule_tree =
let exceptions =
Desugared.Dependency.ExceptionsDependencies.pred exc_graph base_cases
in
let base_case_as_rule_list =
List.map
(fun r -> RuleName.Map.find r def)
(RuleName.Set.elements base_cases)
(fun (r, _) -> RuleName.Map.find r def)
(RuleName.Map.bindings base_cases.rules)
in
match exceptions with
| [] -> Leaf base_case_as_rule_list
@ -337,16 +476,18 @@ let rec rule_tree_to_expr
(** Translates a definition inside a scope, the resulting expression should be
an {!constructor: Dcalc.EDefault} *)
let translate_def
~(is_cond : bool)
~(is_subscope_var : bool)
(ctx : ctx)
(def_info : Desugared.Ast.ScopeDef.t)
(def : Desugared.Ast.rule RuleName.Map.t)
(params : (Uid.MarkedString.info * typ) list Marked.pos option)
(typ : typ)
(io : Desugared.Ast.io)
~(is_cond : bool)
~(is_subscope_var : bool) : untyped Ast.expr boxed =
(exc_graph : Desugared.Dependency.ExceptionsDependencies.t) :
untyped Ast.expr boxed =
(* Here, we have to transform this list of rules into a default tree. *)
let top_list = def_map_to_tree def_info def in
let top_list = def_map_to_tree def exc_graph in
let is_input =
match Marked.unmark io.Desugared.Ast.io_input with
| OnlyInput -> true
@ -428,10 +569,15 @@ let translate_def
| _, None ->
Node (top_list, [Desugared.Ast.empty_rule (Marked.get_mark typ) params]))
let translate_rule ctx (scope : Desugared.Ast.scope) = function
let translate_rule
ctx
(scope : Desugared.Ast.scope)
(exc_graphs :
Desugared.Dependency.ExceptionsDependencies.t Desugared.Ast.ScopeDef.Map.t)
= function
| Desugared.Dependency.Vertex.Var (var, state) -> (
let scope_def =
Desugared.Ast.ScopeDefMap.find
Desugared.Ast.ScopeDef.Map.find
(Desugared.Ast.ScopeDef.Var (var, state))
scope.scope_defs
in
@ -441,23 +587,15 @@ let translate_rule ctx (scope : Desugared.Ast.scope) = function
let is_cond = scope_def.D.scope_def_is_condition in
match Marked.unmark scope_def.Desugared.Ast.scope_def_io.io_input with
| OnlyInput when not (RuleName.Map.is_empty var_def) ->
(* If the variable is tagged as input, then it shall not be redefined. *)
Errors.raise_multispanned_error
((Some "Incriminated variable:", Marked.get_mark (ScopeVar.get_info var))
:: List.map
(fun (rule, _) ->
( Some "Incriminated variable definition:",
Marked.get_mark (RuleName.get_info rule) ))
(RuleName.Map.bindings var_def))
"It is impossible to give a definition to a scope variable tagged as \
input."
assert false (* error already raised *)
| OnlyInput -> []
(* we do not provide any definition for an input-only variable *)
| _ ->
let scope_def_key = Desugared.Ast.ScopeDef.Var (var, state) in
let expr_def =
translate_def ctx
(Desugared.Ast.ScopeDef.Var (var, state))
var_def var_params var_typ scope_def.Desugared.Ast.scope_def_io
translate_def ctx scope_def_key var_def var_params var_typ
scope_def.Desugared.Ast.scope_def_io
(Desugared.Ast.ScopeDef.Map.find scope_def_key exc_graphs)
~is_cond ~is_subscope_var:false
in
let scope_var =
@ -482,7 +620,7 @@ let translate_rule ctx (scope : Desugared.Ast.scope) = function
SubScopeName.Map.find sub_scope_index scope.scope_sub_scopes
in
let sub_scope_vars_redefs_candidates =
Desugared.Ast.ScopeDefMap.filter
Desugared.Ast.ScopeDef.Map.filter
(fun def_key scope_def ->
match def_key with
| Desugared.Ast.ScopeDef.Var _ -> false
@ -500,56 +638,35 @@ let translate_rule ctx (scope : Desugared.Ast.scope) = function
scope.scope_defs
in
let sub_scope_vars_redefs =
Desugared.Ast.ScopeDefMap.mapi
Desugared.Ast.ScopeDef.Map.mapi
(fun def_key scope_def ->
let def = scope_def.Desugared.Ast.scope_def_rules in
let def_typ = scope_def.scope_def_typ in
let is_cond = scope_def.scope_def_is_condition in
match def_key with
| Desugared.Ast.ScopeDef.Var _ -> assert false (* should not happen *)
| Desugared.Ast.ScopeDef.SubScopeVar (sscope, sub_scope_var, pos) ->
| Desugared.Ast.ScopeDef.SubScopeVar (_, sub_scope_var, var_pos) ->
(* 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
Marked.unmark scope_def.Desugared.Ast.scope_def_io.io_input
with
| Desugared.Ast.NoInput ->
Errors.raise_multispanned_error
(( Some "Incriminated subscope:",
Marked.get_mark (SubScopeName.get_info sscope) )
:: ( Some "Incriminated variable:",
Marked.get_mark (ScopeVar.get_info sub_scope_var) )
:: List.map
(fun (rule, _) ->
( Some "Incriminated subscope variable definition:",
Marked.get_mark (RuleName.get_info rule) ))
(RuleName.Map.bindings def))
"It is impossible to give a definition to a subscope variable \
not tagged as input or context."
| Desugared.Ast.NoInput -> assert false (* error already raised *)
| OnlyInput when RuleName.Map.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:",
Marked.get_mark (SubScopeName.get_info sscope) );
Some "Incriminated variable:", pos;
]
"This subscope variable is a mandatory input but no definition \
was provided."
assert false (* error already raised *)
| _ -> ());
(* 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 scope_def.D.scope_def_parameters
def_typ scope_def.Desugared.Ast.scope_def_io ~is_cond
~is_subscope_var:true
def_typ scope_def.Desugared.Ast.scope_def_io
(Desugared.Ast.ScopeDef.Map.find def_key exc_graphs)
~is_cond ~is_subscope_var:true
in
let subscop_real_name =
SubScopeName.Map.find sub_scope_index scope.scope_sub_scopes
in
let var_pos = Desugared.Ast.ScopeDef.get_position def_key in
Ast.Definition
( ( SubScopeVar
( subscop_real_name,
@ -569,7 +686,7 @@ let translate_rule ctx (scope : Desugared.Ast.scope) = function
sub_scope_vars_redefs_candidates
in
let sub_scope_vars_redefs =
List.map snd (Desugared.Ast.ScopeDefMap.bindings sub_scope_vars_redefs)
List.map snd (Desugared.Ast.ScopeDef.Map.bindings sub_scope_vars_redefs)
in
sub_scope_vars_redefs
@ [
@ -582,8 +699,12 @@ let translate_rule ctx (scope : Desugared.Ast.scope) = function
]
(** Translates a scope *)
let translate_scope (ctx : ctx) (scope : Desugared.Ast.scope) :
untyped Ast.scope_decl =
let translate_scope
(ctx : ctx)
(scope : Desugared.Ast.scope)
(exc_graphs :
Desugared.Dependency.ExceptionsDependencies.t Desugared.Ast.ScopeDef.Map.t)
: untyped Ast.scope_decl =
let scope_dependencies =
Desugared.Dependency.build_scope_dependencies scope
in
@ -592,7 +713,11 @@ let translate_scope (ctx : ctx) (scope : Desugared.Ast.scope) :
Desugared.Dependency.correct_computation_ordering scope_dependencies
in
let scope_decl_rules =
List.flatten (List.map (translate_rule ctx scope) scope_ordering)
List.fold_left
(fun scope_decl_rules scope_def_key ->
let new_rules = translate_rule ctx scope exc_graphs scope_def_key in
scope_decl_rules @ new_rules)
[] scope_ordering
in
(* Then, after having computed all the scopes variables, we add the
assertions. TODO: the assertions should be interleaved with the
@ -611,7 +736,7 @@ let translate_scope (ctx : ctx) (scope : Desugared.Ast.scope) :
match states with
| WholeVar ->
let scope_def =
Desugared.Ast.ScopeDefMap.find
Desugared.Ast.ScopeDef.Map.find
(Desugared.Ast.ScopeDef.Var (var, None))
scope.scope_defs
in
@ -629,7 +754,7 @@ let translate_scope (ctx : ctx) (scope : Desugared.Ast.scope) :
List.fold_left
(fun acc (state : StateName.t) ->
let scope_def =
Desugared.Ast.ScopeDefMap.find
Desugared.Ast.ScopeDef.Map.find
(Desugared.Ast.ScopeDef.Var (var, Some state))
scope.scope_defs
in
@ -653,7 +778,11 @@ let translate_scope (ctx : ctx) (scope : Desugared.Ast.scope) :
(** {1 API} *)
let translate_program (pgrm : Desugared.Ast.program) : untyped Ast.program =
let translate_program
(pgrm : Desugared.Ast.program)
(exc_graphs :
Desugared.Dependency.ExceptionsDependencies.t Desugared.Ast.ScopeDef.Map.t)
: untyped Ast.program =
(* First we give mappings to all the locations between Desugared and This
involves creating a new Scopelang scope variable for every state of a
Desugared variable. *)
@ -708,12 +837,18 @@ let translate_program (pgrm : Desugared.Ast.program) : untyped Ast.program =
{ out_str with out_struct_fields })
pgrm.Desugared.Ast.program_ctx.ctx_scopes
in
let new_program_scopes =
ScopeName.Map.fold
(fun scope_name scope new_program_scopes ->
let new_program_scope = translate_scope ctx scope exc_graphs in
ScopeName.Map.add scope_name new_program_scope new_program_scopes)
pgrm.program_scopes ScopeName.Map.empty
in
{
Ast.program_topdefs =
TopdefName.Map.map
(fun (e, ty) -> Expr.unbox (translate_expr ctx e), ty)
pgrm.program_topdefs;
Ast.program_scopes =
ScopeName.Map.map (translate_scope ctx) pgrm.program_scopes;
Ast.program_scopes = new_program_scopes;
program_ctx = { pgrm.program_ctx with ctx_scopes };
}

13
compiler/scopelang/from_desugared.mli
View File

@ -16,4 +16,15 @@
(** Translation from {!module: Desugared.Ast} to {!module: Scopelang.Ast} *)
val translate_program : Desugared.Ast.program -> Shared_ast.untyped Ast.program
val build_exceptions_graph :
Desugared.Ast.program ->
Desugared.Dependency.ExceptionsDependencies.t Desugared.Ast.ScopeDef.Map.t
(** This function builds all the exceptions dependency graphs for all variables
of all scopes. *)
val translate_program :
Desugared.Ast.program ->
Desugared.Dependency.ExceptionsDependencies.t Desugared.Ast.ScopeDef.Map.t ->
Shared_ast.untyped Ast.program
(** This functions returns the translated program as well as all the graphs of
exceptions inferred for each scope variable of the program. *)

18
compiler/shared_ast/interpreter.ml
View File

@ -191,15 +191,14 @@ let rec evaluate_operator
EArray
(List.map
(fun e' ->
evaluate_expr ctx (Marked.same_mark_as (EApp { f; args = [e'] }) e'))
evaluate_expr (Marked.same_mark_as (EApp { f; args = [e'] }) e'))
es)
| Reduce, [_; default; (EArray [], _)] -> Marked.unmark default
| Reduce, [f; _; (EArray (x0 :: xn), _)] ->
Marked.unmark
(List.fold_left
(fun acc x ->
evaluate_expr ctx
(Marked.same_mark_as (EApp { f; args = [acc; x] }) f))
evaluate_expr (Marked.same_mark_as (EApp { f; args = [acc; x] }) f))
x0 xn)
| Concat, [(EArray es1, _); (EArray es2, _)] -> EArray (es1 @ es2)
| Filter, [f; (EArray es, _)] ->
@ -207,8 +206,7 @@ let rec evaluate_operator
(List.filter
(fun e' ->
match
evaluate_expr ctx
(Marked.same_mark_as (EApp { f; args = [e'] }) e')
evaluate_expr (Marked.same_mark_as (EApp { f; args = [e'] }) e')
with
| ELit (LBool b), _ -> b
| _ ->
@ -221,8 +219,7 @@ let rec evaluate_operator
Marked.unmark
(List.fold_left
(fun acc e' ->
evaluate_expr ctx
(Marked.same_mark_as (EApp { f; args = [acc; e'] }) e'))
evaluate_expr (Marked.same_mark_as (EApp { f; args = [acc; e'] }) e'))
init es)
| (Length | Log _ | Eq | Map | Concat | Filter | Fold | Reduce), _ -> err ()
| Not, [(ELit (LBool b), _)] -> ELit (LBool (o_not b))
@ -357,13 +354,12 @@ let rec evaluate_operator
match valid_exceptions with
| [] -> (
match
Marked.unmark
(evaluate_expr ctx (Expr.unthunk_term_nobox justification m))
Marked.unmark (evaluate_expr (Expr.unthunk_term_nobox justification m))
with
| EInj { name; cons; e = ELit (LBool true), _ }
when EnumName.equal name Definitions.option_enum
&& EnumConstructor.equal cons Definitions.some_constr ->
Marked.unmark (evaluate_expr ctx (Expr.unthunk_term_nobox conclusion m))
Marked.unmark (evaluate_expr (Expr.unthunk_term_nobox conclusion m))
| EInj { name; cons; e = (ELit (LBool false), _) as e }
when EnumName.equal name Definitions.option_enum
&& EnumConstructor.equal cons Definitions.some_constr ->
@ -459,7 +455,7 @@ let rec evaluate_expr :
| Eq_dur_dur | HandleDefault | HandleDefaultOpt ) as op;
_;
} ->
evaluate_operator evaluate_expr ctx op m args
evaluate_operator (evaluate_expr ctx) ctx op m args
| _ ->
Errors.raise_spanned_error pos
"function has not been reduced to a lambda at evaluation (should not \

12
compiler/shared_ast/interpreter.mli
View File

@ -20,6 +20,18 @@
open Catala_utils
open Definitions
val evaluate_operator :
((([< all ] as 'a), 'm mark) gexpr -> ('a, 'm mark) gexpr) ->
decl_ctx ->
[< dcalc | lcalc > `Monomorphic `Polymorphic `Resolved ] operator ->
'm mark ->
('a, 'm mark) gexpr list ->
('a, 'm mark) gexpr
(** Evaluates the result of applying the given operator to the given arguments,
which are expected to be already reduced to values. The first argument is
used to evaluate expressions and called when reducing e.g. the [map]
operator. *)
val evaluate_expr :
decl_ctx -> (([< dcalc | lcalc ] as 'a), 'm mark) gexpr -> ('a, 'm mark) gexpr
(** Evaluates an expression according to the semantics of the default calculus. *)

3
examples/allocations_familiales/prologue.catala_fr
View File

@ -85,7 +85,8 @@ déclaration champ d'application AllocationsFamiliales:
interne enfants_à_charge_droit_ouvert_prestation_familiale
contenu collection Enfant
interne prise_en_compte contenu PriseEnCompte dépend de enfant contenu Enfant
résultat versement contenu VersementAllocations dépend de enfant contenu Enfant
résultat versement contenu VersementAllocations
dépend de enfant contenu Enfant
résultat montant_versé contenu argent

30
flake.lock
View File

@ -1,12 +1,15 @@
{
"nodes": {
"flake-utils": {
"inputs": {
"systems": "systems"
},
"locked": {
"lastModified": 1676283394,
"narHash": "sha256-XX2f9c3iySLCw54rJ/CZs+ZK6IQy7GXNY4nSOyu2QG4=",
"lastModified": 1681202837,
"narHash": "sha256-H+Rh19JDwRtpVPAWp64F+rlEtxUWBAQW28eAi3SRSzg=",
"owner": "numtide",
"repo": "flake-utils",
"rev": "3db36a8b464d0c4532ba1c7dda728f4576d6d073",
"rev": "cfacdce06f30d2b68473a46042957675eebb3401",
"type": "github"
},
"original": {
@ -17,11 +20,11 @@
},
"nixpkgs": {
"locked": {
"lastModified": 1678470307,
"narHash": "sha256-OEeMUr3ueLIXyW/OaFUX5jUdimyQwMg/7e+/Q0gC/QE=",
"lastModified": 1681648924,
"narHash": "sha256-pzi3HISK8+7mpEtv08Yr80wswyHKsz+RP1CROG1Qf6s=",
"owner": "NixOS",
"repo": "nixpkgs",
"rev": "0c4800d579af4ed98ecc47d464a5e7b0870c4b1f",
"rev": "f294325aed382b66c7a188482101b0f336d1d7db",
"type": "github"
},
"original": {
@ -36,6 +39,21 @@
"flake-utils": "flake-utils",
"nixpkgs": "nixpkgs"
}
},
"systems": {
"locked": {
"lastModified": 1681028828,
"narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=",
"owner": "nix-systems",
"repo": "default",
"rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e",
"type": "github"
},
"original": {
"owner": "nix-systems",
"repo": "default",
"type": "github"
}
}
},
"root": "root",

2
french_law/python/main.py
View File

@ -143,7 +143,7 @@ if __name__ == '__main__':
print(timeit.timeit(benchmark_iteration_family, number=iterations))
elif action == "bench_housing":
iterations = 1000
print("Iterating {} iterations of the family benefits computation. Total time (s):".format(
print("Iterating {} iterations of the housing benefits computation. Total time (s):".format(
iterations))
print(timeit.timeit(benchmark_iteration_housing, number=iterations))
elif action == "show_log":

41
tests/test_exception/good/groups_of_exceptions.catala_en
View File

@ -45,3 +45,44 @@ let scope Foo (y: integer|input) (x: integer|internal|output) =
⊢ ⟨ ⟨y = 2 ⊢ 2⟩, ⟨y = 3 ⊢ 3⟩ | false ⊢ ∅ ⟩ ⟩
| true ⊢ ⟨ ⟨y = 0 ⊢ 0⟩, ⟨y = 1 ⊢ 1⟩ | false ⊢ ∅ ⟩ ⟩
```
```catala-test-inline
$ catala Exceptions -s Foo -v x
[RESULT] Printing the tree of exceptions for the definitions of variable "x" of scope "Foo".
[RESULT] Definitions with label "base":
┌─⯈ tests/test_exception/good/groups_of_exceptions.catala_en:9.2-25:
└─┐
9 │ label base definition x under condition
│ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾
└─ Test
┌─⯈ tests/test_exception/good/groups_of_exceptions.catala_en:13.2-25:
└──┐
13 │ label base definition x under condition
│ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾
└─ Test
[RESULT] Definitions with label "intermediate":
┌─⯈ tests/test_exception/good/groups_of_exceptions.catala_en:17.2-48:
└──┐
17 │ label intermediate exception base definition x under condition
│ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾
└─ Test
┌─⯈ tests/test_exception/good/groups_of_exceptions.catala_en:21.2-48:
└──┐
21 │ label intermediate exception base definition x under condition
│ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾
└─ Test
[RESULT] Definitions with label "exception_to_intermediate":
┌─⯈ tests/test_exception/good/groups_of_exceptions.catala_en:25.2-37:
└──┐
25 │ exception intermediate definition x under condition
│ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾
└─ Test
┌─⯈ tests/test_exception/good/groups_of_exceptions.catala_en:29.2-37:
└──┐
29 │ exception intermediate definition x under condition
│ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾
└─ Test
[RESULT] The exception tree structure is as follows:
"base"───"intermediate"───"exception_to_intermediate"
```