mirror of
https://github.com/CatalaLang/catala.git
synced 2024-09-20 00:41:05 +03:00
Cleanup: definitions.ml
is not for values
A module without mli is ok as long as it only contains types Here we already stretch it a bit with some functor applications, but having toplevel values defeats the expectation that you can safely `open` this module.
This commit is contained in:
parent
da04faf02f
commit
ba52aae401
@ -14,7 +14,7 @@
|
|||||||
License for the specific language governing permissions and limitations under
|
License for the specific language governing permissions and limitations under
|
||||||
the License. *)
|
the License. *)
|
||||||
|
|
||||||
include Shared_ast
|
open Shared_ast
|
||||||
|
|
||||||
type 'm naked_expr = (lcalc, 'm mark) naked_gexpr
|
type 'm naked_expr = (lcalc, 'm mark) naked_gexpr
|
||||||
and 'm expr = (lcalc, 'm mark) gexpr
|
and 'm expr = (lcalc, 'm mark) gexpr
|
||||||
@ -22,30 +22,32 @@ and 'm expr = (lcalc, 'm mark) gexpr
|
|||||||
type 'm program = 'm expr Shared_ast.program
|
type 'm program = 'm expr Shared_ast.program
|
||||||
|
|
||||||
module OptionMonad = struct
|
module OptionMonad = struct
|
||||||
let return ~(mark : 'a mark) e = Expr.einj e some_constr option_enum mark
|
let return ~(mark : 'a mark) e =
|
||||||
|
Expr.einj e Expr.some_constr Expr.option_enum mark
|
||||||
|
|
||||||
let empty ~(mark : 'a mark) =
|
let empty ~(mark : 'a mark) =
|
||||||
Expr.einj (Expr.elit LUnit mark) none_constr option_enum mark
|
Expr.einj (Expr.elit LUnit mark) Expr.none_constr Expr.option_enum mark
|
||||||
|
|
||||||
let bind_var ~(mark : 'a mark) f x arg =
|
let bind_var ~(mark : 'a mark) f x arg =
|
||||||
let cases =
|
let cases =
|
||||||
EnumConstructor.Map.of_seq
|
EnumConstructor.Map.of_seq
|
||||||
(List.to_seq
|
(List.to_seq
|
||||||
[
|
[
|
||||||
( none_constr,
|
( Expr.none_constr,
|
||||||
let x = Var.make "_" in
|
let x = Var.make "_" in
|
||||||
Expr.eabs
|
Expr.eabs
|
||||||
(Expr.bind [| x |]
|
(Expr.bind [| x |]
|
||||||
(Expr.einj (Expr.evar x mark) none_constr option_enum mark))
|
(Expr.einj (Expr.evar x mark) Expr.none_constr
|
||||||
|
Expr.option_enum mark))
|
||||||
[TLit TUnit, Expr.mark_pos mark]
|
[TLit TUnit, Expr.mark_pos mark]
|
||||||
mark );
|
mark );
|
||||||
(* | None x -> None x *)
|
(* | None x -> None x *)
|
||||||
( some_constr,
|
( Expr.some_constr,
|
||||||
Expr.eabs (Expr.bind [| x |] f) [TAny, Expr.mark_pos mark] mark )
|
Expr.eabs (Expr.bind [| x |] f) [TAny, Expr.mark_pos mark] mark )
|
||||||
(*| Some x -> f (where f contains x as a free variable) *);
|
(*| Some x -> f (where f contains x as a free variable) *);
|
||||||
])
|
])
|
||||||
in
|
in
|
||||||
Expr.ematch arg option_enum cases mark
|
Expr.ematch arg Expr.option_enum cases mark
|
||||||
|
|
||||||
let bind ~(mark : 'a mark) ~(var_name : string) f arg =
|
let bind ~(mark : 'a mark) ~(var_name : string) f arg =
|
||||||
let x = Var.make var_name in
|
let x = Var.make var_name in
|
||||||
@ -86,7 +88,7 @@ module OptionMonad = struct
|
|||||||
~init:
|
~init:
|
||||||
(Expr.einj
|
(Expr.einj
|
||||||
(Expr.eapp f (List.map (fun v -> Expr.evar v mark) xs) mark)
|
(Expr.eapp f (List.map (fun v -> Expr.evar v mark) xs) mark)
|
||||||
some_constr option_enum mark)
|
Expr.some_constr Expr.option_enum mark)
|
||||||
|
|
||||||
let map_var ~(mark : 'a mark) f x arg = mmap_mvar f [x] [arg] ~mark
|
let map_var ~(mark : 'a mark) f x arg = mmap_mvar f [x] [arg] ~mark
|
||||||
|
|
||||||
@ -110,16 +112,16 @@ module OptionMonad = struct
|
|||||||
EnumConstructor.Map.of_seq
|
EnumConstructor.Map.of_seq
|
||||||
(List.to_seq
|
(List.to_seq
|
||||||
[
|
[
|
||||||
( none_constr,
|
( Expr.none_constr,
|
||||||
let x = Var.make var_name in
|
let x = Var.make var_name in
|
||||||
Expr.eabs
|
Expr.eabs
|
||||||
(Expr.bind [| x |] (Expr.eraise NoValueProvided mark))
|
(Expr.bind [| x |] (Expr.eraise NoValueProvided mark))
|
||||||
[TAny, Expr.mark_pos mark]
|
[TAny, Expr.mark_pos mark]
|
||||||
mark );
|
mark );
|
||||||
(* | None x -> raise NoValueProvided *)
|
(* | None x -> raise NoValueProvided *)
|
||||||
some_constr, Expr.fun_id mark (* | Some x -> x*);
|
Expr.some_constr, Expr.fun_id mark (* | Some x -> x*);
|
||||||
])
|
])
|
||||||
in
|
in
|
||||||
if toplevel then Expr.ematch arg option_enum cases mark
|
if toplevel then Expr.ematch arg Expr.option_enum cases mark
|
||||||
else return ~mark (Expr.ematch arg option_enum cases mark)
|
else return ~mark (Expr.ematch arg Expr.option_enum cases mark)
|
||||||
end
|
end
|
||||||
|
@ -27,13 +27,6 @@ type 'm program = 'm expr Shared_ast.program
|
|||||||
|
|
||||||
(** {1 Option-related management}*)
|
(** {1 Option-related management}*)
|
||||||
|
|
||||||
(** {2 Names and types}*)
|
|
||||||
|
|
||||||
val option_enum : EnumName.t
|
|
||||||
val none_constr : EnumConstructor.t
|
|
||||||
val some_constr : EnumConstructor.t
|
|
||||||
val option_enum_config : typ EnumConstructor.Map.t
|
|
||||||
|
|
||||||
(** {2 Term building and management for the [option] monad}*)
|
(** {2 Term building and management for the [option] monad}*)
|
||||||
|
|
||||||
module OptionMonad : sig
|
module OptionMonad : sig
|
||||||
|
@ -720,7 +720,7 @@ let translate_program (prgm : typed D.program) : untyped A.program =
|
|||||||
prgm.decl_ctx with
|
prgm.decl_ctx with
|
||||||
ctx_enums =
|
ctx_enums =
|
||||||
prgm.decl_ctx.ctx_enums
|
prgm.decl_ctx.ctx_enums
|
||||||
|> EnumName.Map.add A.option_enum A.option_enum_config;
|
|> EnumName.Map.add Expr.option_enum Expr.option_enum_config;
|
||||||
}
|
}
|
||||||
in
|
in
|
||||||
let decl_ctx =
|
let decl_ctx =
|
||||||
|
@ -164,7 +164,7 @@ let rec format_typ (fmt : Format.formatter) (typ : typ) : unit =
|
|||||||
| TStruct s -> Format.fprintf fmt "%a.t" format_to_module_name (`Sname s)
|
| TStruct s -> Format.fprintf fmt "%a.t" format_to_module_name (`Sname s)
|
||||||
| TOption t ->
|
| TOption t ->
|
||||||
Format.fprintf fmt "@[<hov 2>(%a)@] %a" format_typ_with_parens t
|
Format.fprintf fmt "@[<hov 2>(%a)@] %a" format_typ_with_parens t
|
||||||
format_enum_name Ast.option_enum
|
format_enum_name Expr.option_enum
|
||||||
| TEnum e -> Format.fprintf fmt "%a.t" format_to_module_name (`Ename e)
|
| TEnum e -> Format.fprintf fmt "%a.t" format_to_module_name (`Ename e)
|
||||||
| TArrow (t1, t2) ->
|
| TArrow (t1, t2) ->
|
||||||
Format.fprintf fmt "@[<hov 2>%a@]"
|
Format.fprintf fmt "@[<hov 2>%a@]"
|
||||||
|
@ -72,7 +72,7 @@ module To_jsoo = struct
|
|||||||
Format.fprintf fmt "Js.Unsafe.any_js_array Js.t "
|
Format.fprintf fmt "Js.Unsafe.any_js_array Js.t "
|
||||||
| TOption t ->
|
| TOption t ->
|
||||||
Format.fprintf fmt "@[<hov 2>(%a)@] %a" format_typ_with_parens t
|
Format.fprintf fmt "@[<hov 2>(%a)@] %a" format_typ_with_parens t
|
||||||
format_enum_name Lcalc.Ast.option_enum
|
format_enum_name Expr.option_enum
|
||||||
| TEnum e -> Format.fprintf fmt "%a Js.t" format_enum_name e
|
| TEnum e -> Format.fprintf fmt "%a Js.t" format_enum_name e
|
||||||
| TArray t1 ->
|
| TArray t1 ->
|
||||||
Format.fprintf fmt "@[%a@ Js.js_array Js.t@]" format_typ_with_parens t1
|
Format.fprintf fmt "@[%a@ Js.js_array Js.t@]" format_typ_with_parens t1
|
||||||
|
@ -295,13 +295,13 @@ let rec format_expression (ctx : decl_ctx) (fmt : Format.formatter) (e : expr) :
|
|||||||
Format.fprintf fmt "%a.%a" (format_expression ctx) e1
|
Format.fprintf fmt "%a.%a" (format_expression ctx) e1
|
||||||
format_struct_field_name field
|
format_struct_field_name field
|
||||||
| EInj (_, cons, e_name)
|
| EInj (_, cons, e_name)
|
||||||
when EnumName.compare e_name L.option_enum = 0
|
when EnumName.equal e_name Expr.option_enum
|
||||||
&& EnumConstructor.compare cons L.none_constr = 0 ->
|
&& EnumConstructor.equal cons Expr.none_constr ->
|
||||||
(* We translate the option type with an overloading by Python's [None] *)
|
(* We translate the option type with an overloading by Python's [None] *)
|
||||||
Format.fprintf fmt "None"
|
Format.fprintf fmt "None"
|
||||||
| EInj (e, cons, e_name)
|
| EInj (e, cons, e_name)
|
||||||
when EnumName.compare e_name L.option_enum = 0
|
when EnumName.equal e_name Expr.option_enum
|
||||||
&& EnumConstructor.compare cons L.some_constr = 0 ->
|
&& EnumConstructor.equal cons Expr.some_constr ->
|
||||||
(* We translate the option type with an overloading by Python's [None] *)
|
(* We translate the option type with an overloading by Python's [None] *)
|
||||||
format_expression ctx fmt e
|
format_expression ctx fmt e
|
||||||
| EInj (e, cons, enum_name) ->
|
| EInj (e, cons, enum_name) ->
|
||||||
@ -414,7 +414,7 @@ let rec format_statement
|
|||||||
Format.fprintf fmt "@[<hov 4>if %a:@\n%a@]@\n@[<hov 4>else:@\n%a@]"
|
Format.fprintf fmt "@[<hov 4>if %a:@\n%a@]@\n@[<hov 4>else:@\n%a@]"
|
||||||
(format_expression ctx) cond (format_block ctx) b1 (format_block ctx) b2
|
(format_expression ctx) cond (format_block ctx) b1 (format_block ctx) b2
|
||||||
| SSwitch (e1, e_name, [(case_none, _); (case_some, case_some_var)])
|
| SSwitch (e1, e_name, [(case_none, _); (case_some, case_some_var)])
|
||||||
when EnumName.compare e_name L.option_enum = 0 ->
|
when EnumName.equal e_name Expr.option_enum ->
|
||||||
(* We translate the option type with an overloading by Python's [None] *)
|
(* We translate the option type with an overloading by Python's [None] *)
|
||||||
let tmp_var = VarName.fresh ("perhaps_none_arg", Pos.no_pos) in
|
let tmp_var = VarName.fresh ("perhaps_none_arg", Pos.no_pos) in
|
||||||
Format.fprintf fmt
|
Format.fprintf fmt
|
||||||
|
@ -433,14 +433,8 @@ and ('a, 'b, 't) base_gexpr =
|
|||||||
}
|
}
|
||||||
-> ('a, < exceptions : yes ; .. >, 't) base_gexpr
|
-> ('a, < exceptions : yes ; .. >, 't) base_gexpr
|
||||||
|
|
||||||
let option_enum : EnumName.t = EnumName.fresh ("eoption", Pos.no_pos)
|
(* Useful for errors and printing, for example *)
|
||||||
let none_constr : EnumConstructor.t = EnumConstructor.fresh ("ENone", Pos.no_pos)
|
(* type any_expr = AnyExpr : ('a, _ mark) gexpr -> any_expr *)
|
||||||
let some_constr : EnumConstructor.t = EnumConstructor.fresh ("ESome", Pos.no_pos)
|
|
||||||
|
|
||||||
let option_enum_config : typ EnumConstructor.Map.t =
|
|
||||||
EnumConstructor.Map.empty
|
|
||||||
|> EnumConstructor.Map.add none_constr (TLit TUnit, Pos.no_pos)
|
|
||||||
|> EnumConstructor.Map.add some_constr (TAny, Pos.no_pos)
|
|
||||||
|
|
||||||
type ('a, 't) boxed_gexpr = (('a, 't) naked_gexpr Bindlib.box, 't) Marked.t
|
type ('a, 't) boxed_gexpr = (('a, 't) naked_gexpr Bindlib.box, 't) Marked.t
|
||||||
(** The annotation is lifted outside of the box for expressions *)
|
(** The annotation is lifted outside of the box for expressions *)
|
||||||
|
@ -240,6 +240,16 @@ let with_ty (type m) (m : m mark) ?pos (ty : typ) : m mark =
|
|||||||
let maybe_ty (type m) ?(typ = TAny) (m : m mark) : typ =
|
let maybe_ty (type m) ?(typ = TAny) (m : m mark) : typ =
|
||||||
match m with Untyped { pos } -> Marked.mark pos typ | Typed { ty; _ } -> ty
|
match m with Untyped { pos } -> Marked.mark pos typ | Typed { ty; _ } -> ty
|
||||||
|
|
||||||
|
(* - Predefined types (option) - *)
|
||||||
|
|
||||||
|
let option_enum = EnumName.fresh ("eoption", Pos.no_pos)
|
||||||
|
let none_constr = EnumConstructor.fresh ("ENone", Pos.no_pos)
|
||||||
|
let some_constr = EnumConstructor.fresh ("ESome", Pos.no_pos)
|
||||||
|
|
||||||
|
let option_enum_config =
|
||||||
|
EnumConstructor.Map.singleton none_constr (TLit TUnit, Pos.no_pos)
|
||||||
|
|> EnumConstructor.Map.add some_constr (TAny, Pos.no_pos)
|
||||||
|
|
||||||
(* - Traversal functions - *)
|
(* - Traversal functions - *)
|
||||||
|
|
||||||
(* shallow map *)
|
(* shallow map *)
|
||||||
|
@ -143,7 +143,7 @@ val escopecall :
|
|||||||
|
|
||||||
val fun_id : 'm mark -> ('a any, 'm mark) boxed_gexpr
|
val fun_id : 'm mark -> ('a any, 'm mark) boxed_gexpr
|
||||||
|
|
||||||
(** Manipulation of marks *)
|
(** {2 Manipulation of marks} *)
|
||||||
|
|
||||||
val no_mark : 'm mark -> 'm mark
|
val no_mark : 'm mark -> 'm mark
|
||||||
val mark_pos : 'm mark -> Pos.t
|
val mark_pos : 'm mark -> Pos.t
|
||||||
@ -171,6 +171,13 @@ val maybe_ty : ?typ:naked_typ -> 'm mark -> typ
|
|||||||
(** Returns the corresponding type on a typed expr, or [typ] (defaulting to
|
(** Returns the corresponding type on a typed expr, or [typ] (defaulting to
|
||||||
[TAny]) at the current position on an untyped one *)
|
[TAny]) at the current position on an untyped one *)
|
||||||
|
|
||||||
|
(** {2 Predefined types} *)
|
||||||
|
|
||||||
|
val option_enum : EnumName.t
|
||||||
|
val none_constr : EnumConstructor.t
|
||||||
|
val some_constr : EnumConstructor.t
|
||||||
|
val option_enum_config : typ EnumConstructor.Map.t
|
||||||
|
|
||||||
(** Manipulation of marked expressions *)
|
(** Manipulation of marked expressions *)
|
||||||
|
|
||||||
val pos : ('a, 'm mark) Marked.t -> Pos.t
|
val pos : ('a, 'm mark) Marked.t -> Pos.t
|
||||||
|
@ -335,9 +335,8 @@ let rec evaluate_operator
|
|||||||
| HandleDefaultOpt, [(EArray exps, _); justification; conclusion] -> (
|
| HandleDefaultOpt, [(EArray exps, _); justification; conclusion] -> (
|
||||||
let valid_exceptions =
|
let valid_exceptions =
|
||||||
ListLabels.filter exps ~f:(function
|
ListLabels.filter exps ~f:(function
|
||||||
| EInj { name; cons; _ }, _
|
| EInj { name; cons; _ }, _ when EnumName.equal name Expr.option_enum ->
|
||||||
when EnumName.equal name Definitions.option_enum ->
|
EnumConstructor.equal cons Expr.some_constr
|
||||||
EnumConstructor.equal cons Definitions.some_constr
|
|
||||||
| _ -> err ())
|
| _ -> err ())
|
||||||
in
|
in
|
||||||
|
|
||||||
@ -347,31 +346,31 @@ let rec evaluate_operator
|
|||||||
Marked.unmark (evaluate_expr (Expr.unthunk_term_nobox justification m))
|
Marked.unmark (evaluate_expr (Expr.unthunk_term_nobox justification m))
|
||||||
with
|
with
|
||||||
| EInj { name; cons; e = ELit (LBool true), _ }
|
| EInj { name; cons; e = ELit (LBool true), _ }
|
||||||
when EnumName.equal name Definitions.option_enum
|
when EnumName.equal name Expr.option_enum
|
||||||
&& EnumConstructor.equal cons Definitions.some_constr ->
|
&& EnumConstructor.equal cons Expr.some_constr ->
|
||||||
Marked.unmark (evaluate_expr (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 }
|
| EInj { name; cons; e = (ELit (LBool false), _) as e }
|
||||||
when EnumName.equal name Definitions.option_enum
|
when EnumName.equal name Expr.option_enum
|
||||||
&& EnumConstructor.equal cons Definitions.some_constr ->
|
&& EnumConstructor.equal cons Expr.some_constr ->
|
||||||
EInj
|
EInj
|
||||||
{
|
{
|
||||||
name = Definitions.option_enum;
|
name = Expr.option_enum;
|
||||||
cons = Definitions.none_constr;
|
cons = Expr.none_constr;
|
||||||
e = Marked.same_mark_as (ELit LUnit) e;
|
e = Marked.same_mark_as (ELit LUnit) e;
|
||||||
}
|
}
|
||||||
| EInj { name; cons; e }
|
| EInj { name; cons; e }
|
||||||
when EnumName.equal name Definitions.option_enum
|
when EnumName.equal name Expr.option_enum
|
||||||
&& EnumConstructor.equal cons Definitions.none_constr ->
|
&& EnumConstructor.equal cons Expr.none_constr ->
|
||||||
EInj
|
EInj
|
||||||
{
|
{
|
||||||
name = Definitions.option_enum;
|
name = Expr.option_enum;
|
||||||
cons = Definitions.none_constr;
|
cons = Expr.none_constr;
|
||||||
e = Marked.same_mark_as (ELit LUnit) e;
|
e = Marked.same_mark_as (ELit LUnit) e;
|
||||||
}
|
}
|
||||||
| _ -> err ())
|
| _ -> err ())
|
||||||
| [((EInj { cons; name; _ } as e), _)]
|
| [((EInj { cons; name; _ } as e), _)]
|
||||||
when EnumName.equal name Definitions.option_enum
|
when EnumName.equal name Expr.option_enum
|
||||||
&& EnumConstructor.equal cons Definitions.some_constr ->
|
&& EnumConstructor.equal cons Expr.some_constr ->
|
||||||
e
|
e
|
||||||
| [_] -> err ()
|
| [_] -> err ()
|
||||||
| _ -> raise (CatalaException ConflictError))
|
| _ -> raise (CatalaException ConflictError))
|
||||||
@ -584,8 +583,8 @@ let interpret_program_lcalc p s : (Uid.MarkedString.info * ('a, 'm) gexpr) list
|
|||||||
(fun ty ->
|
(fun ty ->
|
||||||
match Marked.unmark ty with
|
match Marked.unmark ty with
|
||||||
| TOption _ ->
|
| TOption _ ->
|
||||||
(Expr.einj (Expr.elit LUnit mark_e) Definitions.none_constr
|
(Expr.einj (Expr.elit LUnit mark_e) Expr.none_constr
|
||||||
Definitions.option_enum mark_e
|
Expr.option_enum mark_e
|
||||||
: (_, _) boxed_gexpr)
|
: (_, _) boxed_gexpr)
|
||||||
| _ ->
|
| _ ->
|
||||||
Errors.raise_spanned_error (Marked.get_mark ty)
|
Errors.raise_spanned_error (Marked.get_mark ty)
|
||||||
|
@ -526,8 +526,8 @@ and typecheck_expr_top_down :
|
|||||||
in
|
in
|
||||||
Expr.estructaccess e_struct' field name mark
|
Expr.estructaccess e_struct' field name mark
|
||||||
| A.EInj { name; cons; e = e_enum }
|
| A.EInj { name; cons; e = e_enum }
|
||||||
when Definitions.EnumName.equal name Definitions.option_enum ->
|
when Definitions.EnumName.equal name Expr.option_enum ->
|
||||||
if Definitions.EnumConstructor.equal cons Definitions.some_constr then
|
if Definitions.EnumConstructor.equal cons Expr.some_constr then
|
||||||
let cell_type = unionfind (TAny (Any.fresh ())) in
|
let cell_type = unionfind (TAny (Any.fresh ())) in
|
||||||
let mark = mark_with_tau_and_unify (unionfind (TOption cell_type)) in
|
let mark = mark_with_tau_and_unify (unionfind (TOption cell_type)) in
|
||||||
let e_enum' =
|
let e_enum' =
|
||||||
@ -552,12 +552,12 @@ and typecheck_expr_top_down :
|
|||||||
in
|
in
|
||||||
Expr.einj e_enum' cons name mark
|
Expr.einj e_enum' cons name mark
|
||||||
| A.EMatch { e = e1; name; cases }
|
| A.EMatch { e = e1; name; cases }
|
||||||
when Definitions.EnumName.compare name Definitions.option_enum = 0 ->
|
when Definitions.EnumName.equal name Expr.option_enum ->
|
||||||
let cell_type = unionfind ~pos:e1 (TAny (Any.fresh ())) in
|
let cell_type = unionfind ~pos:e1 (TAny (Any.fresh ())) in
|
||||||
let t_arg = unionfind ~pos:e1 (TOption cell_type) in
|
let t_arg = unionfind ~pos:e1 (TOption cell_type) in
|
||||||
let cases_ty =
|
let cases_ty =
|
||||||
ListLabels.fold_right2
|
ListLabels.fold_right2
|
||||||
[A.none_constr; A.some_constr]
|
[Expr.none_constr; Expr.some_constr]
|
||||||
[unionfind ~pos:e1 (TLit TUnit); cell_type]
|
[unionfind ~pos:e1 (TLit TUnit); cell_type]
|
||||||
~f:A.EnumConstructor.Map.add ~init:A.EnumConstructor.Map.empty
|
~f:A.EnumConstructor.Map.add ~init:A.EnumConstructor.Map.empty
|
||||||
in
|
in
|
||||||
|
Loading…
Reference in New Issue
Block a user