cabal-doctest: Add support for --list-options

sol · Jul 27, 2024 · ae00b17 · ae00b17
1 parent fc1e0d2
commit ae00b17
Show file tree

Hide file tree

Showing 3 changed files with 34 additions and 23 deletions.
diff --git a/src/Cabal/Options.hs b/src/Cabal/Options.hs
@@ -36,16 +36,26 @@ replOnlyOptions = Set.fromList [
 
 rejectUnsupportedOptions :: [String] -> IO ()
 rejectUnsupportedOptions args = case getOpt' Permute options args of
-  (_, _, unsupported : _, _) -> die $ "Error: cabal: unrecognized 'doctest' option `" <> unsupported <> "'"
+  (xs, _, _, _) | ListOptions `elem` xs -> do
+    let
+      names :: [String]
+      names = concat [map (\ c -> ['-', c]) short ++ map ("--" <> ) long | Option short long _ _ <- documentedOptions]
+    putStr (unlines names)
+    exitSuccess
+  (_, _, unsupported : _, _) -> do
+    die $ "Error: cabal: unrecognized 'doctest' option `" <> unsupported <> "'"
   _ -> pass
 
-data Argument = Argument {
-  argumentName :: String
-, argumentValue :: Maybe String
-}
+data Argument = Argument String (Maybe String) | ListOptions
+  deriving (Eq, Show)
 
 options :: [OptDescr Argument]
-options = map toOptDescr Repl.options
+options =
+    Option [] ["list-options"] (NoArg ListOptions) ""
+  : documentedOptions
+
+documentedOptions :: [OptDescr Argument]
+documentedOptions = map toOptDescr Repl.options
   where
     toOptDescr :: Repl.Option -> OptDescr Argument
     toOptDescr (Repl.Option long short arg help) = Option (maybeToList short) [long] (toArgDescr long arg) help
@@ -57,17 +67,8 @@ options = map toOptDescr Repl.options
       Repl.OptionalArgument name -> OptArg argument name
       where
         argument :: Maybe String -> Argument
-        argument argumentValue = Argument {
-          argumentName = "--" <> long
-        , argumentValue
-        }
+        argument value = Argument ("--" <> long) value
 
 discardReplOptions :: [String] -> [String]
 discardReplOptions args = case getOpt Permute options args of
-  (xs, _, _) -> concatMap values (filter (not . isReplOnlyOption) xs)
-  where
-    isReplOnlyOption :: Argument -> Bool
-    isReplOnlyOption arg = Set.member (argumentName arg) replOnlyOptions
-
-    values :: Argument -> [String]
-    values (Argument name value) = name : maybeToList value
+  (xs, _, _) -> concat [name : maybeToList value | Argument name value <- xs, Set.notMember name replOnlyOptions]
diff --git a/test/Cabal/OptionsSpec.hs b/test/Cabal/OptionsSpec.hs
@@ -9,8 +9,11 @@ import           System.IO
 import           System.IO.Silently
 import           System.Exit
 import           System.Process
+import           Data.Set ((\\))
 import qualified Data.Set as Set
 
+import qualified Cabal.ReplOptionsSpec as Repl
+
 import           Cabal.Options
 
 spec :: Spec
@@ -19,7 +22,7 @@ spec = do
     it "is the set of options that are unique to 'cabal repl'" $ do
       build <- Set.fromList . lines <$> readProcess "cabal" ["build", "--list-options"] ""
       repl <- Set.fromList . lines <$> readProcess "cabal" ["repl", "--list-options"] ""
-      Set.toList replOnlyOptions `shouldMatchList` Set.toList (Set.difference repl build)
+      Set.toList replOnlyOptions `shouldMatchList` Set.toList (repl \\ build)
 
   describe "rejectUnsupportedOptions" $ do
     it "produces error messages that are consistent with 'cabal repl'" $ do
@@ -34,6 +37,13 @@ spec = do
 #endif
       shouldFail "doctest" $ rejectUnsupportedOptions ["--installdir"]
 
+    context "with --list-options" $ do
+      it "lists supported command-line options" $ do
+        repl <- Set.fromList . lines <$> readProcess "cabal" ["repl", "--list-options"] ""
+        doctest <- Set.fromList . lines <$> capture_ (rejectUnsupportedOptions ["--list-options"] `shouldThrow` (== ExitSuccess))
+        Set.toList (doctest \\ repl) `shouldMatchList` []
+        Set.toList (repl \\ doctest) `shouldMatchList` Set.toList Repl.unsupported
+
   describe "discardReplOptions" $ do
     it "discards 'cabal repl'-only options" $ do
       discardReplOptions [

diff --git a/test/Cabal/ReplOptionsSpec.hs b/test/Cabal/ReplOptionsSpec.hs
@@ -1,6 +1,6 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE ViewPatterns #-}
-module Cabal.ReplOptionsSpec (spec) where
+module Cabal.ReplOptionsSpec (spec, unsupported) where
 
 import           Imports
 
@@ -28,6 +28,9 @@ undocumented = Set.fromList [
   , "--haddock-hyperlinked-source"
   ]
 
+unsupported :: Set String
+unsupported = undocumented <> Set.fromList (map ("--" <>) phony)
+
 spec :: Spec
 spec = do
   describe "options" $ do
@@ -37,15 +40,12 @@ spec = do
 
     it "is consistent with 'cabal repl --list-options'" $ do
       let
-        exclude :: Set String
-        exclude = undocumented <> Set.fromList (map ("--" <>) phony)
-
         optionNames :: Option -> [String]
         optionNames option = reverse $ "--" <> optionName option : case optionShortName option of
           Nothing -> []
           Just c -> [['-', c]]
 
-      repl <- filter (`Set.notMember` exclude) . lines <$> readProcess "cabal" ["repl", "--list-options"] ""
+      repl <- filter (`Set.notMember` unsupported) . lines <$> readProcess "cabal" ["repl", "--list-options"] ""
       concatMap optionNames options `shouldBe` repl
 
 parseOptions :: String -> [Option]