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. *)
|
|
|
|
|
2020-11-23 11:22:47 +03:00
|
|
|
module Pos = Utils.Pos
|
2020-12-05 20:12:53 +03:00
|
|
|
module Uid = Utils.Uid
|
2020-11-23 11:22:47 +03:00
|
|
|
|
2020-11-23 18:12:45 +03:00
|
|
|
type typ =
|
|
|
|
| TBool
|
|
|
|
| TUnit
|
2020-11-24 13:27:23 +03:00
|
|
|
| TInt
|
2020-12-09 14:20:20 +03:00
|
|
|
| TRat
|
2020-11-23 18:12:45 +03:00
|
|
|
| TTuple of typ Pos.marked list
|
2020-12-03 22:11:41 +03:00
|
|
|
| TEnum of typ Pos.marked list
|
2020-11-23 18:12:45 +03:00
|
|
|
| TArrow of typ Pos.marked * typ Pos.marked
|
2020-11-22 22:56:27 +03:00
|
|
|
|
2020-12-09 14:20:20 +03:00
|
|
|
type lit = LBool of bool | LEmptyError | LInt of Int64.t | LRat of Q.t | LUnit
|
2020-11-24 13:27:23 +03:00
|
|
|
|
|
|
|
type binop = And | Or | Add | Sub | Mult | Div | Lt | Lte | Gt | Gte | Eq | Neq
|
|
|
|
|
2020-12-09 13:23:03 +03:00
|
|
|
type unop = Not | Minus | ErrorOnEmpty
|
2020-11-24 13:27:23 +03:00
|
|
|
|
|
|
|
type operator = Binop of binop | Unop of unop
|
2020-11-22 22:56:27 +03:00
|
|
|
|
|
|
|
type expr =
|
2020-11-27 20:36:38 +03:00
|
|
|
| EVar of expr Bindlib.var Pos.marked
|
2020-12-05 20:12:53 +03:00
|
|
|
| ETuple of (expr Pos.marked * Uid.MarkedString.info option) list
|
|
|
|
(** The [MarkedString.info] is the former struct field name*)
|
|
|
|
| ETupleAccess of expr Pos.marked * int * Uid.MarkedString.info option
|
|
|
|
(** The [MarkedString.info] is the former struct field name*)
|
|
|
|
| EInj of expr Pos.marked * int * Uid.MarkedString.info * typ Pos.marked list
|
|
|
|
(** The [MarkedString.info] is the former enum case name *)
|
|
|
|
| EMatch of expr Pos.marked * (expr Pos.marked * Uid.MarkedString.info) list
|
|
|
|
(** The [MarkedString.info] is the former enum case name *)
|
2020-11-22 22:56:27 +03:00
|
|
|
| ELit of lit
|
2020-11-27 20:36:38 +03:00
|
|
|
| EAbs of Pos.t * (expr, expr Pos.marked) Bindlib.mbinder * typ Pos.marked list
|
2020-11-24 12:28:39 +03:00
|
|
|
| EApp of expr Pos.marked * expr Pos.marked list
|
2020-11-24 13:27:23 +03:00
|
|
|
| EOp of operator
|
2020-11-22 22:56:27 +03:00
|
|
|
| EDefault of expr Pos.marked * expr Pos.marked * expr Pos.marked list
|
2020-11-24 00:26:26 +03:00
|
|
|
| EIfThenElse of expr Pos.marked * expr Pos.marked * expr Pos.marked
|
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 =
|
2020-11-24 12:28:39 +03:00
|
|
|
Bindlib.box_apply (fun b -> (EAbs (pos_binder, b, 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)
|
|
|
|
(e2 : expr Pos.marked Bindlib.box) : expr Pos.marked Bindlib.box =
|
2020-11-26 15:38:42 +03:00
|
|
|
Bindlib.box_apply2
|
2020-11-27 20:36:38 +03:00
|
|
|
(fun e u -> (EApp (e, u), Pos.get_position (Bindlib.unbox e2)))
|
|
|
|
(make_abs
|
|
|
|
(Array.of_list [ x ])
|
|
|
|
e2
|
|
|
|
(Pos.get_position (Bindlib.unbox e2))
|
|
|
|
[ tau ]
|
|
|
|
(Pos.get_position (Bindlib.unbox e2)))
|
2020-11-26 15:38:42 +03:00
|
|
|
(Bindlib.box_list [ e1 ])
|
2020-11-25 20:00:34 +03:00
|
|
|
|
2020-11-22 22:56:27 +03:00
|
|
|
type binder = (expr, expr Pos.marked) Bindlib.binder
|