275 lines
8.4 KiB
Plaintext
275 lines
8.4 KiB
Plaintext
(defmodule Maybe
|
|
(defn zero [] (Maybe.Nothing))
|
|
)
|
|
|
|
(defmodule CLI
|
|
(deftype Type
|
|
(Integer [Long])
|
|
(Floating [Double])
|
|
(Str [String])
|
|
)
|
|
|
|
(defmodule Type
|
|
(defn = [a b]
|
|
(match @a
|
|
(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)))
|
|
)
|
|
|
|
(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)))
|
|
)
|
|
|
|
(deftype Option [
|
|
type- Tag
|
|
long String
|
|
short String
|
|
description String
|
|
required? Bool
|
|
default (Maybe Type)
|
|
options (Maybe (Array Type))
|
|
])
|
|
|
|
(deftype Parser [
|
|
description String
|
|
options (Array Option)
|
|
])
|
|
|
|
(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] (Map.put a (Pair.a (Pair.a v)) (Pair.b (Pair.b v))))
|
|
{}
|
|
(values m)))
|
|
)
|
|
|
|
(defmodule Parser
|
|
(defn values [p]
|
|
(Array.reduce &CLI.CmdMap.put-empty (CLI.CmdMap.new) (options p)))
|
|
)
|
|
|
|
(defn new [descr] (Parser.init descr []))
|
|
|
|
(defn add [p opt]
|
|
(Parser.update-options p &(fn [options] (Array.push-back options @opt))))
|
|
|
|
(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)))))))
|
|
|
|
(defmacro option [long short description required :rest default-options]
|
|
(CLI.option- t long short description required default-options))
|
|
|
|
(defmacro str [long short description required :rest default-options]
|
|
(CLI.option- 'CLI.Tag.Str long short description required default-options))
|
|
|
|
(defmacro int [long short description required :rest default-options]
|
|
(CLI.option- 'CLI.Tag.Integer long short description required default-options))
|
|
|
|
(defmacro float [long short description required :rest default-options]
|
|
(CLI.option- 'CLI.Tag.Floating long short description required default-options))
|
|
|
|
(defn options-str [p]
|
|
(join
|
|
" "
|
|
&(Array.copy-map
|
|
&(fn [o] (fmt "[-%s | --%s]" (Option.short o) (Option.long o)))
|
|
(Parser.options p))))
|
|
|
|
(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)" &(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.")))
|
|
|
|
(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)]
|
|
(cond
|
|
(CmdMap.contains? &values &flag)
|
|
(do
|
|
(set! i (Int.inc i))
|
|
(if (< i (System.get-args-len))
|
|
(CmdMap.put! &values &flag (System.get-arg i))
|
|
(do
|
|
(set! res (Result.Error (fmt "No value for: %s" &flag)))
|
|
(break))))
|
|
(or (= &flag "help") (= &flag "h"))
|
|
(do
|
|
(usage p)
|
|
(System.exit 0))
|
|
(do
|
|
(set! res (Result.Error (fmt "Unknown option: %s" x)))
|
|
(break))))
|
|
(do
|
|
(set! res (Result.Error (fmt "Unexpected argument: %s" x)))
|
|
(break)))))
|
|
(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))
|
|
)
|