Skip to content
Browse files

Merge pull request #3 from camlspotter/master

Ported to OCaml 4.00.1 + opt compilation
  • Loading branch information...
2 parents 8bdf112 + 91186e2 commit ae4c78cca7cc48cf3b6de321612013e69d95edfc @mzp committed
Showing with 6,065 additions and 118 deletions.
  1. +4 −2 .gitignore
  2. +29 −13 OMakefile
  3. +2 −16 README.mkdn
  4. +14 −0 _oasis
  5. +16 −2 base.ml
  6. +57 −0 base.mli
  7. +1 −1 config.ml → chconfig.ml
  8. 0 config.mli → chconfig.mli
  9. +105 −0 cli.ml
  10. +3 −3 controller.ml
  11. +4 −2 controller.mli
  12. +2 −2 list2.ml
  13. +3 −3 main.ml
  14. +1 −0 modules-init.sh
  15. +6 −0 opam/ocaml-hoogle.1.0.0/descr
  16. +12 −0 opam/ocaml-hoogle.1.0.0/opam
  17. +6 −0 opam/template/descr
  18. +2 −0 opam/template/opam
  19. +28 −0 scrape-modules.sh
  20. +52 −21 search.ml
  21. +4 −3 search.mli
  22. +2 −1 searchTest.ml
  23. +110 −49 searchid.ml
  24. +12 −0 searchid.mli
  25. +5,590 −0 setup.ml
View
6 .gitignore
@@ -1,12 +1,14 @@
*~
.omakedb
.omakedb.lock
-*.cm[iox]
+*.cm*
*.omc
*.cgi
*.run
+*.opt
*.annot
*.o
*-runner
config-test.txt
-modules.txt
+modules.txt
+
View
42 OMakefile
@@ -1,3 +1,5 @@
+.PHONY: clean all
+
USE_OCAMLFIND = true
OCAMLPACKS[] =
@@ -5,21 +7,21 @@ OCAMLPACKS[] =
extlib
CamlGI
str
-
+ compiler-libs.bytecomp
if $(not $(OCAMLFIND_EXISTS))
eprintln('This project requires ocamlfind, but is was not found.')
eprintln('You need to install ocamlfind and run "omake --configure".')
exit 1
-OCAMLFLAGS += -dtypes -g -thread
+OCAMLFLAGS += -dtypes -g -thread -w A-4-9 -warn-error A-4-6-9-27-31-33
OCAMLINCLUDES += ../parsing
OCAMLINCLUDES += ../typing
-NATIVE_ENABLED = false
+NATIVE_ENABLED = true
BYTE_ENABLED = true
-FILES[] =
- config
+CGI_FILES[] =
+ chconfig
controller
hList
list2
@@ -28,23 +30,37 @@ FILES[] =
base
main
-PROGRAM = index.cgi
+CGI_PROGRAM = index.cgi
+
+all:: $(OCamlProgram $(CGI_PROGRAM), $(CGI_FILES))
+
+CLI_FILES[] =
+ chconfig
+ controller
+ hList
+ list2
+ searchid
+ search
+ base
+ cli
+
+CLI_PROGRAM = ocamlas
+
+all:: $(OCamlProgram $(CLI_PROGRAM), $(CLI_FILES))
# OCAML_LIBS +=
# OCAML_CLIBS +=
-OCAML_OTHER_LIBS += toplevellib
+# OCAML_OTHER_LIBS += toplevellib
# OCAML_LIB_FLAGS +=
#
-.PHONY: clean all
-
-all: $(OCamlProgram $(PROGRAM), $(FILES)) modules.txt
+all:: modules.txt
modules.txt : modules-init.sh
./modules-init.sh
clean:
- rm -f *.cm[oix] *.o *.omc $(PROGRAM) *.run *~ *.annot
+ rm -f *.cm* *.o *.omc $(CGI_PROGRAM) $(CLI_PROGRAM) *.run *.opt *~ *.annot *Test-runner
.DEFAULT: all
@@ -72,8 +88,8 @@ OUNIT_LIBS[] =
base
hList
-OUnitTest(config, config)
-OUnitTest(search, search config searchid list2)
+OUnitTest(config, chconfig)
+OUnitTest(search, search chconfig searchid list2)
OUnitTest(controller, controller)
########################################################################
View
18 README.mkdn
@@ -13,34 +13,20 @@ It is similar to Hoogle, which is a Haskell API search engine.
PREREQUISITES
-------------
-* ocaml 3.11
+* ocaml 4.00.1
* omake
* findlib
* extlib
* oUnit(for unit test)
+* CamlGI
INSTALL
-------
-### 1. Download OCaml compiler version 3.11.1. ###
-
-* Do no ask me where to find it.
-* You can also use the CVS version
-
-### 2. Extract the compiler source. ###
-
-* tar zxvf ocaml-3.11.1.tar.gz
-* cd ocaml3.11.1
-
### 3. Download OCaml API search ###
* git clone git://github.com/mzp/ocaml-hoogle.git
-### 4. Build a bytecode compiler ###
-
-* ./configure
-* make core
-
### 5. Build OCaml API Search ###
* cd ocaml-hoogle
View
14 _oasis
@@ -0,0 +1,14 @@
+OASISFormat: 0.2
+Name: ocaml-hoogle
+Version: 1.0.0
+Synopsis: OCaml API Search
+Authors: MIZUNO Hiroki
+License: LGPL
+Plugins: StdFiles (0.2)
+BuildType: Custom (0.2)
+InstallType: Custom (0.2)
+XCustomBuild: yes no | omake --install; PREFIX=$prefix omake
+XCustomInstall: PREFIX=$prefix omake install
+XCustomUninstall: PREFIX=$prefix omake uninstall
+XCustomBuildClean: PREFIX=$prefix omake clean
+BuildTools: omake
View
18 base.ml
@@ -1,5 +1,5 @@
-let (@@) f g = f g
-let (+>) f g = g f
+external (@@) : ('a -> 'b) -> 'a -> 'b = "%apply"
+external (+>) : 'a -> ('a -> 'b) -> 'b = "%revapply"
let ($) f g x = f (g x)
let (!$) = Lazy.force
external id : 'a -> 'a = "%identity"
@@ -128,3 +128,17 @@ let open_in_with path f =
let undefined = Obj.magic 42
let undef = undefined
+
+let rec format_list (sep : (unit, Format.formatter, unit) format) f ppf = function
+ | [] -> ()
+ | [x] -> f ppf x
+ | x::xs ->
+ Format.fprintf ppf "@[%a@]%t%a"
+ f x
+ (fun ppf -> Format.fprintf ppf sep)
+ (format_list sep f) xs
+
+let format_ocaml_list f ppf xs =
+ Format.fprintf ppf "[ @[%a@] ]"
+ (format_list ";@ " f) xs
+
View
57 base.mli
@@ -0,0 +1,57 @@
+external ( @@ ) : ('a -> 'b) -> 'a -> 'b = "%apply"
+(** Haskell's ($) *)
+
+external ( +> ) : 'a -> ('a -> 'b) -> 'b = "%revapply"
+(** F#'s (|>) *)
+
+val ( $ ) : ('a -> 'b) -> ('c -> 'a) -> 'c -> 'b
+(** Haskell's (.) *)
+
+val ( !$ ) : 'a Lazy.t -> 'a
+(** Lazy.force *)
+
+external id : 'a -> 'a = "%identity"
+(** Identity *)
+
+val uncurry : ('a * 'b -> 'c) -> 'a -> 'b -> 'c
+val curry : ('a -> 'b -> 'c) -> 'a * 'b -> 'c
+val flip : ('a -> 'b -> 'c) -> 'b -> 'a -> 'c
+val const : 'a -> 'b -> 'a
+val sure : ('a -> 'b) -> 'a option -> 'b option
+val option : ('a -> 'b) -> 'a -> 'b option
+val maybe : ('a -> 'b) -> 'a -> [> `Error of exn | `Val of 'b ]
+val tee : ('a -> 'b) -> 'a -> 'a
+type ('a, 'b) either = Left of 'a | Right of 'b
+
+val failwithf : ('a, unit, string, unit -> 'b) format4 -> 'a
+(** failwith with formatting *)
+
+val assoc : 'a -> ('a * 'b) list -> 'b option
+(** List.assoc with option *)
+
+val string_of_list : string list -> string
+val unfold : ('a -> ('b * 'a) option) -> 'a -> 'b list
+val range : int -> int -> int list
+val interperse : 'a -> 'a list -> 'a list
+val map_accum_left : ('a -> 'b -> 'a * 'c) -> 'a -> 'b list -> 'a * 'c list
+val map_accum_right : ('a -> 'b -> 'a * 'c) -> 'a -> 'b list -> 'a * 'c list
+val filter_map : ('a -> 'b option) -> 'a list -> 'b list
+val group_by : ('a -> 'a -> bool) -> 'a list -> 'a list list
+val index : 'a -> 'a list -> int
+val string_of_char : char -> string
+val hex : int -> string
+val open_out_with : string -> (out_channel -> 'a) -> 'a
+val open_in_with : string -> (in_channel -> 'a) -> 'a
+val undefined : 'a
+val undef : 'a
+
+val format_list :
+ (unit, Format.formatter, unit) format
+ -> (Format.formatter -> 'a -> unit)
+ -> Format.formatter -> 'a list -> unit
+(** Format for lists *)
+
+val format_ocaml_list :
+ (Format.formatter -> 'a -> unit)
+ -> Format.formatter -> 'a list -> unit
+(** Format for lists in OCaml style [ a; b; ... ] *)
View
2 config.ml → chconfig.ml
@@ -32,7 +32,7 @@ let r_path =
regexp "^PATH *:: *\\(.*\\)$"
let parse_line s =
- if s = "" then
+ if s = "" || s.[0] = '#' then
()
else if string_match r_path s 0 then
path := Some (matched_group 1 s)
View
0 config.mli → chconfig.mli
File renamed without changes.
View
105 cli.ml
@@ -0,0 +1,105 @@
+open Base
+
+let q =
+ let rev_args = ref [] in
+ Arg.parse [] (fun x -> rev_args := x::!rev_args)
+ @@ Printf.sprintf "%s <query strings>" Sys.argv.(0);
+ String.concat " " @@ List.rev !rev_args
+
+let configs = Chconfig.read "modules.txt"
+
+let modules = HList.concat_map (fun {Chconfig.modules=m} -> m) configs
+
+let paths = filter_map (fun {Chconfig.path=p} -> p) configs
+
+let results, stat =
+ match Searchid.Stat.get (Search.raw_search q modules) paths with
+ | `Error exn, _ -> raise exn
+ | `Ok res, stat -> res, stat
+
+open Format
+
+let info_of_value id =
+ let _name =
+ match id with
+ | Longident.Lident x -> x
+ | Longident.Ldot (_, x) -> x
+ | _ -> "z"
+ in
+ let _, vd =
+ Env.lookup_value id !Searchid.start_env
+ in
+ vd.Types.val_type, vd.Types.val_loc
+
+let info_of_type id =
+ let _path, td = Env.lookup_type id !Searchid.start_env in
+ td
+
+let analyze_pkind (id, pkind) = match pkind with
+ | Searchid.Pvalue ->
+ `Value (id, info_of_value id)
+ | Searchid.Ptype ->
+ `Type (id, info_of_type id)
+ | Searchid.Pmodule ->
+ `Module id
+ | Searchid.Pmodtype ->
+ `ModuleType id
+ | Searchid.Pclass ->
+ `Class id
+ | Searchid.Pcltype ->
+ `ClassType id
+ | Searchid.Plabel ->
+ `Label id
+ | Searchid.Pconstructor ->
+ `Constr id
+
+(* module O = Outcometree --- We cannot do this! Since outcometree is mli only...
+*)
+open Outcometree
+open Types
+
+let format ppf = function
+ | `Value (id, (type_, _loc)) ->
+(*
+ fprintf ppf "%a@.val %a : %a@."
+ Location.print_loc loc
+ Printtyp.longident id
+ Printtyp.type_scheme type_
+*)
+ fprintf ppf "@[<2>val %a :@ %a@]"
+ Printtyp.longident id
+ Printtyp.type_scheme type_
+ | `Type (id, td) ->
+ (* To print the path name with module names,
+ we hack outcometree *)
+ let o = Printtyp.tree_of_type_declaration (Ident.create "z") td Types.Trec_first in
+ let o = match o with
+ | Osig_type (odecl, ors) ->
+ let odecl = match odecl with
+ | _name, a, b, c, d ->
+ String.concat "." (Longident.flatten id), a, b, c, d
+ in
+ Osig_type (odecl, ors)
+ | _ -> assert false
+ in
+ !Oprint.out_sig_item ppf o;
+ if td.type_manifest = None && td.type_kind = Type_abstract then
+ fprintf ppf " (* abstract *)"
+ | `Module id ->
+ fprintf ppf "module %a" Printtyp.longident id
+ | `ModuleType id ->
+ fprintf ppf "module type %a" Printtyp.longident id
+ | `Class id ->
+ fprintf ppf "class %a" Printtyp.longident id
+ | `ClassType id ->
+ fprintf ppf "class type %a" Printtyp.longident id
+ | `Label id ->
+ fprintf ppf "label %a" Printtyp.longident id
+ | `Constr id ->
+ fprintf ppf "constr %a" Printtyp.longident id
+
+let () =
+ Format.printf "%a@.%a@."
+ (format_list "@." format) (List.map analyze_pkind results)
+ Searchid.Stat.format stat
+
View
6 controller.ml
@@ -9,9 +9,9 @@ type t =
let find_package module_ configs =
let config =
List.find configs
- ~f:(fun { Config.modules=modules } -> List.mem (List.hd module_) modules)
+ ~f:(fun { Chconfig.modules=modules } -> List.mem (List.hd module_) modules)
in
- config.Config.name
+ config.Chconfig.name
let module_ =
function [] -> [""]
@@ -92,7 +92,7 @@ let pagenation ~offset ~window xs =
let available configs =
Table begin
- List.map configs ~f:begin fun { Config.name = name; modules = modules} ->
+ List.map configs ~f:begin fun { Chconfig.name = name; modules = modules} ->
["package", String name;
"modules", Table begin
List.map modules ~f:begin fun s ->
View
6 controller.mli
@@ -3,6 +3,8 @@ type t =
| Bool of bool
| Table of (string * t) list list
-val format : Config.t list -> Search.t -> (string * t) list
+val format : Chconfig.t list -> Search.t -> (string * t) list
+(** formatter for [Search.t] *)
+
val pagenation : offset:int -> window:int -> 'a list -> (string * t) list * 'a list
-val available : Config.t list -> t
+val available : Chconfig.t list -> t
View
4 list2.ml
@@ -1,6 +1,6 @@
(*************************************************************************)
(* *)
-(* Objective Caml LablTk library *)
+(* OCaml LablTk library *)
(* *)
(* Jacques Garrigue, Kyoto University RIMS *)
(* *)
@@ -12,7 +12,7 @@
(* *)
(*************************************************************************)
-(* $Id: list2.ml,v 1.9 2001/12/07 13:40:00 xleroy Exp $ *)
+(* $Id: list2.ml 11156 2011-07-27 14:17:02Z doligez $ *)
open StdLabels
View
6 main.ml
@@ -45,7 +45,7 @@ let index_page (cgi : cgi) =
cgi#template @@ template "templates/index.html"
let configs () =
- Config.read "modules.txt"
+ Chconfig.read "modules.txt"
let available_page (cgi : cgi) =
let t =
@@ -59,10 +59,10 @@ let search_page (cgi : cgi) =
configs ()
in
let modules =
- HList.concat_map (fun {Config.modules=m} -> m) configs
+ HList.concat_map (fun {Chconfig.modules=m} -> m) configs
in
let paths =
- filter_map (fun {Config.path=p} -> p) configs
+ filter_map (fun {Chconfig.path=p} -> p) configs
in
let page, content =
Search.search (cgi#param "q") modules paths
View
1 modules-init.sh
@@ -2,6 +2,7 @@
cat <<EOF > modules.txt
- stdlib
+# Thread realted modules are found in the next PATH spec. The others are found in the default one.
PATH:: `ocamlfind query threads.posix`
Pervasives
Arg
View
6 opam/ocaml-hoogle.1.0.0/descr
@@ -0,0 +1,6 @@
+OCaml API Search
+OCaml API search allows you to search many standard O'Caml libraries
+by either function name, or by approximate type signature. It is based
+on O'Caml Browser.
+
+It is similar to Hoogle, which is a Haskell API search engine.
View
12 opam/ocaml-hoogle.1.0.0/opam
@@ -0,0 +1,12 @@
+opam-version: "1"
+maintainer: "jun.furuse@gmail.com"
+build: [
+ ["ocaml" "setup.ml" "-configure" "--prefix" "%{prefix}%"]
+ ["ocaml" "setup.ml" "-build"]
+ ["ocaml" "setup.ml" "-install"]
+]
+remove: [
+ ["ocaml" "setup.ml" "-uninstall"]
+]
+depends: [ "ocamlfind" "omake" "ounit" "CamlGI" "extlib"]
+ocaml-version: [= "4.00.1"]
View
6 opam/template/descr
@@ -0,0 +1,6 @@
+OCaml API Search
+OCaml API search allows you to search many standard O'Caml libraries
+by either function name, or by approximate type signature. It is based
+on O'Caml Browser.
+
+It is similar to Hoogle, which is a Haskell API search engine.
View
2 opam/template/opam
@@ -0,0 +1,2 @@
+depends: [ "ocamlfind" "omake" "ounit" "CamlGI" "extlib"]
+ocaml-version: [= "4.00.1"]
View
28 scrape-modules.sh
@@ -0,0 +1,28 @@
+#!/bin/sh
+
+stdlib=`ocamlfind query unix`
+stdlib_packs=""
+
+# Package names without '.'
+for l in `ocamlfind list | sed -e 's/ .*//' | grep -v '\.'`
+do
+ dir=`ocamlfind query $l`
+ if [ "$stdlib" = "$dir" ]; then
+ stdlib_packs="$stdlib_packs $l"
+ else # skip if dir is as same as stdlib
+ echo "- $l"
+ echo "PATH:: $dir"
+ ls $dir/*.cmi 2> /dev/null | sed -e 's/.*\///g' -e 's/\.cmi//' -e 's/^./\u&/'
+ fi
+done
+
+echo "- stdlib"
+echo "# Thread realted modules are found in the next PATH spec. The others are found in the default one."
+echo "PATH:: $stdlib/threads"
+ls $stdlib/*.cmi | sed -e 's/.*\///g' -e 's/\.cmi//' -e 's/^./\u&/'
+for p in $stdlib_packs
+do
+ if [ -d "$stdlib/$p" ]; then
+ ls $stdlib/$p/*.cmi | sed -e 's/.*\///g' -e 's/\.cmi//' -e 's/^./\u&/'
+ fi
+done
View
73 search.ml
@@ -19,6 +19,38 @@ type t = {
let init_modules =
!Searchid.module_list
+module Toploop = struct
+ open Config
+ open Misc
+
+ let init_path () =
+ let dirs =
+ if !Clflags.use_threads then "+threads" :: !Clflags.include_dirs
+ else if !Clflags.use_vmthreads then "+vmthreads" :: !Clflags.include_dirs
+ else !Clflags.include_dirs in
+ let exp_dirs =
+ List.map (expand_directory Config.standard_library) dirs in
+ load_path := "" :: List.rev_append exp_dirs (Clflags.std_include_dir ());
+ Env.reset_cache ()
+
+ let set_paths () =
+ init_path ();
+ (* Add whatever -I options have been specified on the command line,
+ but keep the directories that user code linked in with ocamlmktop
+ may have added to load_path. *)
+ load_path := !load_path @ [Filename.concat Config.standard_library "camlp4"];
+ load_path := "" :: (List.rev !Clflags.include_dirs @ !load_path);
+ Dll.add_path !load_path;
+end
+
+module Topdirs = struct
+ open Misc
+ let dir_directory s =
+ let d = expand_directory Config.standard_library s in
+ Config.load_path := d :: !Config.load_path;
+ Dll.add_path [d]
+end
+
let init modules paths =
(* initialize *)
Toploop.set_paths ();
@@ -42,26 +74,27 @@ let string_of_sign sign =
Format.pp_print_flush ppf ();
Buffer.contents b
+(* CR jfuruse: We can get vd.val_type and print it *)
let string_of_value id =
let name =
match id with
- Longident.Lident x -> x
- | Longident.Ldot (_, x) -> x
- | _ -> "z"
+ | Longident.Lident x -> x
+ | Longident.Ldot (_, x) -> x
+ | _ -> "z"
in
let _, vd =
Env.lookup_value id !Searchid.start_env
in
- Str.replace_first (Str.regexp "=[^=]*$") "" @@
- Str.replace_first (Str.regexp "^[^:]*: *") ""
- (string_of_sign [Types.Tsig_value (Ident.create name, vd)])
+ Str.replace_first (Str.regexp "=[^=]*$") "" (* remove equality of external *)
+ @@ Str.replace_first (Str.regexp "^[^:]*: *") "" (* remove "val id :" "exteranl id :" *)
+ (string_of_sign [Types.Sig_value (Ident.create name, vd)])
let ident_of_path ~default = function
Path.Pident i -> i
| Path.Pdot (_, s, _) -> Ident.create s
| Path.Papply _ -> Ident.create default
-let dummy_item = Tsig_modtype (Ident.create "dummy", Tmodtype_abstract)
+let dummy_item = Sig_modtype (Ident.create "dummy", Modtype_abstract)
let string_of_type_decl path =
let td =
@@ -78,12 +111,12 @@ let string_of_type_decl path =
clt = Env.find_cltype path !Searchid.start_env
in
string_of_sign
- [Tsig_cltype (ident_of_path path ~default:"ct", clt, Trec_first);
+ [Sig_class_type (ident_of_path path ~default:"ct", clt, Trec_first);
dummy_item; dummy_item]
| _ -> raise Not_found
with Not_found ->
string_of_sign
- [Tsig_type(ident_of_path path ~default:"t", td, Trec_first)]
+ [Sig_type(ident_of_path path ~default:"t", td, Trec_first)]
let string_of_type id =
let strip s =
@@ -97,6 +130,7 @@ let string_of_type id =
strip @@ string_of_type_decl path
+(** Wrap infix/perfix operators with "(" and ")" *)
let infix s =
if Str.string_match (Str.regexp "[!$%&*+-./:<=>?@^|~]+") s 0 then
Printf.sprintf "(%s)" s
@@ -115,6 +149,7 @@ let to_result (id, kind) =
in
match kind with
Searchid.Pvalue ->
+ (* We can apply infix only against the last elem *)
{kind = Value (string_of_value id); id = List.map ~f:infix id'}
| Searchid.Ptype ->
{ t with kind = Type (string_of_type id) }
@@ -129,17 +164,13 @@ let to_result (id, kind) =
| _ ->
t
-let lift f s =
- s
- +> sure f
- +> List.map ~f:to_result
+let raw_search s modules paths =
+ init modules paths;
+ List.rev @@ ExtList.List.unique @@ List.rev (* unique removes first appearances *)
+ @@ sure (Searchid.search_string_type ~mode:`Exact) s
+ @ sure (Searchid.search_string_type ~mode:`Included) s
+ @ sure Searchid.search_pattern_symbol s
let search s modules paths =
- init modules paths;
- List.rev @@
- ExtList.List.unique @@
- List.rev @@
- lift (Searchid.search_string_type ~mode:`Exact) s
- @ lift (Searchid.search_string_type ~mode:`Included) s
- @ lift Searchid.search_pattern_symbol s
-
+ List.map ~f:to_result
+ @@ raw_search s modules paths
View
7 search.mli
@@ -1,6 +1,6 @@
type kind =
- Value of string
- | Type of string
+ Value of string (** type of the value *)
+ | Type of string (** type def. "" means abstract. *)
| Module
| ModuleType
| Class
@@ -8,8 +8,9 @@ type kind =
| Other
type t = {
- id : string list;
+ id : string list; (** path of the object. ex. ["String"; "length"] for String.length. *)
kind : kind
}
val search : string -> string list -> string list -> t list
+val raw_search : string -> string list -> string list -> (Longident.t * Searchid.pkind) list
View
3 searchTest.ml
@@ -23,8 +23,9 @@ let _ = begin "search.ml" >::: [
end;
"type" >:: begin fun () ->
ok {id=["String"; "t"]; kind = Type "string"} @@
- List.nth (search "t" ["String"] []) 1
+ List.nth (search "t" ["String"] []) 0
end;
+ (* CR jfuruse: We fail here *)
"module" >:: begin fun () ->
ok [{id=["String"]; kind = Module}] @@
search "String" ["String"] []
View
159 searchid.ml
@@ -1,6 +1,6 @@
(*************************************************************************)
(* *)
-(* Objective Caml LablTk library *)
+(* OCaml LablTk library *)
(* *)
(* Jacques Garrigue, Kyoto University RIMS *)
(* *)
@@ -12,8 +12,9 @@
(* *)
(*************************************************************************)
-(* $Id: searchid.ml,v 1.25 2008/07/09 14:03:08 mauny Exp $ *)
+(* $Id: searchid.ml 12511 2012-05-30 13:29:48Z lefessan $ *)
+open Asttypes
open StdLabels
open Location
open Longident
@@ -24,6 +25,46 @@ open Env
open Btype
open Ctype
+module Stat = struct
+ (** search statistics *)
+ let type_included = ref 0
+ let type_exact = ref 0
+ let symbol = ref 0
+
+ let reset () =
+ type_included := 0;
+ type_exact := 0;
+ symbol := 0;
+ ()
+
+ type t = {
+ type_included : int;
+ type_exact : int;
+ symbol : int;
+ time : float
+ }
+
+ let format ppf t =
+ Format.fprintf ppf "%d type checks (inclusion: %d, exact: %d), %d symbol checks (%0.2f secs)"
+ (t.type_included + t.type_exact)
+ t.type_included
+ t.type_exact
+ t.symbol
+ t.time
+
+ let get f v =
+ reset ();
+ let start = Unix.gettimeofday () in
+ let res = try `Ok (f v) with e -> `Error e in
+ let end_ = Unix.gettimeofday () in
+ res, { type_included = !type_included;
+ type_exact = !type_exact;
+ symbol = !symbol;
+ time = end_ -. start
+ }
+
+end
+
(* only initial here, but replaced by Pervasives later *)
let start_env = ref initial
let module_list = ref []
@@ -101,7 +142,7 @@ let rec all_args ty =
let rec equal ~prefix t1 t2 =
match (repr t1).desc, (repr t2).desc with
- Tvar, Tvar -> true
+ Tvar _, Tvar _ -> true
| Tvariant row1, Tvariant row2 ->
let row1 = row_repr row1 and row2 = row_repr row2 in
let fields1 = filter_row_fields false row1.row_fields
@@ -144,7 +185,7 @@ let get_options = List.filter ~f:is_opt
let rec included ~prefix t1 t2 =
match (repr t1).desc, (repr t2).desc with
- Tvar, _ -> true
+ Tvar _, _ -> true
| Tvariant row1, Tvariant row2 ->
let row1 = row_repr row1 and row2 = row_repr row2 in
let fields1 = filter_row_fields false row1.row_fields
@@ -213,15 +254,16 @@ let get_fields ~prefix ~sign self =
let rec search_type_in_signature t ~sign ~prefix ~mode =
let matches = match mode with
- `Included -> included t ~prefix
- | `Exact -> equal t ~prefix
+ `Included -> incr Stat.type_included; included t ~prefix
+ | `Exact -> incr Stat.type_exact; equal t ~prefix
and lid_of_id id = mklid (prefix @ [Ident.name id]) in
List2.flat_map sign ~f:
begin fun item -> match item with
- Tsig_value (id, vd) ->
+ Sig_value (id, vd) ->
if matches vd.val_type then [lid_of_id id, Pvalue] else []
- | Tsig_type (id, td, _) ->
+ | Sig_type (id, td, _) ->
if
+ matches (newconstr (Pident id) td.type_params) ||
begin match td.type_manifest with
None -> false
| Some t -> matches t
@@ -229,28 +271,32 @@ let rec search_type_in_signature t ~sign ~prefix ~mode =
begin match td.type_kind with
Type_abstract -> false
| Type_variant l ->
- List.exists l ~f:(fun (_, l) -> List.exists l ~f:matches)
+ List.exists l ~f:
+ begin fun (_, l, r) ->
+ List.exists l ~f:matches ||
+ match r with None -> false | Some x -> matches x
+ end
| Type_record(l, rep) ->
List.exists l ~f:(fun (_, _, t) -> matches t)
end
then [lid_of_id id, Ptype] else []
- | Tsig_exception (id, l) ->
- if List.exists l ~f:matches
+ | Sig_exception (id, l) ->
+ if List.exists l.exn_args ~f:matches
then [lid_of_id id, Pconstructor]
else []
- | Tsig_module (id, Tmty_signature sign, _) ->
+ | Sig_module (id, Mty_signature sign, _) ->
search_type_in_signature t ~sign ~mode
~prefix:(prefix @ [Ident.name id])
- | Tsig_module _ -> []
- | Tsig_modtype _ -> []
- | Tsig_class (id, cl, _) ->
+ | Sig_module _ -> []
+ | Sig_modtype _ -> []
+ | Sig_class (id, cl, _) ->
let self = self_type cl.cty_type in
if matches self
|| (match cl.cty_new with None -> false | Some ty -> matches ty)
(* || List.exists (get_fields ~prefix ~sign self)
~f:(fun (_,_,ty_field) -> matches ty_field) *)
then [lid_of_id id, Pclass] else []
- | Tsig_cltype (id, cl, _) ->
+ | Sig_class_type (id, cl, _) ->
let self = self_type cl.clty_type in
if matches self
(* || List.exists (get_fields ~prefix ~sign self)
@@ -268,7 +314,7 @@ let search_all_types t ~mode =
begin fun modname ->
let mlid = Lident modname in
try match lookup_module mlid initial with
- _, Tmty_signature sign ->
+ _, Mty_signature sign ->
List2.flat_map tl
~f:(search_type_in_signature ~sign ~prefix:[modname] ~mode)
| _ -> []
@@ -281,12 +327,15 @@ let search_string_type text ~mode =
try
let sexp = Parse.interface (Lexing.from_string ("val z : " ^ text)) in
let sign =
- try Typemod.transl_signature !start_env sexp with _ ->
+ try (Typemod.transl_signature !start_env sexp).sig_type with _ ->
+ (* CR jfuruse: No open of nested modules?
+ A.B.t cannot be found by "t".
+ *)
let env = List.fold_left !module_list ~init:initial ~f:
begin fun acc m ->
try open_pers_signature m acc with Env.Error _ -> acc
end in
- try Typemod.transl_signature env sexp
+ try (Typemod.transl_signature env sexp).sig_type
with Env.Error err -> []
| Typemod.Error (l,_) ->
let start_c = l.loc_start.Lexing.pos_cnum in
@@ -297,7 +346,7 @@ let search_string_type text ~mode =
let end_c = l.loc_end.Lexing.pos_cnum in
raise (Error (start_c - 8, end_c - 8))
in match sign with
- [Tsig_value (_, vd)] ->
+ [ Sig_value (_, vd) ] ->
search_all_types vd.val_type ~mode
| _ -> []
with
@@ -343,6 +392,10 @@ let rec check_match ~pattern s =
| x::l, y::l' when x == y -> check_match ~pattern:l l'
| _ -> false
+let check_match ~pattern s =
+ incr Stat.symbol;
+ check_match ~pattern s
+
let search_pattern_symbol text =
if text = "" then [] else
let pattern = explode text in
@@ -350,20 +403,20 @@ let search_pattern_symbol text =
let l = List.map !module_list ~f:
begin fun modname -> Lident modname,
try match lookup_module (Lident modname) initial with
- _, Tmty_signature sign ->
+ _, Mty_signature sign ->
List2.flat_map sign ~f:
begin function
- Tsig_value (i, _) when check i -> [i, Pvalue]
- | Tsig_type (i, _, _) when check i -> [i, Ptype]
- | Tsig_exception (i, _) when check i -> [i, Pconstructor]
- | Tsig_module (i, _, _) when check i -> [i, Pmodule]
- | Tsig_modtype (i, _) when check i -> [i, Pmodtype]
- | Tsig_class (i, cl, _) when check i
+ Sig_value (i, _) when check i -> [i, Pvalue]
+ | Sig_type (i, _, _) when check i -> [i, Ptype]
+ | Sig_exception (i, _) when check i -> [i, Pconstructor]
+ | Sig_module (i, _, _) when check i -> [i, Pmodule]
+ | Sig_modtype (i, _) when check i -> [i, Pmodtype]
+ | Sig_class (i, cl, _) when check i
|| List.exists
(get_fields ~prefix:[modname] ~sign (self_type cl.cty_type))
~f:(fun (name,_,_) -> check_match ~pattern (explode name))
-> [i, Pclass]
- | Tsig_cltype (i, cl, _) when check i
+ | Sig_class_type (i, cl, _) when check i
|| List.exists
(get_fields ~prefix:[modname] ~sign (self_type cl.clty_type))
~f:(fun (name,_,_) -> check_match ~pattern (explode name))
@@ -371,7 +424,13 @@ let search_pattern_symbol text =
| _ -> []
end
| _ -> []
- with Env.Error _ -> []
+ with
+ | Env.Error _ ->
+ Format.eprintf "Warning: lookup_module %s failed. Check the library.@." modname;
+ []
+ | Not_found ->
+ Format.eprintf "Error: module %s was not found. Check modules.txt.@." modname;
+ assert false
end
in
List2.flat_map l ~f:
@@ -406,15 +465,15 @@ open Parsetree
let rec bound_variables pat =
match pat.ppat_desc with
- Ppat_any | Ppat_constant _ | Ppat_type _ -> []
- | Ppat_var s -> [s]
- | Ppat_alias (pat,s) -> s :: bound_variables pat
+ Ppat_any | Ppat_constant _ | Ppat_type _ | Ppat_unpack _ -> []
+ | Ppat_var s -> [s.txt]
+ | Ppat_alias (pat,s) -> s.txt :: bound_variables pat
| Ppat_tuple l -> List2.flat_map l ~f:bound_variables
| Ppat_construct (_,None,_) -> []
| Ppat_construct (_,Some pat,_) -> bound_variables pat
| Ppat_variant (_,None) -> []
| Ppat_variant (_,Some pat) -> bound_variables pat
- | Ppat_record l ->
+ | Ppat_record (l, _) ->
List2.flat_map l ~f:(fun (_,pat) -> bound_variables pat)
| Ppat_array l ->
List2.flat_map l ~f:bound_variables
@@ -432,7 +491,7 @@ let search_structure str ~name ~kind ~prefix =
List.fold_left ~init:[] str ~f:
begin fun acc item ->
match item.pstr_desc with
- Pstr_module (s, mexp) when s = modu ->
+ Pstr_module (s, mexp) when s.txt = modu ->
loc := mexp.pmod_loc.loc_start.Lexing.pos_cnum;
begin match mexp.pmod_desc with
Pmod_structure str -> str
@@ -452,27 +511,27 @@ let search_structure str ~name ~kind ~prefix =
then loc := pat.ppat_loc.loc_start.Lexing.pos_cnum
end;
false
- | Pstr_primitive (s, _) when kind = Pvalue -> name = s
+ | Pstr_primitive (s, _) when kind = Pvalue -> name = s.txt
| Pstr_type l when kind = Ptype ->
List.iter l ~f:
begin fun (s, td) ->
- if s = name then loc := td.ptype_loc.loc_start.Lexing.pos_cnum
+ if s.txt = name then loc := td.ptype_loc.loc_start.Lexing.pos_cnum
end;
false
- | Pstr_exception (s, _) when kind = Pconstructor -> name = s
- | Pstr_module (s, _) when kind = Pmodule -> name = s
- | Pstr_modtype (s, _) when kind = Pmodtype -> name = s
+ | Pstr_exception (s, _) when kind = Pconstructor -> name = s.txt
+ | Pstr_module (s, _) when kind = Pmodule -> name = s.txt
+ | Pstr_modtype (s, _) when kind = Pmodtype -> name = s.txt
| Pstr_class l when kind = Pclass || kind = Ptype || kind = Pcltype ->
List.iter l ~f:
begin fun c ->
- if c.pci_name = name
+ if c.pci_name.txt = name
then loc := c.pci_loc.loc_start.Lexing.pos_cnum
end;
false
| Pstr_class_type l when kind = Pcltype || kind = Ptype ->
List.iter l ~f:
begin fun c ->
- if c.pci_name = name
+ if c.pci_name.txt = name
then loc := c.pci_loc.loc_start.Lexing.pos_cnum
end;
false
@@ -482,6 +541,8 @@ let search_structure str ~name ~kind ~prefix =
!loc
let search_signature sign ~name ~kind ~prefix =
+ ignore (name = "");
+ ignore (prefix = [""]);
let loc = ref 0 in
let rec search_module_type sign ~prefix =
match prefix with [] -> sign
@@ -490,7 +551,7 @@ let search_signature sign ~name ~kind ~prefix =
List.fold_left ~init:[] sign ~f:
begin fun acc item ->
match item.psig_desc with
- Psig_module (s, mtyp) when s = modu ->
+ Psig_module (s, mtyp) when s.txt = modu ->
loc := mtyp.pmty_loc.loc_start.Lexing.pos_cnum;
begin match mtyp.pmty_desc with
Pmty_signature sign -> sign
@@ -503,27 +564,27 @@ let search_signature sign ~name ~kind ~prefix =
List.iter (search_module_type sign ~prefix) ~f:
begin fun item ->
if match item.psig_desc with
- Psig_value (s, _) when kind = Pvalue -> name = s
+ Psig_value (s, _) when kind = Pvalue -> name = s.txt
| Psig_type l when kind = Ptype ->
List.iter l ~f:
begin fun (s, td) ->
- if s = name then loc := td.ptype_loc.loc_start.Lexing.pos_cnum
+ if s.txt = name then loc := td.ptype_loc.loc_start.Lexing.pos_cnum
end;
false
- | Psig_exception (s, _) when kind = Pconstructor -> name = s
- | Psig_module (s, _) when kind = Pmodule -> name = s
- | Psig_modtype (s, _) when kind = Pmodtype -> name = s
+ | Psig_exception (s, _) when kind = Pconstructor -> name = s.txt
+ | Psig_module (s, _) when kind = Pmodule -> name = s.txt
+ | Psig_modtype (s, _) when kind = Pmodtype -> name = s.txt
| Psig_class l when kind = Pclass || kind = Ptype || kind = Pcltype ->
List.iter l ~f:
begin fun c ->
- if c.pci_name = name
+ if c.pci_name.txt = name
then loc := c.pci_loc.loc_start.Lexing.pos_cnum
end;
false
| Psig_class_type l when kind = Ptype || kind = Pcltype ->
List.iter l ~f:
begin fun c ->
- if c.pci_name = name
+ if c.pci_name.txt = name
then loc := c.pci_loc.loc_start.Lexing.pos_cnum
end;
false
View
12 searchid.mli
@@ -14,6 +14,18 @@
(* $Id: searchid.mli,v 1.6 2002/07/25 22:51:47 garrigue Exp $ *)
+module Stat : sig
+ (** search statistics *)
+ type t = {
+ type_included : int;
+ type_exact : int;
+ symbol : int;
+ time : float;
+ }
+ val format : Format.formatter -> t -> unit
+ val get : ('a -> 'b) -> 'a -> [> `Error of exn | `Ok of 'b ] * t
+end
+
val start_env : Env.t ref
val module_list : string list ref
val longident_of_path : Path.t ->Longident.t
View
5,590 setup.ml
5,590 additions, 0 deletions not shown because the diff is too large. Please use a local Git client to view these changes.

0 comments on commit ae4c78c

Please sign in to comment.
Something went wrong with that request. Please try again.