findlib support
This commit is contained in:
parent
de3314049f
commit
583b55f527
5
build.ml
5
build.ml
|
@ -10,6 +10,9 @@ let modules =
|
||||||
[ "Import"
|
[ "Import"
|
||||||
; "Clflags"
|
; "Clflags"
|
||||||
; "Loc"
|
; "Loc"
|
||||||
|
; "Meta_lexer"
|
||||||
|
; "Meta"
|
||||||
|
; "Findlib"
|
||||||
; "Sexp"
|
; "Sexp"
|
||||||
; "Sexp_lexer"
|
; "Sexp_lexer"
|
||||||
; "Future"
|
; "Future"
|
||||||
|
@ -20,7 +23,7 @@ let modules =
|
||||||
; "Jbuild"
|
; "Jbuild"
|
||||||
]
|
]
|
||||||
|
|
||||||
let lexers = [ "sexp_lexer" ]
|
let lexers = [ "sexp_lexer"; "meta_lexer" ]
|
||||||
|
|
||||||
let path =
|
let path =
|
||||||
match Sys.getenv "PATH" with
|
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_set = Set.Make(String)
|
||||||
module String_map = Map.Make(String)
|
module String_map = Map.Make(String)
|
||||||
|
|
||||||
|
type ('a, 'b) either =
|
||||||
|
| Inl of 'a
|
||||||
|
| Inr of 'b
|
||||||
|
|
||||||
module List = struct
|
module List = struct
|
||||||
include ListLabels
|
include ListLabels
|
||||||
|
|
||||||
|
@ -18,6 +22,17 @@ module List = struct
|
||||||
| Some x -> x :: filter_map l ~f
|
| Some x -> x :: filter_map l ~f
|
||||||
|
|
||||||
let concat_map l ~f = concat (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
|
end
|
||||||
|
|
||||||
type ('a, 'b) eq =
|
type ('a, 'b) eq =
|
||||||
|
@ -46,21 +61,3 @@ let lines_of_file fn =
|
||||||
| line -> loop ic (line :: acc)
|
| line -> loop ic (line :: acc)
|
||||||
in
|
in
|
||||||
with_file_in fn ~f:(fun ic -> loop ic [])
|
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
|
{ start : Lexing.position
|
||||||
; stop : 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
|
{ start : Lexing.position
|
||||||
; stop : 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 =
|
and entry =
|
||||||
| Comment of string
|
| Comment of string
|
||||||
| Var of string * predicate list * action * string
|
| Var of var
|
||||||
| Package of t
|
| Package of t
|
||||||
|
|
||||||
|
and var = string * predicate list * action * string
|
||||||
|
|
||||||
and action = Set | Add
|
and action = Set | Add
|
||||||
|
|
||||||
and predicate =
|
and predicate =
|
||||||
|
@ -17,7 +19,7 @@ and predicate =
|
||||||
| A of string
|
| A of string
|
||||||
|
|
||||||
module Parse = struct
|
module Parse = struct
|
||||||
let error = lex_error
|
let error = Loc.fail_lex
|
||||||
|
|
||||||
let next = Meta_lexer.token
|
let next = Meta_lexer.token
|
||||||
|
|
||||||
|
@ -93,3 +95,22 @@ end
|
||||||
let load fn =
|
let load fn =
|
||||||
with_lexbuf_from_file fn ~f:(fun lb ->
|
with_lexbuf_from_file fn ~f:(fun lb ->
|
||||||
Parse.entries lb 0 [])
|
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 =
|
and entry =
|
||||||
| Comment of string
|
| Comment of string
|
||||||
| Var of string * predicate list * action * string
|
| Var of var
|
||||||
| Package of t
|
| Package of t
|
||||||
|
|
||||||
|
and var = string * predicate list * action * string
|
||||||
|
|
||||||
and action = Set | Add
|
and action = Set | Add
|
||||||
|
|
||||||
and predicate =
|
and predicate =
|
||||||
|
@ -19,3 +21,5 @@ and predicate =
|
||||||
| A of string (** Absent *)
|
| A of string (** Absent *)
|
||||||
|
|
||||||
val load : string -> entry list
|
val load : string -> entry list
|
||||||
|
|
||||||
|
val flatten : t -> (string * var list) list
|
||||||
|
|
|
@ -36,4 +36,4 @@ rule token = parse
|
||||||
| '=' { Equal }
|
| '=' { Equal }
|
||||||
| "+=" { Plus_equal }
|
| "+=" { Plus_equal }
|
||||||
| eof { Eof }
|
| eof { Eof }
|
||||||
| _ { lex_error lexbuf "invalid character" }
|
| _ { Loc.fail_lex lexbuf "invalid character" }
|
||||||
|
|
Loading…
Reference in New Issue