Implement collection of unknown options (#42)

src/Data/NonEmpty/Extra.purs

@@ -21,6 +21,14 @@ append
   -> NonEmpty f a
 append (x :| xs) (y :| ys) = x :| xs <> pure y <> ys
 
+cons
+  :: ∀ f a
+   . (Semigroup (f a), Applicative f)
+  => a
+  -> NonEmpty f a
+  -> NonEmpty f a
+cons x (y:|ys) = x :| pure y <> ys
+
 toList
   :: ∀ a
    . NonEmpty List a

src/Neodoc/ArgParser/Options.purs

@@ -14,6 +14,7 @@ type Options r = {
 , repeatableOptions :: Boolean
 , helpFlags         :: List OptionAlias
 , versionFlags      :: List OptionAlias
+, allowUnknown      :: Boolean
   | r
 }
 

src/Neodoc/ArgParser/Parser.purs

@@ -95,6 +95,12 @@ initialGlobalState = {
 , argCache: Map.empty
 }
 
+_UNKNOWN_ARG :: Arg
+_UNKNOWN_ARG =
+  let arg = Solved.Command "?" true
+      key = toArgKey arg
+   in Arg (-1) arg key Nothing true
+
 parse
   :: ∀ r
    . Spec SolvedLayout
@@ -112,8 +118,17 @@ parse (spec@(Spec { layouts, descriptions })) options@{ helpFlags, versionFlags
       parsers = toplevels <#> \branch ->
         let branch' = toArgBranch options env descriptions branch
             branch'' = toParseBranch (NonEmpty.toList branch')
-         in ArgParseResult (Just branch) <$>
-              parseBranch (Args3 0 true branch'') <* eof
+         in do
+            vs  <- parseBranch (Args3 0 true branch'')
+            vs' <- eof
+
+            -- inject the pseudo argument to collect unknown options into layout
+            -- so that the value reduction will work.
+            let outBranch = if options.allowUnknown
+                  then NonEmpty.cons (Elem $ Arg.getArg _UNKNOWN_ARG) branch
+                  else branch
+
+            return $ ArgParseResult (Just outBranch) (vs <> vs')
 
       parsers' :: List (ArgParser r ArgParseResult)
       parsers' = parsers
@@ -122,13 +137,11 @@ parse (spec@(Spec { layouts, descriptions })) options@{ helpFlags, versionFlags
           --       or: prog
           -- then we consolidate those into a single, artificial
           -- parse whose only requirement is that there be no input.
-          <> if hasEmpty
-                then pure $ ArgParseResult Nothing Nil <$ eof
-                else Nil
+          <> if hasEmpty then singleton emptyBranch else Nil
 
    in runParser $ Args5 { env, options, spec } initialState initialGlobalState tokens $
         let p = if null parsers'
-                  then eof $> ArgParseResult Nothing Nil
+                  then emptyBranch
                   else evalParsers (Args2 (byOrigin <<< getResult) parsers')
          in p `catch` \_ e ->
             let implicitFlags = helpFlags <> versionFlags
@@ -141,18 +154,38 @@ parse (spec@(Spec { layouts, descriptions })) options@{ helpFlags, versionFlags
                   _              -> throw e
 
   where
-  eof :: ∀ r. ArgParser r Unit
+
+  eof :: ∀ r. ArgParser r (List KeyValue)
   eof = do
     input <- getInput
     case input of
-      Nil  -> return unit
+      Nil  -> pure Nil
       toks -> do
+        { options } <- getConfig
         kToks <- for toks \(pTok@(PositionedToken tok _ _)) -> do
           isKnown <- isKnownToken' tok
           return if isKnown
             then known pTok
             else unknown pTok
-        fail' $ unexpectedInputError Nil kToks
+        if options.allowUnknown
+          then
+            let ks = filter isKnown kToks
+                uks = filter isUnknown kToks
+             in case ks of
+                  _:_ -> fail' $ unexpectedInputError Nil kToks
+                  Nil -> pure (Tuple _UNKNOWN_ARG <<< RichValue.from Origin.Argv
+                                                  <<< StringValue
+                                                  <<< getSource
+                                                  <<< unIsKnown <$> uks)
+          else fail' $ unexpectedInputError Nil kToks
+
+  emptyBranch :: ArgParser r ArgParseResult
+  emptyBranch = do
+    { options } <- getConfig
+    let mBranch = if options.allowUnknown
+                    then Just ((Elem $ Arg.getArg _UNKNOWN_ARG):|Nil)
+                    else Nothing
+    ArgParseResult mBranch <$> eof
 
   -- create an implicit top-level to make "-h/--help" and "--version" "just
   -- work". The idea is to remove the empty fallback for '--help' and
@@ -193,7 +226,15 @@ parseBranch (Args3 l sub xs) = do
   let xs' = if not options.laxPlacement
             then NEL.toList <$> groupBy (eq `on` _isFree) xs
             else singleton xs
-  concat <$> for xs' (\x -> solve $ Args4 l options.repeatableOptions sub x)
+  concat <$> for xs' \x ->
+    let p = solve $ Args4 l options.repeatableOptions sub x
+     in if options.allowUnknown
+          then do
+            vs  <- many unknownToken
+            vs' <- p
+            pure $ vs <> vs'
+          else p
+
   where
   _isFree :: ArgParseLayout -> Boolean
   _isFree (ParseGroup _ f _ _ _) = f
@@ -252,6 +293,7 @@ solve (Args4 l repOpts sub req) = skipIf hasTerminated Nil
     --     <> ", out = " <> pretty out
     --     <> ", i = "   <> pretty i
 
+    unknowns <- if options.allowUnknown then many unknownToken else pure Nil
 
     -- 1. try making a match for any arg in `req` w/o allowing substitutions.
     --    if we make a match, we proceed *and never look back*. If we do not
@@ -270,7 +312,7 @@ solve (Args4 l repOpts sub req) = skipIf hasTerminated Nil
         -- trace l' \i-> "solve: matched on argv: " <> pretty kvs <> ", i = " <> pretty i
         let rRep = _toElem <$> filter (_isRepeatable) (fst <$> kvs)
             rep' = nub ((maybe Nil singleton mNewRep) <> rep <> rRep)
-        go (Args6 (l' + 1) sub' req' rep' true (out <> kvs))
+        go (Args6 (l' + 1) sub' req' rep' true (out <> unknowns <> kvs))
       _ -> do
         -- 2. if we did not manage to make a single `req` parse, we ought to try
         --    if any of our args in `rep` is now able to parse. We consume at
@@ -300,8 +342,8 @@ solve (Args4 l repOpts sub req) = skipIf hasTerminated Nil
             let rRep = _toElem <$> filter (_isRepeatable) (fst <$> kvs)
                 rep'' = nub ((maybe Nil singleton mNewRep') <> rep' <> rRep)
             if any (isFrom Origin.Argv <<< snd) kvs
-              then go (Args6 (l' + 1) sub' req rep'' true (out <> kvs))
-              else go (Args6 (l' + 1) sub' req rep'' false (out <> kvs))
+              then go (Args6 (l' + 1) sub' req rep'' true (out <> unknowns <> kvs))
+              else go (Args6 (l' + 1) sub' req rep'' false (out <> unknowns <> kvs))
           -- 3. If we still did not manage to make a match, things aren't
           --    looking too great. It's time for drastic measures. If the parent
           --    is allowing us to, we repeat this above, but allow substitutions
@@ -313,7 +355,7 @@ solve (Args4 l repOpts sub req) = skipIf hasTerminated Nil
             case req' of
               Nil -> do
                 -- trace l' \i -> "solve: empty req' after rep. done. i = " <> pretty i
-                return out
+                return $ out <> unknowns
               _:_ | sub ->
                 let
                   exhaust
@@ -336,7 +378,7 @@ solve (Args4 l repOpts sub req) = skipIf hasTerminated Nil
                       else exhaust req''' (out' <> kVs'')
                  in do
                   -- trace l' \i-> "solve: trying via sub, i = " <> pretty i
-                  exhaust req' out
+                  exhaust req' (out <> unknowns)
               xs -> do
                 -- trace l' \_-> "solve: failed to match: " <> pretty xs
                 fail "..." -- XXX: throw proper error here
@@ -351,7 +393,9 @@ solve (Args4 l repOpts sub req) = skipIf hasTerminated Nil
      in ParseElem (Arg.getId x) isFree x
 
   _isRepeatable :: Arg -> Boolean
-  _isRepeatable x = Arg.isArgRepeatable x || (repOpts && Arg.isOption x)
+  -- note: The `>=0` is to avoid injected arguments (i.e. opts.allowUnknown)
+  _isRepeatable x | Arg.getId x >= 0 = Arg.isArgRepeatable x || (repOpts && Arg.isOption x)
+  _isRepeatable _ = false
 
   {-
     Try to make a match from any of the input layouts.
@@ -372,7 +416,8 @@ solve (Args4 l repOpts sub req) = skipIf hasTerminated Nil
     Here, consumption w/o substitutions is a dead end, since `[-b -c]` won't be
     able to match (it requires either `-b -c` or `-c -b`). Hence, we *must*
     use subsitutions to yield a match. But which argument should be substituted?
-    We select the most eligble argument by see
+    We select the most eligble argument by seeing how many of argv it can
+    consume.
   -}
   match a@(Args3 l sub xs) = {-cachedMatch (getId <$> xs) sub $-} match' a
   match'
@@ -546,7 +591,9 @@ parseLayout
 parseLayout l sub x = do
  skipIf hasTerminated Nil do
   { options } <- getConfig
-  go options x
+  vs  <- if  options.allowUnknown then many unknownToken else pure Nil
+  vs' <- go options x
+  pure $ vs <> vs'
   where
    -- Terminate at singleton groups that house only positionals.
   go options x | options.optionsFirst && isJust (termAs x)
@@ -731,6 +778,19 @@ termAs x = go x
   go (ParseElem _ _ x@(Arg _ (Solved.Positional _ r) _ _ _)) | r = Just x
   go _ = Nothing
 
+unknownToken :: ∀ r. ArgParser r KeyValue
+unknownToken = do
+  i <- getInput
+  case i of
+    (PositionedToken tok source _):toks -> do
+      isKnown <- isKnownToken' tok
+      if isKnown
+        then fail "expected unknown token"
+        else setInput toks
+          *> modifyDepth (_ + 1)
+          $> (_UNKNOWN_ARG /\ RichValue.from Origin.Argv (StringValue source))
+    _ -> fail "expected unknown token"
+
 {-
   Cached lookup if a token is known or not
 -}
@@ -777,15 +837,3 @@ isKnownToken (Spec { layouts, descriptions }) tok = occuresInDescs || occuresInL
       test (Token.EOA _)      (Solved.EOA)          = true
       test (Token.Stdin)      (Solved.Stdin)        = true
       test _ _ = false
-
-{-
-  Pre-emptively determine if a branch can match the empty input.
--}
-canMatchEmptyInput
-  :: NonEmpty List ArgLayout
-  -> Boolean
-canMatchEmptyInput xs = any go xs
-  where go (Group o _ xs) = if o then true
-                                 else all canMatchEmptyInput xs
-        go (Elem x) = isJust $ getFallback x
-

src/Neodoc/Neodoc.purs

@@ -236,6 +236,7 @@ _run input (NeodocOptions opts) = do
           , requireFlags:      opts.requireFlags
           , laxPlacement:      opts.laxPlacement
           , repeatableOptions: opts.repeatableOptions
+          , allowUnknown:      opts.allowUnknown
           , helpFlags:         fromFoldable opts.helpFlags
           , versionFlags:      fromFoldable opts.versionFlags
           } env argv
@@ -323,6 +324,7 @@ _runPure input (NeodocOptions opts) mVer = do
         , requireFlags:      opts.requireFlags
         , laxPlacement:      opts.laxPlacement
         , repeatableOptions: opts.repeatableOptions
+        , allowUnknown:      opts.allowUnknown
         , helpFlags:         fromFoldable opts.helpFlags
         , versionFlags:      fromFoldable opts.versionFlags
         } env argv

src/Neodoc/Options.purs

@@ -45,6 +45,7 @@ newtype NeodocOptions = NeodocOptions {
 , versionFlags :: Array OptionAlias -- ^ list of flags that trigger 'version'
 , helpFlags    :: Array OptionAlias -- ^ list of flags that trigger 'help'
 , repeatableOptions :: Boolean -- ^ options are always allowed to repeat
+, allowUnknown      :: Boolean -- ^ allow unknown options in the input
 , transforms   :: {
     presolve :: ∀ eff. Either
       (Array (Spec UsageLayout -> Eff JsCallbackEff (Spec UsageLayout)))
@@ -72,6 +73,7 @@ defaultOptionsObj = {
 , helpFlags:    [ OA.Short 'h', OA.Long "help"    ]
 , transforms:   { presolve: Right [], postsolve: Right [] }
 , repeatableOptions: false
+, allowUnknown: false
 }
 
 customize :: NeodocOptions -> (_ -> _) -> NeodocOptions
@@ -92,6 +94,7 @@ instance isForeign :: IsForeign NeodocOptions where
     , helpFlags:    _
     , transforms:   _
     , repeatableOptions: _
+    , allowUnknown: _
     }
       <$> readArgv         v
       <*> readEnv          v
@@ -106,6 +109,7 @@ instance isForeign :: IsForeign NeodocOptions where
       <*> readHelpFlags    v
       <*> readTransforms   v
       <*> readRepeatOptions v
+      <*> readAllowUnknown v
 
     where
     readArgv          = _maybe "argv"
@@ -116,6 +120,7 @@ instance isForeign :: IsForeign NeodocOptions where
     readRequireFlags  = _readBool "requireFlags"      defaultOptionsObj.requireFlags
     readLaxPlacement  = _readBool "laxPlacement"      defaultOptionsObj.laxPlacement
     readRepeatOptions = _readBool "repeatableOptions" defaultOptionsObj.repeatableOptions
+    readAllowUnknown  = _readBool "allowUnknown"      defaultOptionsObj.allowUnknown
     readVersion       = _maybe    "version"
     readStopAt        = _default  "stopAt"            defaultOptionsObj.stopAt
     readVersionFlags  = _default  "versionFlags"      defaultOptionsObj.versionFlags

test/Test/Spec/ArgParserSpec.purs

@@ -60,6 +60,7 @@ type Options =  { stopAt            :: Array String
                 , requireFlags      :: Boolean
                 , laxPlacement      :: Boolean
                 , repeatableOptions :: Boolean
+                , allowUnknown      :: Boolean
                 }
 
 defaultOptions :: Options
@@ -70,6 +71,7 @@ defaultOptions = {
 , requireFlags: false
 , laxPlacement: false
 , repeatableOptions: false
+, allowUnknown: false
 }
 
 type Test = { help  :: String
@@ -1032,6 +1034,7 @@ argParserSpec = \_ -> describe "The parser generator" do
                   , requireFlags:      opts.requireFlags
                   , laxPlacement:      opts.laxPlacement
                   , repeatableOptions: opts.repeatableOptions
+                  , allowUnknown:      opts.allowUnknown
                   , helpFlags:         Nil
                   , versionFlags:      Nil
                   } env argv

test/Test/Spec/CompatSpec.purs

@@ -64,6 +64,7 @@ compatSpec tests =
                                       , requireFlags: opts.requireFlags
                                       , laxPlacement: opts.laxPlacement
                                       , repeatableOptions: opts.repeatableOptions
+                                      , allowUnknown: opts.allowUnknown
                                       }
           describe (intercalate " " (
             (toUnfoldable $ StrMap.toList env <#> \t ->

test/Test/Support/CompatParser.purs

@@ -59,6 +59,7 @@ type Flags = {
 , requireFlags      :: Boolean -- ^ 'r'
 , laxPlacement      :: Boolean -- ^ 'l'
 , repeatableOptions :: Boolean -- ^ 'R'
+, allowUnknown      :: Boolean -- ^ 'u'
 }
 
 parseFlags :: String -> Flags
@@ -68,6 +69,7 @@ parseFlags s = {
 , requireFlags:      String.contains (Pattern "r") s
 , laxPlacement:      String.contains (Pattern "l") s
 , repeatableOptions: String.contains (Pattern "R") s
+, allowUnknown:      String.contains (Pattern "u") s
 }
 
 renderFlags :: Flags -> String
@@ -76,6 +78,7 @@ renderFlags f = (if f.optionsFirst then "p" else "")
              <> (if f.requireFlags then "r" else "")
              <> (if f.laxPlacement then "l" else "")
              <> (if f.repeatableOptions then "R" else "")
+             <> (if f.allowUnknown then "u" else "")
 
 readTests :: ∀ eff
    . String
@@ -113,6 +116,7 @@ readTests filepath = do
                         , requireFlags: false
                         , laxPlacement: false
                         , repeatableOptions: false
+                        , allowUnknown: false
                         } $ parseFlags <$> do
                               P.char '/'
                               fromCharArray <$> A.many alpha
@@ -152,8 +156,9 @@ readTests filepath = do
                     , requireFlags      = flags.requireFlags
                     , laxPlacement      = flags.laxPlacement
                     , repeatableOptions = flags.repeatableOptions
+                    , allowUnknown      = flags.allowUnknown
+                    }
                   }
-                }
 
       where
         envVar = do