-
Notifications
You must be signed in to change notification settings - Fork 72
/
Run.hs
157 lines (134 loc) · 4.61 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
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
{-# LANGUAGE CPP #-}
module Run (
doctest
, doctestWithRepl
, Config(..)
, defaultConfig
, doctestWith
, Result
, Summary(..)
, 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 = doctestWithRepl (repl defaultConfig)
doctestWithRepl :: (String, [String]) -> [String] -> IO ()
doctestWithRepl repl 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
isSuccess :: Result -> Bool
isSuccess s = sErrors s == 0 && sFailures s == 0
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 fastMode preserveIt verbose interpreter modules