{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
module Run (
  doctest
, doctestWithRepl

, Config(..)
, defaultConfig
, doctestWith

, Result
, Summary(..)
, formatSummary
, isSuccess
, evaluateResult
, doctestWithResult

, runDocTests
#ifdef TEST
, expandDirs
#endif
) where

import           Imports

import           GHC.ResponseFile (expandResponse)
import           System.Directory (doesFileExist, doesDirectoryExist, getDirectoryContents)
import           System.Environment (getEnvironment)
import           System.Exit (exitFailure, exitSuccess)
import           System.FilePath ((</>), takeExtension)
import           System.IO
import           System.IO.CodePage (withCP65001)

import qualified Control.Exception as E

#if __GLASGOW_HASKELL__ < 900
import           Panic
#else
import           GHC.Utils.Panic
#endif

import           PackageDBs
import           Parse
import           Options hiding (Result(..))
import qualified Options
import           Runner
import           Location
import qualified Interpreter

-- | Run doctest with given list of arguments.
--
-- Example:
--
-- >>> doctest ["-iexample/src", "example/src/Example.hs"]
-- ...
-- Examples: 2  Tried: 2  Errors: 0  Failures: 0
--
-- This can be used to create a Cabal test suite that runs doctest for your
-- project.
--
-- If a directory is given, it is traversed to find all .hs and .lhs files
-- inside of it, ignoring hidden entries.
doctest :: [String] -> IO ()
doctest :: [String] -> IO ()
doctest = (String, [String]) -> [String] -> IO ()
doctestWithRepl (Config -> (String, [String])
repl Config
defaultConfig)

doctestWithRepl :: (String, [String]) -> [String] -> IO ()
doctestWithRepl :: (String, [String]) -> [String] -> IO ()
doctestWithRepl (String, [String])
repl = [String] -> IO [String]
expandResponse ([String] -> IO [String])
-> ([String] -> IO ()) -> [String] -> IO ()
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> \ [String]
args0 -> case [String] -> Result Run
parseOptions [String]
args0 of
  Options.ProxyToGhc [String]
args -> String -> [String] -> IO ()
exec String
Interpreter.ghc [String]
args
  Options.Output String
s -> String -> IO ()
putStr String
s
  Options.Result (Run [String]
warnings Bool
magicMode Config
config) -> do
    (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Handle -> String -> IO ()
hPutStrLn Handle
stderr) [String]
warnings
    Handle -> IO ()
hFlush Handle
stderr

    i <- IO Bool
Interpreter.interpreterSupported
    unless i $ do
      hPutStrLn stderr "WARNING: GHC does not support --interactive, skipping tests"
      exitSuccess

    opts <- case magicMode of
      Bool
False -> [String] -> IO [String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Config -> [String]
ghcOptions Config
config)
      Bool
True -> do
        expandedArgs <- [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[String]] -> [String]) -> IO [[String]] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> IO [String]) -> [String] -> IO [[String]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM String -> IO [String]
expandDirs (Config -> [String]
ghcOptions Config
config)
        packageDBArgs <- getPackageDBArgs
        addDistArgs <- getAddDistArgs
        return (addDistArgs $ packageDBArgs ++ expandedArgs)
    doctestWith config{repl, ghcOptions = opts}

-- | Expand a reference to a directory to all .hs and .lhs files within it.
expandDirs :: String -> IO [String]
expandDirs :: String -> IO [String]
expandDirs String
fp0 = do
    isDir <- String -> IO Bool
doesDirectoryExist String
fp0
    if isDir
        then findHaskellFiles fp0
        else return [fp0]
  where
    findHaskellFiles :: String -> IO [String]
findHaskellFiles String
dir = do
        contents <- String -> IO [String]
getDirectoryContents String
dir
        concat <$> mapM go (filter (not . hidden) contents)
      where
        go :: String -> IO [String]
go String
name = do
            isDir <- String -> IO Bool
doesDirectoryExist String
fp
            if isDir
                then findHaskellFiles fp
                else if isHaskellFile fp
                        then return [fp]
                        else return []
          where
            fp :: String
fp = String
dir String -> String -> String
</> String
name

    hidden :: String -> Bool
hidden (Char
'.':String
_) = Bool
True
    hidden String
_ = Bool
False

    isHaskellFile :: String -> Bool
isHaskellFile String
fp = String -> String
takeExtension String
fp String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
".hs", String
".lhs"]

-- | Get the necessary arguments to add the @cabal_macros.h@ file and autogen
-- directory, if present.
getAddDistArgs :: IO ([String] -> [String])
getAddDistArgs :: IO ([String] -> [String])
getAddDistArgs = do
    env <- IO [(String, String)]
getEnvironment
    let dist = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"dist" (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"HASKELL_DIST_DIR" [(String, String)]
env
        autogen = String
dist String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/build/autogen/"
        cabalMacros = String
autogen String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"cabal_macros.h"

    dirExists <- doesDirectoryExist autogen
    if dirExists
        then do
            fileExists <- doesFileExist cabalMacros
            return $ \[String]
rest ->
                  [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"-i", String
dist, String
"/build/autogen/"]
                String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String
"-optP-include"
                String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (if Bool
fileExists
                    then ([String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"-optP", String
dist, String
"/build/autogen/cabal_macros.h"]String -> [String] -> [String]
forall a. a -> [a] -> [a]
:)
                    else [String] -> [String]
forall a. a -> a
id) [String]
rest
        else return id

doctestWith :: Config -> IO ()
doctestWith :: Config -> IO ()
doctestWith = Config -> IO Result
doctestWithResult (Config -> IO Result) -> (Result -> IO ()) -> Config -> IO ()
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Result -> IO ()
evaluateResult

type Result = Summary

evaluateResult :: Result -> IO ()
evaluateResult :: Result -> IO ()
evaluateResult Result
r = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Result -> Bool
isSuccess Result
r) IO ()
forall a. IO a
exitFailure

doctestWithResult :: Config -> IO Result
doctestWithResult :: Config -> IO Result
doctestWithResult Config
config = do
  ([String] -> IO [Module [Located DocTest]]
extractDocTests (Config -> [String]
ghcOptions Config
config) IO [Module [Located DocTest]]
-> ([Module [Located DocTest]] -> IO Result) -> IO Result
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Config -> [Module [Located DocTest]] -> IO Result
runDocTests Config
config) IO Result -> (SomeException -> IO Result) -> IO Result
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 Result
forall a. IO a
exitFailure
      Maybe GhcException
_ -> SomeException -> IO Result
forall e a. (HasCallStack, Exception e) => e -> IO a
E.throwIO SomeException
e

runDocTests :: Config -> [Module [Located DocTest]] -> IO Result
runDocTests :: Config -> [Module [Located DocTest]] -> IO Result
runDocTests Config{Bool
[String]
(String, [String])
repl :: Config -> (String, [String])
ghcOptions :: Config -> [String]
ghcOptions :: [String]
fastMode :: Bool
preserveIt :: Bool
failFast :: Bool
verbose :: Bool
repl :: (String, [String])
verbose :: Config -> Bool
failFast :: Config -> Bool
preserveIt :: Config -> Bool
fastMode :: Config -> Bool
..} [Module [Located DocTest]]
modules = do
  (String, [String]) -> (Interpreter -> IO Result) -> IO Result
forall a. (String, [String]) -> (Interpreter -> IO a) -> IO a
Interpreter.withInterpreter (([String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String]
ghcOptions) ([String] -> [String]) -> (String, [String]) -> (String, [String])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String, [String])
repl) ((Interpreter -> IO Result) -> IO Result)
-> (Interpreter -> IO Result) -> IO Result
forall a b. (a -> b) -> a -> b
$ \ Interpreter
interpreter -> IO Result -> IO Result
forall a. IO a -> IO a
withCP65001 (IO Result -> IO Result) -> IO Result -> IO Result
forall a b. (a -> b) -> a -> b
$ do
    FastMode
-> PreserveIt
-> FailFast
-> Verbose
-> Interpreter
-> [Module [Located DocTest]]
-> IO Result
runModules
      (if Bool
fastMode then FastMode
FastMode else FastMode
NoFastMode)
      (if Bool
preserveIt then PreserveIt
PreserveIt else PreserveIt
NoPreserveIt)
      (if Bool
failFast then FailFast
FailFast else FailFast
NoFailFast)
      (if Bool
verbose then Verbose
Verbose else Verbose
NonVerbose)
      Interpreter
interpreter [Module [Located DocTest]]
modules