Move to optparse-applicative

app/Main.hs

@@ -1,13 +1,13 @@
 module Main where
 
-import Data.Text (pack)
-import Shellify (runShellify)
-import System.Environment (getArgs, getProgName)
+import Shellify (runShellify, printErrorAndReturnFailure)
+import System.Environment (getArgs)
+import Options(parseCommandLine)
+import Options.Applicative (handleParseResult)
+import Control.Monad ((>=>))
 
 main :: IO ()
-main = do
-  progName <- pack <$> getProgName
-  getTextArgs
-    >>= runShellify . (<>) [progName]
-
-getTextArgs = fmap pack <$> getArgs
+main = getArgs >>=
+         either printErrorAndReturnFailure
+                (handleParseResult >=> runShellify )
+         . parseCommandLine

shellify.cabal

@@ -29,6 +29,7 @@ common deps
     default-language: GHC2021
     build-depends:
         base >=4.16 && <4.21,
+        optparse-applicative >=0.18.1.0 && <0.19,
         raw-strings-qq >=1.1 && <1.2,
         text >=1.2.5.0 && <2.2
 
@@ -54,7 +55,6 @@ library
         containers >=0.6.5.1 && <0.8,
         data-default >=0.7 && <0.9,
         directory >=1.3.6.2 && <1.4,
-        extra >=1.7.13 && <1.9,
         HStringTemplate >=0.8.8 && <0.9,
         lens >=5.1.1 && <5.4,
         mtl >=2.2.2 && <2.4,
@@ -65,7 +65,7 @@ library
 executable nix-shellify
     import: deps
     main-is: Main.hs
-    build-depends:    
+    build-depends:
         shellify >=0
     hs-source-dirs: app
 
@@ -81,6 +81,8 @@ test-suite haskelltest-test
         Paths_shellify
     ghc-options: -threaded -rtsopts -with-rtsopts=-N
     build-depends:
+        data-default >=0.7 && <0.9,
+        extra >=1.7.16 && <1.8,
         hspec >=2.9.7 && <2.12,
         hspec-core >=2.9.7 && <2.12,
         shellify >=0

src/Constants.hs

@@ -3,37 +3,12 @@ module Constants where
 import Data.Text (Text())
 import Text.RawString.QQ (r)
 
-helpText :: Text -> Text
-helpText progName = "USAGE: " <> progName <> [r| -p [PACKAGES] [--with-flakes]
-       |] <> progName <> [r| shell [PACKAGES]
-
-Pass nix-shell arguments to nix-shellify to have it generate a shell.nix in
-the current directory. You can then just run nix develop or nix-shell in that
-directory to have those packages in your environment. To run nix commands
-you must first install Nix.
-
-Options
-
-    -p / --packages
-    Specify packages for nix-shell compatability
-
-    --command / --run
-    Command to run after creating the shell
-
-    --with-flake
-    When using the -p option to specify packages, use this switch to have a
-    flake.nix created in addition to a shell.nix. This is recommended to ensure
-    the versions of dependencies are kept for reproducibility and so that
-    shells are cached to load faster.
-
-    --allow-local-pinned-registries-to-be-prioritized
-    Pinned local repoisitory URLs are usually taken last when looking for URLs for
-    generated flake.nix files. This is usually desired. If you do however want
-    to see these pinned entries in the flake file as specified in your registry,
-    then set this flag.
-
-    --version
-    Show the version number
+hlDesc :: String
+hlDesc = [r|
+  Pass nix-shell arguments to nix-shellify to have it generate a shell.nix in
+  the current directory. You can then just run nix develop or nix-shell in that
+  directory to have those packages in your environment. To run nix commands
+  you must first install Nix.
 |]
 
 noPackagesError = [r|I can't write out a shell file without any packages specified.

src/Options.hs

@@ -1,17 +1,19 @@
 {-# LANGUAGE TemplateHaskell #-}
-module Options (Package(..), Options(..), OutputForm(..), def, Packages(Packages), options) where
+module Options (Options(..), OutputForm(..), Package(..), Packages(Packages), parseCommandLine) where
 
 import Constants
 import FlakeTemplate
 import ShellifyTemplate
 
-import Control.Lens.Combinators (makeLenses, makePrisms, set, over, view)
+import Control.Lens.Combinators (makeLenses, makePrisms)
 import Data.Default (Default(def))
-import Data.List (sort)
-import Data.Maybe (fromMaybe)
-import Data.Text (isPrefixOf, pack, Text())
+import Data.List (isPrefixOf, sort)
+import Data.Maybe (fromMaybe, isJust)
+import Data.Text (pack, Text(), unpack)
 import Data.Version (showVersion)
+import Options.Applicative ((<**>), Parser, ParserResult(Success, Failure, CompletionInvoked), argument, command, defaultPrefs, execParserPure, fullDesc, header, help, helper, hidden, info, long, metavar, option, optional, progDesc, short, simpleVersioner, some, str, strOption, switch)
 import Paths_shellify (version)
+import System.Environment (getArgs)
 
 data OutputForm = Traditional
                 | Flake
@@ -26,82 +28,99 @@ instance Eq Packages where
 
 makePrisms ''Packages
 
+opts = info (commandParser <**> simpleVersioner (showVersion version)
+                           <**> helper) $
+            fullDesc
+         <> progDesc hlDesc
+         <> header "Quickly generate shell.nix files once you have a working shell"
+
+commandParser :: Parser CommandLineOptions
+commandParser = CommandLineOptions
+     <$> optional (some (option str (
+            long "packages"
+         <> short 'p'
+         <> metavar "PACKAGE"
+         <> help "Packages to install in the shell.nix file. This option can be used multiple times to specify multiple packages"
+         )))
+     <*> optional (option str (
+            long "command"
+         <> long "run"
+         <> short 'c'
+         <> metavar "COMMAND"
+         <> help "Command to run on initial shell startup"
+         ))
+     <*> switch (
+            long "with-flake"
+         <> help "When using the -p option to specify packages, use this switch to have a flake.nix created in addition to a shell.nix. This is recommended to ensure the versions of dependencies are kept for reproducibility and so that shells are cached to load faster."
+         )
+     <*> switch (
+            long "allow-local-pinned-registries-to-be-prioritized"
+         <> help "Pinned local repoisitory URLs are usually taken last when looking for URLs for generated flake.nix files. This is usually desired. If you do however want to see these pinned entries in the flake file as specified in your registry, then set this flag."
+         )
+     <*> optional (some (option str (
+           long "arg"
+        <> long "argstr"
+        <> hidden
+        )))
+     <*> optional (some (argument str (metavar "shell PACKAGES...")))
+
 data Options = Options {
     _packages :: !Packages
   , _command :: !(Maybe Text)
   , _outputForm :: !OutputForm
   , _prioritiseLocalPinnedSystem :: !Bool
 } deriving (Eq, Show)
 
-makeLenses ''Options
-
-packageList = view (packages . _Packages)
-
-data OptionsParser = OptionsParser [Text] -- | remainingOptions
-                                   (Either Text (Options -> Options)) -- | result
-
-options :: Text -> [Text] -> Either Text Options
-options progName args =
-  let optionsHandler | hasShellArg args = newStyleOption
-                     | otherwise = oldStyleOption
-      shellArgFilter | hasShellArg args = filter (/= "shell")
-                     | otherwise = id
-      optionsCaller f = worker 
-       where worker (OptionsParser [] t) = t
-             worker (OptionsParser (hd:tl) res) =
-               let (OptionsParser newRemaining newRes) = f hd tl
-               in worker $ OptionsParser newRemaining ((.) <$> newRes <*> res)
-
-      screenForNoPackages (Right opts) | null (packageList opts) = Left noPackagesError
-      screenForNoPackages anyThingElse = anyThingElse
-      initialArgumentsToParse = shellArgFilter args
-      initialModifier = Right $ if hasShellArg args then setFlakeGeneration else id
-      initialOptionParser = OptionsParser initialArgumentsToParse initialModifier
-  in screenForNoPackages $ ($ def) <$> optionsCaller optionsHandler initialOptionParser
+data CommandLineOptions = CommandLineOptions {
+    __packages :: !(Maybe [Text])
+  , __command :: !(Maybe Text)
+  , __withFlake :: !Bool
+  , __prioritiseLocalPinnedSystem :: Bool
+  , __discard :: !(Maybe [String])
+  , __shellPackages :: Maybe [Package]
+} deriving (Show)
 
-  where oldStyleOption :: Text -> [Text] -> OptionsParser
-        oldStyleOption "-p" = handlePackageSwitch
-        oldStyleOption "--packages" = handlePackageSwitch
-        oldStyleOption opt = baseOption opt
-        newStyleOption "-p" = returnError "-p and --packages are not supported with new style commands"
-        newStyleOption "--packages" = returnError "-p and --packages are not supported with new style commands"
-        newStyleOption "--allow-local-pinned-registries-to-be-prioritized" = transformOptionsWith $ set prioritiseLocalPinnedSystem True
-        newStyleOption arg | isSwitch arg = baseOption arg
-                           | otherwise = transformOptionsWith $ appendPackages [arg]
-        baseOption :: Text -> [Text] -> OptionsParser
-        baseOption "-h" = returnError $ helpText progName
-        baseOption "--help" = returnError $ helpText progName
-        baseOption "--version" = returnError $ "Shellify " <> pack ( showVersion version)
-        baseOption "--command" = handleCommandSwitch
-        baseOption "--run" = handleCommandSwitch
-        baseOption "--with-flake" = transformOptionsWith setFlakeGeneration
-        baseOption _ = transformOptionsWith id
-        transformOptionsWith fun wds = OptionsParser wds (Right fun)
-        handlePackageSwitch wds = let (pkgs, remainingOptions) = consumePackageArgs wds
-                                  in transformOptionsWith (appendPackages pkgs) remainingOptions
-        handleCommandSwitch (hd:tl) | isSwitch hd
-                                    = returnError "Argument missing to switch" tl
-                                    | otherwise
-                                    = transformOptionsWith (set Options.command (Just hd)) tl
-        handleCommandSwitch [] = returnError "Argument missing to switch" []
-
-        appendPackages = over (packages. _Packages) . (++)
-        setFlakeGeneration = set outputForm Flake
-        returnError errorText remaining = OptionsParser remaining $ Left errorText
-
-consumePackageArgs :: [Text] -> ([Package], [Text])
-consumePackageArgs = worker []
-  where worker pkgs [] = (pkgs, [])
-        worker pkgs options@(hd:_) | isSwitch hd
-                                   = (pkgs, options)
-        worker pkgs (hd:tl) = worker (hd:pkgs) tl
-
-hasShellArg [] = False
-hasShellArg ("shell":_) = True
-hasShellArg (hd:tl) | isSwitch hd = hasShellArg tl
-                    | otherwise = False
-
-isSwitch = isPrefixOf "-"
+makeLenses ''Options
 
 instance Default Options where
-  def = Options (Packages []) Nothing Traditional False
+  def = Options{
+    _packages = Packages [],
+    _command = Nothing,
+    _outputForm = Traditional,
+    _prioritiseLocalPinnedSystem = False
+  }
+
+parseCommandLine :: [String] -> Either Text (ParserResult Options)
+parseCommandLine =
+    (\case
+      Success res -> fmap Success (parseCommandLineOptions res)
+      Failure failure -> Right $ Failure failure
+      CompletionInvoked f -> Right $ CompletionInvoked f)
+      . execParserPure defaultPrefs opts . fixupRequest
+  where parseCommandLineOptions :: CommandLineOptions -> Either Text Options
+        parseCommandLineOptions originalParsedOptions =
+          let transformedOptions =
+                    (Options <$> Packages . ((++) <$> fromMaybe [] . __packages
+                                                  <*> shellArgs . __shellPackages)
+                             <*> __command
+                             <*> \case
+                               f | __withFlake f -> Flake
+                                 | (hasShellArg . __shellPackages) f -> Flake
+                               _ | otherwise -> Traditional
+                             <*> __prioritiseLocalPinnedSystem) originalParsedOptions
+
+          in if _packages transformedOptions == Packages [] then
+               Left noPackagesError
+             else
+               Right transformedOptions
+          where hasShellArg (Just ("shell":_)) = True
+                hasShellArg _ = False
+                shellArgs (Just ("shell": rst)) = rst
+                shellArgs _ = []
+        fixupRequest (a : b : c : d) | (a == "-p" || a == "--packages")
+                                     && isNotASwitch b
+                                     && isNotASwitch c =
+                                         a : b : fixupRequest ("-p" : c : d)
+          where isNotASwitch = not . isPrefixOf "-"
+        fixupRequest (a : b) = a : fixupRequest b
+        fixupRequest [] = []