wip (compiling but can't compile catala program without internal errors)

instrumentation of Dcalc.expr to show internals representation

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
+  | TTuple of typ Pos.marked list * (struct_name [@opaque]) option
-  | TEnum of typ Pos.marked list * enum_name
+  | 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
+  | EVar of (expr Bindlib.var [@opaque]) Pos.marked
-  | ETuple of expr Pos.marked list * struct_name option
+  | ETuple of expr Pos.marked list * (struct_name [@opaque]) option
-  | ETupleAccess of expr Pos.marked * int * struct_name option * typ Pos.marked list
+  | ETupleAccess of expr Pos.marked * int * (struct_name [@opaque]) option * typ Pos.marked list
-  | EInj of expr Pos.marked * int * enum_name * 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
+  | EMatch of expr Pos.marked * expr Pos.marked list * (enum_name [@opaque])
   | EArray of expr Pos.marked list
-  | ELit of lit
+  | ELit of (lit [@opaque])
-  | EAbs of (expr, expr Pos.marked) Bindlib.mbinder Pos.marked * typ Pos.marked list
+  | EAbs of ((expr, expr Pos.marked) Bindlib.mbinder [@opaque]) Pos.marked * typ Pos.marked list
   | EApp of expr Pos.marked * expr Pos.marked list
   | EAssert of expr Pos.marked
   | EOp of operator
   | 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
 

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
 

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)

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
+    | ScopeVarDefinition, _typ, expr -> 
-      (* ~> match [| arg |] with None -> raise NoValueProvided | Some x -> x *)
+      translate_scope_vardefinition ctx expr
-      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
     | 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

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)

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 =

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

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 ]);