{-# LANGUAGE CPP #-}
{-# 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

#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)

-- 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 :: String -> [String] -> IO ()
mainFromCabal String
libName [String]
cmdArgs = do
  Library
lib <- String -> IO Library
extractCabalLibrary (String -> IO Library) -> IO String -> IO Library
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< HasCallStack => String -> IO String
String -> IO String
findCabalPackage String
libName
  Library -> [String] -> IO ()
mainFromLibrary Library
lib [String]
cmdArgs

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

-- | Like 'mainFromCabal', but with a given library.
mainFromLibrary :: Library -> [String] -> IO ()
mainFromLibrary :: Library -> [String] -> IO ()
mainFromLibrary Library
lib ([String] -> Result Config
parseOptions -> Result Config
opts) =
  case Result Config
opts of
    ResultStdout String
s -> String -> IO ()
putStr String
s
    ResultStderr String
s -> do
       Handle -> String -> IO ()
hPutStrLn Handle
stderr (String
"doctest: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s)
       Handle -> String -> IO ()
hPutStrLn Handle
stderr String
"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 String
err) -> do
        Handle -> String -> IO ()
hPutStrLn Handle
stderr (String
"doctest: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err)
        Handle -> String -> IO ()
hPutStrLn Handle
stderr String
"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] -> [Module a] -> [Module a]
filterModules :: forall a. [String] -> [Module a] -> [Module a]
filterModules [] [Module a]
mods = [Module a]
mods
filterModules [String]
wantedMods0 [Module a]
allMods0
  | (String
_:[String]
_) <- [String]
nonExistingMods = String -> [Module a]
forall a. HasCallStack => String -> a
error (String
"Unknown modules specified: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [String] -> String
forall a. Show a => a -> String
show [String]
nonExistingMods)
  | Bool
otherwise = (Module a -> Bool) -> [Module a] -> [Module a]
forall a. (a -> Bool) -> [a] -> [a]
filter Module a -> Bool
forall {a}. Module a -> Bool
isSpecifiedMod [Module a]
allMods0
 where
  wantedMods1 :: Set String
wantedMods1 = [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList [String]
wantedMods0
  allMods1 :: Set String
allMods1 = [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList ((Module a -> String) -> [Module a] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Module a -> String
forall a. Module a -> String
moduleName [Module a]
allMods0)

  nonExistingMods :: [String]
nonExistingMods = Set String -> [String]
forall a. Set a -> [a]
Set.toList (Set String
wantedMods1 Set String -> Set String -> Set String
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set String
allMods1)
  isSpecifiedMod :: Module a -> Bool
isSpecifiedMod Module{String
moduleName :: forall a. Module a -> String
moduleName :: String
moduleName} = String
moduleName String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
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 -> String -> IO ()
LogLevel -> String -> IO ()
Logging.log LogLevel
Info (String
"Using freshly generated seed to randomize test order: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
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
[String]
Maybe Int
LogLevel
ModuleConfig
cfgLogLevel :: LogLevel
cfgModules :: [String]
cfgThreads :: Maybe Int
cfgModuleConfig :: ModuleConfig
cfgNix :: Bool
cfgGhcArgs :: [String]
cfgLogLevel :: Config -> LogLevel
cfgModules :: Config -> [String]
cfgThreads :: Config -> Maybe Int
cfgModuleConfig :: Config -> ModuleConfig
cfgNix :: Config -> Bool
cfgGhcArgs :: Config -> [String]
..} = do
  [String]
nixGhciArgs <- IO Bool -> IO [String] -> IO [String] -> IO [String]
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 [String]
getNixGhciArgs ([String] -> IO [String]
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
    ([String]
includeArgs, [String]
moduleArgs, [String]
otherGhciArgs) = Library -> ([String], [String], [String])
libraryToGhciArgs Library
lib
    evalGhciArgs :: [String]
evalGhciArgs = [String]
otherGhciArgs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"-XNoImplicitPrelude"] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
nixGhciArgs
    parseGhcArgs :: [String]
parseGhcArgs = [String]
includeArgs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
moduleArgs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
otherGhciArgs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
nixGhciArgs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
cfgGhcArgs

  let
    ?verbosity = ?verbosity::LogLevel
LogLevel
cfgLogLevel

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

  -- Get examples from Haddock comments
  (?verbosity::LogLevel) => LogLevel -> String -> IO ()
LogLevel -> String -> IO ()
Logging.log LogLevel
Verbose String
"Parsing comments.."
  (?verbosity::LogLevel) => LogLevel -> String -> IO ()
LogLevel -> String -> IO ()
Logging.log LogLevel
Debug (String
"Calling GHC API with: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [String] -> String
unwords [String]
parseGhcArgs)
  [Module [Located DocTest]]
allModules <- [String] -> IO [Module [Located DocTest]]
getDocTests [String]
parseGhcArgs

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