{-# LANGUAGE CPP #-}
module Run (
  doctest
#ifdef TEST
, doctestWithOptions
, Summary
, expandDirs
#endif
) where

import           Prelude ()
import           Prelude.Compat

import           Control.Monad (when, unless)
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
import           Runner
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]
args0 = case [String] -> Result Run
parseOptions [String]
args0 of
  Output String
s -> String -> IO ()
putStr String
s
  Result (Run [String]
warnings [String]
args_ Bool
magicMode Bool
fastMode Bool
preserveIt Bool
verbose) -> 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]
args <- case Bool
magicMode of
      Bool
False -> [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String]
args_
      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)
mapM String -> IO [String]
expandDirs [String]
args_
        [String]
packageDBArgs <- IO [String]
getPackageDBArgs
        [String] -> [String]
addDistArgs <- IO ([String] -> [String])
getAddDistArgs
        [String] -> IO [String]
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)

    Summary
r <- Bool -> Bool -> Bool -> [String] -> IO Summary
doctestWithOptions Bool
fastMode Bool
preserveIt Bool
verbose [String]
args 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 ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Summary -> Bool
isSuccess Summary
r) IO ()
forall a. IO a
exitFailure

-- | 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 (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)
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 (m :: * -> *) a. Monad m => a -> m a
return [String
fp]
                        else [String] -> IO [String]
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 (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 =
            case String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"HASKELL_DIST_DIR" [(String, String)]
env of
                Maybe String
Nothing -> String
"dist"
                Just String
x -> String
x
        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 (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 (m :: * -> *) a. Monad m => a -> m a
return [String] -> [String]
forall a. a -> a
id

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

doctestWithOptions :: Bool -> Bool -> Bool -> [String] -> IO Summary
doctestWithOptions :: Bool -> Bool -> Bool -> [String] -> IO Summary
doctestWithOptions Bool
fastMode Bool
preserveIt Bool
verbose [String]
args = do

  -- get examples from Haddock comments
  [Module [Located DocTest]]
modules <- [String] -> IO [Module [Located DocTest]]
getDocTests [String]
args

  [String] -> (Interpreter -> IO Summary) -> IO Summary
forall a. [String] -> (Interpreter -> IO a) -> IO a
Interpreter.withInterpreter [String]
args ((Interpreter -> IO Summary) -> IO Summary)
-> (Interpreter -> IO Summary) -> IO Summary
forall a b. (a -> b) -> a -> b
$ \Interpreter
repl -> IO Summary -> IO Summary
forall a. IO a -> IO a
withCP65001 (IO Summary -> IO Summary) -> IO Summary -> IO Summary
forall a b. (a -> b) -> a -> b
$ do
    Bool
-> Bool
-> Bool
-> Interpreter
-> [Module [Located DocTest]]
-> IO Summary
runModules Bool
fastMode Bool
preserveIt Bool
verbose Interpreter
repl [Module [Located DocTest]]
modules