Examples

The examples are self-contained, cut and paste them in a file to play with them.

A rm command

We define the command line interface of an rm command with the synopsis:

rm [OPTION]… FILE…

The -f, -i and -I flags define the prompt behaviour of rm. It is represented in our program by the prompt type. If more than one of these flags is present on the command line the last one takes precedence.

To implement this behaviour we map the presence of these flags to values of the prompt type by using Cmdliner.Arg.vflag_all.

This argument will contain all occurrences of the flag on the command line and we just take the Cmdliner.Arg.last one to define our term value. If there is no occurrence the last value of the default list [Always] is taken. This means the default prompt behaviour is Always.

(* Implementation of the command, we just print the args. *)

type prompt = Always | Once | Never
let prompt_str = function
| Always -> "always" | Once -> "once" | Never -> "never"

let rm prompt recurse files =
  Printf.printf "prompt = %s\nrecurse = %B\nfiles = %s\n"
    (prompt_str prompt) recurse (String.concat ", " files)

(* Command line interface *)

open Cmdliner

let files = Arg.(non_empty & pos_all file [] & info [] ~docv:"FILE")
let prompt =
  let always =
    let doc = "Prompt before every removal." in
    Always, Arg.info ["i"] ~doc
  in
  let never =
    let doc = "Ignore nonexistent files and never prompt." in
    Never, Arg.info ["f"; "force"] ~doc
  in
  let once =
    let doc = "Prompt once before removing more than three files, or when
               removing recursively. Less intrusive than $(b,-i), while
               still giving protection against most mistakes."
    in
    Once, Arg.info ["I"] ~doc
  in
  Arg.(last & vflag_all [Always] [always; never; once])

let recursive =
  let doc = "Remove directories and their contents recursively." in
  Arg.(value & flag & info ["r"; "R"; "recursive"] ~doc)

let cmd =
  let doc = "Remove files or directories" in
  let man = [
    `S Manpage.s_description;
    `P "$(tname) removes each specified $(i,FILE). By default it does not
        remove directories, to also remove them and their contents, use the
        option $(b,--recursive) ($(b,-r) or $(b,-R)).";
    `P "To remove a file whose name starts with a $(b,-), for example
        $(b,-foo), use one of these commands:";
    `Pre "$(mname) $(b,-- -foo)"; `Noblank;
    `Pre "$(mname) $(b,./-foo)";
    `P "$(tname) removes symbolic links, not the files referenced by the
        links.";
    `S Manpage.s_bugs; `P "Report bugs to <bugs@example.org>.";
    `S Manpage.s_see_also; `P "$(b,rmdir)(1), $(b,unlink)(2)" ]
  in
  let info = Cmd.info "rm" ~version:"v1.1.1" ~doc ~man in
  Cmd.v info Term.(const rm $ prompt $ recursive $ files)

let main () = exit (Cmd.eval cmd)
let () = main ()

A cp command

We define the command line interface of a cp command with the synopsis:

cp [OPTION]… SOURCE… DEST

The DEST argument must be a directory if there is more than one SOURCE. This constraint is too complex to be expressed by the combinators of Cmdliner.Arg.

Hence we just give DEST the Cmdliner.Arg.string type and verify the constraint at the beginning of the implementation of cp. If the constraint is unsatisfied we return an `Error result. By using Cmdliner.Term.ret on the lifted result cp_t of cp, Cmdliner handles the error reporting.

(* Implementation, we check the dest argument and print the args *)

let cp verbose recurse force srcs dest =
  let many = List.length srcs > 1 in
  if many && (not (Sys.file_exists dest) || not (Sys.is_directory dest))
  then `Error (false, dest ^ ": not a directory") else
  `Ok (Printf.printf
         "verbose = %B\nrecurse = %B\nforce = %B\nsrcs = %s\ndest = %s\n"
         verbose recurse force (String.concat ", " srcs) dest)

(* Command line interface *)

open Cmdliner

let verbose =
  let doc = "Print file names as they are copied." in
  Arg.(value & flag & info ["v"; "verbose"] ~doc)

let recurse =
  let doc = "Copy directories recursively." in
  Arg.(value & flag & info ["r"; "R"; "recursive"] ~doc)

let force =
  let doc = "If a destination file cannot be opened, remove it and try again."in
  Arg.(value & flag & info ["f"; "force"] ~doc)

let srcs =
  let doc = "Source file(s) to copy." in
  Arg.(non_empty & pos_left ~rev:true 0 file [] & info [] ~docv:"SOURCE" ~doc)

let dest =
  let doc = "Destination of the copy. Must be a directory if there is more \
             than one $(i,SOURCE)." in
  let docv = "DEST" in
  Arg.(required & pos ~rev:true 0 (some string) None & info [] ~docv ~doc)

let cmd =
  let doc = "Copy files" in
  let man_xrefs =
    [ `Tool "mv"; `Tool "scp"; `Page ("umask", 2); `Page ("symlink", 7) ]
  in
  let man =
    [ `S Manpage.s_bugs;
      `P "Email them to <bugs@example.org>."; ]
  in
  let info = Cmd.info "cp" ~version:"v1.1.1" ~doc ~man ~man_xrefs in
  Cmd.v info Term.(ret (const cp $ verbose $ recurse $ force $ srcs $ dest))


let main () = exit (Cmd.eval cmd)
let () = main ()

A tail command

We define the command line interface of a tail command with the synopsis:

tail [OPTION]… [FILE]…

The --lines option whose value specifies the number of last lines to print has a special syntax where a + prefix indicates to start printing from that line number. In the program this is represented by the loc type. We define a custom loc_arg argument converter for this option.

The --follow option has an optional enumerated value. The argument converter follow, created with Cmdliner.Arg.enum parses the option value into the enumeration. By using Cmdliner.Arg.some and the ~vopt argument of Cmdliner.Arg.opt, the term corresponding to the option --follow evaluates to None if --follow is absent from the command line, to Some Descriptor if present but without a value and to Some v if present with a value v specified.

(* Implementation of the command, we just print the args. *)

type loc = bool * int
type verb = Verbose | Quiet
type follow = Name | Descriptor

let str = Printf.sprintf
let opt_str sv = function None -> "None" | Some v -> str "Some(%s)" (sv v)
let loc_str (rev, k) = if rev then str "%d" k else str "+%d" k
let follow_str = function Name -> "name" | Descriptor -> "descriptor"
let verb_str = function Verbose -> "verbose" | Quiet -> "quiet"

let tail lines follow verb pid files =
  Printf.printf
    "lines = %s\nfollow = %s\nverb = %s\npid = %s\nfiles = %s\n"
    (loc_str lines) (opt_str follow_str follow) (verb_str verb)
    (opt_str string_of_int pid) (String.concat ", " files)

(* Command line interface *)

open Cmdliner

let loc_arg =
  let parse s =
    try
      if s <> "" && s.[0] <> '+'
      then Ok (true, int_of_string s)
      else Ok (false, int_of_string (String.sub s 1 (String.length s - 1)))
    with Failure _ -> Error (`Msg "unable to parse integer")
  in
  let print ppf p = Format.fprintf ppf "%s" (loc_str p) in
  Arg.conv ~docv:"N" (parse, print)

let lines =
  let doc = "Output the last $(docv) lines or use $(i,+)$(docv) to start \
             output after the $(i,N)-1th line."
  in
  Arg.(value & opt loc_arg (true, 10) & info ["n"; "lines"] ~docv:"N" ~doc)

let follow =
  let doc = "Output appended data as the file grows. $(docv) specifies how \
             the file should be tracked, by its $(b,name) or by its \
             $(b,descriptor)."
  in
  let follow = Arg.enum ["name", Name; "descriptor", Descriptor] in
  Arg.(value & opt (some follow) ~vopt:(Some Descriptor) None &
       info ["f"; "follow"] ~docv:"ID" ~doc)

let verb =
  let quiet =
    let doc = "Never output headers giving file names." in
    Quiet, Arg.info ["q"; "quiet"; "silent"] ~doc
  in
  let verbose =
    let doc = "Always output headers giving file names." in
    Verbose, Arg.info ["v"; "verbose"] ~doc
  in
  Arg.(last & vflag_all [Quiet] [quiet; verbose])

let pid =
  let doc = "With -f, terminate after process $(docv) dies." in
  Arg.(value & opt (some int) None & info ["pid"] ~docv:"PID" ~doc)

let files = Arg.(value & (pos_all non_dir_file []) & info [] ~docv:"FILE")

let cmd =
  let doc = "Display the last part of a file" in
  let man = [
    `S Manpage.s_description;
    `P "$(tname) prints the last lines of each $(i,FILE) to standard output. If
        no file is specified reads standard input. The number of printed
        lines can be  specified with the $(b,-n) option.";
    `S Manpage.s_bugs;
    `P "Report them to <bugs@example.org>.";
    `S Manpage.s_see_also;
    `P "$(b,cat)(1), $(b,head)(1)" ]
  in
  let info = Cmd.info "tail" ~version:"v1.1.1" ~doc ~man in
  Cmd.v info Term.(const tail $ lines $ follow $ verb $ pid $ files)


let main () = exit (Cmd.eval cmd)
let () = main ()

A darcs command

We define the command line interface of a darcs command with the synopsis:

darcs [COMMAND] …

The --debug, -q, -v and --prehook options are available in each command. To avoid having to pass them individually to each command we gather them in a record of type copts. By lifting the record constructor copts into the term copts_t we now have a term that we can pass to the commands to stand for an argument of type copts. These options are documented in a section called COMMON OPTIONS, since we also want to put --help and --version in this section, the term information of commands makes a judicious use of the sdocs parameter of Cmdliner.Term.info.

The help command shows help about commands or other topics. The help shown for commands is generated by Cmdliner by making an appropriate use of Cmdliner.Term.ret on the lifted help function.

If the program is invoked without a command we just want to show the help of the program as printed by Cmdliner with --help. This is done by the default_cmd term.

(* Implementations, just print the args. *)

type verb = Normal | Quiet | Verbose
type copts = { debug : bool; verb : verb; prehook : string option }

let str = Printf.sprintf
let opt_str sv = function None -> "None" | Some v -> str "Some(%s)" (sv v)
let opt_str_str = opt_str (fun s -> s)
let verb_str = function
  | Normal -> "normal" | Quiet -> "quiet" | Verbose -> "verbose"

let pr_copts oc copts = Printf.fprintf oc
    "debug = %B\nverbosity = %s\nprehook = %s\n"
    copts.debug (verb_str copts.verb) (opt_str_str copts.prehook)

let initialize copts repodir = Printf.printf
    "%arepodir = %s\n" pr_copts copts repodir

let record copts name email all ask_deps files = Printf.printf
    "%aname = %s\nemail = %s\nall = %B\nask-deps = %B\nfiles = %s\n"
    pr_copts copts (opt_str_str name) (opt_str_str email) all ask_deps
    (String.concat ", " files)

let help copts man_format cmds topic = match topic with
| None -> `Help (`Pager, None) (* help about the program. *)
| Some topic ->
    let topics = "topics" :: "patterns" :: "environment" :: cmds in
    let conv, _ = Cmdliner.Arg.enum (List.rev_map (fun s -> (s, s)) topics) in
    match conv topic with
    | `Error e -> `Error (false, e)
    | `Ok t when t = "topics" -> List.iter print_endline topics; `Ok ()
    | `Ok t when List.mem t cmds -> `Help (man_format, Some t)
    | `Ok t ->
        let page = (topic, 7, "", "", ""), [`S topic; `P "Say something";] in
        `Ok (Cmdliner.Manpage.print man_format Format.std_formatter page)

open Cmdliner

(* Help sections common to all commands *)

let help_secs = [
 `S Manpage.s_common_options;
 `P "These options are common to all commands.";
 `S "MORE HELP";
 `P "Use $(mname) $(i,COMMAND) --help for help on a single command.";`Noblank;
 `P "Use $(mname) $(b,help patterns) for help on patch matching."; `Noblank;
 `P "Use $(mname) $(b,help environment) for help on environment variables.";
 `S Manpage.s_bugs; `P "Check bug reports at http://bugs.example.org.";]

(* Options common to all commands *)

let copts debug verb prehook = { debug; verb; prehook }
let copts_t =
  let docs = Manpage.s_common_options in
  let debug =
    let doc = "Give only debug output." in
    Arg.(value & flag & info ["debug"] ~docs ~doc)
  in
  let verb =
    let doc = "Suppress informational output." in
    let quiet = Quiet, Arg.info ["q"; "quiet"] ~docs ~doc in
    let doc = "Give verbose output." in
    let verbose = Verbose, Arg.info ["v"; "verbose"] ~docs ~doc in
    Arg.(last & vflag_all [Normal] [quiet; verbose])
  in
  let prehook =
    let doc = "Specify command to run before this $(mname) command." in
    Arg.(value & opt (some string) None & info ["prehook"] ~docs ~doc)
  in
  Term.(const copts $ debug $ verb $ prehook)

(* Commands *)

let sdocs = Manpage.s_common_options

let initialize_cmd =
  let repodir =
    let doc = "Run the program in repository directory $(docv)." in
    Arg.(value & opt file Filename.current_dir_name & info ["repodir"]
           ~docv:"DIR" ~doc)
  in
  let doc = "make the current directory a repository" in
  let man = [
    `S Manpage.s_description;
    `P "Turns the current directory into a Darcs repository. Any
       existing files and subdirectories become …";
    `Blocks help_secs; ]
  in
  let info = Cmd.info "initialize" ~doc ~sdocs ~man in
  Cmd.v info Term.(const initialize $ copts_t $ repodir)

let record_cmd =
  let pname =
    let doc = "Name of the patch." in
    Arg.(value & opt (some string) None & info ["m"; "patch-name"] ~docv:"NAME"
           ~doc)
  in
  let author =
    let doc = "Specifies the author's identity." in
    Arg.(value & opt (some string) None & info ["A"; "author"] ~docv:"EMAIL"
           ~doc)
  in
  let all =
    let doc = "Answer yes to all patches." in
    Arg.(value & flag & info ["a"; "all"] ~doc)
  in
  let ask_deps =
    let doc = "Ask for extra dependencies." in
    Arg.(value & flag & info ["ask-deps"] ~doc)
  in
  let files = Arg.(value & (pos_all file) [] & info [] ~docv:"FILE or DIR") in
  let doc = "create a patch from unrecorded changes" in
  let man =
    [`S Manpage.s_description;
     `P "Creates a patch from changes in the working tree. If you specify
         a set of files …";
     `Blocks help_secs; ]
  in
  let info = Cmd.info "record" ~doc ~sdocs ~man in
  Cmd.v info
    Term.(const record $ copts_t $ pname $ author $ all $ ask_deps $ files)

let help_cmd =
  let topic =
    let doc = "The topic to get help on. $(b,topics) lists the topics." in
    Arg.(value & pos 0 (some string) None & info [] ~docv:"TOPIC" ~doc)
  in
  let doc = "display help about darcs and darcs commands" in
  let man =
    [`S Manpage.s_description;
     `P "Prints help about darcs commands and other subjects…";
     `Blocks help_secs; ]
  in
  let info = Cmd.info "help" ~doc ~man in
  Cmd.v info
    Term.(ret (const help $ copts_t $ Arg.man_format $ Term.choice_names $
               topic))

let main_cmd =
  let doc = "a revision control system" in
  let man = help_secs in
  let info = Cmd.info "darcs" ~version:"v1.1.1" ~doc ~sdocs ~man in
  let default = Term.(ret (const (fun _ -> `Help (`Pager, None)) $ copts_t)) in
  Cmd.group info ~default [initialize_cmd; record_cmd; help_cmd]

let () = exit (Cmd.eval main_cmd)