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

module Test.DocTest where

import           Prelude ()
import           Prelude.Compat

import qualified Data.Set as Set

import           Control.Monad (unless)
import           System.Exit (exitFailure)
import           System.IO

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

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
      Summary
r <- Library -> Config -> IO Summary
main 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 :: 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


main :: Library -> Config -> IO Summary
main :: Library -> Config -> IO Summary
main Library
lib Config{Bool
[String]
Maybe Int
cfgThreads :: Config -> Maybe Int
cfgModules :: Config -> [String]
cfgVerbose :: Config -> Bool
cfgPreserveIt :: Config -> 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"]

  -- 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)
  let modules :: [Module [Located DocTest]]
modules = [String]
-> [Module [Located DocTest]] -> [Module [Located DocTest]]
forall a. [String] -> [Module a] -> [Module a]
filterModules [String]
cfgModules [Module [Located DocTest]]
allModules
  Maybe Int
-> Bool
-> Bool
-> Bool
-> [String]
-> [Module [Located DocTest]]
-> IO Summary
runModules Maybe Int
cfgThreads Bool
cfgPreserveIt Bool
cfgVerbose Bool
implicitPrelude [String]
evalGhciArgs [Module [Located DocTest]]
modules