2022-08-16 18:09:26 +03:00
|
|
|
(* This file is part of the Catala compiler, a specification language for tax
|
|
|
|
and social benefits computation rules. Copyright (C) 2020-2022 Inria,
|
|
|
|
contributor: Denis Merigoux <denis.merigoux@inria.fr>, Alain Delaët-Tixeuil
|
|
|
|
<alain.delaet--tixeuil@inria.fr>, Louis Gesbert <louis.gesbert@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. *)
|
|
|
|
|
2022-08-22 19:53:30 +03:00
|
|
|
open Definitions
|
|
|
|
|
2024-02-09 18:48:02 +03:00
|
|
|
let map_decl_ctx ~f ctx =
|
|
|
|
{
|
|
|
|
ctx with
|
|
|
|
ctx_enums = EnumName.Map.map (EnumConstructor.Map.map f) ctx.ctx_enums;
|
|
|
|
ctx_structs = StructName.Map.map (StructField.Map.map f) ctx.ctx_structs;
|
|
|
|
ctx_topdefs = TopdefName.Map.map f ctx.ctx_topdefs;
|
|
|
|
}
|
|
|
|
|
|
|
|
let map_exprs ?typ ~f ~varf { code_items; decl_ctx; lang; module_name } =
|
|
|
|
let boxed_prg =
|
|
|
|
Bindlib.box_apply
|
|
|
|
(fun code_items ->
|
|
|
|
let decl_ctx =
|
|
|
|
match typ with None -> decl_ctx | Some f -> map_decl_ctx ~f decl_ctx
|
|
|
|
in
|
|
|
|
{ code_items; decl_ctx; lang; module_name })
|
|
|
|
(Scope.map_exprs ?typ ~f ~varf code_items)
|
|
|
|
in
|
|
|
|
assert (Bindlib.is_closed boxed_prg);
|
|
|
|
Bindlib.unbox boxed_prg
|
|
|
|
|
|
|
|
let fold_left ~f ~init { code_items; _ } =
|
|
|
|
fst @@ BoundList.fold_left ~f:(fun acc e _ -> f acc e) ~init code_items
|
2022-08-22 19:53:30 +03:00
|
|
|
|
2024-02-09 18:48:02 +03:00
|
|
|
let fold_exprs ~f ~init prg = Scope.fold_exprs ~f ~init prg.code_items
|
2023-03-30 19:52:29 +03:00
|
|
|
|
2024-02-09 18:48:02 +03:00
|
|
|
let fold_right ~f ~init { code_items; _ } =
|
|
|
|
BoundList.fold_right
|
|
|
|
~f:(fun e _ acc -> f e acc)
|
|
|
|
~init:(fun () -> init)
|
|
|
|
code_items
|
2023-03-30 19:52:29 +03:00
|
|
|
|
2023-04-19 19:26:50 +03:00
|
|
|
let empty_ctx =
|
|
|
|
{
|
|
|
|
ctx_enums = EnumName.Map.empty;
|
|
|
|
ctx_structs = StructName.Map.empty;
|
|
|
|
ctx_scopes = ScopeName.Map.empty;
|
2023-08-10 17:52:39 +03:00
|
|
|
ctx_topdefs = TopdefName.Map.empty;
|
2023-11-20 18:01:06 +03:00
|
|
|
ctx_struct_fields = Ident.Map.empty;
|
|
|
|
ctx_enum_constrs = Ident.Map.empty;
|
|
|
|
ctx_scope_index = Ident.Map.empty;
|
|
|
|
ctx_modules = M ModuleName.Map.empty;
|
2023-04-19 19:26:50 +03:00
|
|
|
}
|
|
|
|
|
2023-02-13 17:00:23 +03:00
|
|
|
let get_scope_body { code_items; _ } scope =
|
2022-11-17 19:13:35 +03:00
|
|
|
match
|
2024-02-09 18:48:02 +03:00
|
|
|
BoundList.fold_left ~init:None
|
2023-01-23 14:19:36 +03:00
|
|
|
~f:(fun acc item _ ->
|
|
|
|
match item with
|
|
|
|
| ScopeDef (name, body) when ScopeName.equal scope name -> Some body
|
|
|
|
| _ -> acc)
|
2023-02-13 17:00:23 +03:00
|
|
|
code_items
|
2022-11-17 19:13:35 +03:00
|
|
|
with
|
2024-02-09 18:48:02 +03:00
|
|
|
| None, _ -> raise Not_found
|
|
|
|
| Some body, _ -> body
|
2022-11-17 19:13:35 +03:00
|
|
|
|
2023-05-17 17:15:00 +03:00
|
|
|
let untype : 'm. ('a, 'm) gexpr program -> ('a, untyped) gexpr program =
|
2024-02-09 18:48:02 +03:00
|
|
|
fun prg -> map_exprs ~f:Expr.untype ~varf:Var.translate prg
|
2022-08-17 12:49:16 +03:00
|
|
|
|
2024-02-09 18:48:02 +03:00
|
|
|
let find_scope name =
|
|
|
|
BoundList.find ~f:(function
|
|
|
|
| ScopeDef (n, body) when ScopeName.equal name n -> Some body
|
|
|
|
| _ -> None)
|
2023-03-17 13:34:52 +03:00
|
|
|
|
2022-08-17 12:49:16 +03:00
|
|
|
let to_expr p main_scope =
|
2024-02-09 18:48:02 +03:00
|
|
|
let res = Scope.unfold p.decl_ctx p.code_items main_scope in
|
2023-04-14 15:18:28 +03:00
|
|
|
Expr.Box.assert_closed (Expr.Box.lift res);
|
2023-03-17 19:20:35 +03:00
|
|
|
res
|