Commits

camlspotter committed a5f3e40

eval fix (not sure really working or not

  • Participants
  • Parent commits d372fe3

Comments (0)

Files changed (5)

     | AStr_modtype   of Ident.t * module_expr
     | AStr_class     of Ident.t
     | AStr_cltype    of Ident.t
-    | AStr_include   of module_expr * (Kind.t * Ident.t) list
+    | AStr_include   of module_expr * (Ident.t * (Kind.t * Ident.t)) list
 
   let rec format_module_expr ppf = function
     | AMod_ident p -> fprintf ppf "%s" (Path.name p)
           format_module_expr mexp
     | AStr_class id -> fprintf ppf "class %s" (Ident.name id)
     | AStr_cltype id -> fprintf ppf "class type %s" (Ident.name id)
-    | AStr_include (mexp, kidents) ->
-        fprintf ppf "@[include %a@ : [ @[%a@] ]@]"
+    | AStr_include (mexp, aliases) ->
+        fprintf ppf "@[<v4>include %a@ { @[<v>%a@] }@]"
           format_module_expr mexp
-          (list "; " (fun ppf (k,id) -> 
-            fprintf ppf "%s %s" (String.capitalize (Kind.name k)) (Ident.name id))) 
-          kidents
+          (list ";@ " (fun ppf (id', (k,id)) -> 
+            fprintf ppf "%s %a = %a" 
+              (Kind.name k)
+              Ident.format id' 
+              Ident.format id))
+          aliases
 
   let ident_of_structure_item : structure_item -> (Kind.t * Ident.t) option = function
     | AStr_value id        -> Some (Kind.Value, id)
 	    id1 = id2 && Module_expr.equal mexp1 mexp2
 	| AStr_modtype (id1, mty1), AStr_modtype (id2, mty2) ->
             id1 = id2 && Module_expr.equal mty1 mty2
-	| AStr_include (mexp1, kids1), AStr_include (mexp2, kids2) ->
-	    Module_expr.equal mexp1 mexp2 && kids1 = kids2
+	| AStr_include (mexp1, aliases1), AStr_include (mexp2, aliases2) ->
+            aliases1 = aliases2
+            && Module_expr.equal mexp1 mexp2
 	| (AStr_value _ | AStr_type _ | AStr_exception _ | AStr_modtype _ 
 	  | AStr_class _ | AStr_cltype _ | AStr_module _ | AStr_include _),
 	  (AStr_value _ | AStr_type _ | AStr_exception _ | AStr_modtype _ 
       | Tsig_include _ -> assert false
   end
 
+  let aliases_of_include mexp ids =
+    let sg = match (mexp.mod_type : Types.module_type) with Mty_signature sg -> sg | _ -> assert false in (* CR jfuruse: I hope so... *)
+    let kids = List.concat_map T.kident_of_sigitem sg in
+    (* [ids] only contain things with values, i.e. values, modules and classes *)
+    List.map (fun (k,id) -> match k with
+    | Kind.Value | Kind.Module | Kind.Class -> 
+        begin match List.find_all (fun id' -> Ident0.name id' = Ident0.name id) ids with
+        | [id'] -> id', (k, id)
+        | _ -> assert false
+        end
+    | _ -> Ident.unsafe_create_with_stamp (Ident0.name id) (-1), (k, id)) kids
+
   let rec module_expr mexp =
     try
       match Module_expr.Table.find cache_module_expr mexp with
 	List.map (fun (cls, _names, _) -> AStr_class cls.ci_id_class) classdescs
     | Tstr_class_type iddecls ->
 	List.map (fun (id, _, _) -> AStr_cltype id) iddecls
-    | Tstr_include (mexp, _ids) ->
-        let sg = match (mexp.mod_type : Types.module_type) with Mty_signature sg -> sg | _ -> assert false in (* CR jfuruse: I hope so... *)
-	let kids = List.concat_map T.kident_of_sigitem sg in
-        [AStr_include (module_expr mexp, kids)]
+    | Tstr_include (mexp, ids) ->
+        let aliases = aliases_of_include mexp ids in
+        [AStr_include (module_expr mexp, aliases)]
 
   (* CR jfuruse: caching like module_expr_sub *)
   and module_type mty = module_type_desc mty.mty_desc
       | _ -> assert false)
       ()
 
+(*
   let record_include_sig loc mty sg =
     protect "Spot.Annot.record_include_sig" (fun () ->
       let kids = (* CR jfuruse: copy of structure_item_sub *) 
 	  id (sitem, ref false (* never recorded in the parent sig yet *))) kids;
       record loc (Str sitem))
       ()
+*)
 
   let record_module_expr_def loc id modl =
     protect "Spot.Annot.record_module_expr_def" (fun () ->
     | AStr_modtype   of Ident.t * module_expr
     | AStr_class     of Ident.t
     | AStr_cltype    of Ident.t
-    | AStr_include   of module_expr * (Kind.t * Ident.t) list
+    | AStr_include   of module_expr * (Ident.t * (Kind.t * Ident.t)) list
 
   val ident_of_structure_item : structure_item -> (Kind.t * Ident.t) option
 
   val record_module_expr_use : Location.t -> Typedtree.module_expr -> unit
   val record_include :
     Location.t -> Typedtree.module_expr -> (* Types.signature -> *) unit
+(*
   val record_include_sig :
     Location.t -> Typedtree.module_type -> Types.signature -> unit
+*)
   val record_module_type_def : Location.t -> Ident.t -> Typedtree.module_type -> unit
   val recorded : unit -> (Location.t * t) list
 
 
     List.fold_left (fun str sitem ->
       match sitem with
-      | AStr_value id 
-      | AStr_type id
+      | AStr_value     id 
+      | AStr_type      id
       | AStr_exception id
-      | AStr_class id
-      | AStr_cltype id ->
+      | AStr_class     id
+      | AStr_cltype    id ->
           (* CR jfuruse: not sure *)
           let pident = { PIdent.path = env0.Env.path; ident = Some id } in
           let v = Ident pident in
-          let kind = 
-            match sitem with
-            | AStr_value _ -> Kind.Value
-            | AStr_type _ -> Kind.Type
+          (* CR jfuruse: use ident_of_structure_item *)
+          let kind = match sitem with
+            | AStr_value     _ -> Kind.Value
+            | AStr_type      _ -> Kind.Type
             | AStr_exception _ -> Kind.Exception
-            | AStr_modtype _ -> Kind.Module_type
-            | AStr_class _ -> Kind.Class
-            | AStr_cltype _ -> Kind.Class_type
+            | AStr_modtype   _ -> Kind.Module_type
+            | AStr_class     _ -> Kind.Class
+            | AStr_cltype    _ -> Kind.Class_type
             | AStr_module _ | AStr_include _ -> assert false
           in
           (id, (kind, eager v)) :: str
 
       (* CR: very ad-hoc rule for functor parameter *)      
       | AStr_module (id, AMod_ident (Path.Pdot (Path.Pident _id, 
-                                              "parameter", 
-                                              -2))) ->
+                                                "parameter", 
+                                                -2))) ->
           (* id = id_ *)
           let pident = { PIdent.path = env0.Env.path; ident = Some id } in
           (id, (Kind.Module, eager (Parameter pident))) :: str
           in
           (id, (Kind.Module_type, v)) :: str
 
-      | AStr_include (mexp, kids) ->
+      | AStr_include (mexp, aliases) ->
+          (* be careful: everything must be done lazily *)
+          let v = lazy begin
+            (* createate it lazily for recursiveness of flat *)
+            let env = Env.overrides env0 str in
+            !!(module_expr env None(*?*) mexp)
+          end in
+          let kid_ztbl = 
+            lazy begin match !!v with
+            | Structure (_, str, _ (* CR jfuruse *) ) -> 
+                List.map (fun (id, (k, v)) -> (k, id), v) str
+            | Parameter pid -> 
+                List.map (fun (_, (k,id)) -> 
+                  (k, id), eager (Parameter pid)) aliases
+            | Ident _ -> assert false
+            | Closure _ -> assert false
+            | Error _ -> [] (* error *)
+            end
+          in
+          let str' =
+            List.map (fun (id', (k, id)) ->
+              let v = 
+                lazy begin
+                  try
+                    !!(List.assoc (k, id) !!kid_ztbl)
+                  with
+                  | Not_found -> Error Not_found
+                end
+              in
+              id', (k, v)) aliases
+          in
+          str' @ str
+(*
+      | AStr_include (_ids (* CR jfuruse: todo *), mexp, kids) ->
           (* be careful: everything must be done lazily *)
           let v = lazy begin
             (* createate it lazily for recursiveness of flat *)
               in
               id, (k, v)) kids
           in
-          str' @ str) [] sitems
+          str' @ str
+*)
+          ) [] sitems
 
   and apply v1 v2 =
     lazy begin match !!v1 with
     
 let unsafe_create_with_stamp = Ident_internal.unsafe_create_with_stamp
 
+let format ppf id = Format.pp_print_string ppf (name id)
+
 let parse s =
   let s, pos = Name.parse s in
   let id = unsafe_create_with_stamp s pos in
 open Ident
 
 val name : t -> Name.t
+val format : Format.formatter -> t -> unit
 val unsafe_create_with_stamp : ?flags:int -> string -> int -> t
   (** create an ident with given flags and stamp *)
 val parse : Name.t -> t