This commit is contained in:
Jeremie Dimino 2016-11-13 11:27:31 +00:00
parent 583b55f527
commit 24bb677ed2
6 changed files with 20 additions and 20 deletions

View File

@ -52,7 +52,7 @@ type package =
let db = Hashtbl.create 1024
let make_rule ((_, preds, action, value) : META.var) =
let make_rule ((_, preds, action, value) : Meta.var) =
let preds_required, preds_forbidden =
List.partition_map preds ~f:(function
| P x -> Inl x
@ -64,14 +64,14 @@ let make_rule ((_, preds, action, value) : META.var) =
; value
}
let acknowledge_meta (meta : META.t) =
let pkgs = META.flatten meta in
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
match String_map.find vname acc with
| exception Not_found -> []
| rules -> rules
in
@ -89,12 +89,12 @@ let root_pkg s =
| i -> String.sub s ~pos:0 ~len:i
let rec get_pkg name =
match Hashtbl.find db pkg with
match Hashtbl.find db name 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 };
acknowledge_meta { name = root; entries = Meta.load fn };
get_pkg name
end else
raise (Package_not_found name)
@ -111,12 +111,12 @@ let rec interpret_rules rules ~preds =
| Add ->
match interpret_rules rules ~preds with
| None -> Some rule.value
| Some v -> Some (v ^ " " 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
match String_map.find var pkg.vars with
| exception Not_found -> None
| rules -> interpret_rules rules ~preds

View File

@ -45,6 +45,6 @@ let save kind ~filename x =
let load kind ~filename =
let sexp, _locs =
with_lexbuf_from_file filename ~f:Sexp_lexer.single lb
with_lexbuf_from_file filename ~f:Sexp_lexer.single
in
of_sexp kind sexp

View File

@ -4,14 +4,14 @@ type t =
}
let of_lexbuf lb =
{ start = Lexing.lexeme_start lb
; stop = Lexing.lexeme_stop lb
{ start = Lexing.lexeme_start_p lb
; stop = Lexing.lexeme_end_p lb
}
exception Error of t * string
let fail t fmt =
Printf.ksprintf (fun msg -> raise (File_error (t, msg))) fmt
Printf.ksprintf (fun msg -> raise (Error (t, msg))) fmt
let fail_lex lb fmt =
fail (of_lexbuf lb) fmt

View File

@ -7,5 +7,5 @@ val of_lexbuf : Lexing.lexbuf -> t
exception Error of t * string
val fail : t -> string -> _
val fail_lex : Lexing.lexbuf -> string -> _
val fail : t -> ('a, unit, string, _) format4 -> 'a
val fail_lex : Lexing.lexbuf -> ('a, unit, string, _) format4 -> 'a

View File

@ -32,7 +32,7 @@ module Parse = struct
| _ -> error lb "package name expected"
let string lb =
match lb with
match next lb with
| String s -> s
| _ -> error lb "string expected"
@ -76,8 +76,8 @@ module Parse = struct
| Name "package" ->
let name = package_name lb in
lparen lb;
let entries = entries lb (depth + 1) [] in
entries lb depth (Package { name; entries } :: acc)
let sub_entries = entries lb (depth + 1) [] in
entries lb depth (Package { name; entries = sub_entries } :: acc)
| Name var ->
let preds, action =
match next lb with
@ -87,7 +87,7 @@ module Parse = struct
| _ -> error lb "'=', '+=' or '(' expected"
in
let value = string lb in
Var (var, preds, action, value)
entries lb depth (Var (var, preds, action, value) :: acc)
| _ ->
error lb "'package' or variable name expected"
end

View File

@ -25,8 +25,8 @@ rule token = parse
Buffer.contents buf
else
match s.[i] with
| '\\' -> Buffer.add_char s.[i + 1]; loop (i + 2)
| _ -> Buffer.add_char s.[i ]; loop (i + 1)
| '\\' -> Buffer.add_char buf s.[i + 1]; loop (i + 2)
| _ -> Buffer.add_char buf s.[i ]; loop (i + 1)
in
String (loop 0) }
| '-' { Minus }