diff --git a/compiler/dcalc/ast.ml b/compiler/dcalc/ast.ml index 92abd352..fa970e32 100644 --- a/compiler/dcalc/ast.ml +++ b/compiler/dcalc/ast.ml @@ -33,6 +33,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 +[@@ deriving show] type struct_name = StructName.t @@ -40,11 +41,12 @@ type enum_name = EnumName.t type typ = | TLit of typ_lit - | TTuple of typ Pos.marked list * struct_name option - | TEnum of typ Pos.marked list * enum_name + | TTuple of typ Pos.marked list * (struct_name [@opaque]) option + | TEnum of typ Pos.marked list * (enum_name [@opaque]) | TArrow of typ Pos.marked * typ Pos.marked | TArray of typ Pos.marked | TAny +[@@ deriving show] type date = Runtime.date @@ -66,9 +68,12 @@ type lit = | LDate of date | LDuration of duration + type op_kind = KInt | KRat | KMoney | KDate | KDuration +[@@ deriving show] type ternop = Fold +[@@ deriving show] type binop = | And @@ -87,36 +92,41 @@ type binop = | Map | Concat | Filter +[@@ deriving show] type log_entry = VarDef of typ | BeginCall | EndCall | PosRecordIfTrueBool +[@@ deriving show] type unop = | Not | Minus of op_kind - | Log of log_entry * (Utils.Uid.MarkedString.info list[@opaque]) + | Log of log_entry * (Utils.Uid.MarkedString.info list [@opaque]) | Length | IntToRat | GetDay | GetMonth | GetYear +[@@ deriving show] type operator = Ternop of ternop | Binop of binop | Unop of unop +[@@ deriving show] type expr = - | EVar of (expr Bindlib.var[@opaque]) Pos.marked - | ETuple of expr Pos.marked list * struct_name option - | 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 + | EVar of (expr Bindlib.var [@opaque]) Pos.marked + | ETuple of expr Pos.marked list * (struct_name [@opaque]) option + | ETupleAccess of expr Pos.marked * int * (struct_name [@opaque]) option * typ Pos.marked list + | EInj of expr Pos.marked * int * (enum_name [@opaque]) * typ Pos.marked list + | EMatch of expr Pos.marked * expr Pos.marked list * (enum_name [@opaque]) | EArray of expr Pos.marked list - | ELit of lit - | EAbs of (expr, expr Pos.marked) Bindlib.mbinder Pos.marked * typ Pos.marked list + | ELit of (lit [@opaque]) + | 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 | EDefault of expr Pos.marked list * expr Pos.marked * expr Pos.marked | EIfThenElse of expr Pos.marked * expr Pos.marked * expr Pos.marked | ErrorOnEmpty of expr Pos.marked +[@@ deriving show] type struct_ctx = (StructFieldName.t * typ Pos.marked) list StructMap.t diff --git a/compiler/dcalc/ast.mli b/compiler/dcalc/ast.mli index 5ec563d4..b5f4ddfd 100644 --- a/compiler/dcalc/ast.mli +++ b/compiler/dcalc/ast.mli @@ -124,6 +124,7 @@ type expr = | EDefault of expr Pos.marked list * expr Pos.marked * expr Pos.marked | EIfThenElse of expr Pos.marked * expr Pos.marked * expr Pos.marked | ErrorOnEmpty of expr Pos.marked +[@@deriving show] type struct_ctx = (StructFieldName.t * typ Pos.marked) list StructMap.t diff --git a/compiler/dcalc/dune b/compiler/dcalc/dune index e450c570..0402e8f0 100644 --- a/compiler/dcalc/dune +++ b/compiler/dcalc/dune @@ -3,7 +3,7 @@ (public_name catala.dcalc) (libraries bindlib unionFind utils re camomile runtime) (preprocess - (pps visitors.ppx))) + (pps visitors.ppx ppx_deriving.show))) (documentation (package catala) diff --git a/compiler/lcalc/compile_without_exceptions.ml b/compiler/lcalc/compile_without_exceptions.ml index 7637de8c..e60b93d5 100644 --- a/compiler/lcalc/compile_without_exceptions.ml +++ b/compiler/lcalc/compile_without_exceptions.ml @@ -248,6 +248,44 @@ and translate_expr (ctx : ctx) (e : D.expr Pos.marked) : A.expr Pos.marked Bindl Errors.raise_spanned_error "Internal error: Error on empty found in incorrect place when compiling using the --avoid_exception option." (Pos.get_position e) +let rec translate_scope_vardefinition ctx expr: A.expr Pos.marked Bindlib.box = + match expr with + + | D.ErrorOnEmpty arg, pos_expr -> + begin + (* ~> match [| arg |] with None -> raise NoValueProvided | Some x -> x *) + let pos_arg = Pos.get_position arg in + let x = A.Var.make ("result", pos_arg) in + let arg = translate_expr ctx arg in + + let tau = (D.TAny, pos_arg) in + + let e3 = + A.make_abs + (Array.of_list [ x ]) + (let+ v = Bindlib.box_var x in (v, pos_arg)) + pos_arg [ tau ] pos_arg + and e1 = arg + and e2 = + A.make_abs + (Array.of_list [ x ]) + (Bindlib.box @@ (A.ERaise A.NoValueProvided, pos_expr)) + pos_arg [ tau ] pos_arg + in + + A.make_matchopt e1 e2 e3 + end + + | D.EApp((D.EOp (D.Unop (D.Log (le, l))), pos_log), [e']), pos -> + + let+ e' = translate_scope_vardefinition ctx e' in + A.EApp((A.EOp (D.Unop (D.Log (le, l))), pos_log), [e']), pos + + | (expr, pos) -> + + Errors.raise_spanned_error (Printf.sprintf "Internal error: Found unexpected expression when compiling an expression using the --avoid_exception option. ''Full'' term: %s" (D.show_expr expr)) pos + + let translate_scope_let (ctx: ctx) (s: D.scope_let) : ctx * A.expr Pos.marked Bindlib.box = match s with { @@ -263,29 +301,8 @@ let translate_scope_let (ctx: ctx) (s: D.scope_let) : ctx * A.expr Pos.marked Bi let same_pos e' = Pos.same_pos_as e' expr in match kind, typ, expr with - | ScopeVarDefinition, _typ, (D.ErrorOnEmpty arg, _pos) -> begin - (* ~> match [| arg |] with None -> raise NoValueProvided | Some x -> x *) - let pos = Pos.get_position arg in - let x = A.Var.make ("result", pos) in - let arg = translate_expr ctx arg in - - let tau = (D.TAny, pos) in - - let e3 = - A.make_abs - (Array.of_list [ x ]) - (let+ v = Bindlib.box_var x in (v, pos)) - pos [ tau ] pos - and e1 = arg - and e2 = - A.make_abs - (Array.of_list [ x ]) - (Bindlib.box @@ same_pos @@ A.ERaise A.NoValueProvided) - pos [ tau ] pos - in - - A.make_matchopt e1 e2 e3 - end + | ScopeVarDefinition, _typ, expr -> + translate_scope_vardefinition ctx expr | Assertion, _typ, expr -> begin let pos = Pos.get_position expr in let x = A.Var.make ("result", pos) in @@ -332,7 +349,7 @@ let translate_scope_let (ctx: ctx) (s: D.scope_let) : ctx * A.expr Pos.marked Bi - | kind, _typ, _expr -> + | kind, _typ, (expr, pos) -> let kind_s = match kind with | ScopeVarDefinition -> "ScopeVarDefinition" @@ -341,8 +358,25 @@ let translate_scope_let (ctx: ctx) (s: D.scope_let) : ctx * A.expr Pos.marked Bi | DestructuringInputStruct -> "DestructuringInputStruct" | DestructuringSubScopeResults -> "DestructuringSubScopeResults" | CallingSubScope -> "CallingSubScope" in + + let expr_s = match expr with + | EVar _ -> "EVar" + | ETuple _ -> "ETuple" + | ETupleAccess _ -> "ETupleAccess" + | EInj _ -> "EInj" + | EMatch _ -> "EMatch" + | EArray _ -> "EArray" + | ELit _ -> "ELit" + | EAbs _ -> "EAbs" + | EApp _ -> "EApp" + | EAssert _ -> "EAssert" + | EOp _ -> "EOp" + | EDefault _ -> "EDefault" + | EIfThenElse _ -> "EIfThenElse" + | ErrorOnEmpty _ -> "ErrorOnEmpty" + in - Errors.raise_spanned_error (Printf.sprintf "Internal error: Found %s different to Error on empty at the toplevel when compiling using the --avoid_exception option." kind_s) (Pos.get_position expr) + Errors.raise_spanned_error (Printf.sprintf "Internal error: Found unexpected %s when compiling an expression containing %s using the --avoid_exception option. ''Full'' term: %s" kind_s expr_s (D.show_expr expr)) pos in let is_pure = match kind with @@ -391,7 +425,7 @@ match s with { ListLabels.fold_left acc ~init:result ~f:(fun (body: (A.expr * Pos.t) Bindlib.box) ((v, pos), tau, e) -> - A.make_let_in (D.VarMap.find v ctx).var (tau, pos) e body + A.make_let_in (D.VarMap.find v ctx2).var (tau, pos) e body ) in @@ -414,7 +448,7 @@ let translate_program (prgm : D.program) : A.program = {expr; var=new_var; is_pure=true} ) ctx in - let new_n = (D.VarMap.find n env).var in + let new_n = A.Var.make (Bindlib.name_of n, Pos.no_pos) in let new_e = translate_scope_body env e in let new_acc = (new_n, Bindlib.unbox new_e) :: acc in diff --git a/compiler/utils/dune b/compiler/utils/dune index 2d1789a0..10ebee56 100644 --- a/compiler/utils/dune +++ b/compiler/utils/dune @@ -1,7 +1,8 @@ (library (name utils) (public_name catala.utils) - (libraries cmdliner ANSITerminal re)) + (libraries cmdliner ANSITerminal re) + (preprocess (pps ppx_deriving.show))) (documentation (package catala) diff --git a/compiler/utils/pos.ml b/compiler/utils/pos.ml index f45a98d3..d7d96823 100644 --- a/compiler/utils/pos.ml +++ b/compiler/utils/pos.ml @@ -12,7 +12,8 @@ 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 } +type t = { code_pos : Lexing.position * Lexing.position [@opaque]; law_pos : string list } +[@@deriving show] let from_lpos (p : Lexing.position * Lexing.position) : t = { code_pos = p; law_pos = [] } @@ -168,6 +169,7 @@ let retrieve_loc_text (pos : t) : string = with Sys_error _ -> "Location:" ^ to_string pos type 'a marked = 'a * t +[@@deriving show] let no_pos : t = let zero_pos = diff --git a/compiler/utils/pos.mli b/compiler/utils/pos.mli index b1f3d519..6864c788 100644 --- a/compiler/utils/pos.mli +++ b/compiler/utils/pos.mli @@ -15,6 +15,7 @@ (** Source code position *) type t +[@@deriving show] (** 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 *) @@ -59,6 +60,7 @@ val retrieve_loc_text : t -> string (**{2 AST markings}*) type 'a marked = 'a * t +[@@deriving show] (** Everything related to the source code should keep its position stored, to improve error messages *) val no_pos : t diff --git a/default.nix b/default.nix index 8ba3c127..72fbc477 100644 --- a/default.nix +++ b/default.nix @@ -18,6 +18,7 @@ , js_of_ocaml-ppx , camomile , cppo +, ppx_deriving , menhirLib ? null #for nixos-unstable compatibility. }: @@ -49,6 +50,8 @@ buildDunePackage rec { camomile cppo + ppx_deriving + unionfind bindlib ] ++ (if isNull menhirLib then [ ] else [ menhirLib ]);