cabal-doctest: Add support for --with-compiler

.github/workflows/build.yml

@@ -79,7 +79,7 @@ jobs:
             # ghc: system
             ghc: 9.6.2
     steps:
-      - uses: actions/checkout@v3
+      - uses: actions/checkout@v4
       - uses: hspec/setup-haskell@v1
         with:
           ghc-version: ${{ matrix.ghc }}

.github/workflows/cabal-doctest.yml

@@ -27,20 +27,24 @@ jobs:
           - windows-latest
 
     steps:
-      - uses: actions/checkout@v3
+      - uses: actions/checkout@v4
 
       - run: ghcup install cabal latest --set
         if: matrix.os == 'macos-12'
 
       - run: cabal path -v0 --installdir >> $GITHUB_PATH
         if: matrix.os == 'macos-12'
 
+      - run: ghcup install ghc 8.6.5 --no-set
+
       - run: cabal --version
       - run: cabal path
       - run: cabal update
       - run: cabal install -f cabal-doctest
       - run: cabal doctest
 
+      - run: cabal doctest -w ghc-8.6.5
+
   cabal-doctest-success:
     needs: build
     runs-on: ubuntu-latest

README.md

@@ -198,6 +198,32 @@ $ cabal doctest
 Examples: 2  Tried: 2  Errors: 0  Failures: 0
 ```
 
+```bash
+$ cabal doctest -w ghc-8.6.5
+Examples: 2  Tried: 2  Errors: 0  Failures: 0
+```
+
+```bash
+$ cabal doctest --repl-options=--verbose
+### Started execution at src/Fib.hs:7.
+### example:
+fib 10
+### Successful!
+
+### Started execution at src/Fib.hs:10.
+### example:
+fib 5
+### Successful!
+
+# Final summary:
+Examples: 2  Tried: 2  Errors: 0  Failures: 0
+```
+
+```bash
+$ cabal doctest --build-depends transformers
+Examples: 2  Tried: 2  Errors: 0  Failures: 0
+```
+
 # Writing examples and properties
 
 ## Example groups

package.yaml

@@ -64,6 +64,7 @@ library:
     process:
     ghc-paths: ">= 0.1.0.9"
     transformers:
+    containers:
 
 flags:
   cabal-doctest:

src/Cabal.hs

@@ -12,6 +12,7 @@ import           System.Process
 
 import qualified Info
 import           Cabal.Paths
+import           Cabal.Options
 
 externalCommand :: [String] -> IO ()
 externalCommand args = do
@@ -21,8 +22,9 @@ externalCommand args = do
 
 run :: String -> [String] -> IO ()
 run cabal args = do
+  rejectUnsupportedOptions args
 
-  Paths{..} <- paths cabal
+  Paths{..} <- paths cabal (discardReplOptions args)
 
   let
     doctest = cache </> "doctest" <> "-" <> Info.version
@@ -47,15 +49,16 @@ run cabal args = do
 
   callProcess doctest ["--version"]
 
-  callProcess cabal ("build" : "--only-dependencies" : args)
+  callProcess cabal ("build" : "--only-dependencies" : discardReplOptions args)
 
-  spawnProcess cabal ("repl"
+  rawSystem cabal ("repl"
     : "--build-depends=QuickCheck"
     : "--build-depends=template-haskell"
     : ("--repl-options=-ghci-script=" <> script)
-    : "--with-compiler" : doctest
-    : "--with-hc-pkg" : ghcPkg
-    : args) >>= waitForProcess >>= exitWith
+    : args ++ [
+      "--with-compiler", doctest
+    , "--with-hc-pkg", ghcPkg
+    ]) >>= exitWith
 
 writeFileAtomically :: FilePath -> String -> IO ()
 writeFileAtomically name contents = do

src/Cabal/Options.hs

@@ -0,0 +1,109 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE LambdaCase #-}
+module Cabal.Options (
+  rejectUnsupportedOptions
+, discardReplOptions
+
+#ifdef TEST
+, Option(..)
+, pathOptions
+, replOptions
+, shouldReject
+, Discard(..)
+, shouldDiscard
+#endif
+) where
+
+import           Imports
+
+import           Data.List
+import           System.Exit
+
+import           Data.Set (Set)
+import qualified Data.Set as Set
+
+data Option = Option {
+  optionName :: String
+, _optionArgument :: OptionArgument
+}
+
+data OptionArgument = Argument | NoArgument
+
+pathOptions :: [Option]
+pathOptions = [
+    Option "-z" NoArgument
+  , Option "--ignore-project" NoArgument
+  , Option "--output-format" Argument
+  , Option "--compiler-info" NoArgument
+  , Option "--cache-home" NoArgument
+  , Option "--remote-repo-cache" NoArgument
+  , Option "--logs-dir" NoArgument
+  , Option "--store-dir" NoArgument
+  , Option "--config-file" NoArgument
+  , Option "--installdir" NoArgument
+  ]
+
+replOptions :: [Option]
+replOptions = [
+    Option "-z" NoArgument
+  , Option "--ignore-project" NoArgument
+  , Option "--repl-no-load" NoArgument
+  , Option "--repl-options" Argument
+  , Option "--repl-multi-file" Argument
+  , Option "-b" Argument
+  , Option "--build-depends" Argument
+  , Option "--no-transitive-deps" NoArgument
+  , Option "--enable-multi-repl" NoArgument
+  , Option "--disable-multi-repl" NoArgument
+  , Option "--keep-temp-files" NoArgument
+  ]
+
+rejectUnsupportedOptions :: [String] -> IO ()
+rejectUnsupportedOptions = mapM_ $ \ arg -> when (shouldReject arg) $ do
+  die "Error: cabal: unrecognized 'doctest' option `--installdir'"
+
+shouldReject :: String -> Bool
+shouldReject arg =
+     Set.member arg rejectNames
+  || (`any` longOptionsWithArgument) (`isPrefixOf` arg)
+  where
+    rejectNames :: Set String
+    rejectNames = Set.fromList (map optionName pathOptions)
+
+    longOptionsWithArgument :: [String]
+    longOptionsWithArgument = [name <> "=" | Option name@('-':'-':_) Argument <- pathOptions]
+
+discardReplOptions :: [String] -> [String]
+discardReplOptions = go
+  where
+    go = \ case
+      [] -> []
+      arg : args -> case shouldDiscard arg of
+        Keep -> arg : go args
+        Discard -> go args
+        DiscardWithArgument -> go (drop 1 args)
+
+data Discard = Keep | Discard | DiscardWithArgument
+  deriving (Eq, Show)
+
+shouldDiscard :: String -> Discard
+shouldDiscard arg
+  | Set.member arg flags = Discard
+  | Set.member arg options = DiscardWithArgument
+  | isOptionWithArgument = Discard
+  | otherwise = Keep
+  where
+    flags :: Set String
+    flags = Set.fromList [name | Option name NoArgument <- replOptions]
+
+    options :: Set String
+    options = Set.fromList (longOptions <> shortOptions)
+
+    longOptions :: [String]
+    longOptions = [name | Option name@('-':'-':_) Argument <- replOptions]
+
+    shortOptions :: [String]
+    shortOptions = [name | Option name@['-', _] Argument <- replOptions]
+
+    isOptionWithArgument :: Bool
+    isOptionWithArgument = any (`isPrefixOf` arg) (map (<> "=") longOptions <> shortOptions)

src/Cabal/Paths.hs

@@ -24,8 +24,8 @@ data Paths = Paths {
 , cache :: FilePath
 } deriving (Eq, Show)
 
-paths :: FilePath -> IO Paths
-paths cabal = do
+paths :: FilePath -> [String] -> IO Paths
+paths cabal args = do
   cabalVersion <- strip <$> readProcess cabal ["--numeric-version"] ""
 
   let
@@ -35,7 +35,7 @@ paths cabal = do
   when (parseVersion cabalVersion < Just required) $ do
     die $ "'cabal-install' version " <> showVersion required <> " or later is required, but 'cabal --numeric-version' returned " <> cabalVersion <> "."
 
-  values <- parseFields <$> readProcess cabal ["path", "-v0"] ""
+  values <- parseFields <$> readProcess cabal ("path" : args ++ ["-v0"]) ""
 
   let
     getPath :: String -> String -> IO FilePath

test/Cabal/OptionsSpec.hs

@@ -0,0 +1,100 @@
+{-# LANGUAGE CPP #-}
+module Cabal.OptionsSpec (spec) where
+
+import           Imports
+
+import           Test.Hspec
+
+import           System.IO
+import           System.IO.Silently
+import           System.Exit
+import           System.Process
+import qualified Data.Set as Set
+
+import           Cabal.Options
+
+spec :: Spec
+spec = do
+  describe "pathOptions" $ do
+    it "is the set of options that are unique to 'cabal path'" $ do
+      build <- Set.fromList . lines <$> readProcess "cabal" ["build", "--list-options"] ""
+      path <- Set.fromList . lines <$> readProcess "cabal" ["path", "--list-options"] ""
+      map optionName pathOptions `shouldMatchList` Set.toList (Set.difference path build)
+
+  describe "replOptions" $ 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"] ""
+      map optionName replOptions `shouldMatchList` Set.toList (Set.difference repl build)
+
+  describe "rejectUnsupportedOptions" $ do
+    it "produces error messages that are consistent with 'cabal repl'" $ do
+      let
+        shouldFail :: HasCallStack => String -> IO a -> Expectation
+        shouldFail command action = do
+          hCapture_ [stderr] (action `shouldThrow` (== ExitFailure 1))
+            `shouldReturn` "Error: cabal: unrecognized '" <> command <> "' option `--installdir'\n"
+
+#ifndef mingw32_HOST_OS
+      shouldFail "repl" $ rawSystem "cabal" ["repl", "--installdir"] >>= exitWith
+#endif
+      shouldFail "doctest" $ rejectUnsupportedOptions ["--installdir"]
+
+  describe "shouldReject" $ do
+    it "accepts --foo" $ do
+      shouldReject "--foo" `shouldBe` False
+
+    it "rejects --ignore-project" $ do
+      shouldReject "--ignore-project" `shouldBe` True
+
+    it "rejects -z" $ do
+      shouldReject "-z" `shouldBe` True
+
+    it "rejects --output-format" $ do
+      shouldReject "--output-format" `shouldBe` True
+
+    it "rejects --output-format=" $ do
+      shouldReject "--output-format=json" `shouldBe` True
+
+    it "rejects --installdir" $ do
+      shouldReject "--installdir" `shouldBe` True
+
+  describe "discardReplOptions" $ do
+    it "discards 'cabal repl'-only options" $ do
+      discardReplOptions [
+          "--foo"
+        , "--build-depends=foo"
+        , "--build-depends", "foo"
+        , "-bfoo"
+        , "-b", "foo"
+        , "--bar"
+        , "--enable-multi-repl"
+        , "--repl-options", "foo"
+        , "--repl-options=foo"
+        , "--baz"
+        ] `shouldBe` ["--foo", "--bar", "--baz"]
+
+  describe "shouldDiscard" $ do
+    it "keeps --foo" $ do
+      shouldDiscard "--foo" `shouldBe` Keep
+
+    it "discards --build-depends" $ do
+      shouldDiscard "--build-depends" `shouldBe` DiscardWithArgument
+
+    it "discards --build-depends=" $ do
+      shouldDiscard "--build-depends=foo" `shouldBe` Discard
+
+    it "discards -b" $ do
+      shouldDiscard "-b" `shouldBe` DiscardWithArgument
+
+    it "discards -bfoo" $ do
+      shouldDiscard "-bfoo" `shouldBe` Discard
+
+    it "discards --repl-options" $ do
+      shouldDiscard "--repl-options" `shouldBe` DiscardWithArgument
+
+    it "discards --repl-options=" $ do
+      shouldDiscard "--repl-options=foo" `shouldBe` Discard
+
+    it "discards --enable-multi-repl" $ do
+      shouldDiscard "--enable-multi-repl" `shouldBe` Discard