2020-11-22 22:56:27 +03:00
|
|
|
(* This file is part of the Catala compiler, a specification language for tax and social benefits
|
|
|
|
computation rules. Copyright (C) 2020 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. *)
|
|
|
|
|
2021-04-03 14:44:11 +03:00
|
|
|
[@@@ocaml.warning "-7-34"]
|
2021-04-03 12:49:13 +03:00
|
|
|
|
2021-01-21 23:33:04 +03:00
|
|
|
open Utils
|
2020-11-23 11:22:47 +03:00
|
|
|
|
2021-01-28 15:58:59 +03:00
|
|
|
module ScopeName : Uid.Id with type info = Uid.MarkedString.info = Uid.Make (Uid.MarkedString) ()
|
|
|
|
|
2021-01-14 02:17:24 +03:00
|
|
|
module StructName : Uid.Id with type info = Uid.MarkedString.info = Uid.Make (Uid.MarkedString) ()
|
|
|
|
|
|
|
|
module StructFieldName : Uid.Id with type info = Uid.MarkedString.info =
|
|
|
|
Uid.Make (Uid.MarkedString) ()
|
|
|
|
|
|
|
|
module StructMap : Map.S with type key = StructName.t = Map.Make (StructName)
|
|
|
|
|
|
|
|
module EnumName : Uid.Id with type info = Uid.MarkedString.info = Uid.Make (Uid.MarkedString) ()
|
|
|
|
|
|
|
|
module EnumConstructor : Uid.Id with type info = Uid.MarkedString.info =
|
|
|
|
Uid.Make (Uid.MarkedString) ()
|
|
|
|
|
|
|
|
module EnumMap : Map.S with type key = EnumName.t = Map.Make (EnumName)
|
|
|
|
|
2020-12-10 13:35:56 +03:00
|
|
|
type typ_lit = TBool | TUnit | TInt | TRat | TMoney | TDate | TDuration
|
2021-04-03 12:49:13 +03:00
|
|
|
|
2021-04-03 14:44:11 +03:00
|
|
|
type struct_name = StructName.t
|
2021-04-03 12:49:13 +03:00
|
|
|
|
2021-04-03 14:44:11 +03:00
|
|
|
type enum_name = EnumName.t
|
2020-12-09 16:51:22 +03:00
|
|
|
|
2020-11-23 18:12:45 +03:00
|
|
|
type typ =
|
2020-12-09 16:51:22 +03:00
|
|
|
| TLit of typ_lit
|
2021-04-03 12:49:13 +03:00
|
|
|
| TTuple of typ Pos.marked list * struct_name option
|
|
|
|
| TEnum of typ Pos.marked list * enum_name
|
2020-11-23 18:12:45 +03:00
|
|
|
| TArrow of typ Pos.marked * typ Pos.marked
|
2020-12-28 01:53:02 +03:00
|
|
|
| TArray of typ Pos.marked
|
2020-12-30 00:26:10 +03:00
|
|
|
| TAny
|
2021-04-03 14:44:11 +03:00
|
|
|
|
|
|
|
type date = Runtime.date
|
|
|
|
|
|
|
|
type duration = Runtime.duration
|
|
|
|
|
|
|
|
type integer = Runtime.integer
|
|
|
|
|
|
|
|
type decimal = Runtime.decimal
|
|
|
|
|
|
|
|
type money = Runtime.money
|
2020-12-10 13:35:56 +03:00
|
|
|
|
|
|
|
type lit =
|
|
|
|
| LBool of bool
|
|
|
|
| LEmptyError
|
2021-04-03 12:49:13 +03:00
|
|
|
| LInt of integer
|
|
|
|
| LRat of decimal
|
|
|
|
| LMoney of money
|
2020-12-10 13:35:56 +03:00
|
|
|
| LUnit
|
|
|
|
| LDate of date
|
|
|
|
| LDuration of duration
|
|
|
|
|
2021-02-17 12:34:47 +03:00
|
|
|
type op_kind = KInt | KRat | KMoney | KDate | KDuration
|
2020-12-09 16:51:22 +03:00
|
|
|
|
2020-12-28 01:53:02 +03:00
|
|
|
type ternop = Fold
|
|
|
|
|
2020-12-09 16:51:22 +03:00
|
|
|
type binop =
|
|
|
|
| And
|
|
|
|
| Or
|
2021-03-16 20:34:59 +03:00
|
|
|
| Xor
|
2020-12-09 16:51:22 +03:00
|
|
|
| Add of op_kind
|
|
|
|
| Sub of op_kind
|
|
|
|
| Mult of op_kind
|
|
|
|
| Div of op_kind
|
|
|
|
| Lt of op_kind
|
|
|
|
| Lte of op_kind
|
|
|
|
| Gt of op_kind
|
|
|
|
| Gte of op_kind
|
|
|
|
| Eq
|
|
|
|
| Neq
|
2020-12-28 01:53:02 +03:00
|
|
|
| Map
|
2021-07-08 17:27:46 +03:00
|
|
|
| Concat
|
2021-01-10 20:11:46 +03:00
|
|
|
| Filter
|
2020-12-09 16:51:22 +03:00
|
|
|
|
2021-04-05 20:06:32 +03:00
|
|
|
type log_entry = VarDef of typ | BeginCall | EndCall | PosRecordIfTrueBool
|
2020-12-11 12:51:46 +03:00
|
|
|
|
|
|
|
type unop =
|
|
|
|
| Not
|
|
|
|
| Minus of op_kind
|
2021-04-03 12:49:13 +03:00
|
|
|
| Log of log_entry * (Utils.Uid.MarkedString.info list[@opaque])
|
2020-12-28 01:53:02 +03:00
|
|
|
| Length
|
2021-01-04 02:13:59 +03:00
|
|
|
| IntToRat
|
2021-01-05 18:00:15 +03:00
|
|
|
| GetDay
|
|
|
|
| GetMonth
|
|
|
|
| GetYear
|
2020-11-24 13:27:23 +03:00
|
|
|
|
2020-12-28 01:53:02 +03:00
|
|
|
type operator = Ternop of ternop | Binop of binop | Unop of unop
|
2020-11-22 22:56:27 +03:00
|
|
|
|
|
|
|
type expr =
|
2021-04-03 12:49:13 +03:00
|
|
|
| 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
|
2020-12-28 01:53:02 +03:00
|
|
|
| EArray of expr Pos.marked list
|
2020-11-22 22:56:27 +03:00
|
|
|
| ELit of lit
|
2021-04-03 14:44:11 +03:00
|
|
|
| EAbs of (expr, expr Pos.marked) Bindlib.mbinder Pos.marked * typ Pos.marked list
|
2020-11-24 12:28:39 +03:00
|
|
|
| EApp of expr Pos.marked * expr Pos.marked list
|
2020-12-10 20:11:43 +03:00
|
|
|
| EAssert of expr Pos.marked
|
2020-11-24 13:27:23 +03:00
|
|
|
| EOp of operator
|
2020-12-18 17:59:15 +03:00
|
|
|
| EDefault of expr Pos.marked list * expr Pos.marked * expr Pos.marked
|
2020-11-24 00:26:26 +03:00
|
|
|
| EIfThenElse of expr Pos.marked * expr Pos.marked * expr Pos.marked
|
2021-04-03 16:07:49 +03:00
|
|
|
| ErrorOnEmpty of expr Pos.marked
|
2020-11-22 22:56:27 +03:00
|
|
|
|
2021-01-28 02:28:28 +03:00
|
|
|
type struct_ctx = (StructFieldName.t * typ Pos.marked) list StructMap.t
|
2021-01-14 02:17:24 +03:00
|
|
|
|
2021-01-28 02:28:28 +03:00
|
|
|
type enum_ctx = (EnumConstructor.t * typ Pos.marked) list EnumMap.t
|
2021-01-14 02:17:24 +03:00
|
|
|
|
|
|
|
type decl_ctx = { ctx_enums : enum_ctx; ctx_structs : struct_ctx }
|
|
|
|
|
2020-11-22 22:56:27 +03:00
|
|
|
module Var = struct
|
2020-11-27 20:36:38 +03:00
|
|
|
type t = expr Bindlib.var
|
2020-11-22 22:56:27 +03:00
|
|
|
|
2020-11-27 20:36:38 +03:00
|
|
|
let make (s : string Pos.marked) : t =
|
|
|
|
Bindlib.new_var
|
|
|
|
(fun (x : expr Bindlib.var) : expr -> EVar (x, Pos.get_position s))
|
|
|
|
(Pos.unmark s)
|
2020-11-23 20:51:06 +03:00
|
|
|
|
2020-11-22 22:56:27 +03:00
|
|
|
let compare x y = Bindlib.compare_vars x y
|
|
|
|
end
|
|
|
|
|
|
|
|
module VarMap = Map.Make (Var)
|
|
|
|
|
2020-11-27 20:36:38 +03:00
|
|
|
type vars = expr Bindlib.mvar
|
2020-11-24 17:48:57 +03:00
|
|
|
|
2020-11-27 20:36:38 +03:00
|
|
|
let make_var ((x, pos) : Var.t Pos.marked) : expr Pos.marked Bindlib.box =
|
|
|
|
Bindlib.box_apply (fun x -> (x, pos)) (Bindlib.box_var x)
|
2020-11-23 20:51:06 +03:00
|
|
|
|
2020-11-26 12:38:13 +03:00
|
|
|
let make_abs (xs : vars) (e : expr Pos.marked Bindlib.box) (pos_binder : Pos.t)
|
|
|
|
(taus : typ Pos.marked list) (pos : Pos.t) : expr Pos.marked Bindlib.box =
|
2021-04-03 12:49:13 +03:00
|
|
|
Bindlib.box_apply (fun b -> (EAbs ((b, pos_binder), taus), pos)) (Bindlib.bind_mvar xs e)
|
2020-11-23 20:51:06 +03:00
|
|
|
|
2020-11-24 12:28:39 +03:00
|
|
|
let make_app (e : expr Pos.marked Bindlib.box) (u : expr Pos.marked Bindlib.box list) (pos : Pos.t)
|
|
|
|
: expr Pos.marked Bindlib.box =
|
|
|
|
Bindlib.box_apply2 (fun e u -> (EApp (e, u), pos)) e (Bindlib.box_list u)
|
2020-11-23 20:51:06 +03:00
|
|
|
|
2020-11-27 20:36:38 +03:00
|
|
|
let make_let_in (x : Var.t) (tau : typ Pos.marked) (e1 : expr Pos.marked Bindlib.box)
|
2021-10-28 16:24:39 +03:00
|
|
|
(e2 : expr Pos.marked Bindlib.box) (pos : Pos.t) : expr Pos.marked Bindlib.box =
|
|
|
|
make_app (make_abs (Array.of_list [ x ]) e2 pos [ tau ] pos) [ e1 ] pos
|
2020-11-25 20:00:34 +03:00
|
|
|
|
2021-02-02 01:35:15 +03:00
|
|
|
let make_multiple_let_in (xs : Var.t array) (taus : typ Pos.marked list)
|
2021-10-28 16:24:39 +03:00
|
|
|
(e1 : expr Pos.marked Bindlib.box list) (e2 : expr Pos.marked Bindlib.box) (pos : Pos.t) :
|
2021-02-02 01:35:15 +03:00
|
|
|
expr Pos.marked Bindlib.box =
|
2021-10-28 16:24:39 +03:00
|
|
|
make_app (make_abs xs e2 pos taus pos) e1 pos
|
2021-02-02 01:35:15 +03:00
|
|
|
|
2020-11-22 22:56:27 +03:00
|
|
|
type binder = (expr, expr Pos.marked) Bindlib.binder
|
2021-01-28 15:58:59 +03:00
|
|
|
|
2021-03-11 18:27:57 +03:00
|
|
|
type program = { decl_ctx : decl_ctx; scopes : (ScopeName.t * Var.t * expr Pos.marked) list }
|