mirror of
https://github.com/CatalaLang/catala.git
synced 2024-11-08 07:51:43 +03:00
Slowly connecting dots, missing a translation
This commit is contained in:
Denis Merigoux
parent
444d0bdf32
commit
b21737194f
@ -18,7 +18,7 @@ module Errors = Utils.Errors
|
||||
(** The optional argument subdef allows to choose between differents uids in case the expression is
|
||||
a redefinition of a subvariable *)
|
||||
|
||||
let translate_binop (op : Surface.Ast.binop) : Dcalc.Ast.binop =
|
||||
let translate_binop (op : Ast.binop) : Dcalc.Ast.binop =
|
||||
match op with
|
||||
| And -> And
|
||||
| Or -> Or
|
||||
@ -33,12 +33,11 @@ let translate_binop (op : Surface.Ast.binop) : Dcalc.Ast.binop =
|
||||
| Eq -> Eq
|
||||
| Neq -> Neq
|
||||
|
||||
let translate_unop (op : Surface.Ast.unop) : Dcalc.Ast.unop =
|
||||
match op with Not -> Not | Minus -> Minus
|
||||
let translate_unop (op : Ast.unop) : Dcalc.Ast.unop = match op with Not -> Not | Minus -> Minus
|
||||
|
||||
let rec translate_expr (scope : Scopelang.Ast.ScopeName.t) (def_key : Ast.ScopeDef.t option)
|
||||
(ctxt : Name_resolution.context) ((expr, pos) : Surface.Ast.expression Pos.marked) :
|
||||
Scopelang.Ast.expr Pos.marked =
|
||||
let rec translate_expr (scope : Scopelang.Ast.ScopeName.t)
|
||||
(def_key : Desugared.Ast.ScopeDef.t option) (ctxt : Name_resolution.context)
|
||||
((expr, pos) : Ast.expression Pos.marked) : Scopelang.Ast.expr Pos.marked =
|
||||
let scope_ctxt = Scopelang.Ast.ScopeMap.find scope ctxt.scopes in
|
||||
let rec_helper = translate_expr scope def_key ctxt in
|
||||
match expr with
|
||||
@ -67,17 +66,17 @@ let rec translate_expr (scope : Scopelang.Ast.ScopeName.t) (def_key : Ast.ScopeD
|
||||
(* first we check whether this is a local var, then we resort to scope-wide variables *)
|
||||
match def_key with
|
||||
| Some def_key -> (
|
||||
let def_ctxt = Ast.ScopeDefMap.find def_key scope_ctxt.definitions in
|
||||
match Ast.IdentMap.find_opt x def_ctxt.var_idmap with
|
||||
let def_ctxt = Desugared.Ast.ScopeDefMap.find def_key scope_ctxt.definitions in
|
||||
match Desugared.Ast.IdentMap.find_opt x def_ctxt.var_idmap with
|
||||
| None -> (
|
||||
match Ast.IdentMap.find_opt x scope_ctxt.var_idmap with
|
||||
match Desugared.Ast.IdentMap.find_opt x scope_ctxt.var_idmap with
|
||||
| Some uid -> (Scopelang.Ast.ELocation (ScopeVar (uid, pos)), pos)
|
||||
| None ->
|
||||
Name_resolution.raise_unknown_identifier "for a\n local or scope-wide variable"
|
||||
(x, pos) )
|
||||
| Some uid -> (Scopelang.Ast.EVar uid, pos) )
|
||||
| None -> (
|
||||
match Ast.IdentMap.find_opt x scope_ctxt.var_idmap with
|
||||
match Desugared.Ast.IdentMap.find_opt x scope_ctxt.var_idmap with
|
||||
| Some uid -> (Scopelang.Ast.ELocation (ScopeVar (uid, pos)), pos)
|
||||
| None -> Name_resolution.raise_unknown_identifier "for a scope-wide variable" (x, pos) )
|
||||
)
|
||||
@ -114,10 +113,9 @@ let merge_conditions (precond : Scopelang.Ast.expr Pos.marked option)
|
||||
| None, None -> (Scopelang.Ast.ELit (Dcalc.Ast.LBool true), default_pos)
|
||||
|
||||
let process_default (ctxt : Name_resolution.context) (scope : Scopelang.Ast.ScopeName.t)
|
||||
(def_key : Ast.ScopeDef.t) (param_uid : Scopelang.Ast.Var.t option)
|
||||
(precond : Scopelang.Ast.expr Pos.marked option)
|
||||
(just : Surface.Ast.expression Pos.marked option) (cons : Surface.Ast.expression Pos.marked) :
|
||||
Ast.rule =
|
||||
(def_key : Desugared.Ast.ScopeDef.t) (param_uid : Scopelang.Ast.Var.t option)
|
||||
(precond : Scopelang.Ast.expr Pos.marked option) (just : Ast.expression Pos.marked option)
|
||||
(cons : Ast.expression Pos.marked) : Desugared.Ast.rule =
|
||||
let just =
|
||||
match just with
|
||||
| Some just -> Some (translate_expr scope (Some def_key) ctxt just)
|
||||
@ -130,23 +128,23 @@ let process_default (ctxt : Name_resolution.context) (scope : Scopelang.Ast.Scop
|
||||
|
||||
(* Process a definition *)
|
||||
let process_def (precond : Scopelang.Ast.expr Pos.marked option)
|
||||
(scope_uid : Scopelang.Ast.ScopeName.t) (ctxt : Name_resolution.context) (prgm : Ast.program)
|
||||
(def : Surface.Ast.definition) : Ast.program =
|
||||
let scope : Ast.scope = Scopelang.Ast.ScopeMap.find scope_uid prgm in
|
||||
(scope_uid : Scopelang.Ast.ScopeName.t) (ctxt : Name_resolution.context)
|
||||
(prgm : Desugared.Ast.program) (def : Ast.definition) : Desugared.Ast.program =
|
||||
let scope : Desugared.Ast.scope = Scopelang.Ast.ScopeMap.find scope_uid prgm in
|
||||
let scope_ctxt = Scopelang.Ast.ScopeMap.find scope_uid ctxt.scopes in
|
||||
let default_pos = Pos.get_position def.definition_expr in
|
||||
let param_uid (def_uid : Ast.ScopeDef.t) : Scopelang.Ast.Var.t option =
|
||||
let param_uid (def_uid : Desugared.Ast.ScopeDef.t) : Scopelang.Ast.Var.t option =
|
||||
match def.definition_parameter with
|
||||
| None -> None
|
||||
| Some param ->
|
||||
let def_ctxt = Ast.ScopeDefMap.find def_uid scope_ctxt.definitions in
|
||||
Some (Ast.IdentMap.find (Pos.unmark param) def_ctxt.var_idmap)
|
||||
let def_ctxt = Desugared.Ast.ScopeDefMap.find def_uid scope_ctxt.definitions in
|
||||
Some (Desugared.Ast.IdentMap.find (Pos.unmark param) def_ctxt.var_idmap)
|
||||
in
|
||||
let def_key =
|
||||
match Pos.unmark def.definition_name with
|
||||
| [ x ] ->
|
||||
let x_uid = Name_resolution.get_var_uid scope_uid ctxt x in
|
||||
Ast.ScopeDef.Var x_uid
|
||||
Desugared.Ast.ScopeDef.Var x_uid
|
||||
| [ y; x ] ->
|
||||
let subscope_uid : Scopelang.Ast.SubScopeName.t =
|
||||
Name_resolution.get_subscope_uid scope_uid ctxt y
|
||||
@ -155,82 +153,78 @@ let process_def (precond : Scopelang.Ast.expr Pos.marked option)
|
||||
Scopelang.Ast.SubScopeMap.find subscope_uid scope_ctxt.sub_scopes
|
||||
in
|
||||
let x_uid = Name_resolution.get_var_uid subscope_real_uid ctxt x in
|
||||
Ast.ScopeDef.SubScopeVar (subscope_uid, x_uid)
|
||||
Desugared.Ast.ScopeDef.SubScopeVar (subscope_uid, x_uid)
|
||||
| _ -> Errors.raise_spanned_error "Structs are not handled yet" default_pos
|
||||
in
|
||||
let scope_updated =
|
||||
let x_def =
|
||||
match Ast.ScopeDefMap.find_opt def_key scope.scope_defs with
|
||||
match Desugared.Ast.ScopeDefMap.find_opt def_key scope.scope_defs with
|
||||
| Some def -> def
|
||||
| None -> [ Ast.empty_def default_pos (Option.is_some (param_uid def_key)) ]
|
||||
| None -> [ Desugared.Ast.empty_def default_pos (Option.is_some (param_uid def_key)) ]
|
||||
in
|
||||
let x_def =
|
||||
process_default ctxt scope_uid def_key (param_uid def_key) precond def.definition_condition
|
||||
def.definition_expr
|
||||
:: x_def
|
||||
in
|
||||
{ scope with scope_defs = Ast.ScopeDefMap.add def_key x_def scope.scope_defs }
|
||||
{ scope with scope_defs = Desugared.Ast.ScopeDefMap.add def_key x_def scope.scope_defs }
|
||||
in
|
||||
Scopelang.Ast.ScopeMap.add scope_uid scope_updated prgm
|
||||
|
||||
(** Process a rule from the surface language *)
|
||||
let process_rule (precond : Scopelang.Ast.expr Pos.marked option)
|
||||
(scope : Scopelang.Ast.ScopeName.t) (ctxt : Name_resolution.context) (prgm : Ast.program)
|
||||
(rule : Surface.Ast.rule) : Ast.program =
|
||||
let _consequence_expr =
|
||||
Surface.Ast.Literal (Surface.Ast.Bool (Pos.unmark rule.rule_consequence))
|
||||
(scope : Scopelang.Ast.ScopeName.t) (ctxt : Name_resolution.context)
|
||||
(prgm : Desugared.Ast.program) (rule : Ast.rule) : Desugared.Ast.program =
|
||||
let consequence_expr = Ast.Literal (Ast.Bool (Pos.unmark rule.rule_consequence)) in
|
||||
let def =
|
||||
{
|
||||
Ast.definition_name = rule.rule_name;
|
||||
Ast.definition_parameter = rule.rule_parameter;
|
||||
Ast.definition_condition = rule.rule_condition;
|
||||
Ast.definition_expr = (consequence_expr, Pos.get_position rule.rule_consequence);
|
||||
}
|
||||
in
|
||||
(* let def = { definition_name = rule.rule_name; definition_parameter = rule.rule_parameter;
|
||||
definition_condition = rule.rule_condition; definition_expr = (consequence_expr,
|
||||
Pos.get_position rule.rule_consequence); } in *)
|
||||
process_def precond scope ctxt prgm (assert false (* def *))
|
||||
process_def precond scope ctxt prgm def
|
||||
|
||||
let process_scope_use_item (precond : Surface.Ast.expression Pos.marked option)
|
||||
(scope : Scopelang.Ast.ScopeName.t) (ctxt : Name_resolution.context) (prgm : Ast.program)
|
||||
(item : Surface.Ast.scope_use_item Pos.marked) : Ast.program =
|
||||
let process_scope_use_item (precond : Ast.expression Pos.marked option)
|
||||
(scope : Scopelang.Ast.ScopeName.t) (ctxt : Name_resolution.context)
|
||||
(prgm : Desugared.Ast.program) (item : Ast.scope_use_item Pos.marked) : Desugared.Ast.program =
|
||||
let precond = Option.map (translate_expr scope None ctxt) precond in
|
||||
match Pos.unmark item with
|
||||
| Surface.Ast.Rule rule -> process_rule precond scope ctxt prgm rule
|
||||
| Surface.Ast.Definition def -> process_def precond scope ctxt prgm def
|
||||
| Ast.Rule rule -> process_rule precond scope ctxt prgm rule
|
||||
| Ast.Definition def -> process_def precond scope ctxt prgm def
|
||||
| _ -> prgm
|
||||
|
||||
let process_scope_use (ctxt : Name_resolution.context) (prgm : Ast.program)
|
||||
(use : Surface.Ast.scope_use) : Ast.program =
|
||||
let process_scope_use (ctxt : Name_resolution.context) (prgm : Desugared.Ast.program)
|
||||
(use : Ast.scope_use) : Desugared.Ast.program =
|
||||
let name = fst use.scope_use_name in
|
||||
let scope_uid = Ast.IdentMap.find name ctxt.scope_idmap in
|
||||
let scope_uid = Desugared.Ast.IdentMap.find name ctxt.scope_idmap in
|
||||
(* Make sure the scope exists *)
|
||||
let prgm =
|
||||
match Scopelang.Ast.ScopeMap.find_opt scope_uid prgm with
|
||||
| Some _ -> prgm
|
||||
| None -> Scopelang.Ast.ScopeMap.add scope_uid (Ast.empty_scope scope_uid) prgm
|
||||
| None -> Scopelang.Ast.ScopeMap.add scope_uid (Desugared.Ast.empty_scope scope_uid) prgm
|
||||
in
|
||||
let cond =
|
||||
match use.scope_use_condition with
|
||||
| Some _expr ->
|
||||
let untyped_term = assert false (* expr_to_lambda scope_uid None ctxt expr *) in
|
||||
Some untyped_term
|
||||
| None -> None
|
||||
in
|
||||
List.fold_left (process_scope_use_item cond scope_uid ctxt) prgm use.scope_use_items
|
||||
let precond = use.scope_use_condition in
|
||||
List.fold_left (process_scope_use_item precond scope_uid ctxt) prgm use.scope_use_items
|
||||
|
||||
(** Scopes processing *)
|
||||
let translate_program_to_scope (ctxt : Name_resolution.context) (prgm : Surface.Ast.program) :
|
||||
Ast.program =
|
||||
let desugar_program (ctxt : Name_resolution.context) (prgm : Ast.program) : Desugared.Ast.program =
|
||||
let empty_prgm = Scopelang.Ast.ScopeMap.empty in
|
||||
let processer_article_item (prgm : Ast.program) (item : Surface.Ast.law_article_item) :
|
||||
Ast.program =
|
||||
let processer_article_item (prgm : Desugared.Ast.program) (item : Ast.law_article_item) :
|
||||
Desugared.Ast.program =
|
||||
match item with
|
||||
| CodeBlock (block, _) ->
|
||||
List.fold_left
|
||||
(fun prgm item ->
|
||||
match Pos.unmark item with
|
||||
| Surface.Ast.ScopeUse use -> process_scope_use ctxt prgm use
|
||||
| Ast.ScopeUse use -> process_scope_use ctxt prgm use
|
||||
| _ -> prgm)
|
||||
prgm block
|
||||
| _ -> prgm
|
||||
in
|
||||
let rec processer_structure (prgm : Ast.program) (item : Surface.Ast.law_structure) : Ast.program
|
||||
=
|
||||
let rec processer_structure (prgm : Desugared.Ast.program) (item : Ast.law_structure) :
|
||||
Desugared.Ast.program =
|
||||
match item with
|
||||
| LawHeading (_, children) ->
|
||||
List.fold_left (fun prgm child -> processer_structure prgm child) prgm children
|
||||
@ -240,7 +234,8 @@ let translate_program_to_scope (ctxt : Name_resolution.context) (prgm : Surface.
|
||||
| IntermediateText _ -> prgm
|
||||
in
|
||||
|
||||
let processer_item (prgm : Ast.program) (item : Surface.Ast.program_item) : Ast.program =
|
||||
let processer_item (prgm : Desugared.Ast.program) (item : Ast.program_item) :
|
||||
Desugared.Ast.program =
|
||||
match item with LawStructure s -> processer_structure prgm s
|
||||
in
|
||||
|
||||
@ -1,6 +1,6 @@
|
||||
(library
|
||||
(name surface)
|
||||
(libraries utils menhirLib sedlex re)
|
||||
(libraries utils menhirLib sedlex re desugared scopelang)
|
||||
(public_name catala.surface)
|
||||
(preprocess
|
||||
(pps sedlex.ppx)))
|
||||
|
||||
@ -22,21 +22,21 @@ type ident = string
|
||||
|
||||
type typ = Dcalc.Ast.typ
|
||||
|
||||
type def_context = { var_idmap : Scopelang.Ast.Var.t Ast.IdentMap.t }
|
||||
type def_context = { var_idmap : Scopelang.Ast.Var.t Desugared.Ast.IdentMap.t }
|
||||
(** Inside a definition, local variables can be introduced by functions arguments or pattern
|
||||
matching *)
|
||||
|
||||
type scope_context = {
|
||||
var_idmap : Scopelang.Ast.ScopeVar.t Ast.IdentMap.t;
|
||||
sub_scopes_idmap : Scopelang.Ast.SubScopeName.t Ast.IdentMap.t;
|
||||
var_idmap : Scopelang.Ast.ScopeVar.t Desugared.Ast.IdentMap.t;
|
||||
sub_scopes_idmap : Scopelang.Ast.SubScopeName.t Desugared.Ast.IdentMap.t;
|
||||
sub_scopes : Scopelang.Ast.ScopeName.t Scopelang.Ast.SubScopeMap.t;
|
||||
definitions : def_context Ast.ScopeDefMap.t;
|
||||
definitions : def_context Desugared.Ast.ScopeDefMap.t;
|
||||
(** Contains the local variables in all the definitions *)
|
||||
}
|
||||
(** Inside a scope, we distinguish between the variables and the subscopes. *)
|
||||
|
||||
type context = {
|
||||
scope_idmap : Scopelang.Ast.ScopeName.t Ast.IdentMap.t;
|
||||
scope_idmap : Scopelang.Ast.ScopeName.t Desugared.Ast.IdentMap.t;
|
||||
scopes : scope_context Scopelang.Ast.ScopeMap.t;
|
||||
var_typs : typ Pos.marked Scopelang.Ast.ScopeVarMap.t;
|
||||
}
|
||||
@ -55,11 +55,11 @@ let get_var_typ (ctxt : context) (uid : Scopelang.Ast.ScopeVar.t) : typ Pos.mark
|
||||
|
||||
(** Process a subscope declaration *)
|
||||
let process_subscope_decl (scope : Scopelang.Ast.ScopeName.t) (ctxt : context)
|
||||
(decl : Surface.Ast.scope_decl_context_scope) : context =
|
||||
(decl : Ast.scope_decl_context_scope) : context =
|
||||
let name, name_pos = decl.scope_decl_context_scope_name in
|
||||
let subscope, s_pos = decl.scope_decl_context_scope_sub_scope in
|
||||
let scope_ctxt = Scopelang.Ast.ScopeMap.find scope ctxt.scopes in
|
||||
match Ast.IdentMap.find_opt subscope scope_ctxt.sub_scopes_idmap with
|
||||
match Desugared.Ast.IdentMap.find_opt subscope scope_ctxt.sub_scopes_idmap with
|
||||
| Some use ->
|
||||
Errors.raise_multispanned_error "subscope name already used"
|
||||
[
|
||||
@ -69,48 +69,47 @@ let process_subscope_decl (scope : Scopelang.Ast.ScopeName.t) (ctxt : context)
|
||||
| None ->
|
||||
let sub_scope_uid = Scopelang.Ast.SubScopeName.fresh (name, name_pos) in
|
||||
let original_subscope_uid =
|
||||
match Ast.IdentMap.find_opt subscope ctxt.scope_idmap with
|
||||
match Desugared.Ast.IdentMap.find_opt subscope ctxt.scope_idmap with
|
||||
| None -> raise_unknown_identifier "for a scope" (subscope, s_pos)
|
||||
| Some id -> id
|
||||
in
|
||||
let scope_ctxt =
|
||||
{
|
||||
scope_ctxt with
|
||||
sub_scopes_idmap = Ast.IdentMap.add name sub_scope_uid scope_ctxt.sub_scopes_idmap;
|
||||
sub_scopes_idmap =
|
||||
Desugared.Ast.IdentMap.add name sub_scope_uid scope_ctxt.sub_scopes_idmap;
|
||||
sub_scopes =
|
||||
Scopelang.Ast.SubScopeMap.add sub_scope_uid original_subscope_uid scope_ctxt.sub_scopes;
|
||||
}
|
||||
in
|
||||
{ ctxt with scopes = Scopelang.Ast.ScopeMap.add scope scope_ctxt ctxt.scopes }
|
||||
|
||||
let process_base_typ ((typ, typ_pos) : Surface.Ast.base_typ Pos.marked) : Dcalc.Ast.typ Pos.marked =
|
||||
let process_base_typ ((typ, typ_pos) : Ast.base_typ Pos.marked) : Dcalc.Ast.typ Pos.marked =
|
||||
match typ with
|
||||
| Surface.Ast.Condition -> (Dcalc.Ast.TBool, typ_pos)
|
||||
| Surface.Ast.Data (Surface.Ast.Collection _) ->
|
||||
raise_unsupported_feature "collection type" typ_pos
|
||||
| Surface.Ast.Data (Surface.Ast.Optional _) -> raise_unsupported_feature "option type" typ_pos
|
||||
| Surface.Ast.Data (Surface.Ast.Primitive prim) -> (
|
||||
| Ast.Condition -> (Dcalc.Ast.TBool, typ_pos)
|
||||
| Ast.Data (Ast.Collection _) -> raise_unsupported_feature "collection type" typ_pos
|
||||
| Ast.Data (Ast.Optional _) -> raise_unsupported_feature "option type" typ_pos
|
||||
| Ast.Data (Ast.Primitive prim) -> (
|
||||
match prim with
|
||||
| Surface.Ast.Integer | Surface.Ast.Decimal | Surface.Ast.Money | Surface.Ast.Date ->
|
||||
assert false
|
||||
| Surface.Ast.Boolean -> (Dcalc.Ast.TBool, typ_pos)
|
||||
| Surface.Ast.Text -> raise_unsupported_feature "text type" typ_pos
|
||||
| Surface.Ast.Named _ -> raise_unsupported_feature "struct or enum types" typ_pos )
|
||||
| Ast.Integer | Ast.Decimal | Ast.Money | Ast.Date -> assert false
|
||||
| Ast.Boolean -> (Dcalc.Ast.TBool, typ_pos)
|
||||
| Ast.Text -> raise_unsupported_feature "text type" typ_pos
|
||||
| Ast.Named _ -> raise_unsupported_feature "struct or enum types" typ_pos )
|
||||
|
||||
let process_type ((typ, typ_pos) : Surface.Ast.typ Pos.marked) : Dcalc.Ast.typ Pos.marked =
|
||||
let process_type ((typ, typ_pos) : Ast.typ Pos.marked) : Dcalc.Ast.typ Pos.marked =
|
||||
match typ with
|
||||
| Surface.Ast.Base base_typ -> process_base_typ (base_typ, typ_pos)
|
||||
| Surface.Ast.Func { arg_typ; return_typ } ->
|
||||
| Ast.Base base_typ -> process_base_typ (base_typ, typ_pos)
|
||||
| Ast.Func { arg_typ; return_typ } ->
|
||||
(Dcalc.Ast.TArrow (process_base_typ arg_typ, process_base_typ return_typ), typ_pos)
|
||||
|
||||
(** Process data declaration *)
|
||||
let process_data_decl (scope : Scopelang.Ast.ScopeName.t) (ctxt : context)
|
||||
(decl : Surface.Ast.scope_decl_context_data) : context =
|
||||
(decl : Ast.scope_decl_context_data) : context =
|
||||
(* First check the type of the context data *)
|
||||
let data_typ = process_type decl.scope_decl_context_item_typ in
|
||||
let name, pos = decl.scope_decl_context_item_name in
|
||||
let scope_ctxt = Scopelang.Ast.ScopeMap.find scope ctxt.scopes in
|
||||
match Ast.IdentMap.find_opt name scope_ctxt.var_idmap with
|
||||
match Desugared.Ast.IdentMap.find_opt name scope_ctxt.var_idmap with
|
||||
| Some use ->
|
||||
Errors.raise_multispanned_error "var name already used"
|
||||
[
|
||||
@ -120,7 +119,7 @@ let process_data_decl (scope : Scopelang.Ast.ScopeName.t) (ctxt : context)
|
||||
| None ->
|
||||
let uid = Scopelang.Ast.ScopeVar.fresh (name, pos) in
|
||||
let scope_ctxt =
|
||||
{ scope_ctxt with var_idmap = Ast.IdentMap.add name uid scope_ctxt.var_idmap }
|
||||
{ scope_ctxt with var_idmap = Desugared.Ast.IdentMap.add name uid scope_ctxt.var_idmap }
|
||||
in
|
||||
{
|
||||
ctxt with
|
||||
@ -130,30 +129,33 @@ let process_data_decl (scope : Scopelang.Ast.ScopeName.t) (ctxt : context)
|
||||
|
||||
(** Process an item declaration *)
|
||||
let process_item_decl (scope : Scopelang.Ast.ScopeName.t) (ctxt : context)
|
||||
(decl : Surface.Ast.scope_decl_context_item) : context =
|
||||
(decl : Ast.scope_decl_context_item) : context =
|
||||
match decl with
|
||||
| Surface.Ast.ContextData data_decl -> process_data_decl scope ctxt data_decl
|
||||
| Surface.Ast.ContextScope sub_decl -> process_subscope_decl scope ctxt sub_decl
|
||||
| Ast.ContextData data_decl -> process_data_decl scope ctxt data_decl
|
||||
| Ast.ContextScope sub_decl -> process_subscope_decl scope ctxt sub_decl
|
||||
|
||||
(** Adds a binding to the context *)
|
||||
let add_def_local_var (ctxt : context) (scope_uid : Scopelang.Ast.ScopeName.t)
|
||||
(def_uid : Ast.ScopeDef.t) (name : ident Pos.marked) : context =
|
||||
(def_uid : Desugared.Ast.ScopeDef.t) (name : ident Pos.marked) : context =
|
||||
let scope_ctxt = Scopelang.Ast.ScopeMap.find scope_uid ctxt.scopes in
|
||||
let def_ctx = Ast.ScopeDefMap.find def_uid scope_ctxt.definitions in
|
||||
let def_ctx = Desugared.Ast.ScopeDefMap.find def_uid scope_ctxt.definitions in
|
||||
let local_var_uid = Scopelang.Ast.Var.make name in
|
||||
let def_ctx =
|
||||
{ var_idmap = Ast.IdentMap.add (Pos.unmark name) local_var_uid def_ctx.var_idmap }
|
||||
{ var_idmap = Desugared.Ast.IdentMap.add (Pos.unmark name) local_var_uid def_ctx.var_idmap }
|
||||
in
|
||||
let scope_ctxt =
|
||||
{ scope_ctxt with definitions = Ast.ScopeDefMap.add def_uid def_ctx scope_ctxt.definitions }
|
||||
{
|
||||
scope_ctxt with
|
||||
definitions = Desugared.Ast.ScopeDefMap.add def_uid def_ctx scope_ctxt.definitions;
|
||||
}
|
||||
in
|
||||
{ ctxt with scopes = Scopelang.Ast.ScopeMap.add scope_uid scope_ctxt ctxt.scopes }
|
||||
|
||||
(** Process a scope declaration *)
|
||||
let process_scope_decl (ctxt : context) (decl : Surface.Ast.scope_decl) : context =
|
||||
let process_scope_decl (ctxt : context) (decl : Ast.scope_decl) : context =
|
||||
let name, pos = decl.scope_decl_name in
|
||||
(* Checks if the name is already used *)
|
||||
match Ast.IdentMap.find_opt name ctxt.scope_idmap with
|
||||
match Desugared.Ast.IdentMap.find_opt name ctxt.scope_idmap with
|
||||
| Some use ->
|
||||
Errors.raise_multispanned_error "scope name already used"
|
||||
[
|
||||
@ -165,13 +167,13 @@ let process_scope_decl (ctxt : context) (decl : Surface.Ast.scope_decl) : contex
|
||||
let ctxt =
|
||||
{
|
||||
ctxt with
|
||||
scope_idmap = Ast.IdentMap.add name scope_uid ctxt.scope_idmap;
|
||||
scope_idmap = Desugared.Ast.IdentMap.add name scope_uid ctxt.scope_idmap;
|
||||
scopes =
|
||||
Scopelang.Ast.ScopeMap.add scope_uid
|
||||
{
|
||||
var_idmap = Ast.IdentMap.empty;
|
||||
sub_scopes_idmap = Ast.IdentMap.empty;
|
||||
definitions = Ast.ScopeDefMap.empty;
|
||||
var_idmap = Desugared.Ast.IdentMap.empty;
|
||||
sub_scopes_idmap = Desugared.Ast.IdentMap.empty;
|
||||
definitions = Desugared.Ast.ScopeDefMap.empty;
|
||||
sub_scopes = Scopelang.Ast.SubScopeMap.empty;
|
||||
}
|
||||
ctxt.scopes;
|
||||
@ -182,51 +184,52 @@ let process_scope_decl (ctxt : context) (decl : Surface.Ast.scope_decl) : contex
|
||||
ctxt decl.scope_decl_context
|
||||
|
||||
let qident_to_scope_def (ctxt : context) (scope_uid : Scopelang.Ast.ScopeName.t)
|
||||
(id : Surface.Ast.qident Pos.marked) : Ast.ScopeDef.t =
|
||||
(id : Ast.qident Pos.marked) : Desugared.Ast.ScopeDef.t =
|
||||
let scope_ctxt = Scopelang.Ast.ScopeMap.find scope_uid ctxt.scopes in
|
||||
match Pos.unmark id with
|
||||
| [ x ] -> (
|
||||
match Ast.IdentMap.find_opt (Pos.unmark x) scope_ctxt.var_idmap with
|
||||
match Desugared.Ast.IdentMap.find_opt (Pos.unmark x) scope_ctxt.var_idmap with
|
||||
| None -> raise_unknown_identifier "for a var of the scope" x
|
||||
| Some id -> Ast.ScopeDef.Var id )
|
||||
| Some id -> Desugared.Ast.ScopeDef.Var id )
|
||||
| [ s; x ] -> (
|
||||
let sub_scope_uid =
|
||||
match Ast.IdentMap.find_opt (Pos.unmark s) scope_ctxt.sub_scopes_idmap with
|
||||
match Desugared.Ast.IdentMap.find_opt (Pos.unmark s) scope_ctxt.sub_scopes_idmap with
|
||||
| None -> raise_unknown_identifier "for a subscope of this scope" s
|
||||
| Some id -> id
|
||||
in
|
||||
let real_sub_scope_uid = Scopelang.Ast.SubScopeMap.find sub_scope_uid scope_ctxt.sub_scopes in
|
||||
let sub_scope_ctx = Scopelang.Ast.ScopeMap.find real_sub_scope_uid ctxt.scopes in
|
||||
match Ast.IdentMap.find_opt (Pos.unmark x) sub_scope_ctx.var_idmap with
|
||||
match Desugared.Ast.IdentMap.find_opt (Pos.unmark x) sub_scope_ctx.var_idmap with
|
||||
| None -> raise_unknown_identifier "for a var of this subscope" x
|
||||
| Some id -> Ast.ScopeDef.SubScopeVar (sub_scope_uid, id) )
|
||||
| Some id -> Desugared.Ast.ScopeDef.SubScopeVar (sub_scope_uid, id) )
|
||||
| _ -> raise_unsupported_feature "wrong qident" (Pos.get_position id)
|
||||
|
||||
let process_scope_use (ctxt : context) (use : Surface.Ast.scope_use) : context =
|
||||
let process_scope_use (ctxt : context) (use : Ast.scope_use) : context =
|
||||
let scope_uid =
|
||||
match Ast.IdentMap.find_opt (Pos.unmark use.scope_use_name) ctxt.scope_idmap with
|
||||
match Desugared.Ast.IdentMap.find_opt (Pos.unmark use.scope_use_name) ctxt.scope_idmap with
|
||||
| None -> raise_unknown_identifier "for a scope" use.scope_use_name
|
||||
| Some id -> id
|
||||
in
|
||||
List.fold_left
|
||||
(fun ctxt use_item ->
|
||||
match Pos.unmark use_item with
|
||||
| Surface.Ast.Definition def ->
|
||||
| Ast.Definition def ->
|
||||
let scope_ctxt = Scopelang.Ast.ScopeMap.find scope_uid ctxt.scopes in
|
||||
let def_uid = qident_to_scope_def ctxt scope_uid def.definition_name in
|
||||
let def_ctxt =
|
||||
{
|
||||
var_idmap =
|
||||
( match def.definition_parameter with
|
||||
| None -> Ast.IdentMap.empty
|
||||
| None -> Desugared.Ast.IdentMap.empty
|
||||
| Some param ->
|
||||
Ast.IdentMap.singleton (Pos.unmark param) (Scopelang.Ast.Var.make param) );
|
||||
Desugared.Ast.IdentMap.singleton (Pos.unmark param)
|
||||
(Scopelang.Ast.Var.make param) );
|
||||
}
|
||||
in
|
||||
let scope_ctxt =
|
||||
{
|
||||
scope_ctxt with
|
||||
definitions = Ast.ScopeDefMap.add def_uid def_ctxt scope_ctxt.definitions;
|
||||
definitions = Desugared.Ast.ScopeDefMap.add def_uid def_ctxt scope_ctxt.definitions;
|
||||
}
|
||||
in
|
||||
{ ctxt with scopes = Scopelang.Ast.ScopeMap.add scope_uid scope_ctxt ctxt.scopes }
|
||||
@ -234,50 +237,49 @@ let process_scope_use (ctxt : context) (use : Surface.Ast.scope_use) : context =
|
||||
ctxt use.scope_use_items
|
||||
|
||||
(** Process a code item : for now it only handles scope decls *)
|
||||
let process_use_item (ctxt : context) (item : Surface.Ast.code_item Pos.marked) : context =
|
||||
let process_use_item (ctxt : context) (item : Ast.code_item Pos.marked) : context =
|
||||
match Pos.unmark item with
|
||||
| ScopeDecl _ -> ctxt
|
||||
| ScopeUse use -> process_scope_use ctxt use
|
||||
| _ -> raise_unsupported_feature "item not supported" (Pos.get_position item)
|
||||
|
||||
(** Process a code item : for now it only handles scope decls *)
|
||||
let process_decl_item (ctxt : context) (item : Surface.Ast.code_item Pos.marked) : context =
|
||||
let process_decl_item (ctxt : context) (item : Ast.code_item Pos.marked) : context =
|
||||
match Pos.unmark item with ScopeDecl decl -> process_scope_decl ctxt decl | _ -> ctxt
|
||||
|
||||
(** Process a code block *)
|
||||
let process_code_block (ctxt : context) (block : Surface.Ast.code_block)
|
||||
(process_item : context -> Surface.Ast.code_item Pos.marked -> context) : context =
|
||||
let process_code_block (ctxt : context) (block : Ast.code_block)
|
||||
(process_item : context -> Ast.code_item Pos.marked -> context) : context =
|
||||
List.fold_left (fun ctxt decl -> process_item ctxt decl) ctxt block
|
||||
|
||||
(** Process a program item *)
|
||||
let process_law_article_item (ctxt : context) (item : Surface.Ast.law_article_item)
|
||||
(process_item : context -> Surface.Ast.code_item Pos.marked -> context) : context =
|
||||
let process_law_article_item (ctxt : context) (item : Ast.law_article_item)
|
||||
(process_item : context -> Ast.code_item Pos.marked -> context) : context =
|
||||
match item with CodeBlock (block, _) -> process_code_block ctxt block process_item | _ -> ctxt
|
||||
|
||||
(** Process a law structure *)
|
||||
let rec process_law_structure (ctxt : context) (s : Surface.Ast.law_structure)
|
||||
(process_item : context -> Surface.Ast.code_item Pos.marked -> context) : context =
|
||||
let rec process_law_structure (ctxt : context) (s : Ast.law_structure)
|
||||
(process_item : context -> Ast.code_item Pos.marked -> context) : context =
|
||||
match s with
|
||||
| Surface.Ast.LawHeading (_, children) ->
|
||||
| Ast.LawHeading (_, children) ->
|
||||
List.fold_left (fun ctxt child -> process_law_structure ctxt child process_item) ctxt children
|
||||
| Surface.Ast.LawArticle (_, children) ->
|
||||
| Ast.LawArticle (_, children) ->
|
||||
List.fold_left
|
||||
(fun ctxt child -> process_law_article_item ctxt child process_item)
|
||||
ctxt children
|
||||
| Surface.Ast.MetadataBlock (b, c) ->
|
||||
process_law_article_item ctxt (Surface.Ast.CodeBlock (b, c)) process_item
|
||||
| Surface.Ast.IntermediateText _ -> ctxt
|
||||
| Ast.MetadataBlock (b, c) -> process_law_article_item ctxt (Ast.CodeBlock (b, c)) process_item
|
||||
| Ast.IntermediateText _ -> ctxt
|
||||
|
||||
(** Process a program item *)
|
||||
let process_program_item (ctxt : context) (item : Surface.Ast.program_item)
|
||||
(process_item : context -> Surface.Ast.code_item Pos.marked -> context) : context =
|
||||
match item with Surface.Ast.LawStructure s -> process_law_structure ctxt s process_item
|
||||
let process_program_item (ctxt : context) (item : Ast.program_item)
|
||||
(process_item : context -> Ast.code_item Pos.marked -> context) : context =
|
||||
match item with Ast.LawStructure s -> process_law_structure ctxt s process_item
|
||||
|
||||
(** Derive the context from metadata, in two passes *)
|
||||
let form_context (prgm : Surface.Ast.program) : context =
|
||||
let form_context (prgm : Ast.program) : context =
|
||||
let empty_ctxt =
|
||||
{
|
||||
scope_idmap = Ast.IdentMap.empty;
|
||||
scope_idmap = Desugared.Ast.IdentMap.empty;
|
||||
scopes = Scopelang.Ast.ScopeMap.empty;
|
||||
var_typs = Scopelang.Ast.ScopeVarMap.empty;
|
||||
}
|
||||
@ -295,7 +297,7 @@ let form_context (prgm : Surface.Ast.program) : context =
|
||||
let get_var_uid (scope_uid : Scopelang.Ast.ScopeName.t) (ctxt : context)
|
||||
((x, pos) : ident Pos.marked) : Scopelang.Ast.ScopeVar.t =
|
||||
let scope = Scopelang.Ast.ScopeMap.find scope_uid ctxt.scopes in
|
||||
match Ast.IdentMap.find_opt x scope.var_idmap with
|
||||
match Desugared.Ast.IdentMap.find_opt x scope.var_idmap with
|
||||
| None -> raise_unknown_identifier "for a var of this scope" (x, pos)
|
||||
| Some uid -> uid
|
||||
|
||||
@ -303,7 +305,7 @@ let get_var_uid (scope_uid : Scopelang.Ast.ScopeName.t) (ctxt : context)
|
||||
let get_subscope_uid (scope_uid : Scopelang.Ast.ScopeName.t) (ctxt : context)
|
||||
((y, pos) : ident Pos.marked) : Scopelang.Ast.SubScopeName.t =
|
||||
let scope = Scopelang.Ast.ScopeMap.find scope_uid ctxt.scopes in
|
||||
match Ast.IdentMap.find_opt y scope.sub_scopes_idmap with
|
||||
match Desugared.Ast.IdentMap.find_opt y scope.sub_scopes_idmap with
|
||||
| None -> raise_unknown_identifier "for a subscope of this scope" (y, pos)
|
||||
| Some sub_uid -> sub_uid
|
||||
|
||||
@ -311,14 +313,14 @@ let get_subscope_uid (scope_uid : Scopelang.Ast.ScopeName.t) (ctxt : context)
|
||||
let belongs_to (ctxt : context) (uid : Scopelang.Ast.ScopeVar.t)
|
||||
(scope_uid : Scopelang.Ast.ScopeName.t) : bool =
|
||||
let scope = Scopelang.Ast.ScopeMap.find scope_uid ctxt.scopes in
|
||||
Ast.IdentMap.exists
|
||||
Desugared.Ast.IdentMap.exists
|
||||
(fun _ var_uid -> Scopelang.Ast.ScopeVar.compare uid var_uid = 0)
|
||||
scope.var_idmap
|
||||
|
||||
let get_def_typ (ctxt : context) (def : Ast.ScopeDef.t) : typ Pos.marked =
|
||||
let get_def_typ (ctxt : context) (def : Desugared.Ast.ScopeDef.t) : typ Pos.marked =
|
||||
match def with
|
||||
| Ast.ScopeDef.SubScopeVar (_, x)
|
||||
| Desugared.Ast.ScopeDef.SubScopeVar (_, x)
|
||||
(* we don't need to look at the subscope prefix because [x] is already the uid referring back to
|
||||
the original subscope *)
|
||||
| Ast.ScopeDef.Var x ->
|
||||
| Desugared.Ast.ScopeDef.Var x ->
|
||||
Scopelang.Ast.ScopeVarMap.find x ctxt.var_typs
|
||||
@ -92,43 +92,21 @@ let check_for_cycle (g : ScopeDependencies.t) : unit =
|
||||
])
|
||||
scc))
|
||||
|
||||
let build_scope_dependencies (scope : Ast.scope) (ctxt : Name_resolution.context) :
|
||||
ScopeDependencies.t =
|
||||
let g = ScopeDependencies.empty in
|
||||
let scope_uid = scope.scope_uid in
|
||||
(* Add all the vertices to the graph *)
|
||||
let scope_ctxt = Scopelang.Ast.ScopeMap.find scope_uid ctxt.scopes in
|
||||
let g =
|
||||
Ast.IdentMap.fold
|
||||
(fun _ (v : Scopelang.Ast.ScopeVar.t) g -> ScopeDependencies.add_vertex g (Vertex.Var v))
|
||||
scope_ctxt.var_idmap g
|
||||
in
|
||||
let g =
|
||||
Ast.IdentMap.fold
|
||||
(fun _ (v : Scopelang.Ast.SubScopeName.t) g ->
|
||||
ScopeDependencies.add_vertex g (Vertex.SubScope v))
|
||||
scope_ctxt.sub_scopes_idmap g
|
||||
in
|
||||
let g =
|
||||
Ast.ScopeDefMap.fold
|
||||
(fun def_key _def g ->
|
||||
let fv = assert false (* Dcalc.Ast.term_fv def *) in
|
||||
Ast.ScopeDefSet.fold
|
||||
(fun fv_def g ->
|
||||
match (def_key, fv_def) with
|
||||
| Ast.ScopeDef.Var defined, Ast.ScopeDef.Var used ->
|
||||
(* simple case *)
|
||||
ScopeDependencies.add_edge g (Vertex.Var used) (Vertex.Var defined)
|
||||
| Ast.ScopeDef.SubScopeVar (defined, _), Ast.ScopeDef.Var used ->
|
||||
(* here we are defining the input of a subscope using a var of the scope *)
|
||||
ScopeDependencies.add_edge g (Vertex.Var used) (Vertex.SubScope defined)
|
||||
| Ast.ScopeDef.SubScopeVar (defined, _), Ast.ScopeDef.SubScopeVar (used, _) ->
|
||||
(* here we are defining the input of a scope with the output of another subscope *)
|
||||
ScopeDependencies.add_edge g (Vertex.SubScope used) (Vertex.SubScope defined)
|
||||
| Ast.ScopeDef.Var defined, Ast.ScopeDef.SubScopeVar (used, _) ->
|
||||
(* finally we define a scope var with the output of a subscope *)
|
||||
ScopeDependencies.add_edge g (Vertex.SubScope used) (Vertex.Var defined))
|
||||
fv g)
|
||||
scope.scope_defs g
|
||||
in
|
||||
g
|
||||
(* let build_scope_dependencies (scope : Ast.scope) (ctxt : Name_resolution.context) :
|
||||
ScopeDependencies.t = let g = ScopeDependencies.empty in let scope_uid = scope.scope_uid in (*
|
||||
Add all the vertices to the graph *) let scope_ctxt = Scopelang.Ast.ScopeMap.find scope_uid
|
||||
ctxt.scopes in let g = Ast.IdentMap.fold (fun _ (v : Scopelang.Ast.ScopeVar.t) g ->
|
||||
ScopeDependencies.add_vertex g (Vertex.Var v)) scope_ctxt.var_idmap g in let g =
|
||||
Ast.IdentMap.fold (fun _ (v : Scopelang.Ast.SubScopeName.t) g -> ScopeDependencies.add_vertex g
|
||||
(Vertex.SubScope v)) scope_ctxt.sub_scopes_idmap g in let g = Ast.ScopeDefMap.fold (fun def_key
|
||||
_def g -> let fv = assert false (* Dcalc.Ast.term_fv def *) in Ast.ScopeDefSet.fold (fun fv_def g
|
||||
-> match (def_key, fv_def) with | Ast.ScopeDef.Var defined, Ast.ScopeDef.Var used -> (* simple
|
||||
case *) ScopeDependencies.add_edge g (Vertex.Var used) (Vertex.Var defined) |
|
||||
Ast.ScopeDef.SubScopeVar (defined, _), Ast.ScopeDef.Var used -> (* here we are defining the input
|
||||
of a subscope using a var of the scope *) ScopeDependencies.add_edge g (Vertex.Var used)
|
||||
(Vertex.SubScope defined) | Ast.ScopeDef.SubScopeVar (defined, _), Ast.ScopeDef.SubScopeVar
|
||||
(used, _) -> (* here we are defining the input of a scope with the output of another subscope *)
|
||||
ScopeDependencies.add_edge g (Vertex.SubScope used) (Vertex.SubScope defined) | Ast.ScopeDef.Var
|
||||
defined, Ast.ScopeDef.SubScopeVar (used, _) -> (* finally we define a scope var with the output
|
||||
of a subscope *) ScopeDependencies.add_edge g (Vertex.SubScope used) (Vertex.Var defined)) fv g)
|
||||
scope.scope_defs g in g *)
|
||||
|
||||
15
src/catala/desugared/desugared_to_scope.ml
Normal file
15
src/catala/desugared/desugared_to_scope.ml
Normal file
@ -0,0 +1,15 @@
|
||||
(* 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. *)
|
||||
|
||||
let translate_program (_pgrm : Ast.program) : Scopelang.Ast.program = assert false
|
||||
@ -1,4 +1,4 @@
|
||||
(library
|
||||
(name desugared)
|
||||
(public_name catala.desugared)
|
||||
(libraries utils dcalc scopelang ocamlgraph surface))
|
||||
(libraries utils dcalc scopelang ocamlgraph))
|
||||
|
||||
@ -96,7 +96,7 @@ let driver (source_file : string) (debug : bool) (unstyled : bool) (wrap_weaved_
|
||||
close_out oc;
|
||||
0
|
||||
| Cli.Run ->
|
||||
let ctxt = Desugared.Name_resolution.form_context program in
|
||||
let ctxt = Surface.Name_resolution.form_context program in
|
||||
let scope_uid =
|
||||
match ex_scope with
|
||||
| None -> Errors.raise_error "No scope was provided for execution."
|
||||
@ -107,20 +107,10 @@ let driver (source_file : string) (debug : bool) (unstyled : bool) (wrap_weaved_
|
||||
(Printf.sprintf "There is no scope %s inside the program." name)
|
||||
| Some uid -> uid )
|
||||
in
|
||||
let prgm = Desugared.Desugaring.translate_program_to_scope ctxt program in
|
||||
let _scope =
|
||||
match Scopelang.Ast.ScopeMap.find_opt scope_uid prgm with
|
||||
| Some scope -> scope
|
||||
| None ->
|
||||
let scope_info = Scopelang.Ast.ScopeName.get_info scope_uid in
|
||||
Errors.raise_spanned_error
|
||||
(Printf.sprintf
|
||||
"Scope %s does not define anything, and therefore cannot be executed"
|
||||
(Utils.Pos.unmark scope_info))
|
||||
(Utils.Pos.get_position scope_info)
|
||||
in
|
||||
(* let exec_ctxt = Desugared.Interpreter.execute_scope ctxt prgm scope in
|
||||
Lambda_interpreter.ExecContext.iter (fun context_key value -> Cli.result_print
|
||||
let prgm = Surface.Desugaring.desugar_program ctxt program in
|
||||
let prgm = Desugared.Desugared_to_scope.translate_program prgm in
|
||||
let _prgm = Scopelang.Scope_to_dcalc.translate_program prgm scope_uid in
|
||||
(* Lambda_interpreter.ExecContext.iter (fun context_key value -> Cli.result_print
|
||||
(Printf.sprintf "%s -> %s" (Lambda_interpreter.ExecContextKey.format_t context_key)
|
||||
(Format_lambda.print_term ((value, Pos.no_pos), TDummy)))) exec_ctxt; *)
|
||||
0
|
||||
|
||||
@ -125,6 +125,7 @@ let translate_rules (p : scope_ctx) (ctx : ctx) (rules : Ast.rule list) :
|
||||
|
||||
let translate_scope_decl (p : scope_ctx) (sigma : Ast.scope_decl) : Dcalc.Ast.expr Pos.marked =
|
||||
let ctx = empty_ctx in
|
||||
(* TODO: compute dependency order! *)
|
||||
let rules, ctx = translate_rules p ctx sigma.scope_decl_rules in
|
||||
let scope_variables = Ast.ScopeVarMap.bindings ctx.scope_vars in
|
||||
let pos_sigma = Pos.get_position (Ast.ScopeName.get_info sigma.scope_decl_name) in
|
||||
@ -144,3 +145,13 @@ let translate_scope_decl (p : scope_ctx) (sigma : Ast.scope_decl) : Dcalc.Ast.ex
|
||||
in
|
||||
let func_acc = Bindlib.unbox (Bindlib.bind_var hole_var func_acc) in
|
||||
Bindlib.subst func_acc (return_exp, pos_sigma)
|
||||
|
||||
let translate_program (prgm : Ast.program) (_top_level_scope : Ast.ScopeName.t) :
|
||||
Dcalc.Ast.expr Pos.marked =
|
||||
let _scope_ctx =
|
||||
Ast.ScopeMap.map
|
||||
(fun scope -> Ast.Var.make (Ast.ScopeName.get_info scope.Ast.scope_decl_name))
|
||||
prgm
|
||||
in
|
||||
(* TODO: compute dependency order! *)
|
||||
assert false
|
||||
|
||||
Loading…
Reference in New Issue
Block a user