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

, Config(..)
, defaultConfig
, doctestWith

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

, runDocTests
#ifdef TEST
, expandDirs
#endif
) where

import           Imports

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

    Bool
i <- IO Bool
Interpreter.interpreterSupported
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
i (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      Handle -> String -> IO ()
hPutStrLn Handle
stderr String
"WARNING: GHC does not support --interactive, skipping tests"
      IO ()
forall a. IO a
exitSuccess

    [String]
opts <- case Bool
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
        [String]
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)
        [String]
packageDBArgs <- IO [String]
getPackageDBArgs
        [String] -> [String]
addDistArgs <- IO ([String] -> [String])
getAddDistArgs
        [String] -> IO [String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> [String]
addDistArgs ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ [String]
packageDBArgs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
expandedArgs)
    Config -> IO ()
doctestWith Config
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
    Bool
isDir <- String -> IO Bool
doesDirectoryExist String
fp0
    if Bool
isDir
        then String -> IO [String]
findHaskellFiles String
fp0
        else [String] -> IO [String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [String
fp0]
  where
    findHaskellFiles :: String -> IO [String]
findHaskellFiles String
dir = do
        [String]
contents <- String -> IO [String]
getDirectoryContents String
dir
        [[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]
go ((String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
hidden) [String]
contents)
      where
        go :: String -> IO [String]
go String
name = do
            Bool
isDir <- String -> IO Bool
doesDirectoryExist String
fp
            if Bool
isDir
                then String -> IO [String]
findHaskellFiles String
fp
                else if String -> Bool
isHaskellFile String
fp
                        then [String] -> IO [String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [String
fp]
                        else [String] -> IO [String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
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
    [(String, String)]
env <- IO [(String, String)]
getEnvironment
    let dist :: String
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
autogen = String
dist String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/build/autogen/"
        cabalMacros :: String
cabalMacros = String
autogen String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"cabal_macros.h"

    Bool
dirExists <- String -> IO Bool
doesDirectoryExist String
autogen
    if Bool
dirExists
        then do
            Bool
fileExists <- String -> IO Bool
doesFileExist String
cabalMacros
            ([String] -> [String]) -> IO ([String] -> [String])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (([String] -> [String]) -> IO ([String] -> [String]))
-> ([String] -> [String]) -> IO ([String] -> [String])
forall a b. (a -> b) -> a -> b
$ \[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 ([String] -> [String]) -> IO ([String] -> [String])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [String] -> [String]
forall a. a -> a
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. 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])
fastMode :: Config -> Bool
preserveIt :: Config -> Bool
failFast :: Config -> Bool
verbose :: 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