{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}

module Test.DocTest
  ( mainFromCabal
  , mainFromLibrary
  , mainFromCabalWithConfig
  , mainFromLibraryWithConfig

  -- * Internal
  , filterModules
  , isSuccess
  , setSeed
  , run
  ) where

import           Prelude ()
import           Prelude.Compat

import qualified Data.Set as Set
import           Data.List (intercalate)

import           Control.Monad (unless)
import           Control.Monad.Extra (ifM)
import           System.Exit (exitFailure)
import           System.IO
import           System.Random (randomIO)

import qualified Control.Exception as E

import GHC.Utils.Panic

import Test.DocTest.Internal.Options
import Test.DocTest.Internal.Runner
import Test.DocTest.Internal.Nix (getNixGhciArgs)

-- Cabal
import Distribution.Simple
  ( KnownExtension(ImplicitPrelude), Extension (DisableExtension) )

-- me
import Test.DocTest.Helpers
  ( Library (libDefaultExtensions), extractCabalLibrary, findCabalPackage
  , libraryToGhciArgs )
import Test.DocTest.Internal.Logging (LogLevel(..))

import qualified Test.DocTest.Internal.Logging as Logging

-- | Run doctest with given list of arguments.
--
-- Example:
--
-- @
-- mainFromCabal "my-project" =<< getArgs
-- @
--
mainFromCabal :: String -> [String] -> IO ()
mainFromCabal :: [Char] -> [[Char]] -> IO ()
mainFromCabal [Char]
libName [[Char]]
cmdArgs = do
  Library
lib <- [Char] -> IO Library
extractCabalLibrary ([Char] -> IO Library) -> IO [Char] -> IO Library
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< HasCallStack => [Char] -> IO [Char]
[Char] -> IO [Char]
findCabalPackage [Char]
libName
  Library -> [[Char]] -> IO ()
mainFromLibrary Library
lib [[Char]]
cmdArgs

-- | Run doctest given config.
--
-- Example:
--
-- @
-- mainFromCabal "my-project" defaultConfig
-- @
--
mainFromCabalWithConfig :: String -> Config -> IO ()
mainFromCabalWithConfig :: [Char] -> Config -> IO ()
mainFromCabalWithConfig [Char]
libName Config
config = do
  Library
lib <- [Char] -> IO Library
extractCabalLibrary ([Char] -> IO Library) -> IO [Char] -> IO Library
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< HasCallStack => [Char] -> IO [Char]
[Char] -> IO [Char]
findCabalPackage [Char]
libName
  Library -> Config -> IO ()
mainFromLibraryWithConfig Library
lib Config
config

-- | Like 'mainFromCabal', but with a given library.
mainFromLibrary :: Library -> [String] -> IO ()
mainFromLibrary :: Library -> [[Char]] -> IO ()
mainFromLibrary Library
lib ([[Char]] -> Result Config
parseOptions -> Result Config
opts) =
  case Result Config
opts of
    ResultStdout [Char]
s -> [Char] -> IO ()
putStr [Char]
s
    ResultStderr [Char]
s -> do
       Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr ([Char]
"doctest: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
s)
       Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr [Char]
"Try `doctest --help' for more information."
       IO ()
forall a. IO a
exitFailure
    Result Config
config -> do
      Library -> Config -> IO ()
mainFromLibraryWithConfig Library
lib Config
config

-- | Run doctests with given library and config.
mainFromLibraryWithConfig :: Library -> Config -> IO ()
mainFromLibraryWithConfig :: Library -> Config -> IO ()
mainFromLibraryWithConfig Library
lib Config
config = do
  Summary
r <- Library -> Config -> IO Summary
run Library
lib Config
config IO Summary -> (SomeException -> IO Summary) -> IO Summary
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` \SomeException
e -> do
    case SomeException -> Maybe GhcException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
      Just (UsageError [Char]
err) -> do
        Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr ([Char]
"doctest: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
err)
        Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr [Char]
"Try `doctest --help' for more information."
        IO Summary
forall a. IO a
exitFailure
      Maybe GhcException
_ -> SomeException -> IO Summary
forall e a. Exception e => e -> IO a
E.throwIO SomeException
e
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Summary -> Bool
isSuccess Summary
r) IO ()
forall a. IO a
exitFailure

isSuccess :: Summary -> Bool
isSuccess :: Summary -> Bool
isSuccess Summary
s = Summary -> Int
sErrors Summary
s Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
&& Summary -> Int
sFailures Summary
s Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0

-- | 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] -> [ModuleName] -> [ModuleName]
filterModules :: [[Char]] -> [[Char]] -> [[Char]]
filterModules [] [[Char]]
mods = [[Char]]
mods
filterModules [[Char]]
wantedMods0 [[Char]]
allMods0
  | ([Char]
_:[[Char]]
_) <- [[Char]]
nonExistingMods = [Char] -> [[Char]]
forall a. HasCallStack => [Char] -> a
error ([Char]
"Unknown modules specified: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [[Char]] -> [Char]
forall a. Show a => a -> [Char]
show [[Char]]
nonExistingMods)
  | Bool
otherwise = ([Char] -> Bool) -> [[Char]] -> [[Char]]
forall a. (a -> Bool) -> [a] -> [a]
filter [Char] -> Bool
isSpecifiedMod [[Char]]
allMods0
 where
  wantedMods1 :: Set [Char]
wantedMods1 = [[Char]] -> Set [Char]
forall a. Ord a => [a] -> Set a
Set.fromList [[Char]]
wantedMods0
  allMods1 :: Set [Char]
allMods1 = [[Char]] -> Set [Char]
forall a. Ord a => [a] -> Set a
Set.fromList [[Char]]
allMods0

  nonExistingMods :: [[Char]]
nonExistingMods = Set [Char] -> [[Char]]
forall a. Set a -> [a]
Set.toList (Set [Char]
wantedMods1 Set [Char] -> Set [Char] -> Set [Char]
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set [Char]
allMods1)
  isSpecifiedMod :: [Char] -> Bool
isSpecifiedMod [Char]
nm = [Char]
nm [Char] -> Set [Char] -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set [Char]
wantedMods1

setSeed :: (?verbosity :: LogLevel) => ModuleConfig -> IO ModuleConfig
setSeed :: (?verbosity::LogLevel) => ModuleConfig -> IO ModuleConfig
setSeed cfg :: ModuleConfig
cfg@ModuleConfig{cfgRandomizeOrder :: ModuleConfig -> Bool
cfgRandomizeOrder=Bool
True, cfgSeed :: ModuleConfig -> Maybe Int
cfgSeed=Maybe Int
Nothing} = do
  -- Using an absolute number to prevent copy+paste errors
  Int
seed <- Int -> Int
forall a. Num a => a -> a
abs (Int -> Int) -> IO Int -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Int
forall a (m :: * -> *). (Random a, MonadIO m) => m a
randomIO
  (?verbosity::LogLevel) => LogLevel -> [Char] -> IO ()
LogLevel -> [Char] -> IO ()
Logging.log LogLevel
Info ([Char]
"Using freshly generated seed to randomize test order: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show Int
seed)
  ModuleConfig -> IO ModuleConfig
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ModuleConfig
cfg{cfgSeed=Just seed}
setSeed ModuleConfig
cfg = ModuleConfig -> IO ModuleConfig
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ModuleConfig
cfg

-- | Run doctest for given library and config. Produce a summary of all tests.
run :: Library -> Config -> IO Summary
run :: Library -> Config -> IO Summary
run Library
lib Config{Bool
[[Char]]
Maybe Int
LogLevel
ModuleConfig
cfgLogLevel :: LogLevel
cfgModules :: [[Char]]
cfgThreads :: Maybe Int
cfgModuleConfig :: ModuleConfig
cfgNix :: Bool
cfgGhcArgs :: [[Char]]
cfgLogLevel :: Config -> LogLevel
cfgModules :: Config -> [[Char]]
cfgThreads :: Config -> Maybe Int
cfgModuleConfig :: Config -> ModuleConfig
cfgNix :: Config -> Bool
cfgGhcArgs :: Config -> [[Char]]
..} = do
  [[Char]]
nixGhciArgs <- IO Bool -> IO [[Char]] -> IO [[Char]] -> IO [[Char]]
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
cfgNix) IO [[Char]]
getNixGhciArgs ([[Char]] -> IO [[Char]]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [])

  let
    implicitPrelude :: Bool
implicitPrelude = KnownExtension -> Extension
DisableExtension KnownExtension
ImplicitPrelude Extension -> [Extension] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` Library -> [Extension]
libDefaultExtensions Library
lib
    ([[Char]]
includeArgs, [[Char]]
allModules, [[Char]]
otherGhciArgs) = Library -> ([[Char]], [[Char]], [[Char]])
libraryToGhciArgs Library
lib
    evalGhciArgs :: [[Char]]
evalGhciArgs = [[Char]]
otherGhciArgs [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]
"-XNoImplicitPrelude"] [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]]
nixGhciArgs
    parseGhcArgs :: [[Char]]
parseGhcArgs = [[Char]]
includeArgs [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]]
otherGhciArgs [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]]
nixGhciArgs [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]]
cfgGhcArgs

  let
    ?verbosity = ?verbosity::LogLevel
LogLevel
cfgLogLevel

  ModuleConfig
modConfig <- (?verbosity::LogLevel) => ModuleConfig -> IO ModuleConfig
ModuleConfig -> IO ModuleConfig
setSeed ModuleConfig
cfgModuleConfig

  -- Run tests
  (?verbosity::LogLevel) => LogLevel -> [Char] -> IO ()
LogLevel -> [Char] -> IO ()
Logging.log LogLevel
Verbose [Char]
"Running examples.."
  let
    filteredModules :: [[Char]]
filteredModules = [[Char]] -> [[Char]] -> [[Char]]
filterModules [[Char]]
cfgModules [[Char]]
allModules
    filteredModulesMsg :: [Char]
filteredModulesMsg = [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", " [[Char]]
filteredModules
  (?verbosity::LogLevel) => LogLevel -> [Char] -> IO ()
LogLevel -> [Char] -> IO ()
Logging.log LogLevel
Debug ([Char]
"Running examples in modules: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
filteredModulesMsg)
  (?verbosity::LogLevel) =>
ModuleConfig
-> Maybe Int
-> Bool
-> [[Char]]
-> [[Char]]
-> [[Char]]
-> IO Summary
ModuleConfig
-> Maybe Int
-> Bool
-> [[Char]]
-> [[Char]]
-> [[Char]]
-> IO Summary
runModules ModuleConfig
modConfig Maybe Int
cfgThreads Bool
implicitPrelude [[Char]]
parseGhcArgs [[Char]]
evalGhciArgs [[Char]]
filteredModules