findlib support
This commit is contained in:
parent
de3314049f
commit
583b55f527
5
build.ml
5
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
|
||||
|
|
|
@ -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
|
|
@ -0,0 +1,5 @@
|
|||
(** Findlib database *)
|
||||
|
||||
exception Package_not_found of string
|
||||
|
||||
val query : pkg:string -> preds:string list -> var:string -> string option
|
|
@ -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
|
||||
|
|
13
src/loc.ml
13
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
|
||||
|
|
|
@ -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 -> _
|
||||
|
|
25
src/meta.ml
25
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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -36,4 +36,4 @@ rule token = parse
|
|||
| '=' { Equal }
|
||||
| "+=" { Plus_equal }
|
||||
| eof { Eof }
|
||||
| _ { lex_error lexbuf "invalid character" }
|
||||
| _ { Loc.fail_lex lexbuf "invalid character" }
|
||||
|
|
Loading…
Reference in New Issue