Skip to content

Commit

Permalink
Format.Pp fixes: fixed nested lists, better errors
Browse files Browse the repository at this point in the history
  • Loading branch information
@AltGr
AltGr committed Oct 24, 2015
1 parent 8a6119f commit b2ed670
Show file tree
Hide file tree
Showing 3 changed files with 100 additions and 64 deletions.
100 changes: 54 additions & 46 deletions src/format/opamFile.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -693,7 +693,7 @@ module ConfigSyntax = struct
(Pp.V.string -| Pp.of_module "opam-version" (module OpamVersion: Pp.STR with type t = OpamVersion.t));
"repositories", Pp.ppacc
with_repositories repositories
(Pp.V.map_list
(Pp.V.map_list ~depth:1
(Pp.V.string -|
Pp.of_module "repository" (module OpamRepositoryName: Pp.STR with type t = OpamRepositoryName.t)));
"switch", Pp.ppacc
Expand All @@ -704,7 +704,7 @@ module ConfigSyntax = struct
Pp.V.pos_int;
"download-command", Pp.ppacc_opt
with_dl_tool dl_tool
(Pp.V.map_list Pp.V.arg);
(Pp.V.map_list ~depth:1 Pp.V.arg);
"download-jobs", Pp.ppacc
with_dl_jobs dl_jobs
Pp.V.pos_int;
Expand All @@ -719,7 +719,7 @@ module ConfigSyntax = struct
Pp.V.string;
"solver", Pp.ppacc_opt
with_solver solver
(Pp.V.map_list Pp.V.arg);
(Pp.V.map_list ~depth:1 Pp.V.arg);

(* deprecated fields *)
"alias", Pp.ppacc_opt
Expand All @@ -741,7 +741,7 @@ module ConfigSyntax = struct
Pp.I.check_fields ~name fields -|
Pp.I.fields ~name ~empty fields -|
Pp.check ~name (fun t -> t.switch <> empty.switch)
~errmsg:"Missing switch"
~errmsg:"missing switch"

end
module Config = struct
Expand Down Expand Up @@ -798,11 +798,11 @@ module Repo_configSyntax = struct
Pp.I.check_fields fields -|
Pp.I.fields ~name:"repo-file" ~empty fields -|
Pp.check ~name (fun r -> r.repo_root <> empty.repo_root)
~errmsg:"Missing 'root:'" -|
~errmsg:"missing 'root:'" -|
Pp.check ~name (fun r -> r.repo_url <> OpamUrl.empty)
~errmsg:"Missing 'address:'" -|
~errmsg:"missing 'address:'" -|
Pp.check ~name (fun r -> r.repo_name <> empty.repo_name)
~errmsg:"Missing 'name:'"
~errmsg:"missing 'name:'"

end
module Repo_config = struct
Expand Down Expand Up @@ -893,7 +893,8 @@ module RepoSyntax = struct
"upstream", Pp.ppacc_opt with_upstream upstream Pp.V.string;
"redirect", Pp.ppacc
with_redirect redirect
(Pp.V.map_list (Pp.V.map_option Pp.V.string (Pp.opt Pp.V.filter)));
(Pp.V.map_list ~depth:1
(Pp.V.map_option Pp.V.string (Pp.opt Pp.V.filter)));
]

let pp =
Expand Down Expand Up @@ -962,14 +963,15 @@ module URLSyntax = struct
(Pp.V.url_with_backend `rsync);
"checksum", Pp.ppacc_opt with_checksum checksum
(Pp.V.string -| Pp.check ~name:"checksum" OpamFilename.valid_digest);
"mirrors", Pp.ppacc with_mirrors mirrors (Pp.V.map_list Pp.V.url);
"mirrors", Pp.ppacc with_mirrors mirrors
(Pp.V.map_list ~depth:1 Pp.V.url);
]

let pp_contents =
let name = internal in
Pp.I.check_fields ~name fields -|
Pp.I.fields ~name ~empty fields -|
Pp.check ~name (fun t -> t.url <> OpamUrl.empty) ~errmsg:"Missing URL"
Pp.check ~name (fun t -> t.url <> OpamUrl.empty) ~errmsg:"missing URL"

let pp = Pp.I.map_file pp_contents

Expand Down Expand Up @@ -1356,25 +1358,25 @@ module OPAMSyntax = struct
(Pp.V.string -| Pp.of_module "version" (module OpamPackage.Version: Pp.STR with type t = OpamPackage.Version.t));

"maintainer", no_cleanup Pp.ppacc with_maintainer maintainer
(Pp.V.map_list Pp.V.string);
(Pp.V.map_list ~depth:1 Pp.V.string);
"author", no_cleanup Pp.ppacc
with_author author
(Pp.V.map_list Pp.V.string);
(Pp.V.map_list ~depth:1 Pp.V.string);
"authors", no_cleanup Pp.ppacc
(fun t a -> if t.author = [] then with_author t a else
OpamFormat.bad_format "multiple \"author:\" fields" author)
(fun _ -> [])
(Pp.V.map_list Pp.V.string);
(Pp.V.map_list ~depth:1 Pp.V.string);
"license", no_cleanup Pp.ppacc with_license license
(Pp.V.map_list Pp.V.string);
(Pp.V.map_list ~depth:1 Pp.V.string);
"tags", with_cleanup cleanup_tags Pp.ppacc with_tags tags
(Pp.V.map_list Pp.V.string);
(Pp.V.map_list ~depth:1 Pp.V.string);
"homepage", no_cleanup Pp.ppacc with_homepage homepage
(Pp.V.map_list Pp.V.string);
(Pp.V.map_list ~depth:1 Pp.V.string);
"doc", no_cleanup Pp.ppacc with_doc doc
(Pp.V.map_list Pp.V.string);
(Pp.V.map_list ~depth:1 Pp.V.string);
"bug-reports", no_cleanup Pp.ppacc with_bug_reports bug_reports
(Pp.V.map_list Pp.V.string);
(Pp.V.map_list ~depth:1 Pp.V.string);

"depends", with_cleanup cleanup_depflags Pp.ppacc with_depends depends
(Pp.V.package_formula `Conj Pp.V.ext_constraints);
Expand All @@ -1384,38 +1386,40 @@ module OPAMSyntax = struct
Pp.ppacc with_conflicts conflicts
(Pp.V.package_formula `Disj Pp.V.constraints);
"available", no_cleanup Pp.ppacc with_available available
(Pp.V.list -| Pp.V.filter);
(Pp.V.list_depth 1 -| Pp.V.list -| Pp.V.filter);
"ocaml-version", no_cleanup
Pp.ppacc_opt with_ocaml_version ocaml_version
(Pp.V.list -| Pp.V.constraints Pp.V.compiler_version);
(Pp.V.list_depth 1 -| Pp.V.list -|
Pp.V.constraints Pp.V.compiler_version);
"os", no_cleanup Pp.ppacc with_os os
Pp.V.os_constraint;
"flags", with_cleanup cleanup_flags Pp.ppacc add_flags flags
(Pp.V.map_list @@
(Pp.V.map_list ~depth:1 @@
Pp.V.ident -|
Pp.of_pair "package-flag" (pkg_flag_of_string, string_of_pkg_flag));

"build", no_cleanup Pp.ppacc with_build build
(Pp.V.map_list Pp.V.command);
(Pp.V.map_list ~depth:2 Pp.V.command);
"build-test", no_cleanup Pp.ppacc with_build_test build_test
(Pp.V.map_list Pp.V.command);
(Pp.V.map_list ~depth:2 Pp.V.command);
"build-doc", no_cleanup Pp.ppacc with_build_doc build_doc
(Pp.V.map_list Pp.V.command);
(Pp.V.map_list ~depth:2 Pp.V.command);
"install", no_cleanup Pp.ppacc with_install install
(Pp.V.map_list Pp.V.command);
(Pp.V.map_list ~depth:2 Pp.V.command);
"remove", no_cleanup Pp.ppacc with_remove remove
(Pp.V.map_list Pp.V.command);
(Pp.V.map_list ~depth:2 Pp.V.command);

"substs", no_cleanup Pp.ppacc with_substs substs
(Pp.V.map_list pp_basename);
(Pp.V.map_list ~depth:1 pp_basename);
"patches", no_cleanup Pp.ppacc with_patches patches
(Pp.V.map_list @@ Pp.V.map_option pp_basename (Pp.opt Pp.V.filter));
(Pp.V.map_list ~depth:1 @@
Pp.V.map_option pp_basename (Pp.opt Pp.V.filter));
"build-env", no_cleanup Pp.ppacc with_build_env build_env
(Pp.V.map_list Pp.V.env_binding);
(Pp.V.map_list ~depth:2 Pp.V.env_binding);
"features", no_cleanup Pp.ppacc with_features features
Pp.V.features;
"extra-sources", no_cleanup Pp.ppacc with_extra_sources extra_sources
(Pp.V.map_list @@
(Pp.V.map_list ~depth:1 @@
Pp.V.map_pair
(Pp.V.map_option
Pp.V.url
Expand All @@ -1426,26 +1430,30 @@ module OPAMSyntax = struct
(fun (u,f,md5) -> (u,md5),f));

"messages", no_cleanup Pp.ppacc with_messages messages
(Pp.V.map_list (Pp.V.map_option Pp.V.string_tr (Pp.opt Pp.V.filter)));
(Pp.V.map_list ~depth:1 @@
Pp.V.map_option Pp.V.string_tr (Pp.opt Pp.V.filter));
"post-messages", no_cleanup Pp.ppacc with_post_messages post_messages
(Pp.V.map_list (Pp.V.map_option Pp.V.string_tr (Pp.opt Pp.V.filter)));
(Pp.V.map_list ~depth:1 @@
Pp.V.map_option Pp.V.string_tr (Pp.opt Pp.V.filter));
"depexts", no_cleanup Pp.ppacc_opt with_depexts depexts
(let string_set name =
Pp.V.map_list Pp.V.string -|
Pp.of_pair name OpamStd.String.Set.(of_list, elements)
in
Pp.V.map_list
Pp.V.map_list ~depth:3
(Pp.V.map_pair
(string_set "system-id") (string_set "system-package")) -|
Pp.of_pair "depext-bindings"
OpamStd.String.SetMap.(of_list, bindings));
"libraries", no_cleanup Pp.ppacc with_libraries libraries
(Pp.V.map_list (Pp.V.map_option Pp.V.string (Pp.opt Pp.V.filter)));
(Pp.V.map_list ~depth:1 @@
Pp.V.map_option Pp.V.string (Pp.opt Pp.V.filter));
"syntax", no_cleanup Pp.ppacc with_syntax syntax
(Pp.V.map_list (Pp.V.map_option Pp.V.string (Pp.opt Pp.V.filter)));
(Pp.V.map_list ~depth:1 @@
Pp.V.map_option Pp.V.string (Pp.opt Pp.V.filter));
"dev-repo", no_cleanup Pp.ppacc_opt with_dev_repo dev_repo
(Pp.V.url -|
Pp.check ~errmsg:"Not a remote url"
Pp.check ~errmsg:"invalid remote url"
(function {OpamUrl.transport = "file" | "local" | "path"; _} -> false
| _ -> true));

Expand Down Expand Up @@ -2041,14 +2049,14 @@ module Dot_installSyntax = struct

let fields =
let pp_field =
Pp.V.map_list @@ Pp.V.map_option
Pp.V.map_list ~depth:1 @@ Pp.V.map_option
(Pp.V.string -| pp_optional)
(Pp.opt @@
Pp.singleton -| Pp.V.string -|
Pp.of_module "rel-filename" (module OpamFilename.Base: Pp.STR with type t = OpamFilename.Base.t))
in
let pp_misc =
Pp.V.map_list @@ Pp.V.map_option
Pp.V.map_list ~depth:1 @@ Pp.V.map_option
(Pp.V.string -| pp_optional)
(Pp.singleton -| Pp.V.string -| Pp.pp ~name:"abs-filename"
(fun ~pos s ->
Expand Down Expand Up @@ -2078,7 +2086,7 @@ module Dot_installSyntax = struct
Pp.I.check_opam_version ~optional:true () -|
Pp.I.check_fields ~name fields -|
Pp.I.fields ~name ~empty fields -|
Pp.check ~errmsg:"Man file without destination or recognised suffix"
Pp.check ~errmsg:"man file without destination or recognised suffix"
(fun t ->
List.for_all (function
| m, None -> add_man_section_dir m <> None
Expand Down Expand Up @@ -2188,24 +2196,24 @@ module CompSyntax = struct
(Pp.V.url_with_backend `rsync);

"patches", Pp.ppacc with_patches patches
(Pp.V.map_list @@ Pp.V.url);
(Pp.V.map_list ~depth:1 @@ Pp.V.url);

"configure", Pp.ppacc with_configure configure
(Pp.V.map_list Pp.V.string);
(Pp.V.map_list ~depth:1 Pp.V.string);
"make", Pp.ppacc with_make make
(Pp.V.map_list Pp.V.string);
(Pp.V.map_list ~depth:1 Pp.V.string);
"build", Pp.ppacc with_build build
(Pp.V.map_list Pp.V.command);
(Pp.V.map_list ~depth:1 Pp.V.command);

"packages", Pp.ppacc with_packages packages
(Pp.V.package_formula `Conj Pp.V.constraints);
"env", Pp.ppacc with_env env
(Pp.V.map_list Pp.V.env_binding);
(Pp.V.map_list ~depth:2 Pp.V.env_binding);
"preinstalled", Pp.ppacc_opt with_preinstalled
(fun t -> if t.preinstalled then Some true else None)
Pp.V.bool;
"tags", Pp.ppacc with_tags tags
(Pp.V.map_list Pp.V.string);
(Pp.V.map_list ~depth:1 Pp.V.string);
]

let pp_raw =
Expand All @@ -2214,7 +2222,7 @@ module CompSyntax = struct
Pp.I.check_opam_version () -|
Pp.I.check_fields ~name fields -|
Pp.I.fields ~name ~empty fields -|
Pp.check ~errmsg:"Fields 'build:' and 'configure:'+'make:' are mutually \
Pp.check ~errmsg:"fields 'build:' and 'configure:'+'make:' are mutually \
exclusive "
(fun t -> t.build = [] || t.configure = [] && t.make = [])

Expand Down
54 changes: 38 additions & 16 deletions src/format/opamFormat.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -163,7 +163,7 @@ module Print = struct

let format_opamfile fmt f =
format_items fmt f.file_contents;
Format.pp_print_flush fmt ()
Format.pp_print_newline fmt ()

let items l =
format_items Format.str_formatter l; Format.flush_str_formatter ()
Expand All @@ -172,8 +172,6 @@ module Print = struct
items f.file_contents
end

let log f = OpamConsole.log "FORMAT" f

module Normalise = struct
(** OPAM normalised file format, for signatures:
- each top-level field on a single line
Expand Down Expand Up @@ -274,9 +272,15 @@ module Pp = struct
| Some e -> raise e
| None -> bad_format ?pos fmt
else
Printf.ksprintf
(fun s -> log "%s" (string_of_bad_format (Bad_format (pos, [], s))))
fmt
Printf.ksprintf (fun s ->
if OpamConsole.verbose () then
match exn with
| None ->
OpamConsole.warning "%s"
(string_of_bad_format (Bad_format (pos, [], s)))
| Some e ->
OpamConsole.warning "%s" (string_of_bad_format e))
fmt

(** Basic pp usage *)

Expand Down Expand Up @@ -541,19 +545,37 @@ module Pp = struct

let map_group pp1 = group -| map_list ~posf:value_pos pp1

let map_list pp1 =
let list_depth expected_depth =
let rec depth = function
| List (_,[]) -> 1
| List (_,(v::_)) -> 1 + depth v
| Option (_,v,_) -> depth v
| _ -> 0
in
let rec wrap n v =
if n <= 0 then v else wrap (n-1) (List (pos_null, [v]))
in
let rec lift n v =
if n <= 0 then v else
match v with
| List (_, [v]) -> lift (n-1) v
| v -> v
in
pp
(fun ~pos:_ v -> wrap (expected_depth - depth v) v)
(fun v -> lift expected_depth v)

let map_list ?(depth=0) pp1 =
list_depth depth -|
pp ~name:(Printf.sprintf "[%s]" pp1.name)
(fun ~pos v ->
try [pp1.parse ~pos v] with
| Bad_format _ | Bad_format_list _ | Unexpected _ as err ->
(fun ~pos:_ v ->
match v with
| List (_, l) ->
List.rev @@
List.rev_map (fun v -> parse pp1 ~pos:(value_pos v) v) l
| _ -> raise err)
| _ -> unexpected ())
(function
| [x] -> pp1.print x
| l -> List (pos_null, List.rev @@ List.rev_map (print pp1) l))
| l -> List (pos_null, List.rev @@ List.rev_map (print pp1) l))

let map_option pp1 pp2 =
option -|
Expand Down Expand Up @@ -954,7 +976,7 @@ module Pp = struct
try errs, parse ppa ~pos (acc, Some v) with
| Bad_format (pos,btl,msg) ->
let msg =
Printf.sprintf "%sfield '%s:' %s" in_name field msg
Printf.sprintf "%sfield '%s:', %s" in_name field msg
in
(field,(pos, Printexc.get_backtrace()::btl, msg)) :: errs,
acc
Expand Down Expand Up @@ -1020,7 +1042,7 @@ module Pp = struct
| None -> optional
in
field name (parse opam_v) -|
map_fst (check ~name ~errmsg:"Unsupported or missing file format version" f) -|
map_fst (check ~name ~errmsg:"unsupported or missing file format version" f) -|
pp
(fun ~pos:_ (_,x) -> x)
(fun x ->
Expand All @@ -1036,7 +1058,7 @@ module Pp = struct
exception Invalid_signature of pos * (string*string*string) list option
let signed ~check =
let pp_sig = V.map_list signature in
let pp_sig = V.map_list ~depth:2 signature in
extract_field "signature" -|
pp ~name:"signed-file"
(fun ~pos -> function
Expand Down
Loading

0 comments on commit b2ed670

Please sign in to comment.