From 583b55f52744e4fca597797569109314d5263e0f Mon Sep 17 00:00:00 2001 From: Jeremie Dimino Date: Sun, 13 Nov 2016 11:13:47 +0000 Subject: [PATCH] findlib support --- Makefile | 2 + build.ml | 5 +- src/findlib.ml | 124 +++++++++++++++++++++++++++++++++++++++++++++ src/findlib.mli | 5 ++ src/import.ml | 33 ++++++------ src/loc.ml | 13 +++++ src/loc.mli | 7 +++ src/meta.ml | 25 ++++++++- src/meta.mli | 6 ++- src/meta_lexer.mll | 2 +- 10 files changed, 199 insertions(+), 23 deletions(-) create mode 100644 Makefile create mode 100644 src/findlib.ml create mode 100644 src/findlib.mli diff --git a/Makefile b/Makefile new file mode 100644 index 00000000..dd3dce72 --- /dev/null +++ b/Makefile @@ -0,0 +1,2 @@ +all: + ocaml build.ml diff --git a/build.ml b/build.ml index dd2b453a..a10c6982 100644 --- a/build.ml +++ b/build.ml @@ -10,6 +10,9 @@ let modules = [ "Import" ; "Clflags" ; "Loc" + ; "Meta_lexer" + ; "Meta" + ; "Findlib" ; "Sexp" ; "Sexp_lexer" ; "Future" @@ -20,7 +23,7 @@ let modules = ; "Jbuild" ] -let lexers = [ "sexp_lexer" ] +let lexers = [ "sexp_lexer"; "meta_lexer" ] let path = match Sys.getenv "PATH" with diff --git a/src/findlib.ml b/src/findlib.ml new file mode 100644 index 00000000..64a4edb0 --- /dev/null +++ b/src/findlib.ml @@ -0,0 +1,124 @@ +open Import + +module Preds : sig + type t + + val make : string list -> t + + val is_subset : t -> subset:t -> bool + val intersects : t -> t -> bool +end = struct + type t = string list + + let make l = List.sort l ~cmp:String.compare + + let rec is_subset t ~subset = + match t, subset with + | _, [] -> true + | [], _ :: _ -> false + | x1 :: l1, x2 :: l2 -> + let d = String.compare x1 x2 in + if d = 0 then + is_subset l1 ~subset:l2 + else if d < 0 then + is_subset l1 ~subset + else + is_subset t ~subset:l2 + + let rec intersects a b = + match a, b with + | [], _ | _, [] -> false + | x1 :: l1, x2 :: l2 -> + let d = String.compare x1 x2 in + if d = 0 then + true + else if d < 0 then + intersects l1 b + else + intersects a l2 +end + +type rule = + { preds_required : Preds.t + ; preds_forbidden : Preds.t + ; action : Meta.action + ; value : string + } + +type package = + { name : string + ; vars : rule list (* In reverse order of the META file *) String_map.t + } + +let db = Hashtbl.create 1024 + +let make_rule ((_, preds, action, value) : META.var) = + let preds_required, preds_forbidden = + List.partition_map preds ~f:(function + | P x -> Inl x + | A x -> Inr x) + in + { preds_required = Preds.make preds_required + ; preds_forbidden = Preds.make preds_forbidden + ; action + ; value + } + +let acknowledge_meta (meta : META.t) = + let pkgs = META.flatten meta in + List.iter pkgs ~f:(fun (name, vars) -> + let vars = + List.fold_left vars ~init:String_map.empty ~f:(fun acc ((vname, _, _, _) as var) -> + let rule = make_rule var in + let rules = + match String_map.find acc vname with + | exception Not_found -> [] + | rules -> rules + in + String_map.add acc ~key:vname ~data:(rule :: rules)) + in + Hashtbl.add db name { name; vars }) + +let findlib_dir = ref "" + +exception Package_not_found of string + +let root_pkg s = + match String.index s '.' with + | exception Not_found -> s + | i -> String.sub s ~pos:0 ~len:i + +let rec get_pkg name = + match Hashtbl.find db pkg with + | exception Not_found -> + let root = root_pkg name in + let fn = !findlib_dir ^/ root ^/ "META" in + if Sys.file_exists fn then begin + acknowledge_meta { name = root; entries = META.load fn }; + get_pkg name + end else + raise (Package_not_found name) + | pkg -> pkg + +let rec interpret_rules rules ~preds = + match rules with + | [] -> None + | rule :: rules -> + if Preds.is_subset preds ~subset:rule.preds_required && + not (Preds.intersects preds rule.preds_forbidden) then + match rule.action with + | Set -> Some rule.value + | Add -> + match interpret_rules rules ~preds with + | None -> Some rule.value + | Some v -> Some (v ^ " " rule.value) + else + interpret_rules rules ~preds + +let get_var pkg ~preds var = + match String_map.find pkg.vars var with + | exception Not_found -> None + | rules -> interpret_rules rules ~preds + +let query ~pkg ~preds ~var = + get_var (get_pkg pkg) ~preds:(Preds.make preds) var diff --git a/src/findlib.mli b/src/findlib.mli new file mode 100644 index 00000000..a197c3d1 --- /dev/null +++ b/src/findlib.mli @@ -0,0 +1,5 @@ +(** Findlib database *) + +exception Package_not_found of string + +val query : pkg:string -> preds:string list -> var:string -> string option diff --git a/src/import.ml b/src/import.ml index aa2c1996..ef96321c 100644 --- a/src/import.ml +++ b/src/import.ml @@ -6,6 +6,10 @@ include MoreLabels module String_set = Set.Make(String) module String_map = Map.Make(String) +type ('a, 'b) either = + | Inl of 'a + | Inr of 'b + module List = struct include ListLabels @@ -18,6 +22,17 @@ module List = struct | Some x -> x :: filter_map l ~f let concat_map l ~f = concat (map l ~f) + + let partition_map = + let rec loop l accl accr ~f = + match l with + | [] -> (List.rev accl, List.rev accr) + | x :: l -> + match f x with + | Inl y -> loop l (y :: accl) accr ~f + | Inr y -> loop l accl (y :: accr) ~f + in + fun l ~f -> loop l [] [] ~f end type ('a, 'b) eq = @@ -46,21 +61,3 @@ let lines_of_file fn = | line -> loop ic (line :: acc) in with_file_in fn ~f:(fun ic -> loop ic []) - -type location = - { start : Lexing.position - ; stop : Lexing.position - } - -let lexeme_loc lb = - { start = Lexing.lexeme_start lb - ; stop = Lexing.lexeme_stop lb - } - -exception File_error of location * string - -let file_error ~loc fmt = - Printf.ksprintf (fun msg -> raise (File_error (loc, msg))) fmt - -let lex_error lb fmt = - file_error ~loc:(lexeme_loc lb) fmt diff --git a/src/loc.ml b/src/loc.ml index 91e3160b..e51ce2df 100644 --- a/src/loc.ml +++ b/src/loc.ml @@ -2,3 +2,16 @@ type t = { start : Lexing.position ; stop : Lexing.position } + +let of_lexbuf lb = + { start = Lexing.lexeme_start lb + ; stop = Lexing.lexeme_stop lb + } + +exception Error of t * string + +let fail t fmt = + Printf.ksprintf (fun msg -> raise (File_error (t, msg))) fmt + +let fail_lex lb fmt = + fail (of_lexbuf lb) fmt diff --git a/src/loc.mli b/src/loc.mli index 91e3160b..c737af12 100644 --- a/src/loc.mli +++ b/src/loc.mli @@ -2,3 +2,10 @@ type t = { start : Lexing.position ; stop : Lexing.position } + +val of_lexbuf : Lexing.lexbuf -> t + +exception Error of t * string + +val fail : t -> string -> _ +val fail_lex : Lexing.lexbuf -> string -> _ diff --git a/src/meta.ml b/src/meta.ml index 4f5ac2cd..f967a125 100644 --- a/src/meta.ml +++ b/src/meta.ml @@ -7,9 +7,11 @@ type t = and entry = | Comment of string - | Var of string * predicate list * action * string + | Var of var | Package of t +and var = string * predicate list * action * string + and action = Set | Add and predicate = @@ -17,7 +19,7 @@ and predicate = | A of string module Parse = struct - let error = lex_error + let error = Loc.fail_lex let next = Meta_lexer.token @@ -93,3 +95,22 @@ end let load fn = with_lexbuf_from_file fn ~f:(fun lb -> Parse.entries lb 0 []) + +let flatten t = + let rec loop path acc_vars acc_pkgs entries = + match entries with + | [] -> (List.rev acc_vars, acc_pkgs) + | entry :: rest -> + match entry with + | Comment _ -> + loop path acc_vars acc_pkgs rest + | Var v -> + loop path (v :: acc_vars) acc_pkgs rest + | Package { name; entries } -> + let sub_path = sprintf "%s.%s" path name in + let sub_vars, acc_pkgs = loop sub_path [] acc_pkgs entries in + let acc_pkgs = (sub_path, sub_vars) :: acc_pkgs in + loop path acc_vars acc_pkgs rest + in + let vars, pkgs = loop t.name [] [] t.entries in + (t.name, vars) :: pkgs diff --git a/src/meta.mli b/src/meta.mli index 18ac0c24..33337b34 100644 --- a/src/meta.mli +++ b/src/meta.mli @@ -9,9 +9,11 @@ type t = and entry = | Comment of string - | Var of string * predicate list * action * string + | Var of var | Package of t +and var = string * predicate list * action * string + and action = Set | Add and predicate = @@ -19,3 +21,5 @@ and predicate = | A of string (** Absent *) val load : string -> entry list + +val flatten : t -> (string * var list) list diff --git a/src/meta_lexer.mll b/src/meta_lexer.mll index a9f38984..564a766a 100644 --- a/src/meta_lexer.mll +++ b/src/meta_lexer.mll @@ -36,4 +36,4 @@ rule token = parse | '=' { Equal } | "+=" { Plus_equal } | eof { Eof } - | _ { lex_error lexbuf "invalid character" } + | _ { Loc.fail_lex lexbuf "invalid character" }