command-line.parser: make sure help is printed even where there are o…

…ther parse errors
mrjbq7 · Jul 9, 2024 · b8a8438 · b8a8438
1 parent d8c8b3e
commit b8a8438
Show file tree

Hide file tree

Showing 2 changed files with 32 additions and 11 deletions.
diff --git a/extra/command-line/parser/parser-tests.factor b/extra/command-line/parser/parser-tests.factor
@@ -201,6 +201,26 @@ TUPLE: foo ;
     ] with-string-writer
 ] unit-test
 
+{
+    "Usage:\n    program [--help] [username] [password]\n\nArguments:\n    username    \n    password    \n\nOptions:\n    --help    show this help and exit\n"
+} [
+    [
+        H{
+            { command-line { "--help" "too" "many" "arguments" } }
+            { program-name "program" }
+        } [
+            {
+                T{ option
+                    { name "username" }
+                }
+                T{ option
+                    { name "password" }
+                }
+            } [ ] with-options
+        ] with-variables
+    ] with-string-writer
+] unit-test
+
 { H{ { "foo" { "a" "b" } } { "bar" "c" } } } [
     {
         T{ option { name "--foo" } { #args 2 } }

diff --git a/extra/command-line/parser/parser.factor b/extra/command-line/parser/parser.factor
@@ -275,23 +275,24 @@ M: usage-error error. options>> print-help ;
         ] dip append
     ] until-empty nip ;
 
-: parse-arguments ( options command-line -- positional  )
-    [ [ optional? ] partition ] dip { "--" } split1
-    [ (parse-arguments) f swap ] dip (parse-arguments) ;
+: parse-arguments ( options command-line -- arguments )
+    [ dup [ optional? ] partition ] dip { "--" } split1
+    [ (parse-arguments) f swap ] dip (parse-arguments)
+    [ #args>> { "*" "?" } member? ] reject
+    [ required-options ] unless-empty
+    [ required?>> ] filter namespace [
+        '[ option-variable _ key? ] reject
+        [ required-options ] unless-empty
+    ] keep ;
 
 PRIVATE>
 
 : (parse-options) ( options command-line -- arguments )
     [ [ >option ] map ] dip over default-options [
         default-help? get [ [ HELP prefix ] dip ] when
-        dupd parse-arguments
-        default-help? get [ print-help? get [ over usage-error ] when ] when
-        [ #args>> { "*" "?" } member? ] reject
-        [ required-options ] unless-empty
-        [ required?>> ] filter namespace [
-            '[ option-variable _ key? ] reject
-            [ required-options ] unless-empty
-        ] keep
+        [ parse-arguments ] pick '[
+            default-help? get [ print-help? get [ _ usage-error ] when ] when
+        ] finally
     ] with-variables ;
 
 : parse-options ( options -- arguments )