diff --git a/.merlin b/.merlin index db00dcfa..6f765dad 100644 --- a/.merlin +++ b/.merlin @@ -10,3 +10,4 @@ PKG fileutils PKG uri PKG js_of_ocaml.ppx PKG reason +PKG yaml \ No newline at end of file diff --git a/Makefile b/Makefile index 35407898..bb9ca0a0 100644 --- a/Makefile +++ b/Makefile @@ -1,10 +1,8 @@ -all: ohow wit +all: how ohow wit linkchecker2json how: - ocamlbuild -use-ocamlfind -ocamlc "ocamlc" src/client.byte - js_of_ocaml +weak.js client.byte - ocamlbuild -use-ocamlfind -ocamlc "ocamlc ${CFLAGS}" src/html_of_wiki.byte + ocamlbuild -use-ocamlfind -ocamlc "ocamlc ${CFLAGS}" src/how.byte ohow: ocamlbuild -use-ocamlfind -ocamlc "ocamlc ${CFLAGS}" src/ohow.byte @@ -12,6 +10,7 @@ ohow: wit: ocamlbuild -use-ocamlfind -ocamlc "ocamlc ${CFLAGS}" src/wit.byte + .PHONY: linkchecker2json linkchecker2json: sbcl --load src/linkchecker2json.lisp <<< "(sb-ext:save-lisp-and-die \"linkchecker2json\" :toplevel #'main :executable t)" diff --git a/_tags b/_tags index 86b69ad6..e8ff85af 100644 --- a/_tags +++ b/_tags @@ -13,3 +13,4 @@ true: package(ppx_blob) true: package(ppx_deriving.std) true: package(reason) true: package(str) +true: package(yaml) diff --git a/src/conf.ml b/src/conf.ml new file mode 100644 index 00000000..61d805e1 --- /dev/null +++ b/src/conf.ml @@ -0,0 +1,321 @@ +open Utils.Operators + +type label = string +type doc = string + +type 'a result = + | Bool of bool_result + | String of string_result + | Sequence of 'a sequence_result + | Mapping of 'a mapping_result +and bool_result = bool +and string_result = string +and 'a sequence_result = 'a result list +and 'a mapping_result = ('a * 'a result) list + +type err = string +type 'a checker_t = 'a -> bool +type 'a checker = + | Bool_checker of bool_result checker_t + | String_checker of string_result checker_t + | Sequence_checker of 'a sequence_result checker_t + | Mapping_checker of 'a mapping_result checker_t + | Generic_checker of 'a result checker_t + +type 'a elt_meta = { + default: 'a result option; + check: 'a checker option; + err: err option +} +type 'a elt = + | Bool_t of 'a elt_meta + | String_t of 'a elt_meta + | Sequence_t of 'a elt * 'a elt_meta + | Mapping_t of 'a mapping_pair list * 'a elt_meta + | Either_t of 'a elt * 'a elt * 'a elt_meta +and 'a mapping_pair = { + label: label; + tag: 'a; + elt: 'a elt; + doc: doc; +} + +type 'a t = 'a result + + + +let bool ?err ?check ?default () = + Bool_t {default = default <$> (fun d -> Bool d); + check = check <$> (fun c -> Bool_checker c); + err} + +let string ?err ?check ?default () = + String_t {default = default <$> (fun d -> String d); + check = check <$> (fun c -> String_checker c); + err} + +let sequence ?err ?check ?default elt = + Sequence_t (elt, {default = default <$> (fun d -> Sequence d); + check = check <$> (fun c -> Sequence_checker c); + err}) + +let mapping ?err ?check ?default pairs = + Mapping_t (pairs, {default = default <$> (fun d -> Mapping d); + check = check <$> (fun c -> Mapping_checker c); + err}) + +let either ?err ?check ?default alt alt' = + Either_t (alt, alt', {default; + check = check <$> (fun c -> Generic_checker c); + err}) + +let pair ?(doc = "") label tag elt = + {label; tag; elt; doc} + + +(* + * PARSERS + *) +exception Parse_error +type structure_error_t = [ `Bool + | `Sequence + | `String + | `Mapping + | `Either of structure_error_t * structure_error_t + | `Float + | `Null ] +exception Structure_error of {got: structure_error_t; + expected: structure_error_t; + inside: label} +exception Check_error of err +exception Missing_required_pairs of label list +exception Unexpected_labels of label list +exception Not_matching + + +module type Parser = sig + type t + val parse : in_channel -> t + val structural_check : 'a elt -> t -> unit + val to_result : 'a elt -> t -> 'a result + val check_result : 'a elt -> 'a result -> unit +end + +module Yaml_parser = struct + type t = Yaml.value + + let parse ic = + let content = Utils.read_in_channel ic in + match Yaml.of_string content with + | Result.Ok v -> v + | Result.Error _ -> raise Parse_error + + let true_values = ["Y"; "y"; "true"; "True"; "TRUE"; "on"; "ON"] + let false_values = ["N"; "n"; "false"; "False"; "FALSE"; "off"; "OFF"] + let is_boolean_value x = List.mem x true_values || List.mem x false_values + + let elt_default = function + | Bool_t {default} + | String_t {default} + | Sequence_t (_, {default}) + | Mapping_t (_, {default}) + | Either_t (_, _, {default}) -> default + + let rec structure_error_t_of_elt = function + | Bool_t _ -> `Bool + | String_t _ -> `String + | Sequence_t _ -> `Sequence + | Mapping_t _ -> `Mapping + | Either_t (e, e', _) -> `Either (structure_error_t_of_elt e, structure_error_t_of_elt e') + let rec structure_error_t_of_yaml = function + | `Bool _ -> `Bool + | `String _ -> `String + | `O _ -> `Mapping + | `A _ -> `Sequence + | `Float _ -> `Float + | `Null -> `Null + let structure_error_of_conf_and_yaml conf yaml = + let expected = structure_error_t_of_elt conf in + let got = structure_error_t_of_yaml yaml in + Structure_error {got; expected; inside = ""} + + let required_pairs ps = List.filter (fun {elt} -> Utils.is_none @@ elt_default elt) ps + let pairs_labels ps = List.map (fun {label} -> label) ps + let yaml_pairs_labels ps = List.map (fun (l, _) -> l) ps + + let rec structural_check conf yaml = match conf, yaml with + | Bool_t _, `String s when is_boolean_value s -> () + | String_t _, `String _ -> () + | Sequence_t (elt, _), `A yamls -> List.iter (structural_check elt) yamls + | Mapping_t (pairs, _), `O yaml_pairs -> + let yaml_labels = yaml_pairs_labels yaml_pairs in + let labels = pairs_labels pairs in + let required_labels = pairs_labels @@ required_pairs pairs in + (* let pl p l = Printf.printf "%s: [%s]\n" p (String.concat ", " l) in + * pl "yaml_labels" yaml_labels; pl "labels" labels; pl "required_labels" required_labels; *) + if yaml_labels @< labels + then if required_labels @< yaml_labels + then + let pairs_alist = Utils.alist_of_values (fun {label} -> label) pairs in + Utils.group_alists pairs_alist yaml_pairs + |> List.iter (fun (_, ({label; elt}, yaml)) -> match structural_check elt yaml with + | exception Structure_error {got; expected} -> raise (Structure_error {got; expected; inside = label}) + | x -> x) + else raise (Missing_required_pairs (required_labels @- yaml_labels)) + else raise (Unexpected_labels (yaml_labels @- labels)) + | Either_t (elt, elt', _), yaml -> + (try structural_check elt yaml + with _ -> try structural_check elt' yaml + with _ -> raise (structure_error_of_conf_and_yaml conf yaml)) + | _ -> raise (structure_error_of_conf_and_yaml conf yaml) + + let boolean_of_string = function + | s when List.mem s true_values -> true + | s when List.mem s false_values -> false + | _ -> raise Not_matching + let rec to_result conf yaml = match conf, yaml with + | Bool_t _, `String s -> Bool (boolean_of_string s) + | String_t _, `String s -> String s + | Either_t (elt, elt', _), yaml -> + (try to_result elt yaml + with _ -> to_result elt' yaml) + | Sequence_t (elt, _), `A yamls -> Sequence (List.map (to_result elt) yamls) + | Mapping_t (pairs, _), `O yaml_pairs -> + pairs + |> List.map (fun {label; tag; elt} -> + let default = elt_default elt in + let value = List.assoc_opt label yaml_pairs <$> to_result elt in + let value' = match value, default with + | Some v, _ -> v + | None, Some d -> d + | None, None -> raise Not_matching + in + (tag, value')) + |> (fun alist -> Mapping alist) + | _ -> raise Not_matching + + + let check_or_die check err value = if check value then () else raise (Check_error (err |? "")) + let recursively_check k data = data |> List.iter (fun (elt, res) -> k elt res) + + let bool_check _ = function + | Bool_t {check = Some (Bool_checker check); err}, Bool b -> check_or_die check err b + | Bool_t {check = None}, Bool b -> () + | _ -> raise Not_matching + + let string_check _ = function + | String_t {check = Some (String_checker check); err}, String s -> check_or_die check err s + | String_t {check = None}, String s -> () + | _ -> raise Not_matching + + let sequence_check k = + let rec_check elt results = + recursively_check k (List.map (fun r -> (elt, r)) results) + in + function + | Sequence_t (elt, {check = Some (Sequence_checker check); err}), Sequence results -> + rec_check elt results; + check_or_die check err results + | Sequence_t (elt, {check = None}), Sequence results -> rec_check elt results + | _ -> raise Not_matching + + let mapping_check k = + let rec_check pairs map = + recursively_check k (pairs |> List.map (fun {tag; elt} -> (elt, List.assoc tag map))) + in + function + | Mapping_t (pairs, {check = Some (Mapping_checker check); err}), Mapping map -> + rec_check pairs map; + check_or_die check err map + | Mapping_t (pairs, {check = None}), Mapping map -> rec_check pairs map + | _ -> raise Not_matching + + let either_check k = + let try_check elt elt' value = + try recursively_check k [elt, value] + with Not_matching -> recursively_check k [elt', value] + in + function + | Either_t (elt, elt', {check = Some (Generic_checker check); err}), value -> + try_check elt elt' value; + check_or_die check err value + | Either_t (elt, elt', {check = None}), value -> try_check elt elt' value + | _ -> raise (Failure "either") + + let rec check_result conf result = match conf with + | Bool_t _ -> bool_check check_result (conf, result) + | String_t _ -> string_check check_result (conf, result) + | Sequence_t _ -> sequence_check check_result (conf, result) + | Mapping_t _ -> mapping_check check_result (conf, result) + | Either_t _ -> either_check check_result (conf, result) +end + +let yaml_parser = (module Yaml_parser : Parser with type t = Yaml.value) + +let parse (type a) (module P : Parser with type t = a) elt ic = + let psr_data = P.parse ic in + P.structural_check elt psr_data; + let result = P.to_result elt psr_data in + P.check_result elt result; + result + + +type 'a tag_printer = 'a -> string +type 'a backend_printer = 'a tag_printer -> 'a t -> string + + +let rec yaml_value_of_conf_t label_of_tag = function + | Bool b -> `Bool b + | String s -> `String s + | Sequence seq -> `A (List.map (yaml_value_of_conf_t label_of_tag) seq) + | Mapping map -> `O (map |> List.map (fun (tag, c) -> + (label_of_tag tag, yaml_value_of_conf_t label_of_tag c))) + +let yaml_printer tag_printer result = + let yaml = yaml_value_of_conf_t tag_printer result in + match Yaml.to_string yaml with + | Result.Ok s -> s + | Result.Error _ -> failwith "roh" + + +let tag_printer_of_conf conf = + let rec lookup tag = function + | Mapping_t (pairs, _) -> + (try + pairs + |> List.find (fun {tag = tag'; elt} -> tag = tag') + |> fun {label} -> label + with Not_found -> + pairs + |> List.map (fun {elt} -> try Some (lookup tag elt) with Not_found -> None) + |> List.filter Utils.is_some + |> (function Some x :: _ -> x | _ -> raise Not_found)) + | Sequence_t (c, _) -> lookup tag c + | Either_t (c, c', _) -> (try lookup tag c + with Not_found -> lookup tag c') + | _ -> raise Not_found + in + fun tag -> lookup tag conf + + +let rec type_of_conf = function + | Bool_t _ -> "boolean" + | String_t _ -> "string" + | Sequence_t (conf, _) -> "sequence of " ^ type_of_conf conf + | Either_t (conf, conf', _) -> type_of_conf conf ^ " or " ^ type_of_conf conf' + | Mapping_t _ -> "mapping" +and columns_of_mapping prefix = function + | Mapping_t (pairs, _) -> + pairs + |> List.map (fun {label; elt; doc} -> + (prefix ^ label, type_of_conf elt, doc) :: columns_of_subconf prefix elt) + |> List.flatten + | _ -> assert false +and columns_of_subconf prefix = function + | Mapping_t _ as conf -> columns_of_mapping (" " ^ prefix) conf + | Either_t (c, c', _) -> columns_of_subconf prefix c @ columns_of_subconf prefix c' + | _ -> [] + +let doc_of_conf conf = match conf with + | Mapping_t _ -> columns_of_mapping "" conf |> Utils.sprint_three_cols + | _ -> type_of_conf conf diff --git a/src/conf.mli b/src/conf.mli new file mode 100644 index 00000000..1727c156 --- /dev/null +++ b/src/conf.mli @@ -0,0 +1,111 @@ +type label = string +type doc = string + +type 'a result = + | Bool of bool_result + | String of string_result + | Sequence of 'a sequence_result + | Mapping of 'a mapping_result +and bool_result = bool +and string_result = string +and 'a sequence_result = 'a result list +and 'a mapping_result = ('a * 'a result) list + +type err = string +type 'a checker_t = 'a -> bool +type 'a checker = + | Bool_checker of bool_result checker_t + | String_checker of string_result checker_t + | Sequence_checker of 'a sequence_result checker_t + | Mapping_checker of 'a mapping_result checker_t + | Generic_checker of 'a result checker_t + +type 'a elt_meta = { + default: 'a result option; + check: 'a checker option; + err: err option +} +type 'a elt = + | Bool_t of 'a elt_meta + | String_t of 'a elt_meta + | Sequence_t of 'a elt * 'a elt_meta + | Mapping_t of 'a mapping_pair list * 'a elt_meta + | Either_t of 'a elt * 'a elt * 'a elt_meta +and 'a mapping_pair = { + label: label; + tag: 'a; + elt: 'a elt; + doc: doc; +} + +type 'a t = 'a result + + +val bool : + ?err:err -> + ?check:(bool_result checker_t) -> + ?default:bool_result -> + unit -> 'a elt +val string : + ?err:err -> + ?check:(string_result checker_t) -> + ?default:string_result -> + unit -> 'a elt +val sequence : + ?err:err -> + ?check:('a sequence_result checker_t) -> + ?default:'a sequence_result -> + 'a elt -> 'a elt +val mapping : + ?err:err -> + ?check:('a mapping_result checker_t) -> + ?default:'a mapping_result -> + 'a mapping_pair list -> 'a elt +val either : + ?err:err -> + ?check:('a result checker_t) -> + ?default:'a result -> + 'a elt -> 'a elt -> 'a elt + +val pair : ?doc:doc -> label -> 'a -> 'a elt -> 'a mapping_pair + +exception Parse_error +type structure_error_t = [ `Bool + | `Sequence + | `String + | `Mapping + | `Either of structure_error_t * structure_error_t + | `Float + | `Null ] +exception Structure_error of {got: structure_error_t; + expected: structure_error_t; + inside: label} +exception Check_error of err +exception Missing_required_pairs of label list +exception Unexpected_labels of label list +exception Not_matching + +module type Parser = sig + type t + val parse : in_channel -> t + val structural_check : 'a elt -> t -> unit + val to_result : 'a elt -> t -> 'a result + val check_result : 'a elt -> 'a result -> unit +end + +module Yaml_parser : Parser +val yaml_parser : (module Parser with type t = Yaml.value) + +val parse : (module Parser with type t = 'b) -> 'a elt -> in_channel -> 'a result + + + +type 'a tag_printer = 'a -> string +type 'a backend_printer = 'a tag_printer -> 'a t -> string + +val yaml_printer : 'a backend_printer + +val tag_printer_of_conf : 'a elt -> 'a tag_printer + + +val doc_of_conf : 'a elt -> string diff --git a/src/glcmd.ml b/src/glcmd.ml new file mode 100644 index 00000000..0a110c0e --- /dev/null +++ b/src/glcmd.ml @@ -0,0 +1,306 @@ +open Utils.Operators + +type doc = string + +type argument_name = Short of string | Long of string +type argument_value = string +type argument_type = + | File + | String + | Choice of argument_value list +type argument_names = argument_name list +type argument_valname = string option +type 'a argument = + | Flag of argument_names * 'a * doc + | Arg of argument_names * argument_type * 'a * argument_valname * doc + | Required of argument_names * argument_type * 'a * argument_valname * doc + | Positional of argument_type * argument_valname * doc + | Multiple of argument_type * argument_valname * doc + +type command_name = string +type 'a command_args = 'a argument list +type ('a, 'b) command_fun = ('a * argument_value) list -> argument_value list -> 'b +type ('a, 'b) command = + | Prefix of command_name * ('a, 'b) command list + | Command of command_name * 'a command_args * doc * ('a, 'b) command_fun + | Anonymous of 'a command_args * doc * ('a, 'b) command_fun +type ('a, 'b) commandline = ('a, 'b) command list + +exception Empty_commandline +exception Unknown_command of string +exception Incomplete_command +exception Unknown_argument of string +exception Missing_arguments of string list +exception Invalid_argument_value +exception Missing_argument_value + + +let is_anonymous = function Anonymous _ -> true | _ -> false +let is_command = function Command _ -> true | _ -> false +let is_prefix = function Prefix _ -> true | _ -> false +let is_flag = function Flag _ -> true | _ -> false +let is_arg = function Arg _ -> true | _ -> false +let is_required = function Required _ -> true | _ -> false +let is_positional = function Positional _ -> true | _ -> false +let is_multiple = function Multiple _ -> true | _ -> false +let is_required_or_positional x = is_required x || is_positional x +let is_positional_or_multiple x = is_positional x || is_multiple x +let is_named x = not @@ is_positional_or_multiple x +let is_short_name = function Short _ -> true | _ -> false +let is_long_name = function Long _ -> true | _ -> false + + +let has_anonymous cmdline = List.exists is_anonymous cmdline +let find_anonymous cmdline = List.find is_anonymous cmdline + +let rec collect_cmd_names = function + | [] -> [] + | Prefix (n, _) :: cs | Command (n, _, _, _) :: cs -> n :: collect_cmd_names cs + | _ :: cs -> collect_cmd_names cs + +let rec find_command name = function + | [] -> raise Not_found + | (Prefix (n, _) as c) :: _ | (Command (n, _, _, _) as c) :: _ when n = name -> c + | _ :: cs -> find_command name cs + +let subcmdline name cmdline = match find_command name cmdline with + | Prefix (_, cs) -> cs + | _ -> raise Not_found + +let rec find_tree cmdline cns = + let extract_tree = function + | Prefix (_, t) -> t + | x -> [x] + in + let find cn = find_command cn cmdline |> extract_tree in + match cns with + | [] -> cmdline + | [cn] -> find cn + | cn :: cns -> find_tree (find cn) cns + +let first_name = function + | [] -> raise Not_found + | ns -> List.find_opt is_long_name ns |? List.hd ns + +let sort_arguments arguments = + List.filter is_named arguments @ List.filter is_positional arguments @ (begin + match List.filter is_multiple arguments with + | ([] as l) | ([_] as l) -> l + | _ -> assert false (* multiple Multiple arguments TODO check *) + end) + + +let sprint_argument_name = function + | Short n -> "-" ^ n + | Long n -> "--" ^ n + +let sprint_first_name ns = first_name ns |> sprint_argument_name + +let sprint_argument_type = function + | File -> "FILE" + | String -> "VAL" + | Choice cs -> Printf.sprintf "<%s>" (String.concat "|" cs) + +let sprint_argument = function + | Flag (ns, _, _) -> Printf.sprintf "[%s]" (sprint_first_name ns) + | Arg (ns, _, _, Some vn, _) -> Printf.sprintf "[%s %s]" (sprint_first_name ns) vn + | Arg (ns, t, _, None, _) -> Printf.sprintf "[%s %s]" (sprint_first_name ns) (sprint_argument_type t) + | Required (ns, _, _, Some vn, _) -> Printf.sprintf "%s %s" (sprint_first_name ns) vn + | Required (ns, t, _, None, _) -> Printf.sprintf "%s %s" (sprint_first_name ns) (sprint_argument_type t) + | Positional (t, vn, _) -> Printf.sprintf "%s" (vn |? sprint_argument_type t) + | Multiple (t, vn, _) -> Printf.sprintf "[%s...]" (vn |? sprint_argument_type t) + +let sprint_arguments arguments = String.concat " " (List.map sprint_argument arguments) +let print_arguments out arguments = Printf.fprintf out "%s" (sprint_arguments arguments) + +let sprint_category name = Printf.sprintf "%s\n%s\n" (String.uppercase_ascii name) + +let describe_arguments args = + let names ns = List.map sprint_argument_name ns |> String.concat ", " in + let names_vn ns vn = + let v = "=" ^ vn in + (List.map sprint_argument_name ns + |> String.concat (v ^ ", ")) ^ v + in + let argument_data = function + | Flag (ns, _, doc) -> names ns, doc + | Arg (ns, _, _, Some vn, doc) | Required (ns, _, _, Some vn, doc) -> + names_vn ns vn, doc + | Arg (ns, t, _, None, doc) | Required (ns, t, _, None, doc) -> + names_vn ns (sprint_argument_type t), doc + | Positional (t, vn, doc) -> (vn |? sprint_argument_type t), doc + | Multiple (t, vn, doc) -> (vn |? sprint_argument_type t) ^ "...", doc + in + let collect_data p = List.filter p args |> List.map argument_data in + let named = collect_data is_named in + let positional = collect_data is_positional @ collect_data is_multiple in + let sprint_data header = function + | [] -> "" + | data -> sprint_category header (Utils.sprint_two_cols ~prefix:"\t" data) + in + sprint_data "named arguments" named ^ sprint_data "positional arguments" positional + +let describe_tree prefix tree = + let no_data = ("", "") in + let rec command_data prefix = function + | Anonymous (args, doc, _) -> Printf.sprintf "%s%s" prefix (sprint_arguments args), doc + | Command (name, args, doc, _) -> Printf.sprintf "%s%s %s" prefix name (sprint_arguments args), doc + | Prefix (name, st) -> match find_anonymous st with + | exception Not_found -> no_data + | an -> command_data (prefix ^ name) an + in + let data = tree + |> List.map (command_data prefix) + |> List.filter (fun x -> x <> no_data) + in + match tree with + | [Command (_, args, _, _)] when data <> [] -> + let desc, usage = + let usg, doc = List.hd data in + [(doc, "")], [(usg, "")] + in + sprint_category "description" ("\t" ^ Utils.sprint_two_cols desc) + ^ sprint_category "usage" ("\t" ^ Utils.sprint_two_cols usage) + ^ (describe_arguments args) + | _ -> Utils.sprint_two_cols data + + +let help ?prefix cmd_path cmdline = + let rec not_last = function [] | [_] -> [] | x :: xs -> x :: not_last xs in + let tree = find_tree cmdline cmd_path in + let pre_path = match tree with + | [Command _] -> not_last cmd_path + | _ -> cmd_path + in + let s = String.concat " " pre_path in + describe_tree ((prefix <$> (fun p -> p ^ s) |? s) ^ " ") tree + + +let first_name_string ns = match first_name ns with Short n | Long n -> n + +let first_arg_name = function + | Flag (ns, _, _) | Arg (ns, _, _, _, _) | Required (ns, _, _, _, _) -> + first_name_string ns + | Positional (t, vn, _) | Multiple (t, vn, _) -> vn |? sprint_argument_type t + +(* The [args] is required not to be inferred with a weak type. *) +let required_arguments args = List.filter is_required_or_positional args + +let required_arguments_names args = print_arguments stdout @@ required_arguments args; required_arguments args |> List.map first_arg_name + + +let arg_names_match ns = function + | n when Utils.starts_with "--" n -> List.mem (Long (Utils.trim_n 2 n)) ns + | n when Utils.starts_with "-" n -> List.mem (Short (Utils.trim_n 1 n)) ns + | _ -> false + +let is_argument name = function + | Flag (ns, _, _) | Arg (ns, _, _, _, _) | Required (ns, _, _, _, _) -> + arg_names_match ns name + | _ -> false + +let find_argument name = List.find (is_argument name) + + +let rec find_positional_argument = function + | [] -> raise Not_found + | (Positional _ as arg) :: _ | (Multiple _ as arg) :: _ -> arg + | _ :: cs -> find_positional_argument cs + +let validate_value t value = match t with + | File when Sys.file_exists value -> () + | Choice choices when List.mem value choices -> () + | String -> () + | File -> raise Invalid_argument_value + | Choice _ -> raise Invalid_argument_value + +let parse_argument arg argv = + let type_value t = match argv with + | value :: argv -> + validate_value t value; + (value, argv) + | [] -> raise Missing_argument_value + in + match arg with + | Flag (ns, id, _) -> (`Named (id, first_name_string ns), argv) + | Arg (_, t, id, _, _) | Required (_, t, id, _, _) -> + let value, argv = type_value t in + (`Named (id, value), argv) + | Positional (t, _, _) -> + let value, argv = type_value t in + (`Pos value, argv) + | Multiple (t, _, _) -> + let validate value = + validate_value t value; + value + in + (`Mul (List.map validate argv), []) + +let parse_arguments = + let remove x = List.filter (fun y -> x <> y) in + let find_argument n args = (Utils.optionify @@ find_argument n) args in + let find_positional_argument arg = Utils.optionify find_positional_argument arg in + let rec parse args = function + | [] when required_arguments args = [] -> ([], []) + | a :: argv -> + let collect_value () = match (find_argument a args, find_positional_argument args) with + | (Some arg, _) -> arg, parse_argument arg argv + | (None, Some arg) -> arg, parse_argument arg (a :: argv) (* if it's positional its a value *) + | (None, None) -> raise (Unknown_argument a) + in + let arg, (value, argv) = collect_value () in + let (named, positional) = parse (remove arg args) argv in + begin match value with + | `Named x -> (x :: named, positional) + | `Pos x -> (named, x :: positional) + | `Mul xs -> (named, xs @ positional) + end + | [] -> raise (Missing_arguments (required_arguments_names args)) + in + parse + +let apply_cmdfun f arguments argv = + let arguments = sort_arguments arguments in + let (named, positional) = parse_arguments arguments argv in + f named positional + +let rec apply_anonymous argv cmdline = match find_anonymous cmdline with + | Anonymous (args, _, f) -> apply_cmdfun f args argv + | _ -> assert false + +let rec parse_commands cmdline = + let cmds_names = collect_cmd_names cmdline in + function + | name :: argv when List.mem name cmds_names -> + begin match find_command name cmdline with + | Prefix (_, cs) -> parse_commands cs argv + | Command (_, args, _, f) -> apply_cmdfun f args argv + | _ -> assert false + end + | args when has_anonymous cmdline -> apply_anonymous args cmdline + | name :: _ -> raise (Unknown_command name) + | [] -> raise Incomplete_command + + +let validate_commandline = function _ -> () (* TODO *) + +let run = function + | [] -> raise Empty_commandline + | cmdline -> + validate_commandline cmdline; + Sys.argv + |> Array.to_list + |> List.tl (* skip argv[0] *) + |> parse_commands cmdline + + +let anonymous ?(args = []) ?(doc = "") f = Anonymous (args, doc, f) +let command ?(args = []) ?(doc = "") n f = Command (n, args, doc, f) +let prefix name commands = Prefix (name, commands) + + +let names_of short long = (short <$> (fun s -> [Short s]) |? []) @ [Long long] +let flag ?short ?(doc = "") n x = Flag (names_of short n, x, doc) +let arg ?short ?default ?valname ?(doc = "") n t x = Arg (names_of short n, t, x, valname, doc) +let positional ?valname ?(doc = "") t = Positional (t, valname, doc) +let multiple ?valname ?(doc = "") t = Multiple (t, valname, doc) diff --git a/src/glcmd.mli b/src/glcmd.mli new file mode 100644 index 00000000..f776de0c --- /dev/null +++ b/src/glcmd.mli @@ -0,0 +1,56 @@ +(* Git-like command line argument parser *) + +type doc = string + +type argument_name = Short of string | Long of string +type argument_value = string +type argument_type = + | File + | String + | Choice of argument_value list +type argument_names = argument_name list +type argument_valname = string option +type 'a argument = + | Flag of argument_names * 'a * doc + | Arg of argument_names * argument_type * 'a * argument_valname * doc + | Required of argument_names * argument_type * 'a * argument_valname * doc + | Positional of argument_type * argument_valname * doc + | Multiple of argument_type * argument_valname * doc + +type command_name = string +type 'a command_args = 'a argument list +type ('a, 'b) command_fun = ('a * argument_value) list -> argument_value list -> 'b +type ('a, 'b) command = + | Prefix of command_name * ('a, 'b) command list + | Command of command_name * 'a command_args * doc * ('a, 'b) command_fun + | Anonymous of 'a command_args * doc * ('a, 'b) command_fun +type ('a, 'b) commandline = ('a, 'b) command list + +exception Empty_commandline +exception Unknown_command of string +exception Incomplete_command +exception Unknown_argument of string +exception Missing_arguments of string list +exception Invalid_argument_value +exception Missing_argument_value + +val find_tree : ('a, 'b) commandline -> command_name list -> ('a, 'b) commandline + +val help : ?prefix:string -> string list -> ('a, 'b) commandline -> string + +val run : ('a, 'b) commandline -> 'b + + +val anonymous : ?args:'a command_args -> ?doc:doc -> + ('a, 'b) command_fun -> ('a, 'b) command +val command : ?args:'a command_args -> ?doc:doc -> + command_name -> ('a, 'b) command_fun -> ('a, 'b) command +val prefix : command_name -> ('a, 'b) command list -> ('a, 'b) command + +val flag : ?short:string -> ?doc:doc -> string -> 'a -> 'a argument +val arg : + ?short:string -> ?default:argument_value -> + ?valname:string -> ?doc:doc -> + string -> argument_type -> 'a -> 'a argument +val positional : ?valname:string -> ?doc:doc -> argument_type -> 'a argument +val multiple : ?valname:string -> ?doc:doc -> argument_type -> 'a argument diff --git a/src/how.ml b/src/how.ml new file mode 100644 index 00000000..dfd86bbc --- /dev/null +++ b/src/how.ml @@ -0,0 +1,159 @@ +open Utils.Operators + +type how_cmdline_t = ([`Dir | `Raw | `Silent], unit) Glcmd.commandline +let hcl_ref : how_cmdline_t option ref = ref None +let how_cmd_fun f = fun n p -> + match !hcl_ref with + | Some hcl -> f n p hcl + | None -> assert false + + + +type how_config_key = [ `Api + | `Build_dir + | `Client + | `Def_subp + | `Deploy + | `Dir + | `Force + | `Link_check + | `Manual + | `Raw + | `Server + | `Silent + | `Templates + | `Versions + | `Assets + | `Img + | `Csw + | `Menu ] + +let how_config : how_config_key Conf.elt = + Conf.(mapping [pair "deploy" `Deploy (bool () ~default:false) + ~doc:"Builds the website for deployement purpose (instead of testing)."; + pair "templates" `Templates (sequence (string () + ~check:Sys.file_exists + ~err:"Template does not exist.") + ~default:[]) + ~doc:"The list of templates, outermost first."; + pair "versions" `Versions (sequence (string ()) + ~check:(fun s -> s <> []) + (* ~default:(infer_versions ()) *) + ~err:"Version list cannot be empty.") + ~doc:"The list of version directories."; + pair "build-dir" `Build_dir (string () ~default:"_build") + ~doc:"Name of the build directory."; + (* remote *) + pair "force" `Force (bool () ~default:false) + ~doc:"Overwrites the build directory if it exists when the build starts."; + pair "link-check" `Link_check (mapping [pair "raw" `Raw (bool () ~default:false) + ~doc:"Doesn't converts linkchecker's output to Json when true."; + pair "silent" `Silent (bool () ~default:false) + ~doc:"No output at all when true."]) + ~doc:"Behaviour of the command `how check links'."; + pair "manual" `Manual (string () (* ~default:(infer_manual ()) *)) + ~doc:"Path to the manual directory."; + pair "api" `Api (either (string ()) + (mapping [pair "dir" `Dir (string ()) + ~doc:"The path to the API directory."; + pair "client" `Client (string ()) + ~doc:"The path to the client API directory."; + pair "server" `Server (string ()) + ~doc:"The path to the server API directory."; + pair "default-subproject" `Def_subp (string ()) + ~doc:"Default subproject's name. Obsolete."] + (* ~default:(infer_api ()) *))) + ~doc:"API information. When just a string, the path to the API directory."; + pair "assets" `Assets (either (string ()) + (mapping [pair "dir" `Dir (string ()) + ~doc:"The path to the asset directory."; + pair "images" `Img (string ()) + ~doc:"The path to the image directory."])) + ~doc:"Asset information. When just a string, the path to the image + asset directory."; + pair "menu" `Menu (bool () ~default:false) + ~doc:"Whether to include or not a side menu (cf. doctree extension)."; + pair "client-server-switch" `Csw (bool () ~default:false) + ~doc:"Whether to include or not a client/server switch on compatible pages (cf. extension)."]) + + +let printr s = (fun _ _ -> print_endline s) + +let config_help_cmd _ _ = Conf.doc_of_conf how_config |> print_endline + +let help_cmd = how_cmd_fun (fun _ cmd_path hcl -> Glcmd.help ~prefix:"how" cmd_path hcl |> print_string) + + + + + +(* let rec string_of_conf_structure_error_t = function + * | `Bool -> "bool" + * | `String -> "string" + * | `Mapping -> "mapping" + * | `Sequence -> "sequence" + * | `Float -> "float" + * | `Null -> "null" + * | `Either (a, b) -> Printf.sprintf "either (%s) or (%s)" + * (string_of_conf_structure_error_t a) + * (string_of_conf_structure_error_t b) + * + * let () = + * let open Printf in + * let ic = open_in ".how.yml" in + * Conf.( + * try + * let res = Conf.parse Conf.yaml_parser how_config ic in + * (yaml_printer (tag_printer_of_conf how_config)) res |> print_endline + * with + * | Unexpected_labels ls -> printf "unex labels: %s\n" (String.concat ", " ls) + * | Missing_required_pairs ls -> printf "miss req pairs: %s\n" (String.concat ", " ls) + * | Structure_error {got; expected; inside} -> printf "Error inside \"%s\": expected %s and got %s\n" + * inside + * (string_of_conf_structure_error_t expected) + * (string_of_conf_structure_error_t got) + * ); + * close_in ic *) + + + +let how_commandline = + Glcmd.[anonymous help_cmd ~doc:"Displays available commands"; + command "help" help_cmd + ~args:[multiple String ~valname:"CMD" ~doc:"The command to describe."] + ~doc:"Displays help for a given command."; + command "build" (printr "build") + ~args:[arg "dir" String `Dir ~short:"d" (*~default:"_build"*) ~valname:"DIR" + ~doc:"The directory to build in."; + multiple File ~valname:"VERSION" ~doc:"The versions of the documentation to build."] + ~doc:"Build the documentation of the project."; + prefix "check" + [anonymous (printr "check all") ~doc:"Perform all checks."; + command "links" (printr "check links") + ~args:[arg "dir" File `Dir ~short:"d" ~valname:"DIR" + ~doc:"The directory to check in."; + flag "raw" `Raw ~short:"r" + ~doc:"Prints the raw output of [linkchecker] (ie. no Json formatting)."; + flag "silent" `Silent ~short:"s" + ~doc:"Perform the check but outputs nothing."] + ~doc:"Run [linkchecker] on the build directory to check for deadlinks."; + command "config" (printr "check config") + ~doc:"Checks the validity of the configuration file."]; + prefix "config" + [anonymous (printr "config help") ~doc:"Configuration file related commands."; + command "help" config_help_cmd + ~doc:"Lists the available configuration options"; + command "check" (printr "check config") + ~doc:"Checks the validity of the configuration file."; + command "infer" (printr "inferring.") + ~doc:"Prints a minimal configuration inferred using the structure of the current directory."]; + prefix "init" + [anonymous (printr "init") + ~doc:"Creates an inferred configuration file in the current directory."; + command "infer" (printr "init infer") + ~doc:"Creates an inferred configuration file in the current directory."; + command "default" (printr "init default") + ~doc:"Creates a default configuration file in the current directory."]] + +let () = + hcl_ref := Some how_commandline; + Glcmd.run how_commandline diff --git a/src/utils.ml b/src/utils.ml index b81955fe..640f61d7 100644 --- a/src/utils.ml +++ b/src/utils.ml @@ -1,3 +1,4 @@ +(* GENERAL UTILITIES *) module Operators = struct let (>>=) x f = match x with | Some x -> f x @@ -12,21 +13,73 @@ module Operators = struct | None -> default let (+/+) p q = Paths.(p +/+ q) -end + let rec (^*) s = function + | 0 -> "" + | n when n > 0 -> s ^ (s ^* (n - 1)) + | _ -> failwith "string multiplication operator: negative operand" + + let (@<) l l' = List.for_all (fun x -> List.mem x l') l + + let (@-) l l' = List.filter (fun x -> not @@ List.mem x l') l +end let id x = x +let constantly x = fun _ -> x + let zipk f g k = f (fun fk -> g (fun gk -> k fk gk)) + +(* LIST UTILIIES *) +type ('a, 'b) alist = ('a * 'b) list + +let rec zip l l' = match l, l' with + | [], _ | _, [] -> [] + | x :: l, x' :: l' -> (x, x') :: zip l l' + +let rec unzip = function + | [] -> [], [] + | (x, y) :: ps -> + let xs, ys = unzip ps in + x :: xs, y :: ys + +let group_alists l l' = List.map (fun (k, v) -> match List.assoc_opt k l' with + | Some v' -> [(k, (v, v'))] + | None -> []) l |> List.concat + +let alist_of_values kofv = List.map (fun v -> (kofv v, v)) + let check_errors = List.iter (fun (err, b) -> if Lazy.force b then () else failwith err) + +(* HASHTBL UTILITIES *) +let alist_of_hashtbl h = + let al = ref [] in + Hashtbl.iter (fun k v -> al := (k, v) :: !al) h; + !al + + +(* OPTION UTILITIES *) let is_some = function Some _ -> true | None -> false let is_none = function Some _ -> false | None -> true +let optionify f = fun x -> match f x with + | exception Not_found -> None + | x -> Some x +let not_foundify f = fun x -> match f x with + | Some x -> x + | None -> raise Not_found + + +(* STRING UTILITIES *) +let trim_n n string = match String.length string with + | len when len <= n -> "" + | len -> String.sub string n (len - n) + let trim char string = - let rem_first s = String.sub s 1 (String.length s - 1) in + let rem_first = trim_n 1 in let rec trim = function | "" -> "" | s when s.[0] = char -> trim @@ rem_first s @@ -34,7 +87,54 @@ let trim char string = in trim string +let starts_with prefix s = + let p = String.length prefix in + String.length s >= p && String.sub s 0 p = prefix +let ends_with suffix s = + let l = String.length suffix in + String.length s >= l && String.sub s (String.length s - l) l = suffix + +let rec flip_repr = function + | [] | [] :: _ -> [] + | rows -> + let col = List.map (function [] -> assert false | x :: _ -> x) rows in + let rest = List.map (function [] -> assert false | _ :: xs -> xs) rows in + col :: flip_repr rest + +let sprint_n_cols ?(prefix = "") ?(sep = "\t ") = function + | [] -> "" + | rows -> + let n_cols = List.length (List.nth rows 0) in + assert (rows |> List.map List.length |> List.for_all (fun x -> x = n_cols)); + let maxes = rows + |> flip_repr + |> List.map (List.fold_left (fun n s -> max n (String.length s)) 0) + in + rows + |> List.map (fun cols -> + zip cols maxes + |> List.map (fun (c, n) -> c ^ Operators.(" " ^* (n - String.length c))) + |> String.concat sep + |> fun s -> prefix ^ s) + |> String.concat "\n" + + +let sprint_two_cols ?(prefix = "") ?(sep = "\t ") rows = + rows + |> List.map (fun (c, c') -> [c; c']) + |> sprint_n_cols ~prefix ~sep + +let sprint_three_cols ?(prefix = "") ?(sep = "\t ") rows = + rows + |> List.map (fun (c, c', c'') -> [c; c'; c'']) + |> sprint_n_cols ~prefix ~sep + +let uri_absolute = + let rex = Re.Pcre.regexp "^(http|https|file|localhost:\\d+)://" in + Re.Pcre.pmatch ~rex + +(* FILE UTILITIES *) let sorted_dir_files sort dir = Sys.readdir dir |> Array.to_list |> sort let dir_files = sorted_dir_files id let a'_sorted_dir_files = sorted_dir_files (List.sort compare) @@ -49,12 +149,6 @@ let rec find_files name = function |> List.concat | _ -> [] - -let uri_absolute = - let rex = Re.Pcre.regexp "^(http|https|file|localhost:\\d+)://" in - Re.Pcre.pmatch ~rex - - let read_channel_lines ic = let rec readall lines = try diff --git a/src/utils.mli b/src/utils.mli index 4fc0c62c..a0ed2735 100644 --- a/src/utils.mli +++ b/src/utils.mli @@ -11,28 +11,85 @@ module Operators : sig (** Path concatenation operator. See module [Paths]. *) val (+/+) : string -> string -> string + + (** [s ^* n] equals to [s ^ s ^ ... ^ s], [n] times. *) + val (^*) : string -> int -> string + + (** [l @< l'] returns whether every element in [l] is also + inside [l'] (in terms of [=]). *) + val (@<) : 'a list -> 'a list -> bool + + (** [l @- l'] returns the list of the elements of [l] not present + inside [l'] (in terms of [=]). *) + val (@-) : 'a list -> 'a list -> 'a list end (** The identity function. *) val id : 'a -> 'a +(** [constantly x = fun _ -> x] *) +val constantly : 'a -> 'b -> 'a + +(** Association lists type. *) +type ('a, 'b) alist = ('a * 'b) list + (** Continuation argument zipper. [f (fun a -> g (fun b -> ...))] = [zipk f g (fun a b -> ...)] *) val zipk : (('a -> 'b) -> 'c) -> (('d -> 'e) -> 'b) -> ('a -> 'd -> 'e) -> 'c +(** [zip [a1;a2;...;aN] [b1;b2;...;bM]] returns + [[(a1,b1); (a2,b2); ...; (aL,bL)]] with [L = min N M]. *) +val zip : 'a list -> 'b list -> ('a * 'b) list + +(** Inverse of [zip]. *) +val unzip : ('a * 'b) list -> 'a list * 'b list + +(** Groups association lists using [=] keys. For example, + [group_alists [(1, 10); (2, 20); (3, 30)] [(2, 0); (3, 1); (4, 2)]] returns + [[(2, (10, 0)); (3, (30, 1))]]. *) +val group_alists : ('a, 'b) alist -> ('a, 'c) alist -> ('a, ('b * 'c)) alist + +(** [alist_of_values f [x; x'; ...]] returns [(x, f x); (x', f x'); ...]. *) +val alist_of_values : ('b -> 'a) -> 'b list -> ('a, 'b) alist + (** [check_errors [(msg, exp); ...]] evaluates in order each [exp] and raises [Failure msg] with the [msg] of the first [exp] to return [false], if any. *) val check_errors : (string * bool lazy_t) list -> unit +(** Converts an hash table to an association list. *) +val alist_of_hashtbl : ('a, 'b) Hashtbl.t -> ('a * 'b) list + (** [is_some x] returns whether [x] is [Some y]. *) val is_some : 'a option -> bool (** [is_none x] returns whether [x] is [None]. *) val is_none : 'a option -> bool +(** Inverse of [not_foundify]. *) +val optionify : ('a -> 'b) -> ('a -> 'b option) + +(** [not_foundify f] returns a wrapper of [f] that raises [Not_found] + when [f] returns [None]. *) +val not_foundify : ('a -> 'b option) -> ('a -> 'b) + +(** [trim_n n s] returns [s] without its [n] first characters. *) +val trim_n : int -> string -> string + (** [trim c s] returns [s] with the trailing occurences of [c] removed. *) val trim : char -> string -> string +(** [starts_with s s'] retruns whether [s] is a prefix of [s]. *) +val starts_with : string -> string -> bool + +(** [ends_with s s'] retruns whether [s] is a suffix of [s]. *) +val ends_with : string -> string -> bool + +(** Pretty prints the given columns with even horizontal spacing. *) +val sprint_two_cols : ?prefix:string -> ?sep:string -> (string * string) list -> string + +(** Pretty prints the given columns with even horizontal spacing. *) +val sprint_three_cols : ?prefix:string -> ?sep:string -> (string * string * string) list -> string + (** [sorted_dir_files sort dir] returns the list of the files inside [dir] sorted using the given [sort] function. *) val sorted_dir_files : (string list -> string list) -> string -> string list