diff --git a/CHANGES.markdown b/CHANGES.markdown --- a/CHANGES.markdown +++ b/CHANGES.markdown @@ -1,4 +1,11 @@ +# 0.4 + * Account for `default-language` sections in Cabal files ([#85](https://github.com/martijnbastiaan/doctest-parallel/issues/85)) + * Add support for Cabal 3.14 ([#88](https://github.com/martijnbastiaan/doctest-parallel/pull/88)) + * Add parallel parsing on Linux/macOS. The GHC API is now used to call the parser directly, which allows parallel parsing. On Windows, files will be parsed sequentially still due to the GHC API locking files. ([#85](https://github.com/martijnbastiaan/doctest-parallel/issues/89)) + * Drop support for GHC < 9 + # 0.3.1.1 + * Add support for GHC 9.12 (loosened bounds in Hackage revision) * Add support for GHC 9.10 # 0.3.1 diff --git a/cabal.project b/cabal.project --- a/cabal.project +++ b/cabal.project @@ -5,10 +5,5 @@ tests: true -source-repository-package - type: git - location: https://github.com/haskell-unordered-containers/unordered-containers.git - tag: d52a0fd10bfa701cbbc9d7ac06bd7eb7664b3972 - -allow-newer: - unordered-containers:template-haskell +package doctest-parallel + ghc-options: +RTS -qn4 -A128M -RTS -j4 diff --git a/doctest-parallel.cabal b/doctest-parallel.cabal --- a/doctest-parallel.cabal +++ b/doctest-parallel.cabal @@ -1,7 +1,7 @@ cabal-version: 2.0 name: doctest-parallel -version: 0.3.1.1 +version: 0.4 synopsis: Test interactive Haskell examples description: The doctest program checks examples in source code comments. It is modeled after doctest for Python (). @@ -17,16 +17,13 @@ maintainer: Martijn Bastiaan build-type: Simple tested-with: - GHC == 8.4.4 - , GHC == 8.6.5 - , GHC == 8.8.4 - , GHC == 8.10.7 - , GHC == 9.0.2 + GHC == 9.0.2 , GHC == 9.2.8 - , GHC == 9.4.7 - , GHC == 9.6.3 - , GHC == 9.8.1 - , GHC == 9.10.1 + , GHC == 9.4.8 + , GHC == 9.6.7 + , GHC == 9.8.4 + , GHC == 9.10.2 + , GHC == 9.12.2 extra-source-files: example/example.cabal @@ -93,7 +90,7 @@ Data.List.Extra Paths_doctest_parallel build-depends: - Cabal >= 2.4 && < 3.11 + Cabal >= 2.4 && < 3.15 , Glob , base >=4.10 && <5 , base-compat >=0.7.0 @@ -103,7 +100,8 @@ , directory , exceptions , filepath - , ghc >=8.2 && <9.11 + , ghc >=9.0 && <9.13 + , ghc-exactprint , ghc-paths >=0.1.0.9 , process , random >= 1.2 @@ -186,6 +184,7 @@ MainSpec OptionsSpec ParseSpec + ProjectsSpec PropertySpec Runner.ExampleSpec RunnerSpec diff --git a/src/Data/List/Extra.hs b/src/Data/List/Extra.hs --- a/src/Data/List/Extra.hs +++ b/src/Data/List/Extra.hs @@ -1,4 +1,4 @@ -module Data.List.Extra (trim) where +module Data.List.Extra (trim, splitOn) where import Data.Char (isSpace) import Data.List (dropWhileEnd) @@ -19,3 +19,21 @@ -- | Remove spaces from the end of a string, see 'trim'. trimEnd :: String -> String trimEnd = dropWhileEnd isSpace + +-- TODO: Use doctests after fixing: https://github.com/martijnbastiaan/doctest-parallel/issues/87 + +-- | Break a list into pieces separated by the first argument, consuming the delimiter. +-- +-- > splitOn '.' "A.B" +-- ["A","B"] +-- > splitOn '.' "A.B.C" +-- ["A","B","C"] +-- > splitOn '.' "." +-- ["",""] +-- > splitOn '.' "" +-- [""] +splitOn :: Eq a => a -> [a] -> [[a]] +splitOn needle haystack = + case break (== needle) haystack of + (chunk, []) -> [chunk] + (chunk, _ : rest) -> chunk : splitOn needle rest diff --git a/src/Test/DocTest.hs b/src/Test/DocTest.hs --- a/src/Test/DocTest.hs +++ b/src/Test/DocTest.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} @@ -31,13 +30,8 @@ import qualified Control.Exception as E -#if __GLASGOW_HASKELL__ < 900 -import Panic -#else import GHC.Utils.Panic -#endif -import Test.DocTest.Internal.Parse import Test.DocTest.Internal.Options import Test.DocTest.Internal.Runner import Test.DocTest.Internal.Nix (getNixGhciArgs) @@ -110,17 +104,17 @@ -- | Filter modules to be tested against a list of modules to be tested (specified -- by the user on the command line). If list is empty, test all modules. Throws -- and error if a non-existing module was specified. -filterModules :: [ModuleName] -> [Module a] -> [Module a] +filterModules :: [ModuleName] -> [ModuleName] -> [ModuleName] filterModules [] mods = mods filterModules wantedMods0 allMods0 | (_:_) <- nonExistingMods = error ("Unknown modules specified: " <> show nonExistingMods) | otherwise = filter isSpecifiedMod allMods0 where wantedMods1 = Set.fromList wantedMods0 - allMods1 = Set.fromList (map moduleName allMods0) + allMods1 = Set.fromList allMods0 nonExistingMods = Set.toList (wantedMods1 `Set.difference` allMods1) - isSpecifiedMod Module{moduleName} = moduleName `Set.member` wantedMods1 + isSpecifiedMod nm = nm `Set.member` wantedMods1 setSeed :: (?verbosity :: LogLevel) => ModuleConfig -> IO ModuleConfig setSeed cfg@ModuleConfig{cfgRandomizeOrder=True, cfgSeed=Nothing} = do @@ -137,24 +131,19 @@ let implicitPrelude = DisableExtension ImplicitPrelude `notElem` libDefaultExtensions lib - (includeArgs, moduleArgs, otherGhciArgs) = libraryToGhciArgs lib + (includeArgs, allModules, otherGhciArgs) = libraryToGhciArgs lib evalGhciArgs = otherGhciArgs ++ ["-XNoImplicitPrelude"] ++ nixGhciArgs - parseGhcArgs = includeArgs ++ moduleArgs ++ otherGhciArgs ++ nixGhciArgs ++ cfgGhcArgs + parseGhcArgs = includeArgs ++ otherGhciArgs ++ nixGhciArgs ++ cfgGhcArgs let ?verbosity = cfgLogLevel modConfig <- setSeed cfgModuleConfig - -- Get examples from Haddock comments - Logging.log Verbose "Parsing comments.." - Logging.log Debug ("Calling GHC API with: " <> unwords parseGhcArgs) - allModules <- getDocTests parseGhcArgs - -- Run tests Logging.log Verbose "Running examples.." let filteredModules = filterModules cfgModules allModules - filteredModulesMsg = intercalate ", " (map moduleName filteredModules) + filteredModulesMsg = intercalate ", " filteredModules Logging.log Debug ("Running examples in modules: " <> filteredModulesMsg) - runModules modConfig cfgThreads implicitPrelude evalGhciArgs filteredModules + runModules modConfig cfgThreads implicitPrelude parseGhcArgs evalGhciArgs filteredModules diff --git a/src/Test/DocTest/Helpers.hs b/src/Test/DocTest/Helpers.hs --- a/src/Test/DocTest/Helpers.hs +++ b/src/Test/DocTest/Helpers.hs @@ -9,27 +9,25 @@ import GHC.Stack (HasCallStack) +import Data.Maybe (maybeToList) import System.Directory ( canonicalizePath, doesFileExist ) import System.FilePath ((), isDrive, takeDirectory) import System.FilePath.Glob (glob) import System.Info (compilerVersion) -#if __GLASGOW_HASKELL__ < 804 -import Data.Monoid ((<>)) -#endif - import qualified Data.Set as Set -- Cabal import Distribution.ModuleName (ModuleName) import Distribution.Simple - ( Extension (DisableExtension, EnableExtension, UnknownExtension) ) + ( Extension (DisableExtension, EnableExtension, UnknownExtension), Language (..) ) import Distribution.Types.UnqualComponentName ( unUnqualComponentName ) import Distribution.PackageDescription ( GenericPackageDescription (condLibrary) , exposedModules, libBuildInfo, hsSourceDirs, defaultExtensions, package - , packageDescription, condSubLibraries, includeDirs, autogenModules, ConfVar(..) ) + , packageDescription, condSubLibraries, includeDirs, autogenModules, ConfVar(..) + , defaultLanguage, BuildInfo (otherModules) ) import Distribution.Compiler (CompilerFlavor(GHC)) import Distribution.Pretty (prettyShow) @@ -46,7 +44,9 @@ import Distribution.PackageDescription.Parsec (readGenericPackageDescription) #endif -#if MIN_VERSION_Cabal(3,6,0) +#if MIN_VERSION_Cabal(3,14,0) +import Distribution.Utils.Path (SymbolicPath, makeSymbolicPath) +#elif MIN_VERSION_Cabal(3,6,0) import Distribution.Utils.Path (SourceDir, PackageDir, SymbolicPath) #endif @@ -69,27 +69,36 @@ -- ^ Exposed modules , libDefaultExtensions :: [Extension] -- ^ Extensions enabled by default + , libDefaultLanguages :: [Language] + -- ^ Language version(s) to enable } deriving (Show) -- | Merge multiple libraries into one, by concatenating all their fields. mergeLibraries :: [Library] -> Library mergeLibraries libs = Library + -- XXX: Why do we merge libraries? Shouldn't we always aim to parse ONE library? { libSourceDirectories = concatMap libSourceDirectories libs , libCSourceDirectories = concatMap libCSourceDirectories libs , libModules = concatMap libModules libs , libDefaultExtensions = concatMap libDefaultExtensions libs + , libDefaultLanguages = concatMap libDefaultLanguages libs } -- | Convert a "Library" to arguments suitable to be passed to GHCi. libraryToGhciArgs :: Library -> ([String], [String], [String]) -libraryToGhciArgs Library{..} = (hsSrcArgs <> cSrcArgs, modArgs, extArgs) +libraryToGhciArgs Library{..} = (hsSrcArgs <> cSrcArgs, modArgs, extArgs <> langArgs) where hsSrcArgs = map ("-i" <>) libSourceDirectories cSrcArgs = map ("-I" <>) libCSourceDirectories modArgs = map prettyShow libModules extArgs = map showExt libDefaultExtensions + langArgs = map showLanguage libDefaultLanguages + showLanguage = \case + UnknownLanguage ul -> "-X" <> ul + l -> "-X" <> show l + showExt = \case EnableExtension ext -> "-X" <> show ext DisableExtension ext -> "-XNo" <> show ext @@ -145,7 +154,10 @@ packageFilename = packageName <> ".cabal" projectFilename = "cabal.project" -#if MIN_VERSION_Cabal(3,6,0) +#if MIN_VERSION_Cabal(3,14,0) +compatPrettyShow :: SymbolicPath a b -> FilePath +compatPrettyShow = prettyShow +#elif MIN_VERSION_Cabal(3,6,0) compatPrettyShow :: SymbolicPath PackageDir SourceDir -> FilePath compatPrettyShow = prettyShow #else @@ -199,7 +211,15 @@ -- a specific sublibrary. extractSpecificCabalLibrary :: Maybe String -> FilePath -> IO Library extractSpecificCabalLibrary maybeLibName pkgPath = do - pkg <- readGenericPackageDescription silent pkgPath + pkg <- + readGenericPackageDescription + silent +#if MIN_VERSION_Cabal(3,14,0) + Nothing + (makeSymbolicPath pkgPath) +#else + pkgPath +#endif case maybeLibName of Nothing -> case condLibrary pkg of @@ -227,11 +247,17 @@ goLib lib = Library { libSourceDirectories = map ((root ) . compatPrettyShow) sourceDirs - , libCSourceDirectories = map (root ) cSourceDirs - , libModules = exposedModules lib `rmList` autogenModules buildInfo + , libCSourceDirectories = map ((root )) +#if MIN_VERSION_Cabal(3,14,0) + $ map compatPrettyShow +#endif + cSourceDirs + , libModules = modules `rmList` autogenModules buildInfo , libDefaultExtensions = defaultExtensions buildInfo + , libDefaultLanguages = maybeToList (defaultLanguage buildInfo) } where + modules = otherModules buildInfo <> exposedModules lib buildInfo = libBuildInfo lib sourceDirs = hsSourceDirs buildInfo cSourceDirs = includeDirs buildInfo diff --git a/src/Test/DocTest/Internal/Extract.hs b/src/Test/DocTest/Internal/Extract.hs --- a/src/Test/DocTest/Internal/Extract.hs +++ b/src/Test/DocTest/Internal/Extract.hs @@ -8,46 +8,36 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} -module Test.DocTest.Internal.Extract (Module(..), extract, eraseConfigLocation) where - +module Test.DocTest.Internal.Extract + ( Module(..) + , isEmptyModule + , extract + , extractIO + , eraseConfigLocation + ) where import Prelude hiding (mod, concat) +import Control.DeepSeq (NFData, deepseq) +import Control.Exception (AsyncException, throw, throwIO, fromException) import Control.Monad -import Control.Exception +import Control.Monad.Catch (catches, SomeException, Exception, Handler (Handler)) +import Data.Generics (Data, extQ, mkQ, everythingBut) import Data.List (partition, isPrefixOf) -import Data.List.Extra (trim) +import Data.List.Extra (trim, splitOn) import Data.Maybe - -import Control.DeepSeq (NFData, deepseq) -import Data.Generics (Data, Typeable, extQ, mkQ, everythingBut) +import GHC.Generics (Generic) -import qualified GHC +#if __GLASGOW_HASKELL__ < 912 +import Data.Generics (Typeable) +#endif -#if __GLASGOW_HASKELL__ < 900 -import GHC hiding (Module, Located, moduleName) -import DynFlags -import MonadUtils (liftIO) -#else -import GHC hiding (Module, Located, moduleName) +import GHC hiding (Module, Located, moduleName, parsedSource) import GHC.Driver.Session import GHC.Utils.Monad (liftIO) -#endif -#if __GLASGOW_HASKELL__ < 900 -import Digraph (flattenSCCs) -import Exception (ExceptionMonad) -#else -import GHC.Data.Graph.Directed (flattenSCCs) -import GHC.Utils.Exception (ExceptionMonad) -import Control.Monad.Catch (generalBracket) -#endif - import System.Directory import System.FilePath -#if __GLASGOW_HASKELL__ < 900 -import BasicTypes (SourceText(SourceText)) -import FastString (unpackFS) -#elif __GLASGOW_HASKELL__ < 902 +#if __GLASGOW_HASKELL__ < 902 import GHC.Data.FastString (unpackFS) import GHC.Types.Basic (SourceText(SourceText)) #elif __GLASGOW_HASKELL__ < 906 @@ -57,30 +47,39 @@ import GHC.Data.FastString (unpackFS) #endif -import System.Posix.Internals (c_getpid) - import Test.DocTest.Internal.GhcUtil (withGhc) import Test.DocTest.Internal.Location hiding (unLoc) import Test.DocTest.Internal.Util (convertDosLineEndings) -#if __GLASGOW_HASKELL__ >= 806 -#if __GLASGOW_HASKELL__ < 900 -import DynamicLoading (initializePlugins) +#if MIN_VERSION_ghc_exactprint(1,3,0) +import Language.Haskell.GHC.ExactPrint.Parsers (parseModuleEpAnnsWithCppInternal, defaultCppOptions) #else -import GHC.Runtime.Loader (initializePlugins) -#endif +import Language.Haskell.GHC.ExactPrint.Parsers (parseModuleApiAnnsWithCppInternal, defaultCppOptions) #endif -#if __GLASGOW_HASKELL__ >= 901 -import GHC.Unit.Module.Graph +#if __GLASGOW_HASKELL__ < 902 +import GHC.Driver.Types (throwErrors) +import GHC.Parser.Header (getOptionsFromFile) +#elif __GLASGOW_HASKELL__ < 904 +import GHC.Types.SourceError (throwErrors) +import GHC.Parser.Header (getOptionsFromFile) +#else +import GHC.Types.SourceError (throwErrors) +import GHC.Parser.Header (getOptionsFromFile) +import GHC.Driver.Config.Parser (initParserOpts) #endif -import GHC.Generics (Generic) +#if __GLASGOW_HASKELL__ < 904 +initParserOpts :: DynFlags -> DynFlags +initParserOpts = id +#endif -- | A wrapper around `SomeException`, to allow for a custom `Show` instance. newtype ExtractError = ExtractError SomeException +#if __GLASGOW_HASKELL__ < 912 deriving Typeable +#endif instance Show ExtractError where show (ExtractError e) = @@ -100,6 +99,24 @@ instance Exception ExtractError +data ModuleNotFoundError = ModuleNotFoundError String [FilePath] + deriving ( +#if __GLASGOW_HASKELL__ < 912 + Typeable, +#endif + Exception + ) + +instance Show ModuleNotFoundError where + show (ModuleNotFoundError modName incdirs) = + unlines [ + "Module not found: " ++ modName + , "" + , "Tried the following include directories:" + , "" + , unlines incdirs + ] + -- | Documentation for a module grouped together with the modules name. data Module a = Module { moduleName :: String @@ -108,117 +125,100 @@ , moduleConfig :: [Located String] } deriving (Eq, Functor, Show, Generic, NFData) +isEmptyModule :: Module a -> Bool +isEmptyModule (Module _ setup tests _) = null tests && isNothing setup + eraseConfigLocation :: Module a -> Module a eraseConfigLocation m@Module{moduleConfig} = m{moduleConfig=map go moduleConfig} where go (Located _ a) = noLocation a -#if __GLASGOW_HASKELL__ < 803 -type GhcPs = RdrName -#endif - -#if __GLASGOW_HASKELL__ < 805 -addQuoteInclude :: [String] -> [String] -> [String] -addQuoteInclude includes new = new ++ includes -#endif +moduleParts :: String -> [String] +moduleParts = splitOn '.' --- | Parse a list of modules. -parse :: [String] -> IO [ParsedModule] -parse args = withGhc args $ \modules -> withTempOutputDir $ do - setTargets =<< forM modules (\ m -> guessTarget m -#if __GLASGOW_HASKELL__ >= 903 - Nothing -#endif - Nothing) - mods <- depanal [] False +findModulePath :: [FilePath] -> String -> IO FilePath +findModulePath importPaths modName = do + let + modPath = foldl1 () (moduleParts modName) <.> "hs" - let sortedMods = flattenSCCs -#if __GLASGOW_HASKELL__ >= 901 - $ filterToposortToModules -#endif - $ topSortModuleGraph False mods Nothing - reverse <$> mapM (loadModPlugins >=> parseModule) sortedMods + found <- fmap catMaybes $ forM importPaths $ \importPath -> do + let fullPath = importPath modPath + exists <- doesFileExist fullPath + return $ if exists then Just fullPath else Nothing - where - -- copied from Haddock/GhcUtils.hs - modifySessionDynFlags :: (DynFlags -> DynFlags) -> Ghc () - modifySessionDynFlags f = do - dflags <- getSessionDynFlags - let dflags' = case lookup "GHC Dynamic" (compilerInfo dflags) of - Just "YES" -> gopt_set dflags Opt_BuildDynamicToo - _ -> dflags - _ <- setSessionDynFlags (f dflags') - return () + case found of + [] -> throwIO (ModuleNotFoundError modName importPaths) + (p:_) -> pure p - withTempOutputDir :: Ghc a -> Ghc a - withTempOutputDir action = do - tmp <- liftIO getTemporaryDirectory - x <- liftIO c_getpid - let dir = tmp ".doctest-" ++ show x - modifySessionDynFlags (setOutputDir dir) - gbracket_ - (liftIO $ createDirectory dir) - (liftIO $ removeDirectoryRecursive dir) - action +-- | Parse a list of modules. Can throw an `ModuleNotFoundError` if a module's +-- source file cannot be found. Can throw a `SourceError` if an error occurs +-- while parsing. +parse :: String -> Ghc ParsedSource +parse modName = do + -- Find all specified modules on disk + importPaths0 <- importPaths <$> getDynFlags + path <- liftIO $ findModulePath importPaths0 modName - -- | A variant of 'gbracket' where the return value from the first computation - -- is not required. - gbracket_ :: ExceptionMonad m => m a -> m b -> m c -> m c -#if __GLASGOW_HASKELL__ < 900 - gbracket_ before_ after thing = gbracket before_ (const after) (const thing) + -- LANGUAGE pragmas can influence how a file is parsed. For example, CPP + -- means we need to preprocess the file before parsing it. We use GHC's + -- `getOptionsFromFile` to parse these pragmas and then feed them as options + -- to the "real" parser. + dynFlags0 <- getDynFlags +#if __GLASGOW_HASKELL__ < 904 + flagsFromFile <- #else - gbracket_ before_ after thing = fst <$> generalBracket before_ (\ _ _ -> after) (const thing) + (_, flagsFromFile) <- #endif - - setOutputDir f d = d { - objectDir = Just f - , hiDir = Just f - , stubDir = Just f - , includePaths = addQuoteInclude (includePaths d) [f] - } - + liftIO $ getOptionsFromFile (initParserOpts dynFlags0) path + (dynFlags1, _, _) <- parseDynamicFilePragma dynFlags0 flagsFromFile -#if __GLASGOW_HASKELL__ >= 806 - -- Since GHC 8.6, plugins are initialized on a per module basis - loadModPlugins modsum = do - _ <- setSessionDynFlags (GHC.ms_hspp_opts modsum) - hsc_env <- getSession +#if MIN_VERSION_ghc_exactprint(1,3,0) + result <- parseModuleEpAnnsWithCppInternal defaultCppOptions dynFlags1 path +#else + result <- parseModuleApiAnnsWithCppInternal defaultCppOptions dynFlags1 path +#endif -# if __GLASGOW_HASKELL__ >= 901 - hsc_env' <- liftIO (initializePlugins hsc_env) - setSession hsc_env' - return $ modsum -# else - dynflags' <- liftIO (initializePlugins hsc_env (GHC.ms_hspp_opts modsum)) - return $ modsum { ms_hspp_opts = dynflags' } -# endif + case result of + Left errs -> throwErrors errs +#if MIN_VERSION_ghc_exactprint(1,3,0) + Right (_cppComments, _dynFlags, parsedSource) -> pure parsedSource #else - loadModPlugins = return + Right (_apiAnns, _cppComments, _dynFlags, parsedSource) -> pure parsedSource #endif +-- | Like `extract`, but runs in the `IO` monad given GHC parse arguments. +extractIO :: [String] -> String -> IO (Module (Located String)) +extractIO parseArgs modName = withGhc parseArgs $ extract modName + -- | Extract all docstrings from given list of files/modules. -- -- This includes the docstrings of all local modules that are imported from -- those modules (possibly indirect). -extract :: [String] -> IO [Module (Located String)] -extract args = do - mods <- parse args - let docs = map (fmap (fmap convertDosLineEndings) . extractFromModule) mods +-- +-- Can throw `ExtractError` if an error occurs while extracting the docstrings, +-- or a `SourceError` if an error occurs while parsing the module. Can throw a +-- `ModuleNotFoundError` if a module's source file cannot be found. +extract :: String -> Ghc (Module (Located String)) +extract modName = do + mod <- parse modName + let + docs0 = extractFromModule modName mod + docs1 = fmap convertDosLineEndings <$> docs0 - (docs `deepseq` return docs) `catches` [ + (docs1 `deepseq` return docs1) `catches` [ -- Re-throw AsyncException, otherwise execution will not terminate on -- SIGINT (ctrl-c). All AsyncExceptions are re-thrown (not just -- UserInterrupt) because all of them indicate severe conditions and -- should not occur during normal operation. Handler (\e -> throw (e :: AsyncException)) - , Handler (throwIO . ExtractError) + , Handler (liftIO . throwIO . ExtractError) ] -- | Extract all docstrings from given module and attach the modules name. -extractFromModule :: ParsedModule -> Module (Located String) -extractFromModule m = Module - { moduleName = name +extractFromModule :: String -> ParsedSource -> Module (Located String) +extractFromModule modName m = Module + { moduleName = modName , moduleSetup = listToMaybe (map snd setup) , moduleContent = map snd docs , moduleConfig = moduleAnnsFromModule m @@ -226,10 +226,9 @@ where isSetup = (== Just "setup") . fst (setup, docs) = partition isSetup (docStringsFromModule m) - name = (moduleNameString . GHC.moduleName . ms_mod . pm_mod_summary) m -- | Extract all module annotations from given module. -moduleAnnsFromModule :: ParsedModule -> [Located String] +moduleAnnsFromModule :: ParsedSource -> [Located String] moduleAnnsFromModule mod = [fmap stripOptionString ann | ann <- anns, isOption ann] where @@ -237,10 +236,10 @@ isOption (Located _ s) = optionPrefix `isPrefixOf` s stripOptionString s = trim (drop (length optionPrefix) s) anns = extractModuleAnns source - source = (unLoc . pm_parsed_source) mod + source = unLoc mod -- | Extract all docstrings from given module. -docStringsFromModule :: ParsedModule -> [(Maybe String, Located String)] +docStringsFromModule :: ParsedSource -> [(Maybe String, Located String)] docStringsFromModule mod = #if __GLASGOW_HASKELL__ < 904 map (fmap (toLocated . fmap unpackHDS)) docs @@ -248,7 +247,7 @@ map (fmap (toLocated . fmap renderHsDocString)) docs #endif where - source = (unLoc . pm_parsed_source) mod + source = unLoc mod -- we use dlist-style concatenation here docs :: [(Maybe String, LHsDocString)] @@ -268,11 +267,7 @@ exports :: [(Maybe String, LHsDocString)] exports = [ (Nothing, L (locA loc) doc) -#if __GLASGOW_HASKELL__ < 710 - | L loc (IEDoc doc) <- concat (hsmodExports source) -#elif __GLASGOW_HASKELL__ < 805 - | L loc (IEDoc doc) <- maybe [] unLoc (hsmodExports source) -#elif __GLASGOW_HASKELL__ < 904 +#if __GLASGOW_HASKELL__ < 904 | L loc (IEDoc _ doc) <- maybe [] unLoc (hsmodExports source) #else | L loc (IEDoc _ (unLoc . fmap hsDocString -> doc)) <- maybe [] unLoc (hsmodExports source) @@ -303,9 +298,7 @@ where fromLHsDecl :: AnnSelector (LHsDecl GhcPs) fromLHsDecl (L (locA -> loc) decl) = case decl of -#if __GLASGOW_HASKELL__ < 805 - AnnD (HsAnnotation (SourceText _) ModuleAnnProvenance (L _loc expr)) -#elif __GLASGOW_HASKELL__ < 906 +#if __GLASGOW_HASKELL__ < 906 AnnD _ (HsAnnotation _ (SourceText _) ModuleAnnProvenance (L _loc expr)) #else AnnD _ (HsAnnotation _ ModuleAnnProvenance (L _loc expr)) @@ -320,13 +313,6 @@ extractLit :: SrcSpan -> HsExpr GhcPs -> Maybe (Located String) extractLit loc = \case -- well this is a holy mess innit -#if __GLASGOW_HASKELL__ < 805 - HsPar (L l e) -> extractLit l e - ExprWithTySig (L l e) _ -> extractLit l e - HsOverLit OverLit{ol_val=HsIsString _ s} -> Just (toLocated (L loc (unpackFS s))) - HsLit (HsString _ s) -> Just (toLocated (L loc (unpackFS s))) - _ -> Nothing -#else #if __GLASGOW_HASKELL__ < 904 HsPar _ (L l e) -> extractLit (locA l) e #elif __GLASGOW_HASKELL__ < 909 @@ -334,15 +320,10 @@ #else HsPar _ (L l e) -> extractLit (locA l) e #endif -#if __GLASGOW_HASKELL__ < 807 - ExprWithTySig _ (L l e) -> extractLit l e -#else ExprWithTySig _ (L l e) _ -> extractLit (locA l) e -#endif HsOverLit _ OverLit{ol_val=HsIsString _ s} -> Just (toLocated (L loc (unpackFS s))) HsLit _ (HsString _ s) -> Just (toLocated (L loc (unpackFS s))) _ -> Nothing -#endif -- | Extract all docstrings from given value. extractDocStrings :: Either (HsDecl GhcPs) [LHsDecl GhcPs] -> [(Maybe String, LHsDocString)] @@ -364,12 +345,7 @@ -- Top-level documentation has to be treated separately, because it has -- no location information attached. The location information is -- attached to HsDecl instead. -#if __GLASGOW_HASKELL__ < 805 - DocD x -#else - DocD _ x -#endif - -> select (fromDocDecl (locA loc) x) + DocD _ x -> select (fromDocDecl (locA loc) x) _ -> (extractDocStrings (Left decl), True) @@ -404,12 +380,6 @@ #else DocCommentNamed name doc -> (Just name, hsDocString <$> doc) _ -> (Nothing, L loc $ hsDocString $ unLoc $ docDeclDoc x) -#endif - -#if __GLASGOW_HASKELL__ < 805 --- | Convert a docstring to a plain string. -unpackHDS :: HsDocString -> String -unpackHDS (HsDocString s) = unpackFS s #endif #if __GLASGOW_HASKELL__ < 901 diff --git a/src/Test/DocTest/Internal/GhcUtil.hs b/src/Test/DocTest/Internal/GhcUtil.hs --- a/src/Test/DocTest/Internal/GhcUtil.hs +++ b/src/Test/DocTest/Internal/GhcUtil.hs @@ -3,44 +3,23 @@ import GHC.Paths (libdir) import GHC -#if __GLASGOW_HASKELL__ < 900 -import DynFlags (gopt_set) -#else import GHC.Driver.Session (gopt_set) -#endif -#if __GLASGOW_HASKELL__ < 900 -import Panic (throwGhcException) -#else import GHC.Utils.Panic (throwGhcException) -#endif -#if __GLASGOW_HASKELL__ < 900 -import MonadUtils (liftIO) -#else -import GHC.Utils.Monad (liftIO) -#endif - -import System.Exit (exitFailure) - --- Catch GHC source errors, print them and exit. -handleSrcErrors :: Ghc a -> Ghc a -handleSrcErrors action' = flip handleSourceError action' $ \err -> do - printException err - liftIO exitFailure - -- | Run a GHC action in Haddock mode -withGhc :: [String] -> ([String] -> Ghc a) -> IO a +withGhc :: [String] -> Ghc a -> IO a withGhc flags action = do flags_ <- handleStaticFlags flags runGhc (Just libdir) $ do - handleDynamicFlags flags_ >>= handleSrcErrors . action + handleDynamicFlags flags_ + action handleStaticFlags :: [String] -> IO [Located String] handleStaticFlags flags = return $ map noLoc $ flags -handleDynamicFlags :: GhcMonad m => [Located String] -> m [String] +handleDynamicFlags :: GhcMonad m => [Located String] -> m () handleDynamicFlags flags = do #if __GLASGOW_HASKELL__ >= 901 logger <- getLogger @@ -58,7 +37,7 @@ unknown_opts = [ f | f@('-':_) <- srcs ] case unknown_opts of opt : _ -> throwGhcException (UsageError ("unrecognized option `"++ opt ++ "'")) - _ -> return srcs + _ -> return () setHaddockMode :: DynFlags -> DynFlags setHaddockMode dynflags = (gopt_set dynflags Opt_Haddock) { diff --git a/src/Test/DocTest/Internal/GhciWrapper.hs b/src/Test/DocTest/Internal/GhciWrapper.hs --- a/src/Test/DocTest/Internal/GhciWrapper.hs +++ b/src/Test/DocTest/Internal/GhciWrapper.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE MultiWayIf #-} @@ -144,12 +143,6 @@ let xs = stripMarker line echo xs return xs -#if __GLASGOW_HASKELL__ < 810 - -- For some (happy) reason newer GHCs don't decide to print this - -- message - or at least we don't see it. - | "Loaded package environment from " `isPrefixOf` line -> do - go -#endif | otherwise -> do echo (line ++ "\n") result <- go diff --git a/src/Test/DocTest/Internal/Interpreter.hs b/src/Test/DocTest/Internal/Interpreter.hs --- a/src/Test/DocTest/Internal/Interpreter.hs +++ b/src/Test/DocTest/Internal/Interpreter.hs @@ -84,10 +84,8 @@ let args = flags ++ [ "--interactive" -#if __GLASGOW_HASKELL__ >= 802 , "-fdiagnostics-color=never" , "-fno-diagnostics-show-caret" -#endif ] bracket (new logger defaultConfig{configGhci = ghc} args) close action diff --git a/src/Test/DocTest/Internal/Location.hs b/src/Test/DocTest/Internal/Location.hs --- a/src/Test/DocTest/Internal/Location.hs +++ b/src/Test/DocTest/Internal/Location.hs @@ -1,17 +1,11 @@ -{-# LANGUAGE CPP, DeriveFunctor #-} +{-# LANGUAGE DeriveFunctor #-} module Test.DocTest.Internal.Location where import Control.DeepSeq (deepseq, NFData(rnf)) -#if __GLASGOW_HASKELL__ < 900 -import SrcLoc hiding (Located) -import qualified SrcLoc as GHC -import FastString (unpackFS) -#else import GHC.Types.SrcLoc hiding (Located) import qualified GHC.Types.SrcLoc as GHC import GHC.Data.FastString (unpackFS) -#endif -- | A thing with a location attached. data Located a = Located Location a @@ -57,12 +51,6 @@ -- | Convert a GHC source span to a location. toLocation :: SrcSpan -> Location -#if __GLASGOW_HASKELL__ < 900 toLocation loc = case loc of - UnhelpfulSpan str -> UnhelpfulLocation (unpackFS str) - RealSrcSpan sp -> Location (unpackFS . srcSpanFile $ sp) (srcSpanStartLine sp) -#else -toLocation loc = case loc of UnhelpfulSpan str -> UnhelpfulLocation (unpackFS $ unhelpfulSpanFS str) RealSrcSpan sp _ -> Location (unpackFS . srcSpanFile $ sp) (srcSpanStartLine sp) -#endif diff --git a/src/Test/DocTest/Internal/Logging.hs b/src/Test/DocTest/Internal/Logging.hs --- a/src/Test/DocTest/Internal/Logging.hs +++ b/src/Test/DocTest/Internal/Logging.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ImplicitParams #-} @@ -10,10 +11,20 @@ import Control.DeepSeq (NFData) import Data.Char (toLower, toUpper) import Data.List (intercalate) +import Data.Maybe (fromMaybe) import GHC.Generics (Generic) import System.IO (hPutStrLn, stderr) import Text.Printf (printf) +#if MIN_VERSION_base(4,18,0) +import GHC.Conc.Sync (threadLabel) +#endif + +#if !MIN_VERSION_base(4,18,0) +threadLabel :: ThreadId -> IO (Maybe String) +threadLabel _ = pure Nothing +#endif + -- | Convenience type alias - not used in this module, but sprinkled across the -- project. type DebugLogger = String -> IO () @@ -85,22 +96,22 @@ justifyLeft :: Int -> a -> [a] -> [a] justifyLeft n c s = s ++ replicate (n - length s) c +-- | Pretty name for a 'ThreadId'. Uses 'threadLabel' if available, otherwise +-- falls back to 'show'. +getThreadName :: ThreadId -> IO String +getThreadName threadId = fromMaybe (show threadId) <$> threadLabel threadId + -- | /Prettily/ format a log message -- -- > threadId <- myThreadId --- > formatLog Debug threadId "some debug message" +-- > formatLog Debug (show threadId) "some debug message" -- "[DEBUG ] [ThreadId 1277462] some debug message" -- -formatLog :: ThreadId -> LogLevel -> String -> String -formatLog threadId lvl msg = do +formatLog :: String -> LogLevel -> String -> String +formatLog nm lvl msg = intercalate "\n" (map go (lines msg)) where - go line = - printf - "[%s] [%s] %s" - (map toUpper (showJustifiedLogLevel lvl)) - (show threadId) - line + go = printf "[%s] [%s] %s" (map toUpper (showJustifiedLogLevel lvl)) nm -- | Like 'formatLog', but instantiates the /thread/ argument with the current 'ThreadId' -- @@ -109,8 +120,8 @@ -- formatLogHere :: LogLevel -> String -> IO String formatLogHere lvl msg = do - threadId <- myThreadId - pure (formatLog threadId lvl msg) + threadName <- getThreadName =<< myThreadId + pure (formatLog threadName lvl msg) -- | Should a message be printed? For a given verbosity level and message log level. shouldLog :: (?verbosity :: LogLevel) => LogLevel -> Bool diff --git a/src/Test/DocTest/Internal/Nix.hs b/src/Test/DocTest/Internal/Nix.hs --- a/src/Test/DocTest/Internal/Nix.hs +++ b/src/Test/DocTest/Internal/Nix.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} module Test.DocTest.Internal.Nix where @@ -16,22 +15,8 @@ import System.FilePath ((), isDrive, takeDirectory) import System.Process (readProcess) -#if __GLASGOW_HASKELL__ >= 900 import GHC.Data.Maybe (liftMaybeT) import System.Info (fullCompilerVersion) -#else -import Maybes (liftMaybeT) -import System.Info (compilerVersion) - -fullCompilerVersion :: Version -fullCompilerVersion = - case compilerVersion of - Version majorMinor tags -> - Version (majorMinor ++ [lvl1]) tags - where - lvl1 :: Int - lvl1 = __GLASGOW_HASKELL_PATCHLEVEL1__ -#endif -- | E.g. @9.0.2@ compilerVersionStr :: String diff --git a/src/Test/DocTest/Internal/Options.hs b/src/Test/DocTest/Internal/Options.hs --- a/src/Test/DocTest/Internal/Options.hs +++ b/src/Test/DocTest/Internal/Options.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} @@ -17,11 +16,7 @@ import qualified Paths_doctest_parallel import Data.Version (showVersion) -#if __GLASGOW_HASKELL__ < 900 -import Config as GHC -#else import GHC.Settings.Config as GHC -#endif import Test.DocTest.Internal.Location (Located (Located), Location) import Test.DocTest.Internal.Interpreter (ghc) diff --git a/src/Test/DocTest/Internal/Parse.hs b/src/Test/DocTest/Internal/Parse.hs --- a/src/Test/DocTest/Internal/Parse.hs +++ b/src/Test/DocTest/Internal/Parse.hs @@ -1,6 +1,5 @@ {-# LANGUAGE PatternGuards #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE CPP #-} module Test.DocTest.Internal.Parse ( Module (..) @@ -11,6 +10,7 @@ , ExpectedLine (..) , LineChunk (..) , getDocTests +, getDocTestsIO -- * exported for testing , parseInteractions @@ -24,7 +24,9 @@ import Data.String import Test.DocTest.Internal.Extract +import Test.DocTest.Internal.GhcUtil (withGhc) import Test.DocTest.Internal.Location +import GHC (Ghc) data DocTest = Example Expression ExpectedResult | Property Expression @@ -47,17 +49,13 @@ type Interaction = (Expression, ExpectedResult) - --- | --- Extract 'DocTest's from all given modules and all modules included by the --- given modules. -getDocTests :: [String] -> IO [Module [Located DocTest]] -- ^ Extracted 'DocTest's -getDocTests args = parseModules <$> extract args +-- | Extract 'DocTest's from given module +getDocTestsIO :: [String] -> String -> IO (Module [Located DocTest]) +getDocTestsIO parseArgs mod_ = withGhc parseArgs $ parseModule <$> extract mod_ -parseModules :: [Module (Located String)] -> [Module [Located DocTest]] -parseModules = filter (not . isEmpty) . map parseModule - where - isEmpty (Module _ setup tests _) = null tests && isNothing setup +-- | Extract 'DocTest's from given module +getDocTests :: String -> Ghc (Module [Located DocTest]) +getDocTests mod_ = parseModule <$> extract mod_ -- | Convert documentation to `Example`s. parseModule :: Module (Located String) -> Module [Located DocTest] diff --git a/src/Test/DocTest/Internal/Property.hs b/src/Test/DocTest/Internal/Property.hs --- a/src/Test/DocTest/Internal/Property.hs +++ b/src/Test/DocTest/Internal/Property.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE PatternGuards #-} module Test.DocTest.Internal.Property where diff --git a/src/Test/DocTest/Internal/Runner.hs b/src/Test/DocTest/Internal/Runner.hs --- a/src/Test/DocTest/Internal/Runner.hs +++ b/src/Test/DocTest/Internal/Runner.hs @@ -7,9 +7,10 @@ import Prelude hiding (putStr, putStrLn, error) -import Control.Concurrent (Chan, writeChan, readChan, newChan, forkIO, ThreadId, myThreadId) -import Control.Exception (SomeException, catch) +import Control.Concurrent (Chan, writeChan, readChan, newChan, forkIO, ThreadId, myThreadId, MVar, newMVar) +import Control.Exception (SomeException, AsyncException, throw) import Control.Monad hiding (forM_) +import Control.Monad.Catch (catches, Handler (Handler)) import Data.Foldable (forM_) import Data.Function (on) import Data.List (sortBy) @@ -30,14 +31,18 @@ , cfgRandomizeOrder, cfgImplicitModuleImport, parseLocatedModuleOptions) import Test.DocTest.Internal.Location import qualified Test.DocTest.Internal.Property as Property +import Test.DocTest.Internal.Extract (isEmptyModule) +import Test.DocTest.Internal.GhcUtil (withGhc) +import Test.DocTest.Internal.Logging (LogLevel (..), formatLog, shouldLog, getThreadName) import Test.DocTest.Internal.Runner.Example -import Test.DocTest.Internal.Logging (LogLevel (..), formatLog, shouldLog) import System.IO.CodePage (withCP65001) -import Control.Monad.Extra (whenM) +import Control.Monad.Extra (whenM) +import GHC (Ghc) -#if __GLASGOW_HASKELL__ < 804 -import Data.Semigroup +#ifdef mingw32_HOST_OS +import Control.Concurrent.MVar (putMVar, takeMVar) +import Control.Monad.Catch (finally) #endif -- | Whether an "example" is part of setup block @@ -63,9 +68,6 @@ -- | Sum up summaries. instance Monoid Summary where mempty = Summary 0 0 0 0 -#if __GLASGOW_HASKELL__ < 804 - mappend = (<>) -#endif instance Semigroup Summary where (<>) (Summary x1 x2 x3 x4) (Summary y1 y2 y3 y4) = @@ -81,29 +83,32 @@ -> Bool -- ^ Implicit Prelude -> [String] + -- ^ Arguments passed to the GHC for parsing + -> [String] -- ^ Arguments passed to the GHCi process. - -> [Module [Located DocTest]] + -> [ModuleName] -- ^ Modules under test -> IO Summary -runModules modConfig nThreads implicitPrelude args modules = do +runModules modConfig nThreads implicitPrelude parseArgs evalArgs modules = do isInteractive <- hIsTerminalDevice stderr + ghcLock <- newMVar () -- Start a thread pool. It sends status updates to this thread through 'output'. nCores <- getNumProcessors (input, output) <- makeThreadPool (fromMaybe nCores nThreads) - (runModule modConfig implicitPrelude args) + parseArgs + (runModule modConfig implicitPrelude ghcLock evalArgs) -- Send instructions to threads liftIO (mapM_ (writeChan input) modules) let - nExamples = (sum . map count) modules initState = ReportState { reportStateCount = 0 , reportStateInteractive = isInteractive - , reportStateSummary = mempty{sExamples=nExamples} + , reportStateSummary = mempty } threadId <- myThreadId @@ -126,7 +131,7 @@ let ?threadId = threadId consumeUpdates output =<< case update of - UpdateInternalError fs loc e -> reportInternalError fs loc e >> pure (modsLeft - 1) + UpdateInternalError modName e -> reportInternalError modName e >> pure (modsLeft - 1) UpdateImportError modName result -> reportImportError modName result >> pure (modsLeft - 1) UpdateSuccess fs -> reportSuccess fs >> reportProgress >> pure modsLeft UpdateFailure fs loc expr errs -> reportFailure fs loc expr errs >> pure modsLeft @@ -134,6 +139,7 @@ UpdateOptionError loc err -> reportOptionError loc err >> pure modsLeft UpdateModuleDone -> pure (modsLeft - 1) UpdateLog lvl msg -> report lvl msg >> pure modsLeft + UpdateModuleParsed modName nExamples -> reportModuleParsed modName nExamples >> pure modsLeft -- | Count number of expressions in given module. count :: Module [Located DocTest] -> Int @@ -158,7 +164,8 @@ Report () report lvl msg0 = when (shouldLog lvl) $ do - let msg1 = formatLog ?threadId lvl msg0 + threadName <- liftIO $ getThreadName ?threadId + let msg1 = formatLog threadName lvl msg0 overwrite msg1 -- add a newline, this makes the output permanent @@ -195,95 +202,107 @@ runModule :: ModuleConfig -> Bool + -> MVar () + -- ^ GHC lock -> [String] + -- ^ Eval GHCi arguments -> Chan (ThreadId, ReportUpdate) - -> Module [Located DocTest] - -> IO () -runModule modConfig0 implicitPrelude ghciArgs output mod_ = do - threadId <- myThreadId + -> ModuleName + -> Ghc () +runModule modConfig0 implicitPrelude ghcLock evalArgs output modName = do + threadId <- liftIO myThreadId let update r = writeChan output (threadId, r) - case modConfig2 of - Left (loc, flag) -> - update (UpdateOptionError loc flag) + mod_@(Module module_ setup examples0 modArgs) <- do +#ifdef mingw32_HOST_OS + -- XXX: Cannot use multiple GHC APIs at the same time on Windows + liftIO $ takeMVar ghcLock + getDocTests modName `finally` liftIO (putMVar ghcLock ()) +#else + ghcLock `seq` getDocTests modName +#endif - Right modConfig3 -> do - let - examples1 - | cfgRandomizeOrder modConfig3 = shuffle seed examples0 - | otherwise = examples0 + liftIO $ update (UpdateModuleParsed modName (count (Module module_ setup examples0 modArgs))) + let modConfig2 = parseLocatedModuleOptions modName modConfig0 modArgs - importModule - | cfgImplicitModuleImport modConfig3 = Just (":m +" ++ module_) - | otherwise = Nothing + unless (isEmptyModule mod_) $ + case modConfig2 of + Left (loc, flag) -> + liftIO $ update (UpdateOptionError loc flag) - preserveIt = cfgPreserveIt modConfig3 - seed = fromMaybe 0 (cfgSeed modConfig3) -- Should have been set already + Right modConfig3 -> do + let + examples1 + | cfgRandomizeOrder modConfig3 = shuffle seed examples0 + | otherwise = examples0 - reload repl = do - void $ Interpreter.safeEval repl ":reload" - mapM_ (Interpreter.safeEval repl) $ - if implicitPrelude - then ":m Prelude" : maybeToList importModule - else maybeToList importModule + importModule + | cfgImplicitModuleImport modConfig3 = Just (":m +" ++ module_) + | otherwise = Nothing - when preserveIt $ - -- Evaluate a dumb expression to populate the 'it' variable NOTE: This is - -- one reason why we cannot have safeEval = safeEvalIt: 'it' isn't set in - -- a fresh GHCi session. - void $ Interpreter.safeEval repl $ "()" + preserveIt = cfgPreserveIt modConfig3 + seed = fromMaybe 0 (cfgSeed modConfig3) -- Should have been set already - setup_ repl = do - reload repl - forM_ setup $ \l -> forM_ l $ \(Located _ x) -> case x of - Property _ -> return () - Example e _ -> void $ safeEvalWith preserveIt repl e + reload repl = do + void $ Interpreter.safeEval repl ":reload" + mapM_ (Interpreter.safeEval repl) $ + if implicitPrelude + then ":m Prelude" : maybeToList importModule + else maybeToList importModule + when preserveIt $ + -- Evaluate a dumb expression to populate the 'it' variable NOTE: This is + -- one reason why we cannot have safeEval = safeEvalIt: 'it' isn't set in + -- a fresh GHCi session. + void $ Interpreter.safeEval repl $ "()" - let logger = update . UpdateLog Debug - Interpreter.withInterpreter logger ghciArgs $ \repl -> withCP65001 $ do - -- Try to import this module, if it fails, something is off - importResult <- - case importModule of - Nothing -> pure (Right "") - Just i -> Interpreter.safeEval repl i + setup_ repl = do + reload repl + forM_ setup $ \l -> forM_ l $ \(Located _ x) -> case x of + Property _ -> return () + Example e _ -> void $ safeEvalWith preserveIt repl e - case importResult of - Right "" -> do - -- Run setup group - successes <- - mapM - (runTestGroup FromSetup preserveIt repl (reload repl) update) - setup - -- only run tests, if setup does not produce any errors/failures - when - (and successes) - (mapM_ - (runTestGroup NotFromSetup preserveIt repl (setup_ repl) update) - examples1) - _ -> - update (UpdateImportError module_ importResult) + let logger = update . UpdateLog Debug + liftIO $ Interpreter.withInterpreter logger evalArgs $ \repl -> withCP65001 $ do + -- Try to import this module, if it fails, something is off + importResult <- + case importModule of + Nothing -> pure (Right "") + Just i -> Interpreter.safeEval repl i - -- Signal main thread a module has been tested - update UpdateModuleDone + case importResult of + Right "" -> do + -- Run setup group + successes <- + mapM + (runTestGroup FromSetup preserveIt repl (reload repl) update) + setup - pure () + -- only run tests, if setup does not produce any errors/failures + when + (and successes) + (mapM_ + (runTestGroup NotFromSetup preserveIt repl (setup_ repl) update) + examples1) + _ -> + update (UpdateImportError module_ importResult) - where - Module module_ setup examples0 modArgs = mod_ - modConfig2 = parseLocatedModuleOptions module_ modConfig0 modArgs + -- Signal main thread a module has been tested + liftIO $ update UpdateModuleDone data ReportUpdate = UpdateSuccess FromSetup -- ^ Test succeeded + | UpdateModuleParsed ModuleName Int + -- ^ Parsed module, found /n/ examples | UpdateFailure FromSetup Location Expression [String] -- ^ Test failed with unexpected result | UpdateError FromSetup Location Expression String -- ^ Test failed with an error | UpdateModuleDone -- ^ All examples tested in module - | UpdateInternalError FromSetup (Module [Located DocTest]) SomeException + | UpdateInternalError ModuleName SomeException -- ^ Exception caught while executing internal code | UpdateImportError ModuleName (Either String String) -- ^ Could not import module @@ -294,20 +313,33 @@ makeThreadPool :: Int -> - (Chan (ThreadId, ReportUpdate) -> Module [Located DocTest] -> IO ()) -> - IO (Chan (Module [Located DocTest]), Chan (ThreadId, ReportUpdate)) -makeThreadPool nThreads mutator = do + [String] -> + (Chan (ThreadId, ReportUpdate) -> ModuleName -> Ghc ()) -> + IO (Chan ModuleName, Chan (ThreadId, ReportUpdate)) +makeThreadPool nThreads parseArgs mutator = do input <- newChan output <- newChan forM_ [1..nThreads] $ \_ -> - forkIO $ forever $ do - i <- readChan input - threadId <- myThreadId - catch - (mutator output i) - (\e -> writeChan output (threadId, UpdateInternalError NotFromSetup i e)) + forkIO $ withGhc parseArgs $ forever $ do + modName <- liftIO $ readChan input + threadId <- liftIO myThreadId + let update e = liftIO $ writeChan output (threadId, UpdateInternalError modName e) + catches + (mutator output modName) + -- Re-throw AsyncException, otherwise execution will not terminate on + -- SIGINT (ctrl-c). All AsyncExceptions are re-thrown (not just + -- UserInterrupt) because all of them indicate severe conditions and + -- should not occur during normal operation. + [ Handler (\e -> throw (e :: AsyncException)) + , Handler (\e -> update (e :: SomeException)) + ] return (input, output) +reportModuleParsed :: (?verbosity::LogLevel, ?threadId::ThreadId) => ModuleName -> Int -> Report () +reportModuleParsed modName nExamples = do + report Debug (printf "Parsed module %s with %d examples" modName nExamples) + updateSummary NotFromSetup (Summary nExamples 0 0 0) + reportFailure :: (?verbosity::LogLevel, ?threadId::ThreadId) => FromSetup -> Location -> Expression -> [String] -> Report () reportFailure fromSetup loc expression err = do report Error (printf "%s: failure in expression `%s'" (show loc) expression) @@ -328,12 +360,12 @@ report Error "" updateSummary FromSetup (Summary 0 1 1 0) -reportInternalError :: (?verbosity::LogLevel, ?threadId::ThreadId) => FromSetup -> Module a -> SomeException -> Report () -reportInternalError fs mod_ err = do - report Error (printf "Internal error when executing tests in %s" (moduleName mod_)) +reportInternalError :: (?verbosity::LogLevel, ?threadId::ThreadId) => ModuleName -> SomeException -> Report () +reportInternalError modName err = do + report Error (printf "Error when executing tests in %s" modName) report Error (show err) report Error "" - updateSummary fs emptySummary{sErrors=1} + updateSummary NotFromSetup emptySummary{sErrors=1} reportImportError :: (?verbosity::LogLevel, ?threadId::ThreadId) => ModuleName -> Either String String -> Report () reportImportError modName importResult = do diff --git a/test/ExtractSpec.hs b/test/ExtractSpec.hs --- a/test/ExtractSpec.hs +++ b/test/ExtractSpec.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} @@ -7,22 +6,17 @@ import Test.Hspec import Test.HUnit - -#if __GLASGOW_HASKELL__ < 900 -import Panic (GhcException (..)) -#else import GHC.Utils.Panic (GhcException (..)) -#endif import Test.DocTest.Internal.Extract import Test.DocTest.Internal.Location import System.FilePath -shouldGive :: HasCallStack => (String, String) -> [Module String] -> Assertion +shouldGive :: HasCallStack => (String, String) -> Module String -> Assertion (d, m) `shouldGive` expected = do - r <- map (fmap unLoc) `fmap` extract ["-i" ++ dir, dir m] - map eraseConfigLocation r `shouldBe` map eraseConfigLocation expected + r <- fmap unLoc `fmap` extractIO ["-i" ++ dir] m + eraseConfigLocation r `shouldBe` eraseConfigLocation expected where dir = "test/extract" d @@ -35,83 +29,83 @@ describe "extract" $ do it "extracts documentation for a top-level declaration" $ do - ("declaration", "Foo.hs") `shouldGive` [mod_ "Foo" [" Some documentation"]] + ("declaration", "Foo") `shouldGive` mod_ "Foo" [" Some documentation"] it "extracts documentation from argument list" $ do - ("argument-list", "Foo.hs") `shouldGive` [mod_ "Foo" [" doc for arg1", " doc for arg2"]] + ("argument-list", "Foo") `shouldGive` mod_ "Foo" [" doc for arg1", " doc for arg2"] it "extracts documentation for a type class function" $ do - ("type-class", "Foo.hs") `shouldGive` [mod_ "Foo" [" Convert given value to a string."]] + ("type-class", "Foo") `shouldGive` mod_ "Foo" [" Convert given value to a string."] it "extracts documentation from the argument list of a type class function" $ do - ("type-class-args", "Foo.hs") `shouldGive` [mod_ "Foo" [" foo", " bar"]] + ("type-class-args", "Foo") `shouldGive` mod_ "Foo" [" foo", " bar"] it "extracts documentation from the module header" $ do - ("module-header", "Foo.hs") `shouldGive` [mod_ "Foo" [" Some documentation"]] + ("module-header", "Foo") `shouldGive` mod_ "Foo" [" Some documentation"] - it "extracts documentation from imported modules" $ do - ("imported-module", "Bar.hs") `shouldGive` [mod_ "Bar" [" documentation for bar"], mod_ "Baz" [" documentation for baz"]] + it "does not extract documentation from imported modules" $ do + ("imported-module", "Bar") `shouldGive` mod_ "Bar" [" documentation for bar"] it "extracts documentation from export list" $ do - ("export-list", "Foo.hs") `shouldGive` [mod_ "Foo" [" documentation from export list"]] + ("export-list", "Foo") `shouldGive` mod_ "Foo" [" documentation from export list"] it "extracts documentation from named chunks" $ do - ("named-chunks", "Foo.hs") `shouldGive` [mod_ "Foo" [" named chunk foo", "\n named chunk bar"]] + ("named-chunks", "Foo") `shouldGive` mod_ "Foo" [" named chunk foo", "\n named chunk bar"] it "returns docstrings in the same order they appear in the source" $ do - ("comment-order", "Foo.hs") `shouldGive` [mod_ "Foo" [" module header", " export list 1", " export list 2", " foo", " named chunk", " bar"]] + ("comment-order", "Foo") `shouldGive` mod_ "Foo" [" module header", " export list 1", " export list 2", " foo", " named chunk", " bar"] it "extracts $setup code" $ do - ("setup", "Foo.hs") `shouldGive` [(mod_ "Foo" [" foo", " bar", " baz"]){moduleSetup=Just "\n some setup code"}] + ("setup", "Foo") `shouldGive` (mod_ "Foo" [" foo", " bar", " baz"]){moduleSetup=Just "\n some setup code"} it "fails on invalid flags" $ do - extract ["--foobar", "test/Foo.hs"] `shouldThrow` (\e -> case e of UsageError "unrecognized option `--foobar'" -> True; _ -> False) + extractIO ["--foobar"] "test/Foo.hs" `shouldThrow` (\e -> case e of UsageError "unrecognized option `--foobar'" -> True; _ -> False) describe "extract (regression tests)" $ do it "works with infix operators" $ do - ("regression", "Fixity.hs") `shouldGive` [mod_ "Fixity" []] + ("regression", "Fixity") `shouldGive` mod_ "Fixity" [] it "works with parallel list comprehensions" $ do - ("regression", "ParallelListComp.hs") `shouldGive` [mod_ "ParallelListComp" []] + ("regression", "ParallelListComp") `shouldGive` mod_ "ParallelListComp" [] it "works with list comprehensions in instance definitions" $ do - ("regression", "ParallelListCompClass.hs") `shouldGive` [mod_ "ParallelListCompClass" []] + ("regression", "ParallelListCompClass") `shouldGive` mod_ "ParallelListCompClass" [] it "works with foreign imports" $ do - ("regression", "ForeignImport.hs") `shouldGive` [mod_ "ForeignImport" []] + ("regression", "ForeignImport") `shouldGive` mod_ "ForeignImport" [] it "works for rewrite rules" $ do - ("regression", "RewriteRules.hs") `shouldGive` [mod_ "RewriteRules" [" doc for foo"]] + ("regression", "RewriteRules") `shouldGive` mod_ "RewriteRules" [" doc for foo"] it "works for rewrite rules with type signatures" $ do - ("regression", "RewriteRulesWithSigs.hs") `shouldGive` [mod_ "RewriteRulesWithSigs" [" doc for foo"]] + ("regression", "RewriteRulesWithSigs") `shouldGive` mod_ "RewriteRulesWithSigs" [" doc for foo"] it "strips CR from dos line endings" $ do - ("dos-line-endings", "Foo.hs") `shouldGive` [mod_ "Foo" ["\n foo\n bar\n baz"]] + ("dos-line-endings", "Foo") `shouldGive` mod_ "Foo" ["\n foo\n bar\n baz"] it "works with a module that splices in an expression from an other module" $ do - ("th", "Foo.hs") `shouldGive` [mod_ "Foo" [" some documentation"], mod_ "Bar" []] + ("th", "Foo") `shouldGive` mod_ "Foo" [" some documentation"] it "works for type families and GHC 7.6.1" $ do - ("type-families", "Foo.hs") `shouldGive` [mod_ "Foo" []] + ("type-families", "Foo") `shouldGive` mod_ "Foo" [] it "ignores binder annotations" $ do - ("module-options", "Binders.hs") `shouldGive` [mod_ "Binders" []] + ("module-options", "Binders") `shouldGive` mod_ "Binders" [] it "ignores module annotations that don't start with 'doctest-parallel:'" $ do - ("module-options", "NoOptions.hs") `shouldGive` [mod_ "NoOptions" []] + ("module-options", "NoOptions") `shouldGive` mod_ "NoOptions" [] it "detects monomorphic module settings" $ do - ("module-options", "Mono.hs") `shouldGive` [(mod_ "Mono" []){moduleConfig= + ("module-options", "Mono") `shouldGive` (mod_ "Mono" []){moduleConfig= [ noLocation "--no-randomize-error1" , noLocation "--no-randomize-error2" , noLocation "--no-randomize-error3" , noLocation "--no-randomize-error4" , noLocation "--no-randomize-error5" , noLocation "--no-randomize-error6" - ]}] + ]} it "detects polypormphic module settings" $ do - ("module-options", "Poly.hs") `shouldGive` [(mod_ "Poly" []){moduleConfig= + ("module-options", "Poly") `shouldGive` (mod_ "Poly" []){moduleConfig= [ noLocation "--no-randomize-error" - ]}] + ]} diff --git a/test/GhciWrapperSpec.hs b/test/GhciWrapperSpec.hs --- a/test/GhciWrapperSpec.hs +++ b/test/GhciWrapperSpec.hs @@ -1,12 +1,10 @@ -{-# LANGUAGE CPP #-} - module GhciWrapperSpec (main, spec) where import Test.Hspec import System.IO.Silently import Control.Exception -import Data.List (isInfixOf) +import Data.List (isInfixOf, isPrefixOf) import Test.DocTest.Internal.GhciWrapper (Interpreter, Config(..), defaultConfig) import qualified Test.DocTest.Internal.GhciWrapper as Interpreter @@ -75,18 +73,15 @@ it "shows exceptions" $ withInterpreter $ \ghci -> do ghci "import Control.Exception" `shouldReturn` "" - ghci "throwIO DivideByZero" `shouldReturn` "*** Exception: divide by zero\n" + res <- ghci "throwIO DivideByZero" + res `shouldSatisfy` isPrefixOf "*** Exception: divide by zero\n" it "shows exceptions (ExitCode)" $ withInterpreter $ \ghci -> do ghci "import System.Exit" `shouldReturn` "" ghci "exitWith $ ExitFailure 10" `shouldReturn` "*** Exception: ExitFailure 10\n" it "gives an error message for identifiers that are not in scope" $ withInterpreter $ \ghci -> do -#if __GLASGOW_HASKELL__ >= 800 ghci "foo" >>= (`shouldSatisfy` isInfixOf "Variable not in scope: foo") -#else - ghci "foo" >>= (`shouldSatisfy` isSuffixOf "Not in scope: \8216foo\8217\n") -#endif context "when configVerbose is True" $ do it "prints prompt" $ do withInterpreterConfig defaultConfig{configVerbose = True} $ \ghci -> do diff --git a/test/LocationSpec.hs b/test/LocationSpec.hs --- a/test/LocationSpec.hs +++ b/test/LocationSpec.hs @@ -1,18 +1,11 @@ -{-# LANGUAGE CPP #-} - module LocationSpec (main, spec) where import Test.Hspec import Test.DocTest.Internal.Location -#if __GLASGOW_HASKELL__ < 900 -import SrcLoc -import FastString (fsLit) -#else import GHC.Types.SrcLoc import GHC.Data.FastString (fsLit) -#endif main :: IO () main = hspec spec diff --git a/test/MainSpec.hs b/test/MainSpec.hs --- a/test/MainSpec.hs +++ b/test/MainSpec.hs @@ -1,9 +1,8 @@ {-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiWayIf #-} -module MainSpec (main, spec) where +module MainSpec where import Test.Hspec import Test.HUnit (assertEqual, Assertion) diff --git a/test/ParseSpec.hs b/test/ParseSpec.hs --- a/test/ParseSpec.hs +++ b/test/ParseSpec.hs @@ -8,6 +8,7 @@ import Test.DocTest.Internal.Parse import Test.DocTest.Internal.Location +import Test.DocTest.Internal.Extract (isEmptyModule) main :: IO () main = hspec spec @@ -24,14 +25,14 @@ module_ :: String -> Writer [[DocTest]] () -> Writer [Module [DocTest]] () module_ name gs = tell [Module name Nothing (execWriter gs) []] -shouldGive :: IO [Module [Located DocTest]] -> Writer [Module [DocTest]] () -> Expectation -shouldGive action expected = map (fmap $ map unLoc) `fmap` action `shouldReturn` execWriter expected +shouldGive :: IO (Module [Located DocTest]) -> Writer [Module [DocTest]] () -> Expectation +shouldGive action expected = map (fmap $ map unLoc) `fmap` fmap pure action `shouldReturn` execWriter expected spec :: Spec spec = do - describe "getDocTests" $ do + describe "getDocTestsIO" $ do it "extracts properties from a module" $ do - getDocTests ["test/parse/property/Fib.hs"] `shouldGive` do + getDocTestsIO ["-itest/parse/property"] "Fib" `shouldGive` do module_ "Fib" $ do group $ do prop_ "foo" @@ -39,7 +40,7 @@ prop_ "baz" it "extracts examples from a module" $ do - getDocTests ["test/parse/simple/Fib.hs"] `shouldGive` do + getDocTestsIO ["-itest/parse/simple"] "Fib" `shouldGive` do module_ "Fib" $ do group $ do ghci "putStrLn \"foo\"" @@ -50,7 +51,7 @@ "baz" it "extracts examples from documentation for non-exported names" $ do - getDocTests ["test/parse/non-exported/Fib.hs"] `shouldGive` do + getDocTestsIO ["-itest/parse/non-exported"] "Fib" `shouldGive` do module_ "Fib" $ do group $ do ghci "putStrLn \"foo\"" @@ -61,7 +62,7 @@ "baz" it "extracts multiple examples from a module" $ do - getDocTests ["test/parse/multiple-examples/Foo.hs"] `shouldGive` do + getDocTestsIO ["-itest/parse/multiple-examples"] "Foo" `shouldGive` do module_ "Foo" $ do group $ do ghci "foo" @@ -71,17 +72,17 @@ "42" it "returns an empty list, if documentation contains no examples" $ do - getDocTests ["test/parse/no-examples/Fib.hs"] >>= (`shouldBe` []) + getDocTestsIO ["-itest/parse/no-examples"] "Fib" >>= (`shouldSatisfy` isEmptyModule) it "sets setup code to Nothing, if it does not contain any tests" $ do - getDocTests ["test/parse/setup-empty/Foo.hs"] `shouldGive` do + getDocTestsIO ["-itest/parse/setup-empty"] "Foo" `shouldGive` do module_ "Foo" $ do group $ do ghci "foo" "23" it "keeps modules that only contain setup code" $ do - getDocTests ["test/parse/setup-only/Foo.hs"] `shouldGive` do + getDocTestsIO ["-itest/parse/setup-only"] "Foo" `shouldGive` do tell [Module "Foo" (Just [Example "foo" ["23"]]) [] []] describe "parseInteractions (an internal function)" $ do diff --git a/test/ProjectsSpec.hs b/test/ProjectsSpec.hs new file mode 100644 --- /dev/null +++ b/test/ProjectsSpec.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE MultiWayIf #-} + +module ProjectsSpec (main, spec) where + +import Test.Hspec +import System.Environment (getEnvironment) +import System.Process (readCreateProcess, proc) + +import qualified Data.Map as Map + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + env <- Map.fromList <$> runIO getEnvironment + + let + -- Only test with cabal + cDescribe = + if + | "STACK_EXE" `Map.member` env -> xdescribe + | "NIX_BUILD_TOP" `Map.member` env -> xdescribe + | otherwise -> describe + + cDescribe "T85-default-language" $ do + it "cabal run doctests" $ do + _ <- readCreateProcess (proc "cabal" ["run", "-v0", "--", "doctests", "--quiet"]) "" + pure () diff --git a/test/RunSpec.hs b/test/RunSpec.hs --- a/test/RunSpec.hs +++ b/test/RunSpec.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} module RunSpec (main, spec) where import Prelude () diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -9,6 +9,7 @@ import qualified MainSpec import qualified OptionsSpec import qualified ParseSpec +import qualified ProjectsSpec import qualified PropertySpec import qualified RunnerSpec import qualified RunSpec @@ -26,6 +27,7 @@ describe "MainSpec" MainSpec.spec describe "OptionsSpec" OptionsSpec.spec describe "ParseSpec" ParseSpec.spec + describe "ProjectsSpec" ProjectsSpec.spec describe "PropertySpec" PropertySpec.spec describe "RunnerSpec" RunnerSpec.spec describe "RunSpec" RunSpec.spec