catala/src/catala/default_calculus/ast.ml

136 lines
4.2 KiB
OCaml
Raw Normal View History

(* 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
module Uid = Utils.Uid
2020-11-23 11:22:47 +03:00
2020-12-14 20:09:38 +03:00
(** Abstract syntax tree for the default calculus *)
(** {1 Abstract syntax tree} *)
2020-12-10 13:35:56 +03:00
type typ_lit = TBool | TUnit | TInt | TRat | TMoney | TDate | TDuration
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
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-12-10 13:35:56 +03:00
type date = ODate.Unix.t
2020-12-09 16:51:22 +03:00
2020-12-10 16:00:00 +03:00
type duration = Z.t
2020-12-10 13:35:56 +03:00
type lit =
| LBool of bool
| LEmptyError
| LInt of Z.t
| LRat of Q.t
| LMoney of Z.t
| LUnit
| LDate of date
| LDuration of duration
type op_kind =
| KInt
| KRat
| KMoney
| KDate
| KDuration (** All ops don't have a Kdate and KDuration *)
2020-12-09 16:51:22 +03:00
type binop =
| And
| Or
| 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-11 12:51:46 +03:00
type log_entry = VarDef | BeginCall | EndCall
type unop =
| Not
| Minus of op_kind
| ErrorOnEmpty
| Log of log_entry * Utils.Uid.MarkedString.info list
type operator = Binop of binop | Unop of unop
2020-12-14 20:09:38 +03:00
(** The expressions use the {{:https://lepigre.fr/ocaml-bindlib/} Bindlib} library, based on
higher-order abstract syntax*)
type expr =
2020-11-27 20:36:38 +03:00
| EVar of expr Bindlib.var Pos.marked
| 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 *)
| 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
| 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
2020-11-24 00:26:26 +03:00
| EIfThenElse of expr Pos.marked * expr Pos.marked * expr Pos.marked
2020-12-14 20:09:38 +03:00
(** {1 Variable helpers} *)
module Var = struct
2020-11-27 20:36:38 +03:00
type t = expr Bindlib.var
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)
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-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 =
Bindlib.box_apply (fun b -> (EAbs (pos_binder, b, taus), pos)) (Bindlib.bind_mvar xs e)
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-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 =
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)))
(Bindlib.box_list [ e1 ])
2020-11-25 20:00:34 +03:00
type binder = (expr, expr Pos.marked) Bindlib.binder