-
Notifications
You must be signed in to change notification settings - Fork 72
/
Run.hs
133 lines (116 loc) · 4.06 KB
/
Run.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
{-# 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
import Panic
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 args0 = case parseOptions args0 of
Output s -> putStr s
Result (Run warnings args_ magicMode fastMode preserveIt) -> do
mapM_ (hPutStrLn stderr) warnings
hFlush stderr
i <- Interpreter.interpreterSupported
unless i $ do
hPutStrLn stderr "WARNING: GHC does not support --interactive, skipping tests"
exitSuccess
args <- case magicMode of
False -> return args_
True -> do
expandedArgs <- concat <$> mapM expandDirs args_
packageDBArgs <- getPackageDBArgs
addDistArgs <- getAddDistArgs
return (addDistArgs $ packageDBArgs ++ expandedArgs)
r <- doctestWithOptions fastMode preserveIt args `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
when (not $ isSuccess r) exitFailure
-- | 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 =
case lookup "HASKELL_DIST_DIR" env of
Nothing -> "dist"
Just x -> x
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
isSuccess :: Summary -> Bool
isSuccess s = sErrors s == 0 && sFailures s == 0
doctestWithOptions :: Bool -> Bool -> [String] -> IO Summary
doctestWithOptions fastMode preserveIt args = do
-- get examples from Haddock comments
modules <- getDocTests args
Interpreter.withInterpreter args $ \repl -> withCP65001 $ do
runModules fastMode preserveIt repl modules