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
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
|
{-# LANGUAGE ScopedTypeVariables, ViewPatterns #-}
-- | This test checks if 'downsweep can return partial results when various
-- kinds of parse errors occur in modules.
import GHC
import GhcMake
import DynFlags
import Outputable
import Exception (ExceptionMonad, ghandle)
import Bag
import Control.Monad
import Control.Monad.IO.Class (liftIO)
import Control.Exception
import Data.IORef
import Data.List (sort, find, stripPrefix, isPrefixOf, isSuffixOf)
import Data.Either
import System.Environment
import System.Exit
import System.IO
import System.IO.Unsafe (unsafePerformIO)
any_failed :: IORef Bool
any_failed = unsafePerformIO $ newIORef False
{-# NOINLINE any_failed #-}
it :: ExceptionMonad m => [Char] -> m Bool -> m ()
it msg act =
ghandle (\(_ex :: AssertionFailed) -> dofail) $
ghandle (\(_ex :: ExitCode) -> dofail) $ do
res <- act
case res of
False -> dofail
True -> return ()
where
dofail = do
liftIO $ hPutStrLn stderr $ "FAILED: " ++ msg
liftIO $ writeIORef any_failed True
main :: IO ()
main = do
libdir:args <- getArgs
runGhc (Just libdir) $ do
dflags0 <- getSessionDynFlags
(dflags1, _, _) <- parseDynamicFlags dflags0 $ map noLoc $
[ "-fno-diagnostics-show-caret"
-- , "-v3"
] ++ args
_ <- setSessionDynFlags dflags1
go "Parse error in export list"
[ [ "module A where"
, "import B"
]
, [ "module B !parse_error where"
-- ^ this used to cause getImports to throw an exception instead
-- of having downsweep return an error for just this module
, "import C"
]
, [ "module C where"
]
]
(\mss -> return $
sort (map (moduleNameString . moduleName . ms_mod) mss) == ["A"]
)
go "Parse error in export list with bypass module"
[ [ "module A where"
, "import B"
, "import C"
]
, [ "module B !parse_error where"
, "import D"
]
, [ "module C where"
, "import D"
]
, [ "module D where"
]
]
(\mss -> return $
sort (map (moduleNameString . moduleName . ms_mod) mss) == ["A", "C", "D"]
)
go "Parse error in import list"
[ [ "module A where"
, "import B"
]
, [ "module B where"
, "!parse_error"
-- ^ this is silently ignored, getImports assumes the import
-- list is just empty. This smells like a parser bug to me but
-- I'm still documenting this behaviour here.
, "import C"
]
, [ "module C where"
]
]
(\mss -> return $
sort (map (moduleNameString . moduleName . ms_mod) mss) == ["A", "B"]
)
go "CPP preprocessor error"
[ [ "module A where"
, "import B"
]
, [ "{-# LANGUAGE CPP #-}"
, "#elif <- cpp error here"
, "module B where"
, "import C"
]
, [ "module C where"
]
]
(\mss -> return $
sort (map (moduleNameString . moduleName . ms_mod) mss) == ["A"]
)
go "CPP preprocessor error with bypass"
[ [ "module A where"
, "import B"
, "import C"
]
, [ "{-# LANGUAGE CPP #-}"
, "#elif <- cpp error here"
, "module B where"
, "import C"
]
, [ "module C where"
]
]
(\mss -> return $
sort (map (moduleNameString . moduleName . ms_mod) mss) == ["A", "C"]
)
go "Import error"
[ [ "module A where"
, "import B"
, "import DoesNotExist_FooBarBaz"
]
, [ "module B where"
]
]
(\mss -> return $
sort (map (moduleNameString . moduleName . ms_mod) mss) == ["A", "B"]
)
errored <- readIORef any_failed
when errored $ exitFailure
return ()
go :: String -> [[String]] -> ([ModSummary] -> Ghc Bool) -> Ghc ()
go label mods cnd =
defaultErrorHandler defaultFatalMessager defaultFlushOut $ do
liftIO $ hPutStrLn stderr $ "== " ++ label
liftIO $ mapM_ writeMod mods
tgt <- guessTarget "A" Nothing
setTargets [tgt]
hsc_env <- getSession
emss <- liftIO $ downsweep hsc_env [] [] False
-- liftIO $ hPutStrLn stderr $ showSDocUnsafe $ ppr $ rights emss
-- liftIO $ hPrint stderr $ bagToList $ unionManyBags $ lefts emss
it label $ cnd (rights emss)
writeMod :: [String] -> IO ()
writeMod src =
writeFile (mod++".hs") $ unlines src
where
Just modline = find ("module" `isPrefixOf`) src
Just (takeWhile (/=' ') -> mod) = stripPrefix "module " modline
|
