diff --git a/CHANGES.markdown b/CHANGES.markdown --- a/CHANGES.markdown +++ b/CHANGES.markdown @@ -1,3 +1,14 @@ +Changes in 0.22.7 + - cabal-doctest: Accept component + - cabal-doctest: Get rid of separate `cabal build` step + - cabal-doctest: Add support for `--list-options` + +Changes in 0.22.6 + - cabal-doctest: Take `with-compiler:` from `cabal-project` into account + - cabal-doctest: Add support for `--with-compiler` + - cabal-doctest: Fix `ghc-pkg` discovery logic + - cabal-doctest: Cache `doctest` executables + Changes in 0.22.5 - Add (experimental) `cabal-doctest` executable. This is guarded behind a flag for now, use `cabal install doctest -f cabal-doctest` to install it. diff --git a/doctest.cabal b/doctest.cabal --- a/doctest.cabal +++ b/doctest.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: doctest -version: 0.22.6 +version: 0.22.7 synopsis: Test interactive Haskell examples description: `doctest` is a tool that checks [examples](https://www.haskell.org/haddock/doc/html/ch03s08.html#idm140354810775744) and [properties](https://www.haskell.org/haddock/doc/html/ch03s08.html#idm140354810771856) @@ -132,6 +132,7 @@ Cabal Cabal.Options Cabal.Paths + Cabal.ReplOptions Extract GhcUtil Imports @@ -160,6 +161,7 @@ , ghc-paths >=0.1.0.9 , process , syb >=0.3 + , temporary , transformers default-language: Haskell2010 if impl(ghc >= 9.0) @@ -214,6 +216,7 @@ other-modules: Cabal.OptionsSpec Cabal.PathsSpec + Cabal.ReplOptionsSpec ExtractSpec InfoSpec InterpreterSpec @@ -231,6 +234,7 @@ Cabal Cabal.Options Cabal.Paths + Cabal.ReplOptions Extract GhcUtil Imports @@ -287,6 +291,7 @@ , silently >=1.2.4 , stringbuilder >=0.4 , syb >=0.3 + , temporary , transformers default-language: Haskell2010 if impl(ghc >= 9.0) diff --git a/src/Cabal.hs b/src/Cabal.hs --- a/src/Cabal.hs +++ b/src/Cabal.hs @@ -3,9 +3,11 @@ import Imports +import Data.List +import Data.Version (makeVersion) import System.IO +import System.IO.Temp import System.Environment -import System.Exit (exitWith) import System.Directory import System.FilePath import System.Process @@ -40,7 +42,6 @@ , "--program-suffix", "-" <> Info.version , "--install-method=copy" , "--with-compiler", ghc - , "--with-hc-pkg", ghcPkg ] doesFileExist script >>= \ case @@ -49,16 +50,24 @@ callProcess doctest ["--version"] - callProcess cabal ("build" : "--only-dependencies" : discardReplOptions args) + let + repl extraArgs = call cabal ("repl" + : "--build-depends=QuickCheck" + : "--build-depends=template-haskell" + : ("--repl-options=-ghci-script=" <> script) + : args ++ extraArgs) - rawSystem cabal ("repl" - : "--build-depends=QuickCheck" - : "--build-depends=template-haskell" - : ("--repl-options=-ghci-script=" <> script) - : args ++ [ - "--with-compiler", doctest - , "--with-hc-pkg", ghcPkg - ]) >>= exitWith + case ghcVersion < makeVersion [9,4] of + True -> do + callProcess cabal ("build" : "--only-dependencies" : discardReplOptions args) + repl ["--with-compiler", doctest, "--with-hc-pkg", ghcPkg] + + False -> do + withSystemTempDirectory "cabal-doctest" $ \ dir -> do + repl ["--keep-temp-files", "--repl-multi-file", dir] + files <- filter (isSuffixOf "-inplace") <$> listDirectory dir + options <- concat <$> mapM (fmap lines . readFile . combine dir) files + call doctest ("--no-magic" : options) writeFileAtomically :: FilePath -> String -> IO () writeFileAtomically name contents = do diff --git a/src/Cabal/Options.hs b/src/Cabal/Options.hs --- a/src/Cabal/Options.hs +++ b/src/Cabal/Options.hs @@ -5,105 +5,70 @@ , discardReplOptions #ifdef TEST -, Option(..) -, pathOptions -, replOptions -, shouldReject -, Discard(..) -, shouldDiscard +, replOnlyOptions #endif ) where import Imports -import Data.List import System.Exit +import System.Console.GetOpt 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 - ] +import qualified Cabal.ReplOptions as Repl -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 +replOnlyOptions :: Set String +replOnlyOptions = Set.fromList [ + "-z" + , "--ignore-project" + , "--repl-no-load" + , "--repl-options" + , "--repl-multi-file" + , "-b" + , "--build-depends" + , "--no-transitive-deps" + , "--enable-multi-repl" + , "--disable-multi-repl" + , "--keep-temp-files" ] 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) +rejectUnsupportedOptions args = case getOpt' Permute options args of + (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 Discard = Keep | Discard | DiscardWithArgument +data Argument = Argument String (Maybe String) | ListOptions 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) +options :: [OptDescr Argument] +options = + Option [] ["list-options"] (NoArg ListOptions) "" + : documentedOptions - longOptions :: [String] - longOptions = [name | Option name@('-':'-':_) Argument <- replOptions] +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 - shortOptions :: [String] - shortOptions = [name | Option name@['-', _] Argument <- replOptions] + toArgDescr :: String -> Repl.Argument -> ArgDescr Argument + toArgDescr long = \ case + Repl.Argument name -> ReqArg (argument . Just) name + Repl.NoArgument -> NoArg (argument Nothing) + Repl.OptionalArgument name -> OptArg argument name + where + argument :: Maybe String -> Argument + argument value = Argument ("--" <> long) value - isOptionWithArgument :: Bool - isOptionWithArgument = any (`isPrefixOf` arg) (map (<> "=") longOptions <> shortOptions) +discardReplOptions :: [String] -> [String] +discardReplOptions args = case getOpt Permute options args of + (xs, _, _) -> concat [name : maybeToList value | Argument name value <- xs, Set.notMember name replOnlyOptions] diff --git a/src/Cabal/Paths.hs b/src/Cabal/Paths.hs --- a/src/Cabal/Paths.hs +++ b/src/Cabal/Paths.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE StrictData #-} module Cabal.Paths ( Paths(..) , paths @@ -19,7 +20,8 @@ import Text.ParserCombinators.ReadP data Paths = Paths { - ghc :: FilePath + ghcVersion :: Version +, ghc :: FilePath , ghcPkg :: FilePath , cache :: FilePath } deriving (Eq, Show) @@ -45,11 +47,15 @@ ghc <- getPath "'ghc'" "compiler-path" - ghcVersion <- strip <$> readProcess ghc ["--numeric-version"] "" + ghcVersionString <- strip <$> readProcess ghc ["--numeric-version"] "" + ghcVersion <- case parseVersion ghcVersionString of + Nothing -> die $ "Cannot determine GHC version from '" <> ghcVersionString <> "'." + Just version -> return version + let ghcPkg :: FilePath - ghcPkg = takeDirectory ghc "ghc-pkg-" <> ghcVersion + ghcPkg = takeDirectory ghc "ghc-pkg-" <> ghcVersionString #ifdef mingw32_HOST_OS <.> "exe" #endif @@ -61,12 +67,13 @@ abi <- strip <$> readProcess ghcPkg ["--no-user-package-db", "field", "base", "abi", "--simple-output"] "" cache_home <- getPath "Cabal's cache directory" "cache-home" - let cache = cache_home "doctest" "ghc-" <> ghcVersion <> "-" <> abi + let cache = cache_home "doctest" "ghc-" <> ghcVersionString <> "-" <> abi createDirectoryIfMissing True cache return Paths { - ghc + ghcVersion + , ghc , ghcPkg , cache } @@ -84,9 +91,6 @@ hPutStrLn stderr "Error: [cabal-doctest]" hPutStrLn stderr message exitFailure - -strip :: String -> String -strip = reverse . dropWhile isSpace . reverse . dropWhile isSpace parseVersion :: String -> Maybe Version parseVersion = lookup "" . map swap . readP_to_S Version.parseVersion diff --git a/src/Cabal/ReplOptions.hs b/src/Cabal/ReplOptions.hs new file mode 100644 --- /dev/null +++ b/src/Cabal/ReplOptions.hs @@ -0,0 +1,191 @@ +module Cabal.ReplOptions ( + Option(..) +, Argument(..) +, options +) where + +import Imports + +data Option = Option { + optionName :: String +, optionShortName :: Maybe Char +, optionArgument :: Argument +, optionHelp :: String +} deriving (Eq, Show) + +data Argument = Argument String | NoArgument | OptionalArgument String + deriving (Eq, Show) + +options :: [Option] +options = [ + Option "help" (Just 'h') NoArgument "Show this help text" + , Option "verbose" (Just 'v') (OptionalArgument "n") "Control verbosity (n is 0--3, default verbosity level is 1)" + , Option "builddir" Nothing (Argument "DIR") "The directory where Cabal puts generated build files (default dist)" + , Option "ghc" (Just 'g') NoArgument "compile with GHC" + , Option "ghcjs" Nothing NoArgument "compile with GHCJS" + , Option "uhc" Nothing NoArgument "compile with UHC" + , Option "haskell-suite" Nothing NoArgument "compile with a haskell-suite compiler" + , Option "with-compiler" (Just 'w') (Argument "PATH") "give the path to a particular compiler" + , Option "with-hc-pkg" Nothing (Argument "PATH") "give the path to the package tool" + , Option "prefix" Nothing (Argument "DIR") "bake this prefix in preparation of installation" + , Option "bindir" Nothing (Argument "DIR") "installation directory for executables" + , Option "libdir" Nothing (Argument "DIR") "installation directory for libraries" + , Option "libsubdir" Nothing (Argument "DIR") "subdirectory of libdir in which libs are installed" + , Option "dynlibdir" Nothing (Argument "DIR") "installation directory for dynamic libraries" + , Option "libexecdir" Nothing (Argument "DIR") "installation directory for program executables" + , Option "libexecsubdir" Nothing (Argument "DIR") "subdirectory of libexecdir in which private executables are installed" + , Option "datadir" Nothing (Argument "DIR") "installation directory for read-only data" + , Option "datasubdir" Nothing (Argument "DIR") "subdirectory of datadir in which data files are installed" + , Option "docdir" Nothing (Argument "DIR") "installation directory for documentation" + , Option "htmldir" Nothing (Argument "DIR") "installation directory for HTML documentation" + , Option "haddockdir" Nothing (Argument "DIR") "installation directory for haddock interfaces" + , Option "sysconfdir" Nothing (Argument "DIR") "installation directory for configuration files" + , Option "program-prefix" Nothing (Argument "PREFIX") "prefix to be applied to installed executables" + , Option "program-suffix" Nothing (Argument "SUFFIX") "suffix to be applied to installed executables" + , Option "enable-library-vanilla" Nothing NoArgument "Enable Vanilla libraries" + , Option "disable-library-vanilla" Nothing NoArgument "Disable Vanilla libraries" + , Option "enable-library-profiling" (Just 'p') NoArgument "Enable Library profiling" + , Option "disable-library-profiling" Nothing NoArgument "Disable Library profiling" + , Option "enable-shared" Nothing NoArgument "Enable Shared library" + , Option "disable-shared" Nothing NoArgument "Disable Shared library" + , Option "enable-static" Nothing NoArgument "Enable Static library" + , Option "disable-static" Nothing NoArgument "Disable Static library" + , Option "enable-executable-dynamic" Nothing NoArgument "Enable Executable dynamic linking" + , Option "disable-executable-dynamic" Nothing NoArgument "Disable Executable dynamic linking" + , Option "enable-executable-static" Nothing NoArgument "Enable Executable fully static linking" + , Option "disable-executable-static" Nothing NoArgument "Disable Executable fully static linking" + , Option "enable-profiling" Nothing NoArgument "Enable Executable and library profiling" + , Option "disable-profiling" Nothing NoArgument "Disable Executable and library profiling" + , Option "enable-executable-profiling" Nothing NoArgument "Enable Executable profiling (DEPRECATED)" + , Option "disable-executable-profiling" Nothing NoArgument "Disable Executable profiling (DEPRECATED)" + , Option "profiling-detail" Nothing (Argument "level") "Profiling detail level for executable and library (default, none, exported-functions, toplevel-functions, all-functions, late)." + , Option "library-profiling-detail" Nothing (Argument "level") "Profiling detail level for libraries only." + , Option "enable-optimization" (Just 'O') (OptionalArgument "n") "Build with optimization (n is 0--2, default is 1)" + , Option "disable-optimization" Nothing NoArgument "Build without optimization" + , Option "enable-debug-info" Nothing (OptionalArgument "n") "Emit debug info (n is 0--3, default is 0)" + , Option "disable-debug-info" Nothing NoArgument "Don't emit debug info" + , Option "enable-build-info" Nothing NoArgument "Enable build information generation during project building" + , Option "disable-build-info" Nothing NoArgument "Disable build information generation during project building" + , Option "enable-library-for-ghci" Nothing NoArgument "Enable compile library for use with GHCi" + , Option "disable-library-for-ghci" Nothing NoArgument "Disable compile library for use with GHCi" + , Option "enable-split-sections" Nothing NoArgument "Enable compile library code such that unneeded definitions can be dropped from the final executable (GHC 7.8+)" + , Option "disable-split-sections" Nothing NoArgument "Disable compile library code such that unneeded definitions can be dropped from the final executable (GHC 7.8+)" + , Option "enable-split-objs" Nothing NoArgument "Enable split library into smaller objects to reduce binary sizes (GHC 6.6+)" + , Option "disable-split-objs" Nothing NoArgument "Disable split library into smaller objects to reduce binary sizes (GHC 6.6+)" + , Option "enable-executable-stripping" Nothing NoArgument "Enable strip executables upon installation to reduce binary sizes" + , Option "disable-executable-stripping" Nothing NoArgument "Disable strip executables upon installation to reduce binary sizes" + , Option "enable-library-stripping" Nothing NoArgument "Enable strip libraries upon installation to reduce binary sizes" + , Option "disable-library-stripping" Nothing NoArgument "Disable strip libraries upon installation to reduce binary sizes" + , Option "configure-option" Nothing (Argument "OPT") "Extra option for configure" + , Option "user" Nothing NoArgument "Enable doing a per-user installation" + , Option "global" Nothing NoArgument "Disable doing a per-user installation" + , Option "package-db" Nothing (Argument "DB") "Append the given package database to the list of package databases used (to satisfy dependencies and register into). May be a specific file, 'global' or 'user'. The initial list is ['global'], ['global', 'user'], or ['global', $sandbox], depending on context. Use 'clear' to reset the list to empty. See the user guide for details." + , Option "flags" (Just 'f') (Argument "FLAGS") "Force values for the given flags in Cabal conditionals in the .cabal file. E.g., --flags=\"debug -usebytestrings\" forces the flag \"debug\" to true and \"usebytestrings\" to false." + , Option "extra-include-dirs" Nothing (Argument "PATH") "A list of directories to search for header files" + , Option "enable-deterministic" Nothing NoArgument "Enable Try to be as deterministic as possible (used by the test suite)" + , Option "disable-deterministic" Nothing NoArgument "Disable Try to be as deterministic as possible (used by the test suite)" + , Option "ipid" Nothing (Argument "IPID") "Installed package ID to compile this package as" + , Option "cid" Nothing (Argument "CID") "Installed component ID to compile this component as" + , Option "extra-lib-dirs" Nothing (Argument "PATH") "A list of directories to search for external libraries" + , Option "extra-lib-dirs-static" Nothing (Argument "PATH") "A list of directories to search for external libraries when linking fully static executables" + , Option "extra-framework-dirs" Nothing (Argument "PATH") "A list of directories to search for external frameworks (OS X only)" + , Option "extra-prog-path" Nothing (Argument "PATH") "A list of directories to search for required programs (in addition to the normal search locations)" + , Option "instantiate-with" Nothing (Argument "NAME=MOD") "A mapping of signature names to concrete module instantiations." + , Option "enable-tests" Nothing NoArgument "Enable dependency checking and compilation for test suites listed in the package description file." + , Option "disable-tests" Nothing NoArgument "Disable dependency checking and compilation for test suites listed in the package description file." + , Option "enable-coverage" Nothing NoArgument "Enable build package with Haskell Program Coverage. (GHC only)" + , Option "disable-coverage" Nothing NoArgument "Disable build package with Haskell Program Coverage. (GHC only)" + , Option "enable-library-coverage" Nothing NoArgument "Enable build package with Haskell Program Coverage. (GHC only) (DEPRECATED)" + , Option "disable-library-coverage" Nothing NoArgument "Disable build package with Haskell Program Coverage. (GHC only) (DEPRECATED)" + , Option "enable-benchmarks" Nothing NoArgument "Enable dependency checking and compilation for benchmarks listed in the package description file." + , Option "disable-benchmarks" Nothing NoArgument "Disable dependency checking and compilation for benchmarks listed in the package description file." + , Option "enable-relocatable" Nothing NoArgument "Enable building a package that is relocatable. (GHC only)" + , Option "disable-relocatable" Nothing NoArgument "Disable building a package that is relocatable. (GHC only)" + , Option "disable-response-files" Nothing NoArgument "enable workaround for old versions of programs like \"ar\" that do not support @file arguments" + , Option "allow-depending-on-private-libs" Nothing NoArgument "Allow depending on private libraries. If set, the library visibility check MUST be done externally." + , Option "coverage-for" Nothing (Argument "UNITID") "A list of unit-ids of libraries to include in the Haskell Program Coverage report." + , Option "cabal-lib-version" Nothing (Argument "VERSION") "Select which version of the Cabal lib to use to build packages (useful for testing)." + , Option "enable-append" Nothing NoArgument "Enable appending the new config to the old config file" + , Option "disable-append" Nothing NoArgument "Disable appending the new config to the old config file" + , Option "enable-backup" Nothing NoArgument "Enable the backup of the config file before any alterations" + , Option "disable-backup" Nothing NoArgument "Disable the backup of the config file before any alterations" + , Option "constraint" (Just 'c') (Argument "CONSTRAINT") "Specify constraints on a package (version, installed/source, flags)" + , Option "preference" Nothing (Argument "CONSTRAINT") "Specify preferences (soft constraints) on the version of a package" + , Option "solver" Nothing (Argument "SOLVER") "Select dependency solver to use (default: modular). Choices: modular." + , Option "allow-older" Nothing (OptionalArgument "DEPS") "Ignore lower bounds in all dependencies or DEPS" + , Option "allow-newer" Nothing (OptionalArgument "DEPS") "Ignore upper bounds in all dependencies or DEPS" + , Option "write-ghc-environment-files" Nothing (Argument "always|never|ghc8.4.4+") "Whether to create a .ghc.environment file after a successful build (v2-build only)" + , Option "enable-documentation" Nothing NoArgument "Enable building of documentation" + , Option "disable-documentation" Nothing NoArgument "Disable building of documentation" + , Option "doc-index-file" Nothing (Argument "TEMPLATE") "A central index of haddock API documentation (template cannot use $pkgid)" + , Option "dry-run" Nothing NoArgument "Do not install anything, only print what would be installed." + , Option "only-download" Nothing NoArgument "Do not build anything, only fetch the packages." + , Option "max-backjumps" Nothing (Argument "NUM") "Maximum number of backjumps allowed while solving (default: 4000). Use a negative number to enable unlimited backtracking. Use 0 to disable backtracking completely." + , Option "reorder-goals" Nothing NoArgument "Try to reorder goals according to certain heuristics. Slows things down on average, but may make backtracking faster for some packages." + , Option "count-conflicts" Nothing NoArgument "Try to speed up solving by preferring goals that are involved in a lot of conflicts (default)." + , Option "fine-grained-conflicts" Nothing NoArgument "Skip a version of a package if it does not resolve the conflicts encountered in the last version, as a solver optimization (default)." + , Option "minimize-conflict-set" Nothing NoArgument "When there is no solution, try to improve the error message by finding a minimal conflict set (default: false). May increase run time significantly." + , Option "independent-goals" Nothing NoArgument "Treat several goals on the command line as independent. If several goals depend on the same package, different versions can be chosen." + , Option "prefer-oldest" Nothing NoArgument "Prefer the oldest (instead of the latest) versions of packages available. Useful to determine lower bounds in the build-depends section." + , Option "shadow-installed-packages" Nothing NoArgument "If multiple package instances of the same version are installed, treat all but one as shadowed." + , Option "strong-flags" Nothing NoArgument "Do not defer flag choices (this used to be the default in cabal-install <= 1.20)." + , Option "allow-boot-library-installs" Nothing NoArgument "Allow cabal to install base, ghc-prim, integer-simple, integer-gmp, and template-haskell." + , Option "reject-unconstrained-dependencies" Nothing (Argument "none|all") "Require these packages to have constraints on them if they are to be selected (default: none)." + , Option "reinstall" Nothing NoArgument "Install even if it means installing the same version again." + , Option "avoid-reinstalls" Nothing NoArgument "Do not select versions that would destructively overwrite installed packages." + , Option "force-reinstalls" Nothing NoArgument "Reinstall packages even if they will most likely break other installed packages." + , Option "upgrade-dependencies" Nothing NoArgument "Pick the latest version for all dependencies, rather than trying to pick an installed version." + , Option "only-dependencies" Nothing NoArgument "Install only the dependencies necessary to build the given packages" + , Option "dependencies-only" Nothing NoArgument "A synonym for --only-dependencies" + , Option "index-state" Nothing (Argument "STATE") "Use source package index state as it existed at a previous time. Accepts unix-timestamps (e.g. '@1474732068'), ISO8601 UTC timestamps (e.g. '2016-09-24T17:47:48Z'), or 'HEAD' (default: 'HEAD')." + , Option "root-cmd" Nothing (Argument "COMMAND") "(No longer supported, do not use.)" + , Option "build-summary" Nothing (Argument "TEMPLATE") "Save build summaries to file (name template can use $pkgid, $compiler, $os, $arch)" + , Option "build-log" Nothing (Argument "TEMPLATE") "Log all builds to file (name template can use $pkgid, $compiler, $os, $arch)" + , Option "remote-build-reporting" Nothing (Argument "LEVEL") "Generate build reports to send to a remote server (none, anonymous or detailed)." + , Option "report-planning-failure" Nothing NoArgument "Generate build reports when the dependency solver fails. This is used by the Hackage build bot." + , Option "enable-per-component" Nothing NoArgument "Enable Per-component builds when possible" + , Option "disable-per-component" Nothing NoArgument "Disable Per-component builds when possible" + , Option "run-tests" Nothing NoArgument "Run package test suites during installation." + , Option "semaphore" Nothing NoArgument "Use a semaphore so GHC can compile components in parallel" + , Option "jobs" (Just 'j') (OptionalArgument "NUM") "Run NUM jobs simultaneously (or '$ncpus' if no NUM is given)." + , Option "keep-going" Nothing NoArgument "After a build failure, continue to build other unaffected packages." + , Option "offline" Nothing NoArgument "Don't download packages from the Internet." + , Option "haddock-hoogle" Nothing NoArgument "Generate a hoogle database" + , Option "haddock-html" Nothing NoArgument "Generate HTML documentation (the default)" + , Option "haddock-html-location" Nothing (Argument "URL") "Location of HTML documentation for pre-requisite packages" + , Option "haddock-for-hackage" Nothing NoArgument "Collection of flags to generate documentation suitable for upload to hackage" + , Option "haddock-executables" Nothing NoArgument "Run haddock for Executables targets" + , Option "haddock-tests" Nothing NoArgument "Run haddock for Test Suite targets" + , Option "haddock-benchmarks" Nothing NoArgument "Run haddock for Benchmark targets" + , Option "haddock-all" Nothing NoArgument "Run haddock for all targets" + , Option "haddock-internal" Nothing NoArgument "Run haddock for internal modules and include all symbols" + , Option "haddock-css" Nothing (Argument "PATH") "Use PATH as the haddock stylesheet" + , Option "haddock-hyperlink-source" Nothing NoArgument "Hyperlink the documentation to the source code" + , Option "haddock-quickjump" Nothing NoArgument "Generate an index for interactive documentation navigation" + , Option "haddock-hscolour-css" Nothing (Argument "PATH") "Use PATH as the HsColour stylesheet" + , Option "haddock-contents-location" Nothing (Argument "URL") "Bake URL in as the location for the contents page" + , Option "haddock-base-url" Nothing (Argument "URL") "Base URL for static files." + , Option "haddock-lib" Nothing (Argument "DIR") "location of Haddocks static / auxiliary files" + , Option "haddock-output-dir" Nothing (Argument "DIR") "Generate haddock documentation into this directory. This flag is provided as a technology preview and is subject to change in the next releases." + , Option "test-log" Nothing (Argument "TEMPLATE") "Log all test suite results to file (name template can use $pkgid, $compiler, $os, $arch, $test-suite, $result)" + , Option "test-machine-log" Nothing (Argument "TEMPLATE") "Produce a machine-readable log file (name template can use $pkgid, $compiler, $os, $arch, $result)" + , Option "test-show-details" Nothing (Argument "FILTER") "'always': always show results of individual test cases. 'never': never show results of individual test cases. 'failures': show results of failing test cases. 'streaming': show results of test cases in real time.'direct': send results of test cases in real time; no log file." + , Option "test-keep-tix-files" Nothing NoArgument "keep .tix files for HPC between test runs" + , Option "test-wrapper" Nothing (Argument "FILE") "Run test through a wrapper." + , Option "test-fail-when-no-test-suites" Nothing NoArgument "Exit with failure when no test suites are found." + , Option "test-options" Nothing (Argument "TEMPLATES") "give extra options to test executables (name templates can use $pkgid, $compiler, $os, $arch, $test-suite)" + , Option "test-option" Nothing (Argument "TEMPLATE") "give extra option to test executables (no need to quote options containing spaces, name template can use $pkgid, $compiler, $os, $arch, $test-suite)" + , Option "benchmark-options" Nothing (Argument "TEMPLATES") "give extra options to benchmark executables (name templates can use $pkgid, $compiler, $os, $arch, $benchmark)" + , Option "benchmark-option" Nothing (Argument "TEMPLATE") "give extra option to benchmark executables (no need to quote options containing spaces, name template can use $pkgid, $compiler, $os, $arch, $benchmark)" + , Option "project-dir" Nothing (Argument "DIR") "Set the path of the project directory" + , Option "project-file" Nothing (Argument "FILE") "Set the path of the cabal.project file (relative to the project directory when relative)" + , Option "ignore-project" (Just 'z') NoArgument "Ignore local project configuration (unless --project-dir or --project-file is also set)" + , Option "repl-no-load" Nothing NoArgument "Disable loading of project modules at REPL startup." + , Option "repl-options" Nothing (Argument "FLAG") "Use the option(s) for the repl" + , Option "repl-multi-file" Nothing (Argument "DIR") "Write repl options to this directory rather than starting repl mode" + , Option "build-depends" (Just 'b') (Argument "DEPENDENCIES") "Include additional packages in the environment presented to GHCi." + , Option "no-transitive-deps" Nothing NoArgument "Don't automatically include transitive dependencies of requested packages." + , Option "enable-multi-repl" Nothing NoArgument "Enable multi-component repl sessions" + , Option "disable-multi-repl" Nothing NoArgument "Disable multi-component repl sessions" + , Option "keep-temp-files" Nothing NoArgument "Keep temporary files" + ] diff --git a/src/Imports.hs b/src/Imports.hs --- a/src/Imports.hs +++ b/src/Imports.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} module Imports (module Imports) where import Prelude as Imports @@ -6,5 +7,20 @@ import Control.Monad as Imports import Control.Arrow as Imports +import Data.Char +import System.Exit +import System.Process + pass :: Monad m => m () pass = return () + +strip :: String -> String +strip = reverse . dropWhile isSpace . reverse . dropWhile isSpace + +call :: FilePath -> [FilePath] -> IO () +call name args = rawSystem name args >>= \ case + ExitSuccess -> pass + err -> exitWith err + +exec :: FilePath -> [FilePath] -> IO () +exec name args = rawSystem name args >>= exitWith diff --git a/src/Interpreter.hs b/src/Interpreter.hs --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -18,7 +18,6 @@ import System.Process import System.Directory (getPermissions, executable) import Control.Exception hiding (handle) -import Data.Char import GHC.Paths (ghc) import Language.Haskell.GhciWrapper @@ -78,9 +77,6 @@ firstLine = strip $ head l lastLine = strip $ last l err = Left "unterminated multi-line command" - where - strip :: String -> String - strip = dropWhile isSpace . reverse . dropWhile isSpace . reverse filterXTemplateHaskell :: String -> String filterXTemplateHaskell input = case words input of diff --git a/src/Parse.hs b/src/Parse.hs --- a/src/Parse.hs +++ b/src/Parse.hs @@ -174,8 +174,3 @@ then (0, c : replicate count '.' ++ acc, res) else (0, c : acc, res) finish (count, acc, res) = mkChunk (replicate count '.' ++ acc) ++ res - - --- | Remove leading and trailing whitespace. -strip :: String -> String -strip = dropWhile isSpace . reverse . dropWhile isSpace . reverse diff --git a/src/Run.hs b/src/Run.hs --- a/src/Run.hs +++ b/src/Run.hs @@ -27,7 +27,6 @@ import System.FilePath ((), takeExtension) import System.IO import System.IO.CodePage (withCP65001) -import System.Process (rawSystem) import qualified Control.Exception as E @@ -63,7 +62,7 @@ doctestWithRepl :: (String, [String]) -> [String] -> IO () doctestWithRepl repl args0 = case parseOptions args0 of - Options.ProxyToGhc args -> rawSystem Interpreter.ghc args >>= E.throwIO + Options.ProxyToGhc args -> exec Interpreter.ghc args Options.Output s -> putStr s Options.Result (Run warnings magicMode config) -> do mapM_ (hPutStrLn stderr) warnings diff --git a/test/Cabal/OptionsSpec.hs b/test/Cabal/OptionsSpec.hs --- a/test/Cabal/OptionsSpec.hs +++ b/test/Cabal/OptionsSpec.hs @@ -9,23 +9,20 @@ 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 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 + describe "replOnlyOptions" $ 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) + Set.toList replOnlyOptions `shouldMatchList` Set.toList (repl \\ build) describe "rejectUnsupportedOptions" $ do it "produces error messages that are consistent with 'cabal repl'" $ do @@ -36,65 +33,28 @@ `shouldReturn` "Error: cabal: unrecognized '" <> command <> "' option `--installdir'\n" #ifndef mingw32_HOST_OS - shouldFail "repl" $ rawSystem "cabal" ["repl", "--installdir"] >>= exitWith + shouldFail "repl" $ call "cabal" ["repl", "--installdir"] #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 + 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 [ - "--foo" + "-w", "ghc-9.10" , "--build-depends=foo" , "--build-depends", "foo" , "-bfoo" , "-b", "foo" - , "--bar" + , "--disable-optimization" , "--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 + , "--allow-newer" + ] `shouldBe` ["--with-compiler", "ghc-9.10", "--disable-optimization", "--allow-newer"] diff --git a/test/Cabal/ReplOptionsSpec.hs b/test/Cabal/ReplOptionsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Cabal/ReplOptionsSpec.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ViewPatterns #-} +module Cabal.ReplOptionsSpec (spec, unsupported) where + +import Imports + +import Test.Hspec + +import Data.List +import System.Process +import Data.Set (Set) +import qualified Data.Set as Set + +import Cabal.ReplOptions + +phony :: [String] +phony = [ + "with-PROG" + , "PROG-option" + , "PROG-options" + ] + +undocumented :: Set String +undocumented = Set.fromList [ + "--enable-optimisation" + , "--disable-optimisation" + , "--haddock-hyperlink-sources" + , "--haddock-hyperlinked-source" + ] + +unsupported :: Set String +unsupported = undocumented <> Set.fromList (map ("--" <>) phony) + +spec :: Spec +spec = do + describe "options" $ do + it "is the list of documented 'repl' options" $ do + documentedOptions <- parseOptions <$> readProcess "cabal" ["help", "repl"] "" + options `shouldBe` filter (optionName >>> (`notElem` phony)) documentedOptions + + it "is consistent with 'cabal repl --list-options'" $ do + let + optionNames :: Option -> [String] + optionNames option = reverse $ "--" <> optionName option : case optionShortName option of + Nothing -> [] + Just c -> [['-', c]] + + repl <- filter (`Set.notMember` unsupported) . lines <$> readProcess "cabal" ["repl", "--list-options"] "" + concatMap optionNames options `shouldBe` repl + +parseOptions :: String -> [Option] +parseOptions = map parseOption . takeOptions + where + parseOption :: String -> Option + parseOption input = case input of + longAndHelp@('-':'-':_) -> parseLongOption Nothing longAndHelp + '-':short:',':' ':longAndHelp -> parseLongOption (Just short) longAndHelp + '-':short:'[':(breakOn ']' -> + (_arg, ']':',':' ':longAndHelp)) -> parseLongOption (Just short) longAndHelp + '-':short:' ':(breakOn ' ' -> + (arg, ' ':'o':'r':' ':(stripPrefix ('-':short:arg) -> + Just (',':' ':longAndHelp)))) -> parseLongOption (Just short) longAndHelp + _ -> err + where + parseLongOption :: Maybe Char -> String -> Option + parseLongOption short longAndHelp = case breakOnAny " [=" longAndHelp of + ('-':'-':long, ' ':help) -> accept long NoArgument help + ('-':'-':long, '[':'=': (breakOn ']' -> + (arg, ']':help))) -> accept long (OptionalArgument arg) help + ('-':'-':long, '=':(breakOn ' ' -> + (arg, ' ':help))) -> accept long (Argument arg) help + _ -> err + where + accept :: String -> Argument -> String -> Option + accept long arg help = Option long short arg (strip help) + + err :: HasCallStack => Option + err = error input + + breakOn c = break (== c) + breakOnAny xs = break (`elem` xs) + + takeOptions :: String -> [String] + takeOptions input = map strip . joinLines $ case break (== "Flags for repl:") (lines input) of + (_, "Flags for repl:" : xs) -> case break (== "") xs of + (ys, "" : _) -> ys + _ -> undefined + _ -> undefined + + joinLines :: [String] -> [String] + joinLines = go + where + go = \ case + x : y : ys | isOption y -> x : go (y : ys) + x : y : ys -> go $ (x ++ ' ' : strip y) : ys + x : xs -> x : xs + [] -> [] + + isOption = isPrefixOf " -"