Source

ocamlspot / spoteval.ml

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
(***********************************************************************)
(*                                                                     *)
(*                            OCamlSpotter                             *)
(*                                                                     *)
(*                             Jun FURUSE                              *)
(*                                                                     *)
(*   Copyright 2008-2012 Jun Furuse. All rights reserved.              *)
(*   This file is distributed under the terms of the GNU Library       *)
(*   General Public License, with the special exception on linking     *)
(*   described in file LICENSE.                                        *)
(*                                                                     *)
(***********************************************************************)

open Format
open Utils
open Ext

(* To avoid name collisions *)
module OCaml = struct
  module Format = Format
end

open Spot

module PIdent = struct
  type t = {
    path : string; (* "" means predefined *)
    ident : Ident.t option; (* None means the top module *)
  }

  let format ppf id =
    fprintf ppf "%s%s" 
      (match id.path with
      | "" -> ""
      | p -> 
          (let len = String.length p in
           if len > 20 then
             "..." ^ String.sub p (len - 20) 20 
           else p) ^ ":")
      (match id.ident with
      | Some id -> Ident.name id
      | None -> "TOP")
end

module Value : sig

  type t = 
    | Ident of PIdent.t
    | Structure of PIdent.t * structure * structure option (* sig part *)
    | Closure of PIdent.t * env * Ident.t * Types.module_type * Abstraction.module_expr
    | Parameter of PIdent.t
    | Error of exn 

  and structure = structure_item list

  and structure_item = Ident.t * (Kind.t * z)

  and z = t Lazy.t

  and env = {
    path : string;
    cwd : string;
    load_paths : string list;
    binding : binding;
  } 

  and binding
      
  module Binding : sig
    type t = binding
    val domain : t -> Ident.t list
    val find : t -> Ident.t -> (Kind.t * z) option
    val override : t -> structure_item -> t
    val overrides : t -> structure -> t
    val set : t -> structure -> unit
    val predef : t
    val empty : t
    val invalid : t
  end

  module Enforcer(A : sig 
  end) : sig
    val t : t -> unit
    val env : env -> unit
    val binding : binding -> unit
    val structure : structure -> unit
    val structure_item : structure_item -> unit
    val z : z -> unit
  end

  module Format : sig
    (* include module type of Format 3.12 *)
    val t : formatter -> t -> unit
    val env : formatter -> env -> unit
    val binding : formatter -> binding -> unit
    val structure : formatter -> structure -> unit
    val z : formatter -> z -> unit
  end

end = struct

  type t = 
    | Ident     of PIdent.t
    | Structure of PIdent.t * structure * structure option (* sig part *)
    | Closure   of PIdent.t * env * Ident.t * Types.module_type * Abstraction.module_expr
    | Parameter of PIdent.t
    | Error     of exn 

  and structure = structure_item list

  and structure_item = Ident.t * (Kind.t * z)

  and z = t Lazy.t 

  and env = {
    path : string;
    cwd : string;
    load_paths : string list;
    binding : binding;
  }

  (* dirty hack for flat recursion *)
  and binding = structure option ref
      
  module Binding = struct
    type t = binding
    let error () = failwith "Binding: premature"
    let with_check f t = match !t with
      | None -> error ()
      | Some str -> f str
    let domain = with_check (List.map fst) 
    let find t id = try Some (with_check (List.assoc id) t) with Not_found -> None
    let override t v = ref (Some (with_check (fun t -> v :: t) t))
    let overrides t vs = ref (Some (with_check (fun t -> vs @ t) t))
    let invalid = ref None 
    let empty = ref (Some [])
    let predef = 
      let items = ref [] in
      let add_predefined kind id = 
        items := 
          (id, 
           (kind, eager (Ident { PIdent.path = "";
                                 ident = Some id })))
          :: !items
      in
      Predef.build_initial_env 
        (fun id decl _ -> 
          add_predefined Kind.Type id;
          match decl.Types.type_kind with
          | Types.Type_abstract -> ()
          | Types.Type_record (l, _) -> List.iter (fun (id, _, _) -> add_predefined Kind.Type id) l
          | Types.Type_variant l     -> List.iter (fun (id, _, _) -> add_predefined Kind.Type id) l
        )
        (fun id _ _ -> add_predefined Kind.Exception id) 
        ();
      List.iter (fun (_, id) -> add_predefined Kind.Value id) Predef.builtin_values;
      ref (Some !items)
    let set b str = b := Some str
  end

  module Enforcer(A : sig 
  end) = struct
    (* prevent looping forever *)
    let cache = ref []
    let rec t = function
      | Structure (_, str, str_opt) -> 
          structure str;
          Option.iter str_opt ~f:structure
      | Closure (_, e, _, _, _) -> env e
      | Ident _ | Error _ | Parameter _ -> ()
    and env e = binding e.binding
    and binding b =
      match !b with
      | None -> failwith "Enforcer.binding: binding is premature"
      | Some str -> structure str
    and structure str = List.iter structure_item str
    and structure_item (_, (_, zt)) = z zt
    and z zt =
      if List.memq zt !cache then ()
      else begin
        cache := zt :: !cache;
        t !!zt
      end
  end

  module Format = struct

    include Format

    let rec t ppf = function
      | Ident id -> fprintf ppf "Ident(%a)" PIdent.format id
      | Parameter id -> fprintf ppf "Parameter(%a)" PIdent.format id
      | Structure (pid, str, None) -> 
            fprintf ppf "@[<v2>Module(%a)@ %a None@]"
              PIdent.format pid
            structure str
      | Structure (pid, str, Some str') -> 
            fprintf ppf "@[<v2>Module(%a)@ %a (Some %a)@]"
              PIdent.format pid
            structure str
            structure str'
      | Closure (pid, _, id, _mty, module_expr) ->
            fprintf ppf "(@[<2>(%a =)fun %s ->@ @[%a@]@])" 
              PIdent.format pid
              (Ident.name id)
              Abstraction.format_module_expr module_expr
      | Error (Failure s) -> fprintf ppf "ERROR(%s)" s
      | Error exn -> fprintf ppf "ERROR(%s)" (Printexc.to_string exn)
            
    and env ppf env = 
      fprintf ppf "{ @[path=%s;@,@[<2>load_paths=@,[@[%a@]];@]@,@[<2>structure=@,@[%a@]@]@] }"
        env.path
        (Format.list "; " (fun ppf s -> fprintf ppf "%S" s)) env.load_paths
        binding env.binding
        
    and binding ppf b = 
      match !b with
      | None -> fprintf ppf "PREM"
      | Some str -> structure ppf str

    and structure ppf =
      fprintf ppf "{ @[<v>%a@] }"
        (Format.list ";@ " (fun ppf (id, (kind, t)) ->
            fprintf ppf "@[<2>%s %s =@ %a@]" 
              (String.capitalize (Kind.to_string kind))
            (Ident.name id) z t))
        
    and z ppf = Format.lazy_ t ppf
  end
end

module Binding = Value.Binding

module Env = struct
  open Value
  type t = env = {
    path : string;
    cwd : string;
    load_paths : string list;
    binding : Binding.t;
  } 
  let format = Value.Format.env
  let domain t = Binding.domain t.binding
  let find t id = Binding.find t.binding id
  let override t v = { t with binding = Binding.override t.binding v }
  let overrides t vs = { t with binding = Binding.overrides t.binding vs }
  let predef = {
    path = "";
    cwd = "";
    load_paths = [];
    binding = Binding.predef;
  }
end

module Eval = struct

  open Abstraction
  open Value
  module Format = OCaml.Format

  let str_of_global_ident = ref (fun ~cwd:_ ~load_paths:_ _ -> assert false : cwd: string -> load_paths: string list -> Ident.t -> string * Value.structure)
  let packed = ref (fun _ _ -> assert false : Env.t -> string -> Value.t)

  let rec find_path env (kind, p) : Value.z = 
    match p with
    | Path.Papply (p1, p2) -> 
	let v1 = find_path env (kind, p1) in (* CR jfuruse: Kind.Module ? *)
	let v2 = find_path env (kind, p2) in
	apply v1 v2
    | Path.Pident id -> 
        (* predef check first (testing) *)
        begin match Env.find Env.predef id with
        | Some (_, v) -> v
        | None -> 
            if Ident.global id then
              lazy begin try
                let path, str = !str_of_global_ident ~cwd:env.cwd ~load_paths:env.load_paths id in
                let str = Structure ( { PIdent.path = path; ident = None }, 
                                      str,
                                      None (* CR jfuruse: todo (read .mli *))
                in
                Debug.format "@[<2>LOAD SUCCESS %s =@ %a@]@."
                  (Ident.name id)
                  Value.Format.t str;
                str
              with
              | e -> 
                  eprintf "LOAD FAILURE %s: %s@." (Ident.name id) (Printexc.to_string e);
                  Error e
              end
            else begin 
              lazy begin
                Debug.format "find_path %s:%s in { %s }@." 
                  (Kind.name kind)
                  (Path.name p)
                  (String.concat "; " 
                    (List.map Ident.name (Env.domain env)));
                match Env.find env id with
                | Some (_, lazy v) -> v
                | None -> 
    (*
                  (* it may be a predefed thing *)
                  try !!(snd (Env.find Env.predef id)) with Not_found ->
    *)
                    (* If it is a non-value object, it might be included with stamp = -1 *)
                    let error id = 
                      Error (Failure (Printf.sprintf "%s:%s not found in { %s }" 
                                        (Kind.name kind)
                                        (Ident.name id)
                                        (String.concat "; " 
                                           (List.map Ident.name (Env.domain env)))))
                    in
                    match kind with
                    | Kind.Value | Kind.Module | Kind.Class | Kind.Exception -> error id
                    | _ ->
                        let gid = Ident.unsafe_create_with_stamp (Ident0.name id) (-1) in
                        match Env.find env gid with
                        | Some (_, lazy v) -> v
                        | None -> error id
              end
            end
            end
    | Path.Pdot (p, name, pos) ->
        lazy begin
          match !!(find_path env (Kind.Module, p)) with
          | Ident _ -> (try assert false with e -> Error e)
          | Parameter pid -> Parameter pid
          | Closure _ -> (try assert false with e -> Error e)
          | Error exn -> Error exn
          | Structure (pid, str, _ (* CR jfuruse *)) -> 
              Debug.format "Module %s found (%a)@." (Path.name p) PIdent.format pid;
              try
                !!(find_ident str (kind, name, pos))
              with
              | Not_found -> Error (Failure (Printf.sprintf "Not_found %s:%d" name pos))
        end

  and find_ident (str : Value.structure) (kind, name, pos) : Value.z =
    let name_filter = fun (id, (k,_)) -> 
(*
      Debug.format "DEBUG: %s %s ? %s %s@."
        (Kind.to_string kind)
        name 
        (Kind.to_string k)
        (Ident0.name id);
*)
      k = kind && Ident0.name id = name in
    (* CR jfuruse: double check by pos! *)
    lazy begin
      try
        !!(snd (snd (List.find (fun id_value ->
          (* pos_filter id_value && *) name_filter id_value) str)))
      with
      | Not_found ->
          Debug.format "Error: Not found %s %s in { @[%a@] }@."
            (String.capitalize (Kind.to_string kind))
            name
            Value.Format.structure str;
          Error (Failure (Printf.sprintf "Not found: %s__%d" name pos))
    end

  and module_expr env idopt : module_expr -> Value.z = function
    | AMod_functor_parameter -> 
        eager (Parameter { PIdent.path= env.path; ident = idopt })
    | AMod_abstract -> eager (Error (Failure "abstract"))
    | AMod_ident p -> find_path env (Kind.Module, p)
    | AMod_packed s -> lazy (!packed env s)
    | AMod_structure str -> 
        lazy begin
          let str = structure env str in
          Structure ({ PIdent.path= env.path; ident = idopt }, str, None)
        end
    | AMod_functor (id, mty, mexp) -> 
        Debug.format "creating a closure of a functor (fun %s -> ...) under %s@."
          (Ident.name id)
          (String.concat "; " (List.map Ident.name (Env.domain env)));
        eager (Closure ({ PIdent.path = env.path; ident = idopt }, 
                        env, id, mty, mexp))
    | AMod_constraint (mexp, _mty) -> 
        (* [mty] may not be a simple signature but an ident which is
           hard to get its definition at this point. 
           Therefore we do not constrain our result here. 
           Only the sensitive case is when a constrained module is
           included, but we can handle this case using included
           value list. 

           Types never override themselves so the including module's
           type wins against the type of the same name in the included one:

           type t (* WINS! *)
           include (struct
           type t (* ocamlspot does not hide it *)
           end : sig
        (* type system hide t *)
           end)
        *)
        module_expr env idopt (*?*) mexp
    | AMod_apply (mexp1, mexp2) ->
        let v1 = module_expr env None mexp1 in
        let v2 = module_expr env None mexp2 in
	apply v1 v2
    | AMod_unpack mty -> module_expr env None mty

  (* expand internal Include and get alist by Ident.t *)
  (* the list order is REVERSED and is last-defined-first, 
     but it is REQUIRED for environment query *)
  and structure env0 sitems : Value.structure =

    List.fold_left (fun str sitem ->
      match sitem with
      | AStr_value     id 
      | AStr_type      id
      | AStr_exception id
      | AStr_class     id
      | AStr_class_type    id ->
          (* CR jfuruse: not sure *)
          let pident = { PIdent.path = env0.Env.path; ident = Some id } in
          let v = Ident pident in
          (* 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_class_type _ -> Kind.Class_type
            | AStr_included (_, _, kind, _) -> kind
            | AStr_module _ -> 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))) ->
          (* id = id_ *)
          let pident = { PIdent.path = env0.Env.path; ident = Some id } in
          (id, (Kind.Module, eager (Parameter pident))) :: str
          
      | AStr_module (id, mexp) ->
          let v = lazy begin
            try
              (* create it lazily for recursiveness of flat *)
              let env = Env.overrides env0 str in
              !!(module_expr env (Some id) mexp)
            with
            | exn -> Error exn
          end
          in
          (id, (Kind.Module, v)) :: str

      | AStr_modtype (id, mexp) ->
          (* CR jfuruse: dup code *)
          let v = lazy begin
            try
              (* create it lazily for recursiveness of flat *)
              let env = Env.overrides env0 str in
              !!(module_expr env (Some id) mexp) (* ??? *)
            with
            | exn -> Error exn
          end
          in
          (id, (Kind.Module_type, v)) :: str

      | AStr_included (id', mexp, k, id) ->
          (* shared include should share the result of mexp *)
          (* 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 -> [ (k, id), eager (Parameter pid) ]
            | Ident _ -> assert false
            | Closure _ -> assert false
            | Error _ -> [] (* error *)
            end
          in
          let v = lazy begin
            let kid_tbl = !!kid_ztbl in
              (* include does not preserve id stamp, so we must ignore them *)
            match 
              List.find_map_opt (fun ((k', id'), v) -> 
                if k = k' && Ident0.name id = Ident0.name id' then Some v else None) kid_tbl
            with
            | Some vz -> !!vz
            | None -> 
                Format.eprintf "INCLUDE ERROR: %s %a in @[%a@]@."
                  (Kind.name k)
                  Ident.format id
                  (Format.list ";@ " (fun ppf ((k,id), _) -> 
                    Format.fprintf ppf "%s %a" (Kind.name k) Ident.format id))
                  kid_tbl;
                Error (Failure "not found in include")
          end in
          (id', (k, v)) :: str
          ) [] sitems

  and apply v1 v2 =
    lazy begin match !!v1 with
    | Ident _ -> assert false
    | Parameter pid -> Parameter pid (* CR jfuruse: ??? *)
    | Structure _ -> assert false
    | Error exn -> Error exn
    | Closure (_, env, id, _mty, mexp) -> 
        let v = 
          !!(module_expr (Env.override env (id, (Kind.Module, v2)))
               None(*?*) mexp)
        in
        Debug.format "closure app: %a@." Value.Format.t v;
        v
    end
end
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.