aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--stdlib/source/lux/cli.lux86
-rw-r--r--stdlib/test/test/lux/cli.lux74
2 files changed, 75 insertions, 85 deletions
diff --git a/stdlib/source/lux/cli.lux b/stdlib/source/lux/cli.lux
index 8f44d3df9..5b8806384 100644
--- a/stdlib/source/lux/cli.lux
+++ b/stdlib/source/lux/cli.lux
@@ -2,11 +2,10 @@
lux
(lux (control monad
["p" parser])
- (data (coll [list "L/" Monoid<List> Monad<List>])
- [text "T/" Monoid<Text>]
+ (data (coll [list "list/" Monoid<List> Monad<List>])
+ [text "text/" Eq<Text>]
text/format
- ["E" error]
- [sum])
+ ["E" error])
[io]
[meta #+ with-gensyms]
(meta [code]
@@ -47,45 +46,40 @@
{#;doc "Parses the next input with a parsing function."}
(All [a] (-> (-> Text (E;Error a)) (CLI a)))
(function [inputs]
- (case inputs
- (#;Cons arg inputs')
- (case (parser arg)
- (#E;Success value)
- (#E;Success [inputs' value])
-
- (#E;Error parser-error)
- (#E;Error parser-error))
-
- _
- (#E;Error "Cannot parse empty arguments."))))
-
-(def: #export (option names)
- {#;doc "Checks that a given option (with multiple possible names) has a value."}
- (-> (List Text) (CLI Text))
+ (do E;Monad<Error>
+ [[remaining raw] (any inputs)
+ output (parser raw)]
+ (wrap [remaining output]))))
+
+(def: #export (this reference)
+ {#;doc "Checks that a token is in the inputs."}
+ (-> Text (CLI Unit))
(function [inputs]
- (let [[pre post] (list;split-with (. ;not (list;member? text;Eq<Text> names)) inputs)]
- (case post
- #;Nil
- (#E;Error ($_ T/compose "Missing option (" (text;join-with " " names) ")"))
-
- (^ (list& _ value post'))
- (#E;Success [(L/compose pre post') value])
-
- _
- (#E;Error ($_ T/compose "Option lacks value (" (text;join-with " " names) ")"))
- ))))
-
-(def: #export (flag names)
- {#;doc "Checks that a given flag (with multiple possible names) is set."}
- (-> (List Text) (CLI Bool))
+ (do E;Monad<Error>
+ [[remaining raw] (any inputs)]
+ (if (text/= reference raw)
+ (wrap [remaining []])
+ (E;fail (format "Missing token: \"" reference "\""))))))
+
+(def: #export (somewhere cli)
+ {#;doc "Given a parser, tries to parse it somewhere in the inputs (i.e. not necessarily parsing the immediate inputs)."}
+ (All [a] (-> (CLI a) (CLI a)))
(function [inputs]
- (let [[pre post] (list;split-with (. ;not (list;member? text;Eq<Text> names)) inputs)]
- (case post
- #;Nil
- (#E;Success [pre false])
-
- (#;Cons _ post')
- (#E;Success [(L/compose pre post') true])))))
+ (loop [immediate inputs]
+ (case (p;run immediate cli)
+ (#E;Success [remaining output])
+ (#E;Success [remaining output])
+
+ (#E;Error error)
+ (case immediate
+ #;Nil
+ (#E;Error error)
+
+ (#;Cons to-omit immediate')
+ (do E;Monad<Error>
+ [[remaining output] (recur immediate')]
+ (wrap [(#;Cons to-omit remaining)
+ output])))))))
(def: #export end
{#;doc "Ensures there are no more inputs."}
@@ -93,7 +87,7 @@
(function [inputs]
(case inputs
#;Nil (#E;Success [inputs []])
- _ (#E;Error (T/compose "Unknown parameters: " (text;join-with " " inputs))))))
+ _ (#E;Error (format "Unknown parameters: " (text;join-with " " inputs))))))
## [Syntax]
(type: Program-Args
@@ -118,7 +112,7 @@
(wrap [])))
(program: (name)
- (io (log! (T/compose "Hello, " name))))
+ (io (log! (text/compose "Hello, " name))))
(program: ([config config^])
(do Monad<IO>
@@ -137,9 +131,9 @@
(case ((: (;;CLI (io;IO Unit))
(do ;;Monad<CLI>
[(~@ (|> args
- (L/map (function [[binding parser]]
- (list binding parser)))
- L/join))
+ (list/map (function [[binding parser]]
+ (list binding parser)))
+ list/join))
(~ g!_) ;;end]
((~' wrap) (do io;Monad<IO>
[]
diff --git a/stdlib/test/test/lux/cli.lux b/stdlib/test/test/lux/cli.lux
index 6c6b113ea..410751b13 100644
--- a/stdlib/test/test/lux/cli.lux
+++ b/stdlib/test/test/lux/cli.lux
@@ -4,59 +4,55 @@
(control ["M" monad #+ do Monad]
pipe
["p" parser])
- (data text/format
- [text "Text/" Eq<Text>]
- [number]
- [product]
+ (data [product]
[sum]
+ ["E" error]
+ [number]
+ [text "text/" Eq<Text>]
+ text/format
(coll [list]))
- ["&" cli]
- ["r" math/random])
+ ["r" math/random]
+ ["." cli])
lux/test)
(context: "CLI"
[num-args (|> r;nat (:: @ map (n.% +10)))
#let [(^open "Nat/") number;Codec<Text,Nat>
gen-arg (:: @ map Nat/encode r;nat)]
- option-name (r;text +5)
- singleton gen-arg]
+ yes gen-arg
+ #let [gen-ignore (|> (r;text +5) (r;filter (|>. (text/= yes) not)))]
+ no gen-ignore
+ pre-ignore (r;list +5 gen-ignore)
+ post-ignore (r;list +5 gen-ignore)]
($_ seq
(test "Can read any argument."
- (|> (&;run (list singleton) &;any)
- (case> (#;Left _)
+ (|> (.;run (list yes) .;any)
+ (case> (#E;Error _)
false
- (#;Right arg)
- (Text/= arg singleton))))
-
+ (#E;Success arg)
+ (text/= arg yes))))
+ (test "Can test tokens."
+ (and (|> (.;run (list yes) (.;this yes))
+ (case> (#E;Error _) false (#E;Success _) true))
+ (|> (.;run (list no) (.;this yes))
+ (case> (#E;Error _) true (#E;Success _) false))))
(test "Can use custom token parsers."
- (|> (&;run (list singleton) (&;parse Nat/decode))
- (case> (#;Left _)
+ (|> (.;run (list yes) (.;parse Nat/decode))
+ (case> (#E;Error _)
false
- (#;Right parsed)
- (Text/= (Nat/encode parsed)
- singleton))))
-
- (test "Can obtain option values."
- (and (|> (&;run (list option-name singleton) (&;option (list option-name)))
- (case> (#;Left _)
- false
-
- (#;Right value)
- (Text/= value singleton)))
- (|> (&;run (list singleton) (&;option (list option-name)))
- (case> (#;Left _) true (#;Right _) false))))
-
- (test "Can check flags."
- (and (|> (&;run (list option-name) (&;flag (list option-name)))
- (case> (#;Right true) true _ false))
- (|> (&;run (list) (&;flag (list option-name)))
- (case> (#;Right false) true _ false))))
-
+ (#E;Success parsed)
+ (text/= (Nat/encode parsed)
+ yes))))
(test "Can query if there are any more inputs."
- (and (|> (&;run (list) &;end)
- (case> (#;Right []) true _ false))
- (|> (&;run (list singleton) (p;not &;end))
- (case> (#;Right []) false _ true))))
+ (and (|> (.;run (list) .;end)
+ (case> (#E;Success []) true _ false))
+ (|> (.;run (list yes) (p;not .;end))
+ (case> (#E;Success []) false _ true))))
+ (test "Can parse CLI input anywhere."
+ (|> (.;run (list;concat (list pre-ignore (list yes) post-ignore))
+ (|> (.;somewhere (.;this yes))
+ (p;before (p;some .;any))))
+ (case> (#E;Error _) false (#E;Success _) true)))
))
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-23 14:07:48 +0000