{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# 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           Control.Monad (unless)
import           Control.Monad.Compat (when)
import           Control.Monad.Extra (whenM)
import           Data.List (isInfixOf)
import           Data.Maybe (fromMaybe)
import           System.Directory (doesDirectoryExist, makeAbsolute)
import           System.Environment (lookupEnv, setEnv)
import           System.Exit (exitFailure)
import           System.FilePath ((</>))
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

setSeed :: Bool -> ModuleConfig -> IO ModuleConfig
setSeed :: Bool -> ModuleConfig -> IO ModuleConfig
setSeed Bool
quiet 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
  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)
  ModuleConfig -> IO ModuleConfig
forall (f :: * -> *) a. Applicative f => a -> f a
pure ModuleConfig
cfg{cfgSeed :: Maybe Int
cfgSeed=Int -> Maybe Int
forall a. a -> Maybe a
Just Int
seed}
setSeed Bool
_quiet ModuleConfig
cfg = ModuleConfig -> IO ModuleConfig
forall (f :: * -> *) a. Applicative f => a -> f a
pure ModuleConfig
cfg

-- | @GHC_PACKAGE_PATH@. Here as a variable to prevent typos.
gHC_PACKAGE_PATH :: String
gHC_PACKAGE_PATH :: String
gHC_PACKAGE_PATH = String
"GHC_PACKAGE_PATH"

-- | Add locally built package to @GHC_PACKAGE_PATH@ if a Nix environment is
-- detected.
addLocalNixPackageToGhcPath :: IO ()
addLocalNixPackageToGhcPath :: IO ()
addLocalNixPackageToGhcPath = do
  String -> IO (Maybe String)
lookupEnv String
"NIX_BUILD_TOP" IO (Maybe String) -> (Maybe String -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe String
Nothing -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just String
_ -> do
      String
pkgDb <- String -> IO String
makeAbsolute (String
"dist" String -> String -> String
</> String
"package.conf.inplace")
      String
ghcPackagePath <- String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" (Maybe String -> String) -> IO (Maybe String) -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
gHC_PACKAGE_PATH

      -- Don't add package db if it is already mentioned on path
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((String
pkgDb String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":") String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` String
ghcPackagePath) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        -- Only add package db if it exists on disk
        IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (String -> IO Bool
doesDirectoryExist String
pkgDb) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          String -> String -> IO ()
setEnv String
gHC_PACKAGE_PATH (String
pkgDb String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ghcPackagePath)

-- | 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
ModuleConfig
cfgNix :: Config -> Bool
cfgModuleConfig :: Config -> ModuleConfig
cfgQuiet :: Config -> Bool
cfgThreads :: Config -> Maybe Int
cfgModules :: Config -> [String]
cfgVerbose :: Config -> Bool
cfgNix :: Bool
cfgModuleConfig :: ModuleConfig
cfgQuiet :: Bool
cfgThreads :: Maybe Int
cfgModules :: [String]
cfgVerbose :: Bool
..} = do
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
cfgNix IO ()
addLocalNixPackageToGhcPath

  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"]

    -- Nix doesn't always expose the GHC library (_specifically_ the GHC lib) even
    -- if a package lists it as a dependency. This simply always exposes it as a
    -- workaround.
    nixGhciArgs :: [String]
nixGhciArgs
      | Bool
cfgNix = [String
"-package", String
"ghc"]
      | Bool
otherwise = []

  ModuleConfig
modConfig <- Bool -> ModuleConfig -> IO ModuleConfig
setSeed Bool
cfgQuiet ModuleConfig
cfgModuleConfig

  -- 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 [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
nixGhciArgs)
  ModuleConfig
-> Maybe Int
-> Bool
-> Bool
-> [String]
-> Bool
-> [Module [Located DocTest]]
-> IO Summary
runModules
    ModuleConfig
modConfig Maybe Int
cfgThreads Bool
cfgVerbose 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)