diff options
author | Eduardo Julian | 2017-10-17 00:18:39 -0400 |
---|---|---|
committer | Eduardo Julian | 2017-10-17 00:18:39 -0400 |
commit | 98bfe062d911163a063f7139a840410964f12878 (patch) | |
tree | 72e01cf099855bea06d4c40a78b47c1ec4afc842 | |
parent | 7127550a3a8bc07f34a9a7f9404b5eea6a3b11cd (diff) |
- Simplified CLI.
- Added way to parse CLI argument anywhere within the inputs.
-rw-r--r-- | stdlib/source/lux/cli.lux | 86 | ||||
-rw-r--r-- | stdlib/test/test/lux/cli.lux | 74 |
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))) )) |