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

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

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

import           Prelude ()
import           Prelude.Compat

import qualified Data.Set as Set

import           Control.Monad (unless)
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

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

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

-- | 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 :: [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 :: String
moduleName :: forall a. Module a -> String
moduleName} = String
moduleName String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
wantedMods1

getSeed
  :: Bool
  -- ^ Whether quiet mode is enabled
  -> Bool
  -- ^ Enable order randomization. If 'False', this function always returns 'Nothing'
  -> Maybe Int
  -- ^ User supplied seed. If 'Nothing', a fresh seed will be generated.
  -> IO (Maybe Int)
  -- ^ Maybe seed to use for order randomization.
getSeed :: Bool -> Bool -> Maybe Int -> IO (Maybe Int)
getSeed Bool
_quiet Bool
False Maybe Int
_ = Maybe Int -> IO (Maybe Int)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Int
forall a. Maybe a
Nothing
getSeed Bool
_quiet Bool
True (Just Int
seed) = Maybe Int -> IO (Maybe Int)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
seed)
getSeed Bool
quiet Bool
True Maybe Int
Nothing = do
  -- Using an abslute 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
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
quiet (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    String -> IO ()
putStrLn (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)
  Maybe Int -> IO (Maybe Int)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
seed)

-- | 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
cfgQuiet :: Config -> Bool
cfgSeed :: Config -> Maybe Int
cfgRandomizeOrder :: Config -> Bool
cfgThreads :: Config -> Maybe Int
cfgModules :: Config -> [String]
cfgVerbose :: Config -> Bool
cfgPreserveIt :: Config -> Bool
cfgQuiet :: Bool
cfgSeed :: Maybe Int
cfgRandomizeOrder :: Bool
cfgThreads :: Maybe Int
cfgModules :: [String]
cfgVerbose :: Bool
cfgPreserveIt :: Bool
..} = do
  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"]

  Maybe Int
seed <- Bool -> Bool -> Maybe Int -> IO (Maybe Int)
getSeed Bool
cfgQuiet Bool
cfgRandomizeOrder Maybe Int
cfgSeed

  -- get examples from Haddock comments
  [Module [Located DocTest]]
allModules <- [String] -> IO [Module [Located DocTest]]
getDocTests ([String]
includeArgs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
moduleArgs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
otherGhciArgs)
  Maybe Int
-> Bool
-> Bool
-> Maybe Int
-> Bool
-> [String]
-> Bool
-> [Module [Located DocTest]]
-> IO Summary
runModules
    Maybe Int
cfgThreads Bool
cfgPreserveIt Bool
cfgVerbose Maybe Int
seed Bool
implicitPrelude [String]
evalGhciArgs
    Bool
cfgQuiet ([String]
-> [Module [Located DocTest]] -> [Module [Located DocTest]]
forall a. [String] -> [Module a] -> [Module a]
filterModules [String]
cfgModules [Module [Located DocTest]]
allModules)