Implement quick pattern-check desugaring

[denismerigoux]

The Catala surface syntax contains a handy sugar that allows to check whether a value of a sum type falls into one of the sum type cases:

catala/src/catala/catala_surface/ast.ml

Line 132 in 933fd02

| TestMatchCase of expression Pos.marked * constructor Pos.marked

This AST pattern is not handled by desugaring yet:

catala/src/catala/catala_surface/desugaring.ml

Line 488 in 933fd02

| _ ->

The desugaring should be implemented in the following way. Suppose you have:

declaration enumeration Foo:
  -- Case1
  -- Case2
  -- Case3 content integer

Then x with pattern Case2 should be desugared to:

match x with pattern 
  -- Case1 : false 
  -- Case2: true 
  -- Case3 content y: false

One can take inspiration from

catala/src/catala/catala_surface/desugaring.ml

Lines 259 to 343 in 933fd02

	| MatchWith (e1, (cases, _cases_pos)) ->
	let e1 = translate_expr scope ctxt e1 in
	let cases_d, e_uid =
	List.fold_left
	(fun (cases_d, e_uid) (case, pos_case) ->
	match Pos.unmark case.Ast.match_case_pattern with
	| [ constructor ], binding ->
	let possible_c_uids =
	try Desugared.Ast.IdentMap.find (Pos.unmark constructor) ctxt.constructor_idmap
	with Not_found ->
	Errors.raise_spanned_error
	"The name of this constructor has not been defined before, maybe it is a \
	typo?"
	(Pos.get_position constructor)
	in
	if e_uid = None && Scopelang.Ast.EnumMap.cardinal possible_c_uids > 1 then
	Errors.raise_spanned_error
	(Format.asprintf
	"This constuctor 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))
	(Scopelang.Ast.EnumMap.bindings possible_c_uids))
	(Pos.get_position constructor)
	else
	let e_uid, c_uid =
	match e_uid with
	| Some e_uid -> (
	( e_uid,
	try Scopelang.Ast.EnumMap.find e_uid possible_c_uids
	with Not_found ->
	Errors.raise_spanned_error
	(Format.asprintf "This constructor is not part of the %a enumeration"
	Scopelang.Ast.EnumName.format_t e_uid)
	(Pos.get_position constructor) ) )
	| None -> Scopelang.Ast.EnumMap.choose possible_c_uids
	in
	( match Scopelang.Ast.EnumConstructorMap.find_opt c_uid cases_d with
	| None -> ()
	| Some e_case ->
	Errors.raise_multispanned_error
	(Format.asprintf "The constructor %a has been matched twice:"
	Scopelang.Ast.EnumConstructor.format_t c_uid)
	[
	(None, Pos.get_position case.match_case_expr);
	(None, Pos.get_position (Bindlib.unbox e_case));
	] );
	let ctxt, (param_var, param_pos) =
	match binding with
	| None -> (ctxt, (Scopelang.Ast.Var.make ("_", Pos.no_pos), Pos.no_pos))
	| Some param ->
	let ctxt, param_var = Name_resolution.add_def_local_var ctxt param in
	(ctxt, (param_var, Pos.get_position param))
	in
	let case_body = translate_expr scope ctxt case.Ast.match_case_expr in
	let e_binder = Bindlib.bind_mvar (Array.of_list [ param_var ]) case_body in
	let case_expr =
	Bindlib.box_apply2
	(fun e_binder case_body ->
	Pos.same_pos_as
	(Scopelang.Ast.EAbs
	( param_pos,
	e_binder,
	[
	Scopelang.Ast.EnumConstructorMap.find c_uid
	(Scopelang.Ast.EnumMap.find e_uid ctxt.Name_resolution.enums);
	] ))
	case_body)
	e_binder case_body
	in
	(Scopelang.Ast.EnumConstructorMap.add c_uid case_expr cases_d, Some e_uid)
	| _ :: _, _ ->
	Errors.raise_spanned_error
	"The deep pattern matching syntactic sugar is not yet supported" pos_case
	| [], _ -> assert false
	(* should not happen *))
	(Scopelang.Ast.EnumConstructorMap.empty, None)
	cases
	in
	Bindlib.box_apply2
	(fun e1 cases_d -> (Scopelang.Ast.EMatch (e1, Option.get e_uid, cases_d), pos))
	e1
	(LiftEnumConstructorMap.lift_box cases_d)