findlib support

Makefile

@@ -0,0 +1,2 @@
+all:
+	ocaml build.ml

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

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

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

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

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

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 -> _

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

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

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" }