2022-11-28 18:23: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 :
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 . * )
open Shared_ast
open Ast
let expr ctx env e =
(* The typer takes care of disambiguating: this consists in: - ensuring
[ EAbs . tys ] doesn't contain any [ TAny ] - [ EDStructAccess . name_opt ] is always
[ Some ] * )
(* Intermediate unboxings are fine since the last [untype] will rebox in
depth * )
2022-12-13 18:06:36 +03:00
Typing . check_expr ~ leave_unresolved : false ctx ~ env ( Expr . unbox e )
2022-11-28 18:23:27 +03:00
let rule ctx env rule =
let env =
match rule . rule_parameter with
| None -> env
2023-02-28 16:40:05 +03:00
| Some ( vars_and_types , _ ) ->
ListLabels . fold_right vars_and_types ~ init : env ~ f : ( fun ( ( v , _ ) , t ) ->
2023-02-22 14:11:42 +03:00
Typing . Env . add_var v t )
2022-11-28 18:23:27 +03:00
in
(* Note: we could use the known rule type here to direct typing. We choose not
to because it shouldn't be needed for disambiguation , and we prefer to
focus on local type errors first . * )
{
rule with
rule_just = expr ctx env rule . rule_just ;
rule_cons = expr ctx env rule . rule_cons ;
}
let scope ctx env scope =
let env = Typing . Env . open_scope scope . scope_uid env in
let scope_defs =
2023-04-18 11:31:44 +03:00
ScopeDef . Map . map
2022-11-28 18:23:27 +03:00
( fun def ->
let scope_def_rules =
(* Note: ordering in file order might be better for error reporting ?
When we gather errors , the ordering could be done afterwards ,
though * )
RuleName . Map . map ( rule ctx env ) def . scope_def_rules
in
{ def with scope_def_rules } )
scope . scope_defs
in
2023-04-28 15:15:43 +03:00
let scope_assertions =
AssertionName . Map . map ( expr ctx env ) scope . scope_assertions
in
2022-11-28 18:23:27 +03:00
{ scope with scope_defs ; scope_assertions }
let program prg =
2023-08-31 17:54:45 +03:00
(* Caution: this environment building code is very similar to that in
scopelang / ast . ml . Any edits should probably be reflected . * )
2023-08-10 17:52:39 +03:00
let base_typing_env prg =
2023-08-31 17:54:45 +03:00
let env = Typing . Env . empty prg . program_ctx in
2023-08-10 17:52:39 +03:00
let env =
TopdefName . Map . fold
( fun name ( _ e , ty ) env -> Typing . Env . add_toplevel_var name ty env )
2023-08-31 17:54:45 +03:00
prg . program_topdefs env
2023-08-10 17:52:39 +03:00
in
let env =
ScopeName . Map . fold
( fun scope_name scope env ->
let vars =
ScopeDef . Map . fold
( fun var def vars ->
match var with
2023-11-03 19:15:55 +03:00
| Var ( v , _ states ) ->
ScopeVar . Map . add v def . scope_def_typ vars
| SubScopeVar _ ->
vars )
2023-08-10 17:52:39 +03:00
scope . scope_defs ScopeVar . Map . empty
in
2023-11-03 19:15:55 +03:00
(* at this stage, rule resolution and the corresponding encapsulation into default terms hasn't taken place, so input and output variables don't need different typing *)
Typing . Env . add_scope scope_name ~ vars ~ in_vars : vars env )
2023-08-10 17:52:39 +03:00
prg . program_scopes env
in
env
in
let rec build_typing_env prg =
ModuleName . Map . fold
( fun modname prg ->
Typing . Env . add_module modname ~ module_env : ( build_typing_env prg ) )
prg . program_modules ( base_typing_env prg )
in
2023-02-08 18:55:07 +03:00
let env =
2023-08-10 17:52:39 +03:00
ModuleName . Map . fold
( fun modname prg ->
Typing . Env . add_module modname ~ module_env : ( build_typing_env prg ) )
prg . program_modules ( base_typing_env prg )
2023-02-08 18:55:07 +03:00
in
2023-02-13 17:00:23 +03:00
let program_topdefs =
2023-02-08 18:55:07 +03:00
TopdefName . Map . map
2023-05-11 18:39:38 +03:00
( function
| Some e , ty ->
Some ( Expr . unbox ( expr prg . program_ctx env ( Expr . box e ) ) ) , ty
| None , ty -> None , ty )
2023-02-13 17:00:23 +03:00
prg . program_topdefs
2023-02-08 18:55:07 +03:00
in
2022-11-28 18:23:27 +03:00
let program_scopes =
ScopeName . Map . map ( scope prg . program_ctx env ) prg . program_scopes
in
2023-02-13 17:00:23 +03:00
{ prg with program_topdefs ; program_scopes }