Clear STAN-0001 suggestion

doc/maintainers/stack_errors.md

@@ -5,30 +5,13 @@
 In connection with considering Stack's support of the
 [Haskell Error Index](https://errors.haskell.org/) initiative, this page seeks
 to take stock of the errors that Stack itself can raise, by reference to the
-`master` branch of the Stack repository. Last updated: 2023-10-17.
-
-*   `GHC.GHC.Utils.GhcPkg.Main.Compat`
-
-    ~~~haskell
-    [S-6512] = CannotParse String String String
-    [S-3384] | CannotOpenDBForModification FilePath IOException
-    [S-1430] | SingleFileDBUnsupported FilePath
-    [S-5996] | ParsePackageInfoExceptions String
-    [S-3189] | CannotFindPackage PackageArg (Maybe FilePath)
-
-    ~~~
+`master` branch of the Stack repository. Last updated: 2023-10-18.
 
 *   `Stack.main`: catches exceptions from action `commandLineHandler`.
 
     -   `ExitCode`
     -   `throwIO`
 
-*   `Stack.StackException`
-
-    ~~~haskell
-    [S-2186] = InvalidReExecVersion String String
-    ~~~
-
 *   `Stack.main`: catches exceptions from action `run`:
 
     -   `ExitCode` (`exitWith`)
@@ -45,6 +28,16 @@ to take stock of the errors that Stack itself can raise, by reference to the
         [S-2816] = InconsistentDependenciesBug
         ~~~
 
+    -   `GHC.GHC.Utils.GhcPkg.Main.Compat`
+
+        ~~~haskell
+        [S-6512] = CannotParse String String String
+        [S-3384] | CannotOpenDBForModification FilePath IOException
+        [S-1430] | SingleFileDBUnsupported FilePath
+        [S-5996] | ParsePackageInfoExceptions String
+        [S-3189] | CannotFindPackage PackageArg (Maybe FilePath)
+        ~~~
+
     -   `Options.Applicative.Builder.Extra.OptionsApplicativeExtraException`
 
         ~~~haskell
@@ -72,6 +65,12 @@ to take stock of the errors that Stack itself can raise, by reference to the
         [S-5743] | DuplicatePackagesBug
         ~~~
 
+    -   `Stack.CLI.CliPrettyException`
+
+        ~~~haskell
+        [S-4639] = NoArgumentsBug
+        ~~~
+
     -   `Stack.Clean.CleanException`
 
         ~~~haskell
@@ -322,6 +321,12 @@ to take stock of the errors that Stack itself can raise, by reference to the
         [S-4230] | ExistingMSYS2NotDeleted (Path Abs Dir) IOException
         ~~~
 
+    -   `Stack.StackException`
+
+        ~~~haskell
+        [S-2186] = InvalidReExecVersion String String
+        ~~~
+
     -   `Stack.Storage.User.StorageUserException`
 
         ~~~haskell

src/Data/Attoparsec/Interpreter.hs

@@ -60,7 +60,9 @@ import           Data.Char ( isSpace )
 import           Conduit ( decodeUtf8C, withSourceFile )
 import           Data.Conduit.Attoparsec ( ParseError (..), Position (..), sinkParserEither )
 import           Data.List ( intercalate )
+import           Data.List.NonEmpty ( singleton )
 import           Data.Text ( pack )
+import           RIO.NonEmpty ( nonEmpty )
 import           Stack.Constants ( stackProgName )
 import           Stack.Prelude
 import           System.FilePath ( takeExtension )
@@ -108,7 +110,7 @@ interpreterArgsParser isLiterate progName = P.option "" sheBangLine *> interpret
 
 -- | Extract Stack arguments from a correctly placed and correctly formatted
 -- comment when it is being used as an interpreter
-getInterpreterArgs :: String -> IO [String]
+getInterpreterArgs :: String -> IO (NonEmpty String)
 getInterpreterArgs file = do
   eArgStr <- withSourceFile file parseFile
   case eArgStr of
@@ -134,14 +136,16 @@ getInterpreterArgs file = do
     mapM_ stackWarn (lines err)
     stackWarn "Missing or unusable Stack options specification"
     stackWarn "Using runghc without any additional Stack options"
-    pure ["runghc"]
+    pure $ singleton "runghc"
 
   parseArgStr str =
     case P.parseOnly (argsParser Escaping) (pack str) of
       Left err -> handleFailure ("Error parsing command specified in the "
                       ++ "Stack options comment: " ++ err)
-      Right [] -> handleFailure "Empty argument list in Stack options comment"
-      Right args -> pure args
+      Right args -> maybe
+        (handleFailure "Empty argument list in Stack options comment")
+        pure
+        (nonEmpty args)
 
   decodeError e =
     case e of

src/Options/Applicative/Complicated.hs

@@ -57,8 +57,17 @@ complicatedOptions ::
   -> AddCommand
      -- ^ commands (use 'addCommand')
   -> IO (GlobalOptsMonoid, RIO Runner ())
-complicatedOptions numericVersion stringVersion numericHpackVersion h pd
-  footerStr commonParser mOnFailure commandParser = do
+complicatedOptions
+    numericVersion
+    stringVersion
+    numericHpackVersion
+    h
+    pd
+    footerStr
+    commonParser
+    mOnFailure
+    commandParser
+  = do
     args <- getArgs
     (a, (b, c)) <- let parserPrefs = prefs $ noBacktrack <> showHelpOnEmpty
                    in  case execParserPure parserPrefs parser args of

src/Stack/Build/ConstructPlan.hs

@@ -80,7 +80,6 @@ import           Stack.Types.SourceMap
 import           Stack.Types.Version
                    ( latestApplicableVersion, versionRangeText, withinRange )
 import           System.Environment ( lookupEnv )
-import Data.List.NonEmpty (nonEmpty)
 
 data PackageInfo
   = PIOnlyInstalled InstallLocation Installed
@@ -621,7 +620,7 @@ addDep name packageInfo = do
               Nothing -> do
                 -- This could happen for GHC boot libraries missing from
                 -- Hackage.
-                cs <- asks (nonEmpty . callStack)
+                cs <- asks (NE.nonEmpty . callStack)
                 cs' <- maybe
                   (throwIO CallStackEmptyBug)
                   (pure . NE.tail)

src/Stack/CLI.hs

@@ -7,6 +7,7 @@ module Stack.CLI
 import           Data.Attoparsec.Interpreter ( getInterpreterArgs )
 import           Data.Char ( toLower )
 import qualified Data.List as L
+import           Data.List.NonEmpty ( prependList )
 import           Options.Applicative
                    ( Parser, ParserFailure, ParserHelp, ParserResult (..), flag, switch
                    , handleParseResult, help, helpError, idm, long, metavar
@@ -16,6 +17,8 @@ import           Options.Applicative.Builder.Extra
                    ( boolFlags, extraHelpOption, textOption )
 import           Options.Applicative.Complicated
                    ( addCommand, addSubCommands, complicatedOptions )
+import qualified RIO.NonEmpty as NE
+import           RIO.NonEmpty ( (<|) )
 import qualified RIO.Process ( exec )
 import           RIO.Process ( withProcessContextNoLogging )
 import           Stack.Build ( buildCmd )
@@ -82,6 +85,18 @@ import qualified System.Directory as D
 import           System.Environment ( getProgName, withArgs )
 import           System.FilePath ( pathSeparator, takeDirectory )
 
+-- | Type representing \'pretty\' exceptions thrown by functions in the
+-- "Stack.CLI" module.
+data CliPrettyException
+  = NoArgumentsBug
+  deriving (Show, Typeable)
+
+instance Pretty CliPrettyException where
+  pretty NoArgumentsBug = bugPrettyReport "[S-4639]" $
+    flow "commandLineHandler: no command line arguments on event of failure."
+
+instance Exception CliPrettyException
+
 -- | Stack's command line handler.
 commandLineHandler ::
      FilePath
@@ -112,10 +127,16 @@ commandLineHandler currentDir progName isInterpreter =
     else mempty
   failureCallback f args =
     case L.stripPrefix "Invalid argument" (fst (renderFailure f "")) of
-      Just _ -> if isInterpreter
-                  then parseResultHandler args f
-                  else secondaryCommandHandler args f
-                      >>= interpreterHandler currentDir args
+      Just _ -> maybe
+        (prettyThrowIO NoArgumentsBug)
+        ( \args' -> if isInterpreter
+            then
+              parseResultHandler (NE.toList args') f
+            else
+              secondaryCommandHandler args' f
+                >>= interpreterHandler currentDir args'
+        )
+        (NE.nonEmpty args)
       Nothing -> parseResultHandler args f
 
   parseResultHandler args f =
@@ -613,12 +634,12 @@ commandLineHandler currentDir progName isInterpreter =
 -- (i.e. `stack something` looks for `stack-something` before
 -- failing with "Invalid argument `something'")
 secondaryCommandHandler ::
-     [String]
+     NonEmpty String
   -> ParserFailure ParserHelp
   -> IO (ParserFailure ParserHelp)
 secondaryCommandHandler args f =
   -- don't even try when the argument looks like a path or flag
-  if elem pathSeparator cmd || "-" `L.isPrefixOf` L.head args
+  if elem pathSeparator cmd || "-" `L.isPrefixOf` NE.head args
      then pure f
   else do
     mExternalExec <- D.findExecutable cmd
@@ -627,20 +648,20 @@ secondaryCommandHandler args f =
         -- TODO show the command in verbose mode
         -- hPutStrLn stderr $ unwords $
         --   ["Running", "[" ++ ex, unwords (tail args) ++ "]"]
-        _ <- RIO.Process.exec ex (L.tail args)
+        _ <- RIO.Process.exec ex (NE.tail args)
         pure f
       Nothing -> pure $ fmap (vcatErrorHelp (noSuchCmd cmd)) f
  where
   -- FIXME this is broken when any options are specified before the command
   -- e.g. stack --verbosity silent cmd
-  cmd = stackProgName ++ "-" ++ L.head args
+  cmd = stackProgName <> "-" <> NE.head args
   noSuchCmd name = errorHelp $ stringChunk
     ("Auxiliary command not found in path '" ++ name ++ "'.")
 
 interpreterHandler ::
      Monoid t
   => FilePath
-  -> [String]
+  -> NonEmpty String
   -> ParserFailure ParserHelp
   -> IO (GlobalOptsMonoid, (RIO Runner (), t))
 interpreterHandler currentDir args f = do
@@ -653,17 +674,18 @@ interpreterHandler currentDir args f = do
     (file:fileArgs') -> runInterpreterCommand file stackArgs fileArgs'
     [] -> parseResultHandler (errorCombine (noSuchFile firstArg))
  where
-  firstArg = L.head args
+  firstArg = NE.head args
 
-  spanM _ [] = pure ([], [])
-  spanM p xs@(x:xs') = do
+  spanM p xs@(x :| rest) = do
     r <- p x
     if r
-    then do
-      (ys, zs) <- spanM p xs'
-      pure (x:ys, zs)
-    else
-      pure ([], xs)
+      then case rest of
+        [] -> pure ([x], [])
+        (x': rest') -> do
+          (ys, zs) <- spanM p (x' :| rest')
+          pure (x : ys, zs)
+      else
+        pure ([], NE.toList xs)
 
   -- if the first argument contains a path separator then it might be a file,
   -- or a Stack option referencing a file. In that case we only show the
@@ -685,14 +707,14 @@ interpreterHandler currentDir args f = do
     let parseCmdLine = commandLineHandler currentDir progName True
         -- Implicit file arguments are put before other arguments that
         -- occur after "--". See #3658
-        cmdArgs = stackArgs ++ case break (== "--") iargs of
-          (beforeSep, []) -> beforeSep ++ ["--"] ++ [path] ++ fileArgs
+        cmdArgs = prependList stackArgs $ case NE.break (== "--") iargs of
+          (beforeSep, []) -> prependList beforeSep $ "--" <| path :| fileArgs
           (beforeSep, optSep : afterSep) ->
-            beforeSep ++ [optSep] ++ [path] ++ fileArgs ++ afterSep
+            prependList beforeSep $ optSep <| path :| fileArgs <> afterSep
      -- TODO show the command in verbose mode
      -- hPutStrLn stderr $ unwords $
      --   ["Running", "[" ++ progName, unwords cmdArgs ++ "]"]
-    (a,b) <- withArgs cmdArgs parseCmdLine
+    (a,b) <- withArgs (NE.toList cmdArgs) parseCmdLine
     pure (a,(b,mempty))
 
 -- Vertically combine only the error component of the first argument with the