Permalink
Browse files

[enhance] compiler, packages: New directive to resolve ident conflict…

…s beetween packages
  • Loading branch information...
1 parent bad6b2a commit 160db1a4971f0ec4f4f299e0b28b0be217069ab6 @BourgerieQuentin BourgerieQuentin committed Feb 16, 2012
View
@@ -324,9 +324,10 @@ let pass_simple_slicer ~(options:opa_options) (env:'tmp_env env_Gen) =
let updated =
StringMap.fold
(fun k v updated ->
- match QmlRenamingMap.new_from_original_opt renaming v with
- | None -> updated
- | Some r -> StringMap.add k r updated
+ let v = List.filter_map (QmlRenamingMap.new_from_original_opt renaming) v in
+ match v with
+ | [] -> updated
+ | r -> StringMap.add k r updated
)
map_before StringMap.empty
@@ -490,12 +491,16 @@ let pass_DbAccessorsGeneration ~options:(_ : opa_options) env =
let map =
OpaMapToIdent.fold_val_map
(fun k v map ->
- IdentMap.add (Ident.source k) v map)
+ match v with
+ | [] -> map
+ | v::_ -> IdentMap.add (Ident.source k) v map)
IdentMap.empty in
let revmap =
OpaMapToIdent.fold_val_map
(fun k v revmap ->
- IdentMap.add v (Ident.source k) revmap)
+ List.fold_left
+ (fun revmap v -> IdentMap.add v (Ident.source k) revmap)
+ revmap v)
IdentMap.empty in
Some (QmlAlphaConv.create_from_maps ~map:map ~revmap:revmap)
in
View
@@ -1,5 +1,5 @@
(*
- Copyright © 2011 MLstate
+ Copyright © 2011, 2012 MLstate
This file is part of OPA.
@@ -681,10 +681,21 @@ let pass_SaToQml =
let options = OpaToQml.options in
OpaToQml.UidsOpaToQml.code ~options env.P.sa_lcode
in
- let type_renaming = SurfaceAstRenaming.ObjectType.fold StringMap.safe_merge env.P.sa_type_renaming in
- let type_renaming = StringMap.map (fun (i,_) -> OpaToQml.UidsOpaToQml.typeident_aux ~check:false i) type_renaming in
+ let duplicated = Hashtbl.create 16 in
+ let type_renaming =
+ SurfaceAstRenaming.ObjectType.fold
+ (StringMap.merge_i
+ (fun i x y -> Hashtbl.add duplicated i y; x)
+ )
+ env.P.sa_type_renaming in
+ let type_renaming = StringMap.map
+ (fun (i,_) -> OpaToQml.UidsOpaToQml.typeident_aux ~check:false i)
+ type_renaming in
let type_renamer ?(check=true) str =
- try StringMap.find str type_renaming
+ try let x = StringMap.find str type_renaming in
+ match Hashtbl.find_all duplicated str with
+ | [] -> x
+ | _ -> OManager.error "Duplicated type ident is found %s\n" str
with Not_found ->
(* need to do that because the db uses bypasses with type [embed_info]
* but this type is not defined in the code because the bypasses can only
@@ -1168,6 +1168,9 @@ directive1 <-
/ "unsafe_cast" {{ `unsafe_cast }}
/ "wait" {{ `wait }}
+directive0pack <-
+ / "from" {{ fun x -> `from x }}
+
directive2 <-
/ "catch" {{ `catch }}
/ "deprecated" {{ `deprecated }}
@@ -1203,6 +1206,8 @@ directive <-
}}
/ "@" (=exact_ident(directive0)):v !"("
{{ Directive (v,[],[]) }}
+ / "@" (=exact_ident(directive0pack)):v Opa_lexer.lpar_nosp package_identifier:pck rpar
+ {{ Directive (v pck,[],[]) }}
/ "@" (=exact_ident(directive1)):v Opa_lexer.lpar_nosp expr:e rpar
{{ Directive (v,[e],[]) }}
/ "@" (=exact_ident(directive1str)):v Opa_lexer.lpar_nosp string:str rpar
@@ -1212,6 +1217,7 @@ directive <-
/ "@" (=exact_ident(directive2)):v Opa_lexer.lpar_nosp expr:e1 comma expr:e2 rpar
{{ Directive (v,[e1;e2],[]) }}
/ "@" (=exact_ident(directive1or2str)):v Opa_lexer.lpar_nosp string:str (comma expr:e {{ [e] }} / _succeed {{ [] }}):el rpar
+
{{ Directive (v str,el,[]) }}
/ "@" !strict_spacing deco_ml_identifier_nosp:v (function_arguments_nosp / !"(" {{ [] }}):l
{|
View
@@ -16,6 +16,8 @@
along with OPA. If not, see <http://www.gnu.org/licenses/>.
*)
+module Format = BaseFormat
+
(*
We test strictly than the val_ function is called only on
identifiers registred in opacapi, using the opacapi interface.
@@ -60,9 +62,9 @@ let other_side = function
*)
(* Reference to the maps*)
-let r_var = ref (StringMap.empty : Ident.t StringMap.t)
-let r_var_client = ref (StringMap.empty : Ident.t StringMap.t)
-let r_type = ref (StringMap.empty : Ident.t StringMap.t)
+let r_var = ref (StringMap.empty : Ident.t list StringMap.t)
+let r_var_client = ref (StringMap.empty : Ident.t list StringMap.t)
+let r_type = ref (StringMap.empty : Ident.t list StringMap.t)
(* registering the references to be able to save them *)
let () =
@@ -78,7 +80,9 @@ let print_side = function
| `client -> "client"
let val_no_opacapi_check ?(side=`server) s =
- StringMap.find s !(get_rmap side)
+ match StringMap.find s !(get_rmap side) with
+ | [i] -> i
+ | l -> OManager.i_error "Found multiple ident for %s : %a" s (Format.pp_list " " (fun f i -> Format.fprintf f "%s" (Ident.to_uniq_string i))) l
let val_noerr ?(side=`server) s =
opacapi_check s ;
@@ -119,7 +123,9 @@ let typed_val ?(label=Annot.nolabel "OpaMapToIdent") ?(side=`server) ?(ty=[]) ?(
let typ s =
opacapi_check s ;
try
- StringMap.find s !r_type
+ match StringMap.find s !r_type with
+ | [i] -> i
+ | l -> OManager.i_error "Found multiple ident for %s : %a" s (Format.pp_list " " (fun f i -> Format.fprintf f "%s" (Ident.to_uniq_string i))) l
with Not_found ->
OManager.i_error
"OpaMapToIdent: Type not found: %S\nIt contains:@\n%a@\n"
@@ -133,19 +139,18 @@ let specialized_typ ?(ty = []) ?(ty_row = []) name gamma =
QmlTypes.Scheme.specialize ~typeident ~ty ~ty_row scheme
let val_opt ?(side=`server) s =
- opacapi_check s ;
- StringMap.find_opt s !(get_rmap side)
+ try Some (val_noerr ~side s) with Not_found -> None
let val_add ?(side=`server) s =
let new_s = Ident.next s in
let r_var = get_rmap side in
- r_var := StringMap.safe_add s new_s !r_var;
+ r_var := StringMap.replace s (function | None -> [new_s] | Some l -> new_s::l) !r_var;
new_s
let val_unsafe_add ?(side=`server) s =
let new_s = Ident.next s in
let r_var = get_rmap side in
- r_var := StringMap.add s new_s !r_var;
+ r_var := StringMap.replace s (function | None -> [new_s] | Some l -> new_s::l) !r_var;
new_s
let set_val_map ?(side=`server) v = (get_rmap side) := v
@@ -174,7 +179,7 @@ let val_start_server_add () =
| None ->
let ident = Ident.next "run_services" in
start_server := (Some str_start_server);
- set_val_map (StringMap.add str_start_server ident (get_val_map ()));
+ set_val_map (StringMap.add str_start_server [ident] (get_val_map ()));
ident
(** Hack for opacapi - To be cleanned by introduce dependencies
beetween initialisations values (css, etc...) and init server *)
@@ -183,8 +188,16 @@ let _ = Opacapi.(!!) str_start_server
let get_toplevel_vars () = StringMap.elts !r_var
let filter f =
- r_var := StringMap.filter_val f !r_var;
- r_var_client := StringMap.filter_val f !r_var_client
+ let fil map =
+ StringMap.fold
+ (fun s i acc ->
+ match List.filter f i with
+ | [] -> acc
+ | l -> StringMap.add s l acc)
+ map StringMap.empty
+ in
+ r_var := fil !r_var;
+ r_var_client := fil !r_var_client
let reset () =
set_val_map ~side:`server StringMap.empty;
View
@@ -106,23 +106,23 @@ val specialized_typ : ?ty:QmlAst.ty list -> ?ty_row:QmlAst.ty_row list -> string
(** {6 Map setter & getter}*)
(** Directly get the map of values *)
-val get_val_map : ?side: side -> unit -> QmlAst.ident StringMap.t
+val get_val_map : ?side: side -> unit -> QmlAst.ident list StringMap.t
(** Directly set the map of values *)
-val set_val_map : ?side:side -> QmlAst.ident StringMap.t -> unit
+val set_val_map : ?side:side -> QmlAst.ident list StringMap.t -> unit
(** Directly set the map of types *)
-val set_typ_map : QmlAst.ident StringMap.t -> unit
+val set_typ_map : QmlAst.ident list StringMap.t -> unit
(** {6 Iterators}*)
(** Iter on the map of value.*)
-val iter_val_map : ?side:side -> (string -> QmlAst.ident -> unit) -> unit
+val iter_val_map : ?side:side -> (string -> QmlAst.ident list -> unit) -> unit
(** Map on the map of value.*)
-val map_val_map : ?side:side -> (QmlAst.ident -> 'a) -> 'a StringMap.t
+val map_val_map : ?side:side -> (QmlAst.ident list -> 'a) -> 'a StringMap.t
(** Fold on the map of value.*)
-val fold_val_map : ?side:side -> (string -> QmlAst.ident -> 'a -> 'a) -> 'a -> 'a
+val fold_val_map : ?side:side -> (string -> QmlAst.ident list -> 'a -> 'a) -> 'a -> 'a
(** keep the maps only the identifiers satisfying the given predicates
this function is applied to the two maps of identifiers (client and server) *)
View
@@ -796,6 +796,7 @@ module Classic = struct
| `open_ -> Format.pp_print_string f "open_"
| `toplevel_open -> Format.pp_print_string f "toplevel_open"
| `toplevel -> Format.pp_print_string f "toplevel"
+ | `from s -> Format.fprintf f "from(%s)" s
| `local s -> pp f "local[%s]" (Ident.to_string s)
| `doctype (sl, access) ->
pp f "doctype([%a], %a)" (list ",@ " Format.pp_print_string) sl self#variant access
@@ -1356,6 +1357,7 @@ module Js = struct
| `open_ -> Format.pp_print_string f "open_"
| `toplevel_open -> Format.pp_print_string f "toplevel_open"
| `toplevel -> Format.pp_print_string f "toplevel"
+ | `from s -> Format.fprintf f "from(%s)" s
| `local s -> pp f "local[%s]" (Ident.to_string s)
| `doctype (sl, access) ->
pp f "doctype([%a], %a)" (list ",@ " Format.pp_print_string) sl self#variant access
View
@@ -370,6 +370,7 @@ type alpha_renaming_directive =
| `toplevel_open
| `module_
| `toplevel
+ | `from of string (* to manage conflicts beetween packages *)
]
(**
Oops, something went wrong.

0 comments on commit 160db1a

Please sign in to comment.