doctest-0.24.2: src/Run.hs

{-# 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 = doctestWithRepl (repl defaultConfig)

doctestWithRepl :: (String, [String]) -> [String] -> IO ()
doctestWithRepl repl = expandResponse >=> \ args0 -> case parseOptions args0 of
  Options.ProxyToGhc args -> exec Interpreter.ghc args
  Options.Output s -> putStr s
  Options.Result (Run warnings magicMode config) -> do
    mapM_ (hPutStrLn stderr) warnings
    hFlush stderr

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

    opts <- case magicMode of
      False -> return (ghcOptions config)
      True -> do
        expandedArgs <- concat <$> mapM expandDirs (ghcOptions 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 fp0 = do
    isDir <- doesDirectoryExist fp0
    if isDir
        then findHaskellFiles fp0
        else return [fp0]
  where
    findHaskellFiles dir = do
        contents <- getDirectoryContents dir
        concat <$> mapM go (filter (not . hidden) contents)
      where
        go name = do
            isDir <- doesDirectoryExist fp
            if isDir
                then findHaskellFiles fp
                else if isHaskellFile fp
                        then return [fp]
                        else return []
          where
            fp = dir </> name

    hidden ('.':_) = True
    hidden _ = False

    isHaskellFile fp = takeExtension fp `elem` [".hs", ".lhs"]

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

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

doctestWith :: Config -> IO ()
doctestWith = doctestWithResult >=> evaluateResult

type Result = Summary

evaluateResult :: Result -> IO ()
evaluateResult r = unless (isSuccess r) exitFailure

doctestWithResult :: Config -> IO Result
doctestWithResult config = do
  (extractDocTests (ghcOptions config) >>= runDocTests config) `E.catch` \e -> do
    case fromException e of
      Just (UsageError err) -> do
        hPutStrLn stderr ("doctest: " ++ err)
        hPutStrLn stderr "Try `doctest --help' for more information."
        exitFailure
      _ -> E.throwIO e

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