Something went wrong. Try again.
ocaml
Something went wrong. Try again.
7.2 kB · 220 lines
OCaml
at pp-ast
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221(* * SPDX-FileCopyrightText: 2024 The Forester Project Contributors * SPDX-FileCopyrightText: 2026 The Forester Project Contributors * * SPDX-License-Identifier: GPL-3.0-or-later *)
open Forester_coreopen Config_erroropen Result.Syntax
let pp_dirlist fmt key = Format.( fprintf fmt "[%a]" (pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt "; ") pp_print_string) key)
(** In order to warn the user about unrecognized configuration options, we construct the set of keys and remove them when they are read. *)module Key_set = struct include Set.Make (struct type t = Toml.Types.Table.key list
let compare = compare end)
let remove : string list -> t -> t = fun strs set -> let key = List.map Toml.Types.Table.Key.of_string strs in remove key setend
let keys (tbl : Toml.Types.value Toml.Types.Table.t) = let rec go current keys tbl = List.fold_left begin fun acc (key, value) -> match value with | Toml.Types.TBool _ | TInt _ | TFloat _ | TString _ | TDate _ | TArray _ -> (key :: current) :: acc | TTable tbl -> go (key :: current) acc tbl end keys (Toml.Types.Table.to_list tbl) in Key_set.of_list @@ List.map List.rev @@ go [] [] tbl
let parse lexbuf filename : (Config.t, Config_error.t) result = match Toml.Parser.parse lexbuf filename with | `Error (msg, {source; _}) -> let range = Grace.Range.of_lexbuf ~source:(`File source) lexbuf in error @@ `Config_parse_error {range; msg} | `Ok tbl -> let open Toml.Lenses in if Option.is_none (get tbl (key "forest" |-- table)) then error `No_forest_table else let keys = ref (keys tbl) in let with_default ~value ~pp_value k lens = let open Toml.Lenses in match get tbl lens with | None -> Format.printf "%a@." Grace_ansi_renderer.( pp_diagnostic ?config:None ?code_to_string:None) Grace.Diagnostic.( createf Warning "option [%a] not set, using default %a" Format.( pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt ".") pp_print_string) k pp_value value); value | Some v -> keys := Key_set.remove k !keys; v in let forest = key "forest" |-- table in let* url = let k = ["forest"; "url"] in match get tbl (forest |-- key "url" |-- string) with | Some url -> keys := Key_set.remove k !keys; begin try ok @@ URI.of_string_exn url with _ -> error @@ `Invalid_url {url} end | None -> ok Config.default_url in let default = Config.default ~url () in let trees = let k = ["forest"; "trees"] in with_default ~value:default.trees ~pp_value:pp_dirlist k (forest |-- key "trees" |-- array |-- strings) in let errors, foreign = let k = ["forest"; "foreign"] in match get tbl (forest |-- key "foreign" |-- array |-- tables) with | None -> ([], default.foreign) | Some foreign_tbls -> ( keys := Key_set.remove k !keys; let@ foreign_tbl = List_util.error_partition @~ foreign_tbls in let route_locally = match get foreign_tbl (key "route_locally" |-- bool) with | None -> true | Some b -> b in let include_in_manifest = match get foreign_tbl (key "include_in_manifest" |-- bool) with | None -> true | Some b -> b in match get foreign_tbl (key "path" |-- string) with | None -> error @@ `No_path_in_foreign_table | Some path -> ok Config.{path; route_locally; include_in_manifest}) in let assets = with_default ~value:default.assets ~pp_value:pp_dirlist ["forest"; "assets"] (forest |-- key "assets" |-- array |-- strings) in let home = let k = ["forest"; "home"] in URI.named_uri ~base:url @@ with_default ~value:"index" ~pp_value:Format.pp_print_string k (forest |-- key "home" |-- string) in let theme = let result = get tbl (forest |-- key "theme" |-- string) in keys := Key_set.remove ["forest"; "theme"] !keys; result in let unused_keys = !keys |> Key_set.to_list |> List.map (List.map Toml.Types.Table.Key.to_string >>> Config_error.unknown_options) in List.iter Error.print_config_error (errors @ unused_keys); ok @@ Config.{url; assets; trees; foreign; home; theme; path = Some filename}
let parse_forest_config_string str = let lexbuf = Lexing.from_string str in parse lexbuf "<anonymous>"
let validate ~env config = let is_dir path_str = try let path = Eio.(Path.(Stdenv.fs env / Unix.realpath path_str)) in assert (Eio.Path.is_directory path); ok () with _ -> error @@ `Missing_dir {dir = path_str} in let is_file path_str = try let path = Eio.(Path.(Stdenv.fs env / Unix.realpath path_str)) in assert (Eio.Path.is_file path); ok () with _ -> error @@ `Missing_file {file = path_str} in match config with | Config.{trees; assets; foreign; theme; _} -> let blobs = List.map (fun ({path; _} : Config.foreign) -> path) foreign in let filter_err f = List.filter_map (f >>> ( function Error e -> Ok e | Ok v -> Error v ) >>> Result.to_option) in let errors = List.concat [ filter_err is_dir trees; filter_err is_dir assets; filter_err is_file blobs; begin match theme with | None -> [] | Some dir -> begin match is_dir dir with Ok _ -> [] | Error e -> [e] end end; ] in if List.is_empty @@ errors then ok config else error errors
let parse_forest_config_file ~env filename = let* ch = try ok @@ open_in filename with Sys_error _exn -> error @@ [`Missing_file {file = filename}] in let@ () = Fun.protect ~finally:(fun _ -> close_in ch) in let lexbuf = Lexing.from_channel ch in let result = Result.map_error List.singleton @@ parse lexbuf filename in (* This is important! *) Sys.chdir @@ Filename.dirname filename; Result.bind result (validate ~env)
let find_forest_config ~env ~start_dir = let toml_files_in dir = try Eio.Path.read_dir Eio.Path.(Eio.Stdenv.fs env / dir) |> List.filter (fun name -> Filename.extension name = ".toml") |> List.sort String.compare with _ -> [] in let try_candidate name dir = match parse_forest_config_file ~env (Filename.concat dir name) with | Ok config -> Some config | Error _ -> None in let rec go dir = match List.find_map (fun name -> try_candidate name dir) (toml_files_in dir) with | Some _ as found -> found | None -> let parent = Filename.dirname dir in if parent = dir then None else go parent in go start_dir