{-# 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
  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
  mainFromLibrary lib cmdArgs

-- | Run doctest given config.
--
-- Example:
--
-- @
-- mainFromCabal "my-project" defaultConfig
-- @
--
mainFromCabalWithConfig :: String -> Config -> IO ()
mainFromCabalWithConfig :: [Char] -> Config -> IO ()
mainFromCabalWithConfig [Char]
libName Config
config = do
  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
  mainFromLibraryWithConfig lib 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
  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. (HasCallStack, Exception e) => e -> IO a
E.throwIO SomeException
e
  unless (isSuccess r) 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
  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
  Logging.log Info ("Using freshly generated seed to randomize test order: " <> show seed)
  pure 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]]
cfgGhcArgs :: Config -> [[Char]]
cfgNix :: Config -> Bool
cfgModuleConfig :: Config -> ModuleConfig
cfgThreads :: Config -> Maybe Int
cfgModules :: Config -> [[Char]]
cfgLogLevel :: Config -> LogLevel
..} = do
  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 = 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
    (includeArgs, allModules, otherGhciArgs) = libraryToGhciArgs lib
    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]]
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 = cfgLogLevel

  modConfig <- setSeed cfgModuleConfig

  -- Run tests
  Logging.log Verbose "Running examples.."
  let
    filteredModules = [[Char]] -> [[Char]] -> [[Char]]
filterModules [[Char]]
cfgModules [[Char]]
allModules
    filteredModulesMsg = [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", " [[Char]]
filteredModules
  Logging.log Debug ("Running examples in modules: " <> filteredModulesMsg)
  runModules modConfig cfgThreads implicitPrelude parseGhcArgs evalGhciArgs filteredModules