cli/cli.carp

; TODO: this is temporary until we have this in the stdlib
(defmodule Maybe
  (defn zero [] (Maybe.Nothing))
)

(doc CLI "is a simple CLI library for Carp.

```clojure
(load \"https://veitheller.de/git/carpentry/cli@0.0.6\")

(defn main []
  (let [p (=> (CLI.new @\"My super cool tool!\")
              (CLI.add &(CLI.int \"flag\" \"f\" \"my flag\" true))
              (CLI.add &(CLI.str \"thing\" \"t\" \"my thing\" false @\"hi\" &[@\"a\" @\"b\" @\"hi\"])))]
    (match (CLI.parse &p)
      (Result.Success flags)
        (println* &(str &(Map.get &flags \"flag\")) \" \" &(str &(Map.get &flags \"thing\")))
      (Result.Error msg) (do (IO.errorln &msg) (CLI.usage &p)))))
```

## Installation

```clojure
(load \"https://veitheller.de/git/carpentry/cli@0.0.6\")
```

## Usage

`CLI` should be built using combinators, as in the example above. It has, as of
now, three option types: integrals (longs), floating point numbers (doubles),
and strings. They can be built using `CLI.int`, `CLI.float`, and `CLI.str`,
respectively. Their structure is always the same:

```clojure
(CLI.int <long> <short> <description> <required?>)
; or
(CLI.int <long> <short> <description> <required?> <default>)
; or
(CLI.int <long> <short> <description> <required?> <default> <options-array>)
```

You’ll have to set a default if you want to specify options, although you can
set it to `(Maybe.Nothing)` if you want to make sure that it has to be set
manually.

Once you’re done building your flag structure, you can run `CLI.parse`. It
will not abort the program on error, instead it will tell you what went wrong
in a `Result.Error`. If it succeeds, the `Result.Success` contains a `Map` from
the long flag name to the value. The values are not in the map if they are
unset.")
(defmodule CLI
  (hidden Type)
  (private Type)
  (deftype Type
    (Integer [Long])
    (Floating [Double])
    (Str [String])
    (None [])
  )

  (defmodule Type
    (defn = [a b]
      (match @a
        (None)
          (match @b
            (None) true
            _ false)
        (Integer i)
          (match @b
            (Integer j) (= i j)
            _ false)
        (Floating f)
          (match @b
            (Floating g) (= f g)
            _ false)
        (Str s)
          (match @b
            (Str t) (= s t)
            _ false)))

    (defn format [s t]
      (match @t
        (Integer i) (Long.format s i)
        (Floating f) (Double.format s f)
        (Str s2) (String.format s &s2)))

    (defn str [t]
      (match @t
        (Integer i) (str i)
        (Floating f) (str f)
        (Str s) (str s)
        (None) @"none"))

    (defn to-int [x]
      (match x
        (Integer l) (Long.to-int l)
        _ 0))

    (defn to-long [x]
      (match x
        (Integer l) l
        _ 0l))

    (defn to-str [x]
      (match x
        (Str s) s
        _ @""))

    (defn to-float [x]
      (match x
        (Floating d) (Double.to-float d)
        _ 0.0f))

    (defn to-double [x]
      (match x
        (Floating d) d
        _ 0.0))

    (defn zero [] (None))
  )

  (hidden Tag)
  (private Tag)
  (deftype Tag
    (Integer [])
    (Floating [])
    (Str [])
  )

  (defmodule Tag
    (defn to-type [t s]
      (match t
        (Integer) (CLI.Type.Integer (Long.from-string s))
        (Floating) (CLI.Type.Floating (Double.from-string s))
        (Str) (CLI.Type.Str @s)))
  )

  (doc Option "is the option type. To construct an `Option`, please use
[`int`](#int), [`float`](#float), or [`str`](#str).")
  (deftype Option [
    type- Tag
    long String
    short String
    description String
    required? Bool
    default (Maybe Type)
    options (Maybe (Array Type))
  ])

  (doc Parser "is the parser type. To construct a `Parser`, please use
[`new`](#new).")
  (deftype Parser [
    description String
    options (Array Option)
  ])

  (private CmdMap)
  (hidden CmdMap)
  ; this is pretty brutal. It’s a (Pair (Pair <long> <short>) (<tag> <value>))
  ; we need to make our own map because long or short might match and both are
  ; equivalent. This means a lot of manual work. Sorry about that.
  (deftype CmdMap [
    values (Array (Pair (Pair String String) (Pair Tag (Maybe Type))))
  ])

  (defmodule CmdMap
    (defn new [] (init []))

    (defn put [m o v]
      (update-values m
        &(fn [vs]
          (Array.push-back vs
            (Pair.init
              (Pair.init @(CLI.Option.long o) @(CLI.Option.short o))
              @v)))))

    (defn put-empty [m o]
      (put m o &(Pair.init-from-refs (CLI.Option.type- o) (CLI.Option.default o))))

    (defn contains? [m s]
      (let-do [found false]
        (foreach [e (values m)]
          (let [k (Pair.a e)]
            (when (or (= (Pair.a k) s) (= (Pair.b k) s))
              (do
                (set! found true)
                (break)))))
        found))

    (defn set? [m s]
      (let-do [found false]
        (foreach [e (values m)]
          (let [k (Pair.a e)
                v (Pair.b (Pair.b e))]
            (when (or (= (Pair.a k) s) (= (Pair.b k) s))
              (do
                (set! found (Maybe.just? v))
                (break)))))
        found))

    (defn get [m s]
      (let-do [res (CLI.Type.Str @"")]
        (foreach [e (values m)]
          (let [k (Pair.a e)
                v (Pair.b (Pair.b e))]
            (when (or (= (Pair.a k) s) (= (Pair.b k) s))
              (do
                (set! res (Maybe.unsafe-from @v))
                (break)))))
        res))

    (defn in? [m s vs]
      (let-do [found true]
        (foreach [e (values m)]
          (let [k (Pair.a e)
                v (Pair.b (Pair.b e))]
            (when (or (= (Pair.a k) s) (= (Pair.b k) s))
              (match @v
                (Maybe.Just value)
                  (do
                    (set! found (Array.contains? vs &value))
                    (break))
                (Maybe.Nothing) (break)))))
        found))

    (defn put! [m s v]
      (let [vs (values m)]
        (for [i 0 (Array.length vs)]
          (let [p (Array.unsafe-nth vs i)
                k (Pair.a p)
                vp (Pair.b p)]
            (when (or (= (Pair.a k) s) (= (Pair.b k) s))
              (do
                (Pair.set-b! vp (Maybe.Just (CLI.Tag.to-type @(Pair.a vp) v)))
                (break)))))))

    (defn to-map [m]
      (Array.reduce
        &(fn [a v]
          (match @(Pair.b (Pair.b v))
            (Maybe.Just e) (Map.put a (Pair.a (Pair.a v)) &e)
            (Maybe.Nothing) a))
        {}
        (values m)))
  )

  (defmodule Parser
    (defn values [p]
      (Array.reduce &CLI.CmdMap.put-empty (CLI.CmdMap.new) (options p)))
  )

  (doc new "creates a new `Parser` with a program description `descr`.")
  (defn new [descr] (Parser.init descr []))

  (doc add "adds an `Option` `opt` to the `Parser` `p`.")
  (defn add [p opt]
    (Parser.update-options p &(fn [options] (Array.push-back options @opt))))

  (hidden option-)
  (private option-)
  (defndynamic option- [t long short description required default-options]
    (if (= (length default-options) 0)
      (list 'CLI.Option.init (list t)
        (list 'copy long) (list 'copy short) (list 'copy description)
        required '(Maybe.Nothing) '(Maybe.Nothing))
      (if (= (length default-options) 1)
        (list 'CLI.Option.init (list t)
          (list 'copy long) (list 'copy short) (list 'copy description)
          required (list 'Maybe.Just (list 'to-cli-type (car default-options))) '(Maybe.Nothing))
        (list 'CLI.Option.init (list t)
          (list 'copy long) (list 'copy short) (list 'copy description)
          required (list 'Maybe.Just (list 'to-cli-type (car default-options)))
          (list 'Maybe.Just
            (list 'Array.copy-map '(ref (fn [e] (to-cli-type @e))) (cadr default-options)))))))

  (doc str "creates a string option.")
  (defmacro str [long short description required :rest default-options]
    (CLI.option- 'CLI.Tag.Str long short description required default-options))

  (doc int "creates a integer option. The actual type is a `Long`.")
  (defmacro int [long short description required :rest default-options]
    (CLI.option- 'CLI.Tag.Integer long short description required default-options))

  (doc float "creates a integer option. The actual type is a `Double`.")
  (defmacro float [long short description required :rest default-options]
    (CLI.option- 'CLI.Tag.Floating long short description required default-options))

  (private options-str)
  (hidden options-str)
  (defn options-str [p]
    (join
      " "
      &(Array.copy-map
        &(fn [o] (fmt "[-%s | --%s]" (Option.short o) (Option.long o)))
        (Parser.options p))))

  (doc usage "takes a `Parser` `p` and prints its usage information.")
  (defn usage [p]
    (do
      (IO.println
        &(fmt "usage: %s %s\n%s\nOptions:"
              (System.get-arg 0) &(options-str p) (Parser.description p)))
      (foreach [arg (Parser.options p)]
        (do
          (IO.print
            &(fmt "  --%s|-%s: %s"
                  (Option.long arg) (Option.short arg) (Option.description arg)))
          (when @(Option.required? arg) (IO.print " REQUIRED"))
          (when (Maybe.just? (Option.default arg))
            (IO.print &(fmt " (default: %s)" &(str &(Maybe.unsafe-from @(Option.default arg))))))
          (match @(Option.options arg)
            (Maybe.Just o)
              (IO.print &(fmt " (options: %s)" &(join ", " &(Array.copy-map &str &o))))
            (Maybe.Nothing) ())
          (IO.println "")))
      (IO.println "  --help|-h: print this help message and exit.")))

  (doc parse "parses the arguments as specified by the parser `p`.

If everything goes right, it will return a `Success` containing a map from
the long arguments to their values. Because values can be optional, they are
returned as `Maybe`.

Otherwise it will return an `Error` containing an error message. If that error
mesage is empty, `--help` was requested. If you don’t want to provide a
`--help` feature, you can override that flag.")
  (defn parse [p]
    (let-do [values (Parser.values p)
             res (Result.Success @p)
             options (Parser.options p)]
      (for [i 1 (System.get-args-len)]
        (let [x (System.get-arg i)]
          (if (or (String.starts-with? x "--") (String.starts-with? x "-"))
            (let [flag (Pattern.substitute #"^\-\-?" x "" 1)
                  splt (String.split-by &flag &[\=])
                  k (if (> (Array.length &splt) 1) (Array.unsafe-nth &splt 0) &flag)
                  v (cond (> (Array.length &splt) 1) (Array.nth &splt 1)
                          (< i (System.get-args-len))
                            (do (set! i (Int.inc i)) (Maybe.Just @(System.get-arg i)))
                          (Maybe.Nothing))]
              (cond
                (CmdMap.contains? &values k)
                  (match v
                    (Maybe.Just val) (CmdMap.put! &values k &val)
                    (Maybe.Nothing)
                      (do
                        (set! res (Result.Error (fmt "No value for: %s" &flag)))
                        (break)))
                (or (= k "help") (= k "h"))
                  (do
                    (set! res (Result.Error @""))
                    (break))
                (do
                  (set! res (Result.Error (fmt "Unknown option: %s" x)))
                  (break))))
            (do
              (set! res (Result.Error (fmt "Unexpected argument: %s" x)))
              (break)))))
      (when (Result.success? &res)
        (foreach [o options]
          (cond
            (and @(Option.required? o)
                 (not (CmdMap.set? &values (Option.long o))))
              (do
                (set! res (Result.Error (fmt "Required option missing: --%s" (Option.long o))))
                (break))
            (Maybe.just? (Option.options o))
              (let-do [opts (Maybe.unsafe-from @(Option.options o))]
                (when (not (CmdMap.in? &values (Option.long o) &opts))
                  (do
                    (set! res
                      (Result.Error
                        (fmt
                          "Option %s received an invalid option %s (Options are %s)"
                          (Option.long o)
                          &(CmdMap.get &values (Option.long o))
                          &(join ", " &(Array.copy-map &str &opts)))))
                    (break))))
            ())))
      (match res
        (Result.Success _) (Result.Success (CmdMap.to-map &values))
        (Result.Error x) (Result.Error x))))
)

(definterface to-cli-type (Fn [a] CLI.Type))

(defmodule String
  (defn to-cli-type [s] (CLI.Type.Str s))
)

(defmodule Double
  (defn to-cli-type [f] (CLI.Type.Floating f))
)

(defmodule Long
  (defn to-cli-type [l] (CLI.Type.Integer l))
)