Permalink
Browse files

[feature] surfaceAst: create bind_ident (and use in pattern) node to …

…distinguish use or bind of ident and add directive to bind case

any pattern binding can be associated with directive,
in particular this includes lambda to enable parameter tagging
  • Loading branch information...
1 parent 3454ec0 commit 46769f16941e69a790dde5753e76941cd9853614 @OpaOnWindowsNow OpaOnWindowsNow committed Sep 8, 2011
View
12 libqmlcompil/qmlAst.ml
@@ -680,6 +680,16 @@ type simple_slicer_directive =
*)
| `sliced_expr ] (** see the description in surfaceAst *)
+type userland_public_visibility_directive = [`sync | `async ]
+type compiler_public_visibility_directive = [ `funaction ]
+type public_visibility_directive = [ userland_public_visibility_directive | compiler_public_visibility_directive]
+
+type 'a generic_visibility_directive = [ `visibility_annotation of [ `public of 'a | `private_ ] ]
+
+
+type userland_visibility_directive = userland_public_visibility_directive generic_visibility_directive
+type visibility_directive = public_visibility_directive generic_visibility_directive
+
type slicer_directive =
[ `side_annotation of [ `server
| `client
@@ -688,7 +698,7 @@ type slicer_directive =
| `prefer_client
| `prefer_both
| `both_implem ]
- | `visibility_annotation of [ `public of [`sync | `async | `funaction] | `private_ ]
+ | visibility_directive
]
(** Fun actions *)
View
2 opa/checkopacapi.ml
@@ -180,7 +180,7 @@ let stdlib acc code =
match p with
| SA.PatVar ident | SA.PatAs (_, ident) ->
if is_opacapi e
- then StringSet.add ident acc
+ then StringSet.add ident.SA.ident acc
else acc
| _ -> acc
in
View
2 opa/pass_OpaDocApi.ml
@@ -133,7 +133,7 @@ let add_code_doctype sa_code =
match fst name with
| SA.PatCoerce (n,_) -> getname n
| SA.PatVar n
- | SA.PatAs (_,n) -> Some n
+ | SA.PatAs (_,n) -> Some n.SA.ident
| _ -> None
in
match getname name with
View
21 opalang/opaPrint.ml
@@ -152,6 +152,11 @@ struct
| None -> `no_sugar
end
+type userland_visibility_directive = QmlAst.userland_visibility_directive
+type all_directives = SurfaceAst.all_directives
+
+let userland_visibilities_to_whatever ds =
+ (ds : userland_visibility_directive list :> [> all_directives] list)
class virtual ['ident] generic_printer =
object (self)
@@ -281,15 +286,16 @@ object (self)
| PatRecord (fields, rowvar) -> self#pat_record f fields rowvar
| PatAny -> pp f "_"
| PatConst c -> self#const_expr f c
- | PatVar v -> self#ident f v
+ | PatVar v -> pp f "%a %a" self#pat_directives (userland_visibilities_to_whatever v.directives) self#ident v.ident
| PatCoerce (p,ty) -> pp f "%a : %a" self#under_colon#pat p self#ty ty
- | PatAs (p,i) -> pp f "%a as %a" self#pat p self#ident i
+ | PatAs (p,i) -> pp f "%a %a as %a" self#pat_directives (userland_visibilities_to_whatever i.directives) self#pat p self#ident i.ident
+
method pat_record_binding f ((s, p) as pat) =
match p with
| PatCoerce ((PatRecord ([], _), _), (TypeRecord (TyRow ([], None)), _)), _ -> self#field f s
| _ ->
let getvar = function
- | S.PatVar v, _ -> Some v
+ | S.PatVar v, _ -> Some v.ident
| _ -> None
in
if self#is_tilde_field getvar pat
@@ -310,7 +316,7 @@ object (self)
let rowvar = if rowvar = `open_ then " ; ..." else "" in
let is_tilde_field field =
let getvar = function
- | S.PatVar v, _ -> Some v
+ | S.PatVar v, _ -> Some v.S.ident
| _ -> None
in
self#is_tilde_field getvar field
@@ -483,6 +489,11 @@ object (self)
| #all_directives,exprs, [] -> pp f "@[<2>@@%a(%a)@]" self#variant variant (list ",@ " self#reset#expr) exprs
| #all_directives,exprs, tys -> pp f "@[<2>@@%a(%a ; %a)@]" self#variant variant (list ",@ " self#reset#expr) exprs (list ",@ " self#ty) tys
+
+ method pat_directive f (v:SurfaceAst.all_directives) = pp f "@[<2>@@%a@]" self#variant v
+
+ method pat_directives f (vs:SurfaceAst.all_directives list) = pp f "%a" (Format.pp_list "@ " self#pat_directive) vs
+
method record_binding : 'dir. (string * ('ident, [< all_directives ] as 'dir) expr) pprinter = fun f ((s, e) as expr) ->
match e with
| (Directive ((`coerce : [< all_directives]),[(Record [],_)],[TypeRecord (TyRow ([],None)), _]),_) -> self#field f s
@@ -590,7 +601,7 @@ object (self)
pp f "package %s" s
method pat_binding : 'dir. ('ident pat * ('ident, [< all_directives ] as 'dir) expr) pprinter = fun f (p,e) ->
match p, e with
- | (PatVar i,_LABEL1), (Lambda (r,e),_LABEL2) -> self#lambda_binding self#ident f (i,r,e)
+ | (PatVar i,_LABEL1), (Lambda (r,e),_LABEL2) -> self#lambda_binding self#ident f (i.SurfaceAst.ident,r,e)
| _, (Directive ((`visibility_annotation `public b : [< all_directives ]),[e],_),_) -> (
match b with
| `async -> pp f "publish %a" self#pat_binding (p,e)
View
29 opalang/opaToQml.ml
@@ -107,12 +107,13 @@ struct
(s, C.P.var void),
same_pos (SA.LetIn (false,[(i, C.T.coerce (same_pos (SA.Ident void) p) (C.T.void ()))], e)) p
| SA.PatCoerce ((SA.PatVar v, l) as p, ty) ->
+ let v = v.SA.ident in
let i = next ~label "remove_coerce" in
(s, p),
(same_pos (SA.LetIn (false,[(i,C.T.coerce (SA.Ident v,l) ty)], e)) e)
| _ ->
let i = next ~label "simplify_lambda" in
- (s, same_pos (SA.PatVar i) p),
+ (s, same_pos (SA.PatVar {SA.ident=i;SA.directives=[]}) p),
(same_pos (SA.Match (same_pos (SA.Ident i) p, [(p, e)])) e)
)
) r e
@@ -128,7 +129,7 @@ struct
| None ->
match p with
| SA.PatVar a ->
- pp, (SA.Ident a, copy_label label)
+ pp, (SA.Ident a.SA.ident, copy_label label)
| SA.PatRecord (spl, rowvar) ->
if rowvar = `open_ then (
let context = OpaError.Context.annot label in
@@ -148,10 +149,10 @@ struct
let p, e = rebuild ~and_coerces map p in
p, C.T.coerce e ty
| SA.PatAs (p,i) ->
- p, (SA.Ident i, label)
+ p, (SA.Ident i.SA.ident, label)
| SA.PatAny ->
let i = next ~label "rebuild" in
- (SA.PatVar i, label), (SA.Ident i, copy_label label)
+ (SA.PatVar {SA.ident=i;directives=[]}, label), (SA.Ident i, copy_label label)
)
let remove_as ~and_coerces p e =
@@ -161,9 +162,9 @@ struct
match p with
| SA.PatAs (p, s) ->
let p,e = rebuild ~and_coerces map p in
- let map = IntMap.add label.QmlLoc.notes s map in
- let map = IntMap.add (snd p).QmlLoc.notes s map in
- (map, (s,e,p)::acc), p
+ let map = IntMap.add label.QmlLoc.notes s.SA.ident map in
+ let map = IntMap.add (snd p).QmlLoc.notes s.SA.ident map in
+ (map, (s.SA.ident,e,p)::acc), p
| SA.PatCoerce (pc, _) when and_coerces ->
let i = next ~label "remove_coerce" in
let p,e = rebuild ~and_coerces map p' in
@@ -181,7 +182,7 @@ struct
let label = snd p in
match fst p with
| SA.PatVar v ->
- [(v, SurfaceAstCons.Refresh.expr expr)]
+ [(v.SA.ident, SurfaceAstCons.Refresh.expr expr)]
| SA.PatRecord (spl, _) ->
List.concat_map
(fun (s, p) ->
@@ -195,7 +196,7 @@ struct
*)
assert false
| SA.PatAs (p, s) ->
- (s, expr) :: pattern_to_bindings expr p
+ (s.SA.ident, expr) :: pattern_to_bindings expr p
| SA.PatCoerce (p, ty) ->
let i = next ~label "pattern_to_bindings" in
SurfaceAstCons.with_same_pos p (fun () ->
@@ -396,17 +397,17 @@ struct
QA.PatConst
(make_label_from_opa_annot opa_annot, (const_expr (c, opa_annot)))
| SA.PatVar i ->
- QA.PatVar (make_label_from_opa_annot opa_annot, ident i)
+ QA.PatVar (make_label_from_opa_annot opa_annot, ident i.SA.ident)
| SA.PatCoerce (p, ty_) ->
let ty_ = ty ty_ in
let p = aux p in
QA.PatCoerce ((make_label_from_opa_annot opa_annot), p, ty_)
| SA.PatAs (p, i) ->
#<If:PATTERNS_REAL_PATAS $equals "0">
- fail p (Printf.sprintf "PatAs %s" (Arg.to_string i))
+ fail p (Printf.sprintf "PatAs %s" (Arg.to_string i.SA.ident))
#<Else>
let p = aux p in
- QA.PatAs (make_label_from_opa_annot opa_annot, p, ident i)
+ QA.PatAs (make_label_from_opa_annot opa_annot, p, ident i.SA.ident)
#<End>
in
(* Effective body of the function [pat] dealing with a whole
@@ -457,7 +458,7 @@ struct
let params =
let extract_ident (s_, p) =
match fst p with
- | SA.PatVar i -> ident i
+ | SA.PatVar i -> ident i.SA.ident
| SA.PatAny -> Ident.nextf "anonymous_lambda_arg_%s" s_
(* not equivalent but once typing is done, it doesn't matter *)
(*| SA.PatRecord [] -> fresh_ident ()*)
@@ -676,7 +677,7 @@ struct
* and a slicer annotation, you don't want to introduce an indirection *)
aux (p, C.E.coerce ~label e ty)
(* the boolean is true when we will keep this name in the future roots *)
- | SA.PatVar ident -> [(ident, false, e)]
+ | SA.PatVar ident -> [(ident.SA.ident, false, e)]
| SA.PatAny -> [(PatternUtils.next ~label "_do_", true, e)]
| _ ->
let annotate = propagate_slicer_annotation e in
View
6 opalang/opaWalk.ml
@@ -67,12 +67,12 @@ struct
let get_vars ?(acc=[]) pat =
fold (fun acc -> function
| (PatVar v,_)
- | (PatAs (_,v),_) -> v :: acc
+ | (PatAs (_,v),_) -> v.ident :: acc
| _ -> acc) acc pat
- let appears_eq equal ident pat =
+ let appears_eq equal target_ident pat =
exists (function
| (PatVar v,_)
- | (PatAs (_,v),_) -> equal v ident
+ | (PatAs (_,v),_) -> equal (v.ident) target_ident
| _ -> false) pat
let appears_str ident pat = appears_eq eq_string ident pat
let appears ident pat = appears_eq Ident.equal ident pat
View
7 opalang/surfaceAst.ml
@@ -64,6 +64,7 @@ let string_of_hash : uids -> string = Ident.stident
(**
{7 Other expressions}
*)
+type bind_directives = QmlAst.userland_visibility_directive (* TODO Move expand here *)
(**
Internal data structures.
@@ -90,6 +91,7 @@ and ('ident, 'dir) record_node = (string * ('ident, 'dir) expr) list
@param 'dir The type of directives, i.e. stuff left by the compiler for a further phase to rewrite.
*)
and ('ident, 'dir) expr = ('ident, 'dir) expr_node label
+and 'ident bind_ident = {ident :'ident ; directives : bind_directives list}
and ('ident, 'dir) expr_node =
| Apply of ('ident, 'dir) expr * ('ident, 'dir) record
(**
@@ -149,13 +151,14 @@ and ('ident, 'dir) preprocessed_db_element_node =
*)
and 'ident pat = 'ident pat_node label
+
and 'ident pat_node =
| PatRecord of 'ident pat_record_node * QmlAst.pat_rowvar
| PatAny
| PatConst of const_expr_node
- | PatVar of 'ident
+ | PatVar of 'ident bind_ident
| PatCoerce of 'ident pat * 'ident ty
- | PatAs of 'ident pat * 'ident
+ | PatAs of 'ident pat * 'ident bind_ident
and 'ident pat_record_node = (string * 'ident pat) list
View
2 opalang/surfaceAstCons.ml
@@ -169,7 +169,7 @@ struct
let false_ ?label () = coerce_name ?label (simple_record ?label "false") Opacapi.Types.bool
let bool ?label b = if b then true_ ?label () else false_ ?label ()
- let ident ?(label=w()) i = (PatVar i, c label)
+ let ident ?(label=w()) ?(directives=[]) ident = (PatVar ({ident;directives}), c label)
let var = ident
let string ?(label=w()) s = (PatConst (CString s), c label)
View
4 opalang/surfaceAstConsSig.ml
@@ -76,8 +76,8 @@ sig
val coerce_name : ?label:annot -> ident pat -> string -> ident pat
val any : ?label:annot -> unit -> ident pat
- val ident : ?label:annot -> ident -> ident pat
- val var : ?label:annot -> ident -> ident pat
+ val ident : ?label:annot -> ?directives:bind_directives list -> ident -> ident pat
+ val var : ?label:annot -> ?directives:bind_directives list -> ident -> ident pat
val string : ?label:annot -> string -> ident pat
View
22 opalang/surfaceAstTraversal.ml
@@ -26,6 +26,8 @@ open SurfaceAstHelper
let (|>) = InfixOperator.(|>)
let (@*) = InfixOperator.(@*)
+let ident a = a.ident
+
(* FIXME: add some signatures *)
let unannot sub (v,annot) =
@@ -76,8 +78,8 @@ module Pattern =
struct
let get_vars_gen add empty p =
PatTraverse.fold (fun acc -> function
- | (PatVar a, _) -> add a acc
- | (PatAs (_,a), _) -> add a acc
+ | (PatVar a, _)
+ | (PatAs (_,a), _) -> add (ident a) acc
| _ -> acc
) empty p
(* TODO: one functor applied to string and exprident? *)
@@ -87,8 +89,8 @@ struct
let get_vars_code l =
PatTraverse.lift_fold SPat.sub_code
(fun acc -> function
- | (PatVar a, _) -> IdentSet.add a acc
- | (PatAs (_,a), _) -> IdentSet.add a acc
+ | (PatVar a, _)
+ | (PatAs (_,a), _) -> IdentSet.add (ident a) acc
| _ -> acc
) IdentSet.empty l
(* FIXME: we can have duplicates *)
@@ -98,8 +100,8 @@ struct
PatTraverse.lift_fold_right_down sub
(fun x acc ->
match x with
- | (PatVar a, _) -> a :: acc
- | (PatAs (_,a), _) -> a :: acc
+ | (PatVar a, _)
+ | (PatAs (_,a), _) -> (ident a) :: acc
| _ -> acc
) l []
let get_var_list_pattern l = get_var_list SPat.sub_p l
@@ -273,15 +275,15 @@ struct
PatTraverse.lift_fold SPat.sub_pat_record_node
(fun env ->
function
- | (PatVar a, _) -> add_env env a None
- | (PatAs (_,a), _) -> add_env env a None (* could say Some... *)
+ | (PatVar a, _)
+ | (PatAs (_,a), _) -> add_env env (ident a) None (* could say Some... *)
| _ -> env) env r in
let add_pat pat env =
PatTraverse.fold
(fun env ->
function
- | (PatVar a, _) -> add_env env a None
- | (PatAs (_,a), _) -> add_env env a None (* could say Some... *)
+ | (PatVar a, _)
+ | (PatAs (_,a), _) -> add_env env (ident a) None (* could say Some... *)
| _ -> env) env pat in
let rec process_pattern_expr tra env acc (pat,expr) =
let env_bnd = add_pat pat env in
View
6 opalang/syntax/opa_parser.trx
@@ -390,7 +390,7 @@ record_pat <-
match p,tilda with
| None,true -> `value (var_to_patvar i)
| None,false -> `novalue i
- | Some p,true -> `value (PatAs (p,ident),label)
+ | Some p,true -> `value (PatAs (p,{ident=ident;directives=[]}),label)
| Some p,false -> `value p in
(ident, p, t)
}}
@@ -418,12 +418,12 @@ pattern = deco just_pattern_as_coerce
;just_pattern_as <- pattern_no_as_coerce:p (Opa_lexer.AS ml_identifier:v {{ v }})?:o
{{ match o with
| None -> undecorate p
- | Some i -> PatAs (p,i)
+ | Some i -> PatAs (p,{ident=i;directives=[]})
}}
;pattern_no_as_coerce = deco just_pattern_no_as_coerce
;just_pattern_no_as_coerce <-
Opa_lexer.UNDERSCORE {{ PatAny }}
- / ml_identifier_nosp:i !"(" {{ PatVar i }}
+ / ml_identifier_nosp:i !"(" {{ PatVar {ident=i;directives=[]} }}
/ const:c {{ PatConst c }}
/ tuple_pat
/ record_pat
View
18 opalang/syntax/parser_utils.ml
@@ -331,10 +331,10 @@ let encode_args_as_record_pos = encode_tuple_pos
*)
let var_to_patvar (ident, label) =
- (PatVar ident, label)
+ (PatVar {ident=ident;directives=[]}, label)
let var_to_exprvar (ident, label) =
(Ident ident, label)
-let patident s label = (PatVar s, label)
+let patident s label = (PatVar {ident=s;directives=[]}, label)
let patvar = patident
let ident s label = (Ident s, label)
let fresh_ident_pat label =
@@ -782,18 +782,18 @@ let rec bind name acc = function
| (PatConst _,label) as p ->
`one (fresh_name (), Cons.E.match_ ~label (Cons.E.ident ~label name) [(p,Cons.E.void ~label ())]) :: acc
| (PatAny,_) -> acc
- | (PatVar v,label) -> `one (v, Cons.E.ident ~label name) :: acc
+ | (PatVar v,label) -> `one (v.ident, Cons.E.ident ~label name) :: acc
| PatRecord (r, rowvar), label ->
bind_aux_record label name acc rowvar r
- | (PatAs (p,s),label) -> bind name (`one (name,Cons.E.ident ~label s) :: acc) p
+ | (PatAs (p,v),label) -> bind name (`one (v.ident,Cons.E.ident ~label name) :: acc) p
| (PatCoerce (p,ty),label) -> bind name (`one (fresh_name (), Cons.E.coerce ~label (Cons.E.ident ~label name) ty) :: acc) p
and bind_aux_record label name acc rowvar r =
let bindings, block =
List.fold_left_map (fun acc (s,p) ->
let n,p =
match p with
- | (PatAs (p,s),_) -> s,p
- | (PatVar s,label) -> s, Cons.P.any ~label ()
+ | (PatAs (p,s),_) -> s.ident,p
+ | (PatVar s,label) -> s.ident, Cons.P.any ~label ()
| _ -> fresh_name (), p in
let label = snd p in
bind n acc p, (n, Cons.E.dot ~label (Cons.E.ident ~label name) s)
@@ -828,7 +828,9 @@ let rec bind_in_to_expr_in dirs binding e2 =
let (p,e1) = binding in
undecorate (
match p with
- | (PatVar v, label) -> (LetIn (false,declaration_directive dirs [(v,e1)],e2),copy_label label)
+ | (PatVar v, label) ->
+ assert( v.directives = [] );
+ (LetIn (false,declaration_directive dirs [(v.ident,e1)],e2),copy_label label)
| (PatAny, label) -> (LetIn (false,declaration_directive dirs [(fresh_name (),e1)],e2),copy_label label)
| (PatCoerce (p,ty),label) -> (bind_in_to_expr_in dirs (p,Cons.E.coerce ~label e1 ty) e2,label)
| (_,label) ->
@@ -851,7 +853,7 @@ let add_recval ~is_recval label (i,e) =
(i,e)
let rec pat_in_to_simple_bindings_aux ~is_recval (p,e) =
match p with
- | (PatVar v, _) -> [(v,e)]
+ | (PatVar v, _) -> assert( v.directives = [] );[(v.ident,e)]
| (PatAny, _) -> [(fresh_name (),e)]
| (PatCoerce (p,ty),label) -> pat_in_to_simple_bindings_aux ~is_recval (p,Cons.E.coerce ~label e ty)
| (_, label) ->
View
12 passes/pass_ServerDeclaration.ml
@@ -50,7 +50,7 @@ let pass_check_server_entry_point ~options env =
let entry_point_dir = CS.D.server_entry_point ~label e in
CS.C.newval_ignore ~label entry_point_dir in
let fun_fl (has_server, acc) = function
- | S.NewVal ([(S.PatVar "server", _), e],_), label ->
+ | S.NewVal ([(S.PatVar {S.ident="server";_}, _), e],_), label ->
(* [server = $e$] becomes [_ = add_server(e)] *)
(* this special case makes the code a little more readable *)
(true, make_entry_point ~label e :: acc)
@@ -64,12 +64,14 @@ let pass_check_server_entry_point ~options env =
let acc, p =
OpaWalk.Pattern.foldmap
(fun acc -> function
- | (S.PatVar "server",label) ->
+ | (S.PatVar ({S.ident="server";_} as id),label) ->
let fresh = gen () in
- fresh :: acc, (S.PatVar fresh, label)
- | (S.PatAs (p,"server"), label) ->
+ let id = {id with S.ident=gen()} in
+ fresh :: acc, (S.PatVar id, label)
+ | (S.PatAs (p,({S.ident="server";_} as id)), label) ->
let fresh = gen () in
- fresh :: acc, (S.PatAs (p, fresh), label)
+ let id = {id with S.ident=gen()} in
+ fresh :: acc, (S.PatAs (p, id), label)
| p -> acc, p)
acc p in
acc, (p,e))
View
5 passes/surfaceAstDependencies.ml
@@ -893,7 +893,8 @@ let flatten_toplevel_module create_group_list lcode =
let map,iel =
List.fold_left_map
(fun map -> function
- | ((PatVar i,_) as pat), e ->
+ | ((PatVar {ident=i;_},_) as pat), e ->
+ (* directives are not lost => in map *)
IdentMap.add i pat map, (i, remove_access_directive e)
| pat, e ->
let i = fresh_ident () in
@@ -906,7 +907,7 @@ let flatten_toplevel_module create_group_list lcode =
let pel = List.map
(fun (i,e) ->
match IdentMap.find_opt i map with
- | None -> ((PatVar i, copy_label label), e)
+ | None -> ((PatVar {ident=i;directives=[]}, copy_label label), e)
| Some p -> (p,e)
) iel in
(* reordering the result *)
View
42 passes/surfaceAstRenaming.ml
@@ -638,12 +638,13 @@ let add_opened_var name tree ident path all_env =
{all_env with
t = {all_env.t with
tnames = StringMap.add name (OpenedIdent (tree, ident, path @ [name]) :: old_l) all_env.t.tnames}}*)
-let add_pat_var ?no_warning name hierar all_env label =
+let add_pat_var ?no_warning {SurfaceAst.ident=name;directives=directives} hierar all_env label =
if is_hiding_pat_var name all_env then
non_linear_pattern name label;
let exported, bindings = all_env.f.data in
let all_env = with_data all_env (exported, StringSet.add name bindings) in
- add_var ?no_warning ~exported name hierar all_env label
+ let env,ident = add_var ?no_warning ~exported name hierar all_env label in
+ env, {SurfaceAst.ident ;SurfaceAst.directives}
(* do we really need to give all_env back all the time? *)
@@ -1228,23 +1229,22 @@ and f_bindings ~rec_ all_env hierar iel =
* environment *)
(* all_env is what is seen by functions and by the [e] of [let ... in e] *)
let old_all_env = all_env in
- let new_all_env,assoc =
- List.fold_left
- (fun (all_env,assoc) (i,e) ->
- let all_env, _pat_env, ident =
- f_pat_var_ext (Parser_utils.label e) all_env hierar i in
- (update_all_env_with i ident e all_env, (i,ident) :: assoc)
- ) (all_env,[]) iel in
+ let new_all_env, iel =
+ List.fold_left_map
+ (fun all_env (i,e) ->
+ let all_env, _pat_env, {SurfaceAst.ident=ident ; directives=_} =
+ f_pat_var_ext (Parser_utils.label e) all_env hierar {SurfaceAst.ident=i;directives=[]}
+ in
+ (update_all_env_with i ident e all_env, (ident,e))
+ ) all_env iel
+ in
let all_env = if rec_ then new_all_env else old_all_env in
- let (f_env, rev_iel) =
- List.fold_left
- (fun (f_env,l) (i,e) ->
+ let (f_env, iel) =
+ List.fold_left_map
+ (fun f_env (i_new,e) ->
let f_env, e_new = f_expr {all_env with f = f_env} hierar e in
- let i_new = List.assoc i assoc in
- let new_l = (i_new, e_new) :: l in
- (f_env, new_l)
- ) (new_all_env.f, []) iel in
- let iel = List.rev rev_iel in
+ (f_env, (i_new, e_new))
+ ) new_all_env.f iel in
{new_all_env with f = f_env}, iel
(**
@@ -1332,8 +1332,8 @@ and f_module all_env hierar iel =
let all_env =
List.fold_left
(fun all_env (i,e) ->
- let all_env, _pat_env, ident =
- f_pat_var_ext ~no_warning:true (Parser_utils.label e) all_env hierar i in
+ let all_env, _pat_env, {SurfaceAst.ident=ident ; directives=_} =
+ f_pat_var_ext ~no_warning:true (Parser_utils.label e) all_env hierar {SurfaceAst.ident=i; directives=[]} in
update_all_env_with i ident e all_env
) all_env iel in
let (f_env, rev_iel) =
@@ -1438,6 +1438,8 @@ let toplevel_code_elt_node_pe_map =
* so we can just ignore what it changed in the local scope
* to put it in the toplevel one
*)
+ let s = s.SurfaceAst.ident in
+ let ident = ident.SurfaceAst.ident in
let old_l = Option.default [] (StringMap.find_opt s map) in
( match tree_option_of_expr s e with
| None -> StringMap.add s (old_l @ [(Normal ident,label.QmlLoc.pos)]) map
@@ -1501,7 +1503,7 @@ let toplevel_code_elt_node_map_for_patterns envs label : _ -> (_ * _ tmp_code_el
new_envs, `NewVal (new_l,rec_)
| `Database (name, l, props) ->
let local_env = envs.l in
- let (envs, _pat_env, ident) = f_pat_var_ext label envs (fake_hierar "DB") name in
+ let (envs, _pat_env, {SurfaceAst.ident=ident;directives=_}) = f_pat_var_ext label envs (fake_hierar "DB") {SurfaceAst.ident=name; directives=[]} in
let tnames = envs.t.tnames in
let names = Option.default [] (StringMap.find_opt name tnames) in
let names = names @ [(Normal ident,label.QmlLoc.pos)] in

0 comments on commit 46769f1

Please sign in to comment.