Replace createDirectoryHierarchy with createDirectoryIfMissing True
[ghc.git] / compiler / main / ErrUtils.lhs
1 %
2 % (c) The AQUA Project, Glasgow University, 1994-1998
3 %
4 \section[ErrsUtils]{Utilities for error reporting}
5
6 \begin{code}
7
8 module ErrUtils (
9         ErrMsg, WarnMsg, Severity(..),
10         Messages, ErrorMessages, WarningMessages,
11         errMsgSpans, errMsgContext, errMsgShortDoc, errMsgExtraInfo,
12         MsgDoc, mkLocMessage, pprMessageBag, pprErrMsgBag,
13         pprLocErrMsg, makeIntoWarning,
14         
15         errorsFound, emptyMessages,
16         mkErrMsg, mkPlainErrMsg, mkLongErrMsg, mkWarnMsg, mkPlainWarnMsg,
17         printBagOfErrors, 
18         warnIsErrorMsg, mkLongWarnMsg,
19
20         ghcExit,
21         doIfSet, doIfSet_dyn,
22         dumpIfSet, dumpIfSet_dyn, dumpIfSet_dyn_or,
23         mkDumpDoc, dumpSDoc,
24
25         --  * Messages during compilation
26         putMsg, putMsgWith,
27         errorMsg,
28         fatalErrorMsg, fatalErrorMsg',
29         compilationProgressMsg,
30         showPass,
31         debugTraceMsg,
32     ) where
33
34 #include "HsVersions.h"
35
36 import Bag              ( Bag, bagToList, isEmptyBag, emptyBag )
37 import Util
38 import Outputable
39 import FastString
40 import SrcLoc
41 import DynFlags
42 import StaticFlags      ( opt_ErrorSpans )
43
44 import System.Directory
45 import System.Exit      ( ExitCode(..), exitWith )
46 import System.FilePath
47 import Data.List
48 import qualified Data.Set as Set
49 import Data.IORef
50 import Control.Monad
51 import System.IO
52
53 -- -----------------------------------------------------------------------------
54 -- Basic error messages: just render a message with a source location.
55
56 type Messages        = (WarningMessages, ErrorMessages)
57 type WarningMessages = Bag WarnMsg
58 type ErrorMessages   = Bag ErrMsg
59
60 data ErrMsg = ErrMsg {
61         errMsgSpans     :: [SrcSpan],
62         errMsgContext   :: PrintUnqualified,
63         errMsgShortDoc  :: MsgDoc,
64         errMsgExtraInfo :: MsgDoc,
65         errMsgSeverity  :: Severity
66         }
67         -- The SrcSpan is used for sorting errors into line-number order
68
69 type WarnMsg = ErrMsg
70 type MsgDoc = SDoc
71
72 data Severity
73   = SevOutput
74   | SevInfo
75   | SevWarning
76   | SevError
77   | SevFatal
78
79 instance Show ErrMsg where
80     show em = showSDoc (errMsgShortDoc em)
81
82 pprMessageBag :: Bag MsgDoc -> SDoc
83 pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs))
84
85 mkLocMessage :: Severity -> SrcSpan -> MsgDoc -> MsgDoc
86   -- Always print the location, even if it is unhelpful.  Error messages
87   -- are supposed to be in a standard format, and one without a location
88   -- would look strange.  Better to say explicitly "<no location info>".
89 mkLocMessage severity locn msg
90   | opt_ErrorSpans = hang (ppr locn <> colon <+> sev_info) 4 msg
91   | otherwise      = hang (ppr (srcSpanStart locn) <> colon <+> sev_info) 4 msg
92   where
93     sev_info = case severity of
94                  SevWarning -> ptext (sLit "Warning:")
95                  _other     -> empty                 
96       -- For warnings, print    Foo.hs:34: Warning:
97       --                           <the warning message>
98
99 makeIntoWarning :: ErrMsg -> ErrMsg
100 makeIntoWarning err = err { errMsgSeverity = SevWarning }
101
102 -- -----------------------------------------------------------------------------
103 -- Collecting up messages for later ordering and printing.
104
105 mk_err_msg :: Severity -> SrcSpan -> PrintUnqualified -> MsgDoc -> SDoc -> ErrMsg
106 mk_err_msg sev locn print_unqual msg extra 
107  = ErrMsg { errMsgSpans = [locn], errMsgContext = print_unqual
108           , errMsgShortDoc = msg, errMsgExtraInfo = extra
109           , errMsgSeverity = sev }
110
111 mkLongErrMsg, mkLongWarnMsg   :: SrcSpan -> PrintUnqualified -> MsgDoc -> MsgDoc -> ErrMsg
112 -- A long (multi-line) error message
113 mkErrMsg, mkWarnMsg           :: SrcSpan -> PrintUnqualified -> MsgDoc            -> ErrMsg
114 -- A short (one-line) error message
115 mkPlainErrMsg, mkPlainWarnMsg :: SrcSpan ->                     MsgDoc            -> ErrMsg
116 -- Variant that doesn't care about qualified/unqualified names
117
118 mkLongErrMsg   locn unqual msg extra = mk_err_msg SevError   locn unqual        msg extra
119 mkErrMsg       locn unqual msg       = mk_err_msg SevError   locn unqual        msg empty
120 mkPlainErrMsg  locn        msg       = mk_err_msg SevError   locn alwaysQualify msg empty
121 mkLongWarnMsg  locn unqual msg extra = mk_err_msg SevWarning locn unqual        msg extra
122 mkWarnMsg      locn unqual msg       = mk_err_msg SevWarning locn unqual        msg empty
123 mkPlainWarnMsg locn        msg       = mk_err_msg SevWarning locn alwaysQualify msg empty
124
125 ----------------
126 emptyMessages :: Messages
127 emptyMessages = (emptyBag, emptyBag)
128
129 warnIsErrorMsg :: ErrMsg
130 warnIsErrorMsg = mkPlainErrMsg noSrcSpan (text "\nFailing due to -Werror.")
131
132 errorsFound :: DynFlags -> Messages -> Bool
133 errorsFound _dflags (_warns, errs) = not (isEmptyBag errs)
134
135 printBagOfErrors :: DynFlags -> Bag ErrMsg -> IO ()
136 printBagOfErrors dflags bag_of_errors
137   = printMsgBag dflags bag_of_errors
138
139 pprErrMsgBag :: Bag ErrMsg -> [SDoc]
140 pprErrMsgBag bag
141   = [ let style = mkErrStyle unqual
142       in withPprStyle style (d $$ e)
143     | ErrMsg { errMsgShortDoc  = d,
144                errMsgExtraInfo = e,
145                errMsgContext   = unqual } <- sortMsgBag bag ]
146
147 pprLocErrMsg :: ErrMsg -> SDoc
148 pprLocErrMsg (ErrMsg { errMsgSpans     = spans
149                      , errMsgShortDoc  = d
150                      , errMsgExtraInfo = e
151                      , errMsgSeverity  = sev
152                      , errMsgContext   = unqual })
153   = withPprStyle (mkErrStyle unqual) (mkLocMessage sev s (d $$ e))
154   where
155     (s : _) = spans   -- Should be non-empty
156
157 printMsgBag :: DynFlags -> Bag ErrMsg -> IO ()
158 printMsgBag dflags bag
159   = sequence_ [ let style = mkErrStyle unqual
160                 in log_action dflags sev s style (d $$ e)
161               | ErrMsg { errMsgSpans     = s:_,
162                          errMsgShortDoc  = d,
163                          errMsgSeverity  = sev,
164                          errMsgExtraInfo = e,
165                          errMsgContext   = unqual } <- sortMsgBag bag ]
166
167 sortMsgBag :: Bag ErrMsg -> [ErrMsg]
168 sortMsgBag bag = sortLe srcOrder $ bagToList bag
169   where
170     srcOrder err1 err2 =
171         case compare (head (errMsgSpans err1)) (head (errMsgSpans err2)) of
172             LT -> True
173             EQ -> True
174             GT -> False
175
176 ghcExit :: DynFlags -> Int -> IO ()
177 ghcExit dflags val
178   | val == 0  = exitWith ExitSuccess
179   | otherwise = do errorMsg dflags (text "\nCompilation had errors\n\n")
180                    exitWith (ExitFailure val)
181
182 doIfSet :: Bool -> IO () -> IO ()
183 doIfSet flag action | flag      = action
184                     | otherwise = return ()
185
186 doIfSet_dyn :: DynFlags -> DynFlag -> IO () -> IO()
187 doIfSet_dyn dflags flag action | dopt flag dflags = action
188                                | otherwise        = return ()
189
190 -- -----------------------------------------------------------------------------
191 -- Dumping
192
193 dumpIfSet :: Bool -> String -> SDoc -> IO ()
194 dumpIfSet flag hdr doc
195   | not flag   = return ()
196   | otherwise  = printDump (mkDumpDoc hdr doc)
197
198 dumpIfSet_dyn :: DynFlags -> DynFlag -> String -> SDoc -> IO ()
199 dumpIfSet_dyn dflags flag hdr doc
200   | dopt flag dflags || verbosity dflags >= 4
201   = dumpSDoc dflags flag hdr doc
202   | otherwise
203   = return ()
204
205 dumpIfSet_dyn_or :: DynFlags -> [DynFlag] -> String -> SDoc -> IO ()
206 dumpIfSet_dyn_or _ [] _ _ = return ()
207 dumpIfSet_dyn_or dflags (flag : flags) hdr doc
208     = if dopt flag dflags || verbosity dflags >= 4
209       then dumpSDoc dflags flag hdr doc
210       else dumpIfSet_dyn_or dflags flags hdr doc
211
212 mkDumpDoc :: String -> SDoc -> SDoc
213 mkDumpDoc hdr doc
214    = vcat [blankLine,
215            line <+> text hdr <+> line,
216            doc,
217            blankLine]
218      where
219         line = text (replicate 20 '=')
220
221
222 -- | Write out a dump.
223 --      If --dump-to-file is set then this goes to a file.
224 --      otherwise emit to stdout.
225 dumpSDoc :: DynFlags -> DynFlag -> String -> SDoc -> IO ()
226 dumpSDoc dflags dflag hdr doc
227  = do let mFile = chooseDumpFile dflags dflag
228       case mFile of
229             -- write the dump to a file
230             -- don't add the header in this case, we can see what kind
231             -- of dump it is from the filename.
232             Just fileName
233                  -> do
234                         let gdref = generatedDumps dflags
235                         gd <- readIORef gdref
236                         let append = Set.member fileName gd
237                             mode = if append then AppendMode else WriteMode
238                         when (not append) $
239                             writeIORef gdref (Set.insert fileName gd)
240                         createDirectoryIfMissing True (takeDirectory fileName)
241                         handle <- openFile fileName mode
242                         hPrintDump handle doc
243                         hClose handle
244
245             -- write the dump to stdout
246             Nothing
247                  -> printDump (mkDumpDoc hdr doc)
248
249
250 -- | Choose where to put a dump file based on DynFlags
251 --
252 chooseDumpFile :: DynFlags -> DynFlag -> Maybe String
253 chooseDumpFile dflags dflag
254
255         | dopt Opt_DumpToFile dflags
256         , Just prefix <- getPrefix
257         = Just $ setDir (prefix ++ (beautifyDumpName dflag))
258
259         | otherwise
260         = Nothing
261
262         where getPrefix
263                  -- dump file location is being forced
264                  --      by the --ddump-file-prefix flag.
265                | Just prefix <- dumpPrefixForce dflags
266                   = Just prefix
267                  -- dump file location chosen by DriverPipeline.runPipeline
268                | Just prefix <- dumpPrefix dflags
269                   = Just prefix
270                  -- we haven't got a place to put a dump file.
271                | otherwise
272                   = Nothing
273               setDir f = case dumpDir dflags of
274                          Just d  -> d </> f
275                          Nothing ->       f
276
277 -- | Build a nice file name from name of a DynFlag constructor
278 beautifyDumpName :: DynFlag -> String
279 beautifyDumpName dflag
280  = let str  = show dflag
281        cut  = if isPrefixOf "Opt_D_" str then drop 6 str else str
282        dash = map (\c -> if c == '_' then '-' else c) cut
283    in dash
284
285
286 -- -----------------------------------------------------------------------------
287 -- Outputting messages from the compiler
288
289 -- We want all messages to go through one place, so that we can
290 -- redirect them if necessary.  For example, when GHC is used as a
291 -- library we might want to catch all messages that GHC tries to
292 -- output and do something else with them.
293
294 ifVerbose :: DynFlags -> Int -> IO () -> IO ()
295 ifVerbose dflags val act
296   | verbosity dflags >= val = act
297   | otherwise               = return ()
298
299 putMsg :: DynFlags -> MsgDoc -> IO ()
300 putMsg dflags msg = log_action dflags SevInfo noSrcSpan defaultUserStyle msg
301
302 putMsgWith :: DynFlags -> PrintUnqualified -> MsgDoc -> IO ()
303 putMsgWith dflags print_unqual msg
304   = log_action dflags SevInfo noSrcSpan sty msg
305   where
306     sty = mkUserStyle print_unqual AllTheWay
307
308 errorMsg :: DynFlags -> MsgDoc -> IO ()
309 errorMsg dflags msg = log_action dflags SevError noSrcSpan defaultErrStyle msg
310
311 fatalErrorMsg :: DynFlags -> MsgDoc -> IO ()
312 fatalErrorMsg dflags msg = fatalErrorMsg' (log_action dflags) msg
313
314 fatalErrorMsg' :: LogAction -> MsgDoc -> IO ()
315 fatalErrorMsg' la msg = la SevFatal noSrcSpan defaultErrStyle msg
316
317 compilationProgressMsg :: DynFlags -> String -> IO ()
318 compilationProgressMsg dflags msg
319   = ifVerbose dflags 1 (log_action dflags SevOutput noSrcSpan defaultUserStyle (text msg))
320
321 showPass :: DynFlags -> String -> IO ()
322 showPass dflags what
323   = ifVerbose dflags 2 (log_action dflags SevInfo noSrcSpan defaultUserStyle (text "***" <+> text what <> colon))
324
325 debugTraceMsg :: DynFlags -> Int -> MsgDoc -> IO ()
326 debugTraceMsg dflags val msg
327   = ifVerbose dflags val (log_action dflags SevInfo noSrcSpan defaultDumpStyle msg)
328 \end{code}
329