Update safe haskell error/warn formatting
[ghc.git] / compiler / main / HscMain.hs
1 -------------------------------------------------------------------------------
2 --
3 -- | Main API for compiling plain Haskell source code.
4 --
5 -- This module implements compilation of a Haskell source. It is
6 -- /not/ concerned with preprocessing of source files; this is handled
7 -- in "DriverPipeline".
8 --
9 -- There are various entry points depending on what mode we're in:
10 -- "batch" mode (@--make@), "one-shot" mode (@-c@, @-S@ etc.), and
11 -- "interactive" mode (GHCi). There are also entry points for
12 -- individual passes: parsing, typechecking/renaming, desugaring, and
13 -- simplification.
14 --
15 -- All the functions here take an 'HscEnv' as a parameter, but none of
16 -- them return a new one: 'HscEnv' is treated as an immutable value
17 -- from here on in (although it has mutable components, for the
18 -- caches).
19 --
20 -- Warning messages are dealt with consistently throughout this API:
21 -- during compilation warnings are collected, and before any function
22 -- in @HscMain@ returns, the warnings are either printed, or turned
23 -- into a real compialtion error if the @-Werror@ flag is enabled.
24 --
25 -- (c) The GRASP/AQUA Project, Glasgow University, 1993-2000
26 --
27 -------------------------------------------------------------------------------
28
29 module HscMain
30 (
31 -- * Making an HscEnv
32 newHscEnv
33
34 -- * Compiling complete source files
35 , Compiler
36 , HscStatus' (..)
37 , InteractiveStatus, HscStatus
38 , hscCompileOneShot
39 , hscCompileBatch
40 , hscCompileNothing
41 , hscCompileInteractive
42 , hscCompileCmmFile
43 , hscCompileCore
44
45 -- * Running passes separately
46 , hscParse
47 , hscTypecheckRename
48 , hscDesugar
49 , makeSimpleIface
50 , makeSimpleDetails
51 , hscSimplify -- ToDo, shouldn't really export this
52
53 -- ** Backends
54 , hscOneShotBackendOnly
55 , hscBatchBackendOnly
56 , hscNothingBackendOnly
57 , hscInteractiveBackendOnly
58
59 -- * Support for interactive evaluation
60 , hscParseIdentifier
61 , hscTcRcLookupName
62 , hscTcRnGetInfo
63 , hscCheckSafe
64 #ifdef GHCI
65 , hscGetModuleInterface
66 , hscRnImportDecls
67 , hscTcRnLookupRdrName
68 , hscStmt, hscStmtWithLocation
69 , hscDecls, hscDeclsWithLocation
70 , hscTcExpr, hscImport, hscKcType
71 , hscCompileCoreExpr
72 #endif
73 ) where
74
75 #ifdef GHCI
76 import ByteCodeGen ( byteCodeGen, coreExprToBCOs )
77 import Linker
78 import CoreTidy ( tidyExpr )
79 import Type ( Type )
80 import PrelNames
81 import {- Kind parts of -} Type ( Kind )
82 import CoreLint ( lintUnfolding )
83 import DsMeta ( templateHaskellNames )
84 import VarSet
85 import VarEnv ( emptyTidyEnv )
86 import Panic
87
88 import GHC.Exts
89 #endif
90
91 import Id
92 import Module
93 import Packages
94 import RdrName
95 import HsSyn
96 import CoreSyn
97 import StringBuffer
98 import Parser
99 import Lexer
100 import SrcLoc
101 import TcRnDriver
102 import TcIface ( typecheckIface )
103 import TcRnMonad
104 import IfaceEnv ( initNameCache )
105 import LoadIface ( ifaceStats, initExternalPackageState )
106 import PrelInfo
107 import MkIface
108 import Desugar
109 import SimplCore
110 import TidyPgm
111 import CorePrep
112 import CoreToStg ( coreToStg )
113 import qualified StgCmm ( codeGen )
114 import StgSyn
115 import CostCentre
116 import ProfInit
117 import TyCon
118 import Name
119 import SimplStg ( stg2stg )
120 import CodeGen ( codeGen )
121 import OldCmm as Old ( CmmGroup )
122 import PprCmm ( pprCmms )
123 import CmmParse ( parseCmmFile )
124 import CmmBuildInfoTables
125 import CmmPipeline
126 import CmmInfo
127 import OptimizationFuel ( initOptFuelState )
128 import CmmCvt
129 import CodeOutput
130 import NameEnv ( emptyNameEnv )
131 import NameSet ( emptyNameSet )
132 import InstEnv
133 import FamInstEnv
134 import Fingerprint ( Fingerprint )
135
136 import DynFlags
137 import ErrUtils
138 import UniqSupply ( mkSplitUniqSupply )
139
140 import Outputable
141 import HscStats ( ppSourceStats )
142 import HscTypes
143 import MkExternalCore ( emitExternalCore )
144 import FastString
145 import UniqFM ( emptyUFM )
146 import UniqSupply ( initUs_ )
147 import Bag
148 import Exception
149
150 import Data.List
151 import Control.Monad
152 import Data.Maybe
153 import Data.IORef
154 import System.FilePath as FilePath
155 import System.Directory
156
157 #include "HsVersions.h"
158
159
160 {- **********************************************************************
161 %* *
162 Initialisation
163 %* *
164 %********************************************************************* -}
165
166 newHscEnv :: DynFlags -> IO HscEnv
167 newHscEnv dflags = do
168 eps_var <- newIORef initExternalPackageState
169 us <- mkSplitUniqSupply 'r'
170 nc_var <- newIORef (initNameCache us knownKeyNames)
171 fc_var <- newIORef emptyUFM
172 mlc_var <- newIORef emptyModuleEnv
173 optFuel <- initOptFuelState
174 safe_var <- newIORef True
175 return HscEnv { hsc_dflags = dflags,
176 hsc_targets = [],
177 hsc_mod_graph = [],
178 hsc_IC = emptyInteractiveContext dflags,
179 hsc_HPT = emptyHomePackageTable,
180 hsc_EPS = eps_var,
181 hsc_NC = nc_var,
182 hsc_FC = fc_var,
183 hsc_MLC = mlc_var,
184 hsc_OptFuel = optFuel,
185 hsc_type_env_var = Nothing,
186 hsc_safeInf = safe_var }
187
188
189 knownKeyNames :: [Name] -- Put here to avoid loops involving DsMeta,
190 knownKeyNames = -- where templateHaskellNames are defined
191 map getName wiredInThings
192 ++ basicKnownKeyNames
193 #ifdef GHCI
194 ++ templateHaskellNames
195 #endif
196
197 -- -----------------------------------------------------------------------------
198 -- The Hsc monad: Passing an enviornment and warning state
199
200 newtype Hsc a = Hsc (HscEnv -> WarningMessages -> IO (a, WarningMessages))
201
202 instance Monad Hsc where
203 return a = Hsc $ \_ w -> return (a, w)
204 Hsc m >>= k = Hsc $ \e w -> do (a, w1) <- m e w
205 case k a of
206 Hsc k' -> k' e w1
207
208 instance MonadIO Hsc where
209 liftIO io = Hsc $ \_ w -> do a <- io; return (a, w)
210
211 instance Functor Hsc where
212 fmap f m = m >>= \a -> return $ f a
213
214 runHsc :: HscEnv -> Hsc a -> IO a
215 runHsc hsc_env (Hsc hsc) = do
216 (a, w) <- hsc hsc_env emptyBag
217 printOrThrowWarnings (hsc_dflags hsc_env) w
218 return a
219
220 -- A variant of runHsc that switches in the DynFlags from the
221 -- InteractiveContext before running the Hsc computation.
222 --
223 runInteractiveHsc :: HscEnv -> Hsc a -> IO a
224 runInteractiveHsc hsc_env =
225 runHsc (hsc_env { hsc_dflags = ic_dflags (hsc_IC hsc_env) })
226
227 getWarnings :: Hsc WarningMessages
228 getWarnings = Hsc $ \_ w -> return (w, w)
229
230 clearWarnings :: Hsc ()
231 clearWarnings = Hsc $ \_ _ -> return ((), emptyBag)
232
233 logWarnings :: WarningMessages -> Hsc ()
234 logWarnings w = Hsc $ \_ w0 -> return ((), w0 `unionBags` w)
235
236 getHscEnv :: Hsc HscEnv
237 getHscEnv = Hsc $ \e w -> return (e, w)
238
239 instance HasDynFlags Hsc where
240 getDynFlags = Hsc $ \e w -> return (hsc_dflags e, w)
241
242 handleWarnings :: Hsc ()
243 handleWarnings = do
244 dflags <- getDynFlags
245 w <- getWarnings
246 liftIO $ printOrThrowWarnings dflags w
247 clearWarnings
248
249 -- | log warning in the monad, and if there are errors then
250 -- throw a SourceError exception.
251 logWarningsReportErrors :: Messages -> Hsc ()
252 logWarningsReportErrors (warns,errs) = do
253 logWarnings warns
254 when (not $ isEmptyBag errs) $ throwErrors errs
255
256 -- | Throw some errors.
257 throwErrors :: ErrorMessages -> Hsc a
258 throwErrors = liftIO . throwIO . mkSrcErr
259
260 -- | Deal with errors and warnings returned by a compilation step
261 --
262 -- In order to reduce dependencies to other parts of the compiler, functions
263 -- outside the "main" parts of GHC return warnings and errors as a parameter
264 -- and signal success via by wrapping the result in a 'Maybe' type. This
265 -- function logs the returned warnings and propagates errors as exceptions
266 -- (of type 'SourceError').
267 --
268 -- This function assumes the following invariants:
269 --
270 -- 1. If the second result indicates success (is of the form 'Just x'),
271 -- there must be no error messages in the first result.
272 --
273 -- 2. If there are no error messages, but the second result indicates failure
274 -- there should be warnings in the first result. That is, if the action
275 -- failed, it must have been due to the warnings (i.e., @-Werror@).
276 ioMsgMaybe :: IO (Messages, Maybe a) -> Hsc a
277 ioMsgMaybe ioA = do
278 ((warns,errs), mb_r) <- liftIO ioA
279 logWarnings warns
280 case mb_r of
281 Nothing -> throwErrors errs
282 Just r -> ASSERT( isEmptyBag errs ) return r
283
284 -- | like ioMsgMaybe, except that we ignore error messages and return
285 -- 'Nothing' instead.
286 ioMsgMaybe' :: IO (Messages, Maybe a) -> Hsc (Maybe a)
287 ioMsgMaybe' ioA = do
288 ((warns,_errs), mb_r) <- liftIO $ ioA
289 logWarnings warns
290 return mb_r
291
292 -- -----------------------------------------------------------------------------
293 -- | Lookup things in the compiler's environment
294
295 #ifdef GHCI
296 hscTcRnLookupRdrName :: HscEnv -> RdrName -> IO [Name]
297 hscTcRnLookupRdrName hsc_env0 rdr_name = runInteractiveHsc hsc_env0 $ do
298 hsc_env <- getHscEnv
299 ioMsgMaybe $ tcRnLookupRdrName hsc_env rdr_name
300 #endif
301
302 hscTcRcLookupName :: HscEnv -> Name -> IO (Maybe TyThing)
303 hscTcRcLookupName hsc_env0 name = runInteractiveHsc hsc_env0 $ do
304 hsc_env <- getHscEnv
305 ioMsgMaybe' $ tcRnLookupName hsc_env name
306 -- ignore errors: the only error we're likely to get is
307 -- "name not found", and the Maybe in the return type
308 -- is used to indicate that.
309
310 hscTcRnGetInfo :: HscEnv -> Name -> IO (Maybe (TyThing, Fixity, [ClsInst]))
311 hscTcRnGetInfo hsc_env0 name = runInteractiveHsc hsc_env0 $ do
312 hsc_env <- getHscEnv
313 ioMsgMaybe' $ tcRnGetInfo hsc_env name
314
315 #ifdef GHCI
316 hscGetModuleInterface :: HscEnv -> Module -> IO ModIface
317 hscGetModuleInterface hsc_env0 mod = runInteractiveHsc hsc_env0 $ do
318 hsc_env <- getHscEnv
319 ioMsgMaybe $ getModuleInterface hsc_env mod
320
321 -- -----------------------------------------------------------------------------
322 -- | Rename some import declarations
323 hscRnImportDecls :: HscEnv -> [LImportDecl RdrName] -> IO GlobalRdrEnv
324 hscRnImportDecls hsc_env0 import_decls = runInteractiveHsc hsc_env0 $ do
325 hsc_env <- getHscEnv
326 ioMsgMaybe $ tcRnImportDecls hsc_env import_decls
327 #endif
328
329 -- -----------------------------------------------------------------------------
330 -- | parse a file, returning the abstract syntax
331
332 hscParse :: HscEnv -> ModSummary -> IO HsParsedModule
333 hscParse hsc_env mod_summary = runHsc hsc_env $ hscParse' mod_summary
334
335 -- internal version, that doesn't fail due to -Werror
336 hscParse' :: ModSummary -> Hsc HsParsedModule
337 hscParse' mod_summary = do
338 dflags <- getDynFlags
339 let src_filename = ms_hspp_file mod_summary
340 maybe_src_buf = ms_hspp_buf mod_summary
341
342 -------------------------- Parser ----------------
343 liftIO $ showPass dflags "Parser"
344 {-# SCC "Parser" #-} do
345
346 -- sometimes we already have the buffer in memory, perhaps
347 -- because we needed to parse the imports out of it, or get the
348 -- module name.
349 buf <- case maybe_src_buf of
350 Just b -> return b
351 Nothing -> liftIO $ hGetStringBuffer src_filename
352
353 let loc = mkRealSrcLoc (mkFastString src_filename) 1 1
354
355 case unP parseModule (mkPState dflags buf loc) of
356 PFailed span err ->
357 liftIO $ throwOneError (mkPlainErrMsg span err)
358
359 POk pst rdr_module -> do
360 logWarningsReportErrors (getMessages pst)
361 liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" $
362 ppr rdr_module
363 liftIO $ dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics" $
364 ppSourceStats False rdr_module
365
366 -- To get the list of extra source files, we take the list
367 -- that the parser gave us,
368 -- - eliminate files beginning with '<'. gcc likes to use
369 -- pseudo-filenames like "<built-in>" and "<command-line>"
370 -- - normalise them (elimiante differences between ./f and f)
371 -- - filter out the preprocessed source file
372 -- - filter out anything beginning with tmpdir
373 -- - remove duplicates
374 -- - filter out the .hs/.lhs source filename if we have one
375 --
376 let n_hspp = FilePath.normalise src_filename
377 srcs0 = nub $ filter (not . (tmpDir dflags `isPrefixOf`))
378 $ filter (not . (== n_hspp))
379 $ map FilePath.normalise
380 $ filter (not . (== '<') . head)
381 $ map unpackFS
382 $ srcfiles pst
383 srcs1 = case ml_hs_file (ms_location mod_summary) of
384 Just f -> filter (/= FilePath.normalise f) srcs0
385 Nothing -> srcs0
386
387 -- sometimes we see source files from earlier
388 -- preprocessing stages that cannot be found, so just
389 -- filter them out:
390 srcs2 <- liftIO $ filterM doesFileExist srcs1
391
392 return HsParsedModule {
393 hpm_module = rdr_module,
394 hpm_src_files = srcs2
395 }
396
397 -- XXX: should this really be a Maybe X? Check under which circumstances this
398 -- can become a Nothing and decide whether this should instead throw an
399 -- exception/signal an error.
400 type RenamedStuff =
401 (Maybe (HsGroup Name, [LImportDecl Name], Maybe [LIE Name],
402 Maybe LHsDocString))
403
404 -- | Rename and typecheck a module, additionally returning the renamed syntax
405 hscTypecheckRename :: HscEnv -> ModSummary -> HsParsedModule
406 -> IO (TcGblEnv, RenamedStuff)
407 hscTypecheckRename hsc_env mod_summary rdr_module = runHsc hsc_env $ do
408 tc_result <- {-# SCC "Typecheck-Rename" #-}
409 ioMsgMaybe $
410 tcRnModule hsc_env (ms_hsc_src mod_summary)
411 True rdr_module
412
413 -- This 'do' is in the Maybe monad!
414 let rn_info = do decl <- tcg_rn_decls tc_result
415 let imports = tcg_rn_imports tc_result
416 exports = tcg_rn_exports tc_result
417 doc_hdr = tcg_doc_hdr tc_result
418 return (decl,imports,exports,doc_hdr)
419
420 return (tc_result, rn_info)
421
422 -- | Convert a typechecked module to Core
423 hscDesugar :: HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts
424 hscDesugar hsc_env mod_summary tc_result =
425 runHsc hsc_env $ hscDesugar' (ms_location mod_summary) tc_result
426
427 hscDesugar' :: ModLocation -> TcGblEnv -> Hsc ModGuts
428 hscDesugar' mod_location tc_result = do
429 hsc_env <- getHscEnv
430 r <- ioMsgMaybe $
431 {-# SCC "deSugar" #-}
432 deSugar hsc_env mod_location tc_result
433
434 -- always check -Werror after desugaring, this is the last opportunity for
435 -- warnings to arise before the backend.
436 handleWarnings
437 return r
438
439 -- | Make a 'ModIface' from the results of typechecking. Used when
440 -- not optimising, and the interface doesn't need to contain any
441 -- unfoldings or other cross-module optimisation info.
442 -- ToDo: the old interface is only needed to get the version numbers,
443 -- we should use fingerprint versions instead.
444 makeSimpleIface :: HscEnv -> Maybe ModIface -> TcGblEnv -> ModDetails
445 -> IO (ModIface,Bool)
446 makeSimpleIface hsc_env maybe_old_iface tc_result details =
447 runHsc hsc_env $ ioMsgMaybe $
448 mkIfaceTc hsc_env (fmap mi_iface_hash maybe_old_iface) details tc_result
449
450 -- | Make a 'ModDetails' from the results of typechecking. Used when
451 -- typechecking only, as opposed to full compilation.
452 makeSimpleDetails :: HscEnv -> TcGblEnv -> IO ModDetails
453 makeSimpleDetails hsc_env tc_result = mkBootModDetailsTc hsc_env tc_result
454
455
456 {- **********************************************************************
457 %* *
458 The main compiler pipeline
459 %* *
460 %********************************************************************* -}
461
462 {-
463 --------------------------------
464 The compilation proper
465 --------------------------------
466
467 It's the task of the compilation proper to compile Haskell, hs-boot and core
468 files to either byte-code, hard-code (C, asm, LLVM, ect) or to nothing at all
469 (the module is still parsed and type-checked. This feature is mostly used by
470 IDE's and the likes). Compilation can happen in either 'one-shot', 'batch',
471 'nothing', or 'interactive' mode. 'One-shot' mode targets hard-code, 'batch'
472 mode targets hard-code, 'nothing' mode targets nothing and 'interactive' mode
473 targets byte-code.
474
475 The modes are kept separate because of their different types and meanings:
476
477 * In 'one-shot' mode, we're only compiling a single file and can therefore
478 discard the new ModIface and ModDetails. This is also the reason it only
479 targets hard-code; compiling to byte-code or nothing doesn't make sense when
480 we discard the result.
481
482 * 'Batch' mode is like 'one-shot' except that we keep the resulting ModIface
483 and ModDetails. 'Batch' mode doesn't target byte-code since that require us to
484 return the newly compiled byte-code.
485
486 * 'Nothing' mode has exactly the same type as 'batch' mode but they're still
487 kept separate. This is because compiling to nothing is fairly special: We
488 don't output any interface files, we don't run the simplifier and we don't
489 generate any code.
490
491 * 'Interactive' mode is similar to 'batch' mode except that we return the
492 compiled byte-code together with the ModIface and ModDetails.
493
494 Trying to compile a hs-boot file to byte-code will result in a run-time error.
495 This is the only thing that isn't caught by the type-system.
496 -}
497
498
499 -- | Status of a compilation to hard-code or nothing.
500 data HscStatus' a
501 = HscNoRecomp
502 | HscRecomp
503 (Maybe FilePath) -- Has stub files. This is a hack. We can't compile
504 -- C files here since it's done in DriverPipeline.
505 -- For now we just return True if we want the caller
506 -- to compile them for us.
507 a
508
509 -- This is a bit ugly. Since we use a typeclass below and would like to avoid
510 -- functional dependencies, we have to parameterise the typeclass over the
511 -- result type. Therefore we need to artificially distinguish some types. We do
512 -- this by adding type tags which will simply be ignored by the caller.
513 type HscStatus = HscStatus' ()
514 type InteractiveStatus = HscStatus' (Maybe (CompiledByteCode, ModBreaks))
515 -- INVARIANT: result is @Nothing@ <=> input was a boot file
516
517 type OneShotResult = HscStatus
518 type BatchResult = (HscStatus, ModIface, ModDetails)
519 type NothingResult = (HscStatus, ModIface, ModDetails)
520 type InteractiveResult = (InteractiveStatus, ModIface, ModDetails)
521
522 -- ToDo: The old interface and module index are only using in 'batch' and
523 -- 'interactive' mode. They should be removed from 'oneshot' mode.
524 type Compiler result = HscEnv
525 -> ModSummary
526 -> SourceModified
527 -> Maybe ModIface -- Old interface, if available
528 -> Maybe (Int,Int) -- Just (i,n) <=> module i of n (for msgs)
529 -> IO result
530
531 data HsCompiler a = HsCompiler {
532 -- | Called when no recompilation is necessary.
533 hscNoRecomp :: ModIface
534 -> Hsc a,
535
536 -- | Called to recompile the module.
537 hscRecompile :: ModSummary -> Maybe Fingerprint
538 -> Hsc a,
539
540 hscBackend :: TcGblEnv -> ModSummary -> Maybe Fingerprint
541 -> Hsc a,
542
543 -- | Code generation for Boot modules.
544 hscGenBootOutput :: TcGblEnv -> ModSummary -> Maybe Fingerprint
545 -> Hsc a,
546
547 -- | Code generation for normal modules.
548 hscGenOutput :: ModGuts -> ModSummary -> Maybe Fingerprint
549 -> Hsc a
550 }
551
552 genericHscCompile :: HsCompiler a
553 -> (HscEnv -> Maybe (Int,Int) -> RecompileRequired -> ModSummary -> IO ())
554 -> HscEnv -> ModSummary -> SourceModified
555 -> Maybe ModIface -> Maybe (Int, Int)
556 -> IO a
557 genericHscCompile compiler hscMessage hsc_env
558 mod_summary source_modified
559 mb_old_iface0 mb_mod_index
560 = do
561 (recomp_reqd, mb_checked_iface)
562 <- {-# SCC "checkOldIface" #-}
563 checkOldIface hsc_env mod_summary
564 source_modified mb_old_iface0
565 -- save the interface that comes back from checkOldIface.
566 -- In one-shot mode we don't have the old iface until this
567 -- point, when checkOldIface reads it from the disk.
568 let mb_old_hash = fmap mi_iface_hash mb_checked_iface
569
570 let skip iface = do
571 hscMessage hsc_env mb_mod_index UpToDate mod_summary
572 runHsc hsc_env $ hscNoRecomp compiler iface
573
574 compile reason = do
575 hscMessage hsc_env mb_mod_index reason mod_summary
576 runHsc hsc_env $ hscRecompile compiler mod_summary mb_old_hash
577
578 stable = case source_modified of
579 SourceUnmodifiedAndStable -> True
580 _ -> False
581
582 -- If the module used TH splices when it was last compiled,
583 -- then the recompilation check is not accurate enough (#481)
584 -- and we must ignore it. However, if the module is stable
585 -- (none of the modules it depends on, directly or indirectly,
586 -- changed), then we *can* skip recompilation. This is why
587 -- the SourceModified type contains SourceUnmodifiedAndStable,
588 -- and it's pretty important: otherwise ghc --make would
589 -- always recompile TH modules, even if nothing at all has
590 -- changed. Stability is just the same check that make is
591 -- doing for us in one-shot mode.
592
593 case mb_checked_iface of
594 Just iface | not (recompileRequired recomp_reqd) ->
595 if mi_used_th iface && not stable
596 then compile RecompForcedByTH
597 else skip iface
598 _otherwise ->
599 compile recomp_reqd
600
601 hscCheckRecompBackend :: HsCompiler a -> TcGblEnv -> Compiler a
602 hscCheckRecompBackend compiler tc_result hsc_env mod_summary
603 source_modified mb_old_iface _m_of_n
604 = do
605 (recomp_reqd, mb_checked_iface)
606 <- {-# SCC "checkOldIface" #-}
607 checkOldIface hsc_env mod_summary
608 source_modified mb_old_iface
609
610 let mb_old_hash = fmap mi_iface_hash mb_checked_iface
611 case mb_checked_iface of
612 Just iface | not (recompileRequired recomp_reqd)
613 -> runHsc hsc_env $
614 hscNoRecomp compiler
615 iface{ mi_globals = Just (tcg_rdr_env tc_result) }
616 _otherwise
617 -> runHsc hsc_env $
618 hscBackend compiler tc_result mod_summary mb_old_hash
619
620 genericHscRecompile :: HsCompiler a
621 -> ModSummary -> Maybe Fingerprint
622 -> Hsc a
623 genericHscRecompile compiler mod_summary mb_old_hash
624 | ExtCoreFile <- ms_hsc_src mod_summary =
625 panic "GHC does not currently support reading External Core files"
626 | otherwise = do
627 tc_result <- hscFileFrontEnd mod_summary
628 hscBackend compiler tc_result mod_summary mb_old_hash
629
630 genericHscBackend :: HsCompiler a
631 -> TcGblEnv -> ModSummary -> Maybe Fingerprint
632 -> Hsc a
633 genericHscBackend compiler tc_result mod_summary mb_old_hash
634 | HsBootFile <- ms_hsc_src mod_summary =
635 hscGenBootOutput compiler tc_result mod_summary mb_old_hash
636 | otherwise = do
637 guts <- hscDesugar' (ms_location mod_summary) tc_result
638 hscGenOutput compiler guts mod_summary mb_old_hash
639
640 compilerBackend :: HsCompiler a -> TcGblEnv -> Compiler a
641 compilerBackend comp tcg hsc_env ms' _ _mb_old_iface _ =
642 runHsc hsc_env $ hscBackend comp tcg ms' Nothing
643
644 --------------------------------------------------------------
645 -- Compilers
646 --------------------------------------------------------------
647
648 hscOneShotCompiler :: HsCompiler OneShotResult
649 hscOneShotCompiler = HsCompiler {
650
651 hscNoRecomp = \_old_iface -> do
652 hsc_env <- getHscEnv
653 liftIO $ dumpIfaceStats hsc_env
654 return HscNoRecomp
655
656 , hscRecompile = genericHscRecompile hscOneShotCompiler
657
658 , hscBackend = \tc_result mod_summary mb_old_hash -> do
659 dflags <- getDynFlags
660 case hscTarget dflags of
661 HscNothing -> return (HscRecomp Nothing ())
662 _otherw -> genericHscBackend hscOneShotCompiler
663 tc_result mod_summary mb_old_hash
664
665 , hscGenBootOutput = \tc_result mod_summary mb_old_iface -> do
666 (iface, changed, _) <- hscSimpleIface tc_result mb_old_iface
667 hscWriteIface iface changed mod_summary
668 return (HscRecomp Nothing ())
669
670 , hscGenOutput = \guts0 mod_summary mb_old_iface -> do
671 guts <- hscSimplify' guts0
672 (iface, changed, _details, cgguts) <- hscNormalIface guts mb_old_iface
673 hscWriteIface iface changed mod_summary
674 hasStub <- hscGenHardCode cgguts mod_summary
675 return (HscRecomp hasStub ())
676 }
677
678 -- Compile Haskell, boot and extCore in OneShot mode.
679 hscCompileOneShot :: Compiler OneShotResult
680 hscCompileOneShot hsc_env mod_summary src_changed mb_old_iface mb_i_of_n
681 = do
682 -- One-shot mode needs a knot-tying mutable variable for interface
683 -- files. See TcRnTypes.TcGblEnv.tcg_type_env_var.
684 type_env_var <- newIORef emptyNameEnv
685 let mod = ms_mod mod_summary
686 hsc_env' = hsc_env{ hsc_type_env_var = Just (mod, type_env_var) }
687
688 genericHscCompile hscOneShotCompiler
689 oneShotMsg hsc_env' mod_summary src_changed
690 mb_old_iface mb_i_of_n
691
692 hscOneShotBackendOnly :: TcGblEnv -> Compiler OneShotResult
693 hscOneShotBackendOnly = compilerBackend hscOneShotCompiler
694
695 --------------------------------------------------------------
696
697 hscBatchCompiler :: HsCompiler BatchResult
698 hscBatchCompiler = HsCompiler {
699
700 hscNoRecomp = \iface -> do
701 details <- genModDetails iface
702 return (HscNoRecomp, iface, details)
703
704 , hscRecompile = genericHscRecompile hscBatchCompiler
705
706 , hscBackend = genericHscBackend hscBatchCompiler
707
708 , hscGenBootOutput = \tc_result mod_summary mb_old_iface -> do
709 (iface, changed, details) <- hscSimpleIface tc_result mb_old_iface
710 hscWriteIface iface changed mod_summary
711 return (HscRecomp Nothing (), iface, details)
712
713 , hscGenOutput = \guts0 mod_summary mb_old_iface -> do
714 guts <- hscSimplify' guts0
715 (iface, changed, details, cgguts) <- hscNormalIface guts mb_old_iface
716 hscWriteIface iface changed mod_summary
717 hasStub <- hscGenHardCode cgguts mod_summary
718 return (HscRecomp hasStub (), iface, details)
719 }
720
721 -- | Compile Haskell, boot and extCore in batch mode.
722 hscCompileBatch :: Compiler (HscStatus, ModIface, ModDetails)
723 hscCompileBatch = genericHscCompile hscBatchCompiler batchMsg
724
725 hscBatchBackendOnly :: TcGblEnv -> Compiler BatchResult
726 hscBatchBackendOnly = hscCheckRecompBackend hscBatchCompiler
727
728 --------------------------------------------------------------
729
730 hscInteractiveCompiler :: HsCompiler InteractiveResult
731 hscInteractiveCompiler = HsCompiler {
732 hscNoRecomp = \iface -> do
733 details <- genModDetails iface
734 return (HscNoRecomp, iface, details)
735
736 , hscRecompile = genericHscRecompile hscInteractiveCompiler
737
738 , hscBackend = genericHscBackend hscInteractiveCompiler
739
740 , hscGenBootOutput = \tc_result _mod_summary mb_old_iface -> do
741 (iface, _changed, details) <- hscSimpleIface tc_result mb_old_iface
742 return (HscRecomp Nothing Nothing, iface, details)
743
744 , hscGenOutput = \guts0 mod_summary mb_old_iface -> do
745 guts <- hscSimplify' guts0
746 (iface, _changed, details, cgguts) <- hscNormalIface guts mb_old_iface
747 hscInteractive (iface, details, cgguts) mod_summary
748 }
749
750 -- Compile Haskell, extCore to bytecode.
751 hscCompileInteractive :: Compiler (InteractiveStatus, ModIface, ModDetails)
752 hscCompileInteractive = genericHscCompile hscInteractiveCompiler batchMsg
753
754 hscInteractiveBackendOnly :: TcGblEnv -> Compiler InteractiveResult
755 hscInteractiveBackendOnly = compilerBackend hscInteractiveCompiler
756
757 --------------------------------------------------------------
758
759 hscNothingCompiler :: HsCompiler NothingResult
760 hscNothingCompiler = HsCompiler {
761 hscNoRecomp = \iface -> do
762 details <- genModDetails iface
763 return (HscNoRecomp, iface, details)
764
765 , hscRecompile = genericHscRecompile hscNothingCompiler
766
767 , hscBackend = \tc_result _mod_summary mb_old_iface -> do
768 handleWarnings
769 (iface, _changed, details) <- hscSimpleIface tc_result mb_old_iface
770 return (HscRecomp Nothing (), iface, details)
771
772 , hscGenBootOutput = \_ _ _ ->
773 panic "hscCompileNothing: hscGenBootOutput should not be called"
774
775 , hscGenOutput = \_ _ _ ->
776 panic "hscCompileNothing: hscGenOutput should not be called"
777 }
778
779 -- Type-check Haskell and .hs-boot only (no external core)
780 hscCompileNothing :: Compiler (HscStatus, ModIface, ModDetails)
781 hscCompileNothing = genericHscCompile hscNothingCompiler batchMsg
782
783 hscNothingBackendOnly :: TcGblEnv -> Compiler NothingResult
784 hscNothingBackendOnly = compilerBackend hscNothingCompiler
785
786 --------------------------------------------------------------
787 -- NoRecomp handlers
788 --------------------------------------------------------------
789
790 genModDetails :: ModIface -> Hsc ModDetails
791 genModDetails old_iface
792 = do
793 hsc_env <- getHscEnv
794 new_details <- {-# SCC "tcRnIface" #-}
795 liftIO $ initIfaceCheck hsc_env (typecheckIface old_iface)
796 liftIO $ dumpIfaceStats hsc_env
797 return new_details
798
799 --------------------------------------------------------------
800 -- Progress displayers.
801 --------------------------------------------------------------
802
803 oneShotMsg :: HscEnv -> Maybe (Int,Int) -> RecompileRequired -> ModSummary
804 -> IO ()
805 oneShotMsg hsc_env _mb_mod_index recomp _mod_summary =
806 case recomp of
807 UpToDate ->
808 compilationProgressMsg (hsc_dflags hsc_env) $
809 "compilation IS NOT required"
810 _other ->
811 return ()
812
813 batchMsg :: HscEnv -> Maybe (Int,Int) -> RecompileRequired -> ModSummary
814 -> IO ()
815 batchMsg hsc_env mb_mod_index recomp mod_summary =
816 case recomp of
817 MustCompile -> showMsg "Compiling " ""
818 UpToDate
819 | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg "Skipping " ""
820 | otherwise -> return ()
821 RecompBecause reason -> showMsg "Compiling " (" [" ++ reason ++ "]")
822 RecompForcedByTH -> showMsg "Compiling " " [TH]"
823 where
824 showMsg msg reason =
825 compilationProgressMsg (hsc_dflags hsc_env) $
826 (showModuleIndex mb_mod_index ++
827 msg ++ showModMsg (hscTarget (hsc_dflags hsc_env))
828 (recompileRequired recomp) mod_summary)
829 ++ reason
830
831 --------------------------------------------------------------
832 -- FrontEnds
833 --------------------------------------------------------------
834
835 hscFileFrontEnd :: ModSummary -> Hsc TcGblEnv
836 hscFileFrontEnd mod_summary = do
837 hpm <- hscParse' mod_summary
838 hsc_env <- getHscEnv
839 dflags <- getDynFlags
840 tcg_env <-
841 {-# SCC "Typecheck-Rename" #-}
842 ioMsgMaybe $
843 tcRnModule hsc_env (ms_hsc_src mod_summary) False hpm
844 tcSafeOK <- liftIO $ readIORef (tcg_safeInfer tcg_env)
845
846 -- end of the Safe Haskell line, how to respond to user?
847 if not (safeHaskellOn dflags) || (safeInferOn dflags && not tcSafeOK)
848
849 -- if safe haskell off or safe infer failed, wipe trust
850 then wipeTrust tcg_env emptyBag
851
852 -- module safe, throw warning if needed
853 else do
854 tcg_env' <- hscCheckSafeImports tcg_env
855 safe <- liftIO $ hscGetSafeInf hsc_env
856 when (safe && wopt Opt_WarnSafe dflags)
857 (logWarnings $ unitBag $
858 mkPlainWarnMsg (warnSafeOnLoc dflags) $ errSafe tcg_env')
859 return tcg_env'
860 where
861 pprMod t = ppr $ moduleName $ tcg_mod t
862 errSafe t = quotes (pprMod t) <+> text "has been infered as safe!"
863
864 --------------------------------------------------------------
865 -- Safe Haskell
866 --------------------------------------------------------------
867
868 -- Note [Safe Haskell Trust Check]
869 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
870 -- Safe Haskell checks that an import is trusted according to the following
871 -- rules for an import of module M that resides in Package P:
872 --
873 -- * If M is recorded as Safe and all its trust dependencies are OK
874 -- then M is considered safe.
875 -- * If M is recorded as Trustworthy and P is considered trusted and
876 -- all M's trust dependencies are OK then M is considered safe.
877 --
878 -- By trust dependencies we mean that the check is transitive. So if
879 -- a module M that is Safe relies on a module N that is trustworthy,
880 -- importing module M will first check (according to the second case)
881 -- that N is trusted before checking M is trusted.
882 --
883 -- This is a minimal description, so please refer to the user guide
884 -- for more details. The user guide is also considered the authoritative
885 -- source in this matter, not the comments or code.
886
887
888 -- Note [Safe Haskell Inference]
889 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
890 -- Safe Haskell does Safe inference on modules that don't have any specific
891 -- safe haskell mode flag. The basic aproach to this is:
892 -- * When deciding if we need to do a Safe language check, treat
893 -- an unmarked module as having -XSafe mode specified.
894 -- * For checks, don't throw errors but return them to the caller.
895 -- * Caller checks if there are errors:
896 -- * For modules explicitly marked -XSafe, we throw the errors.
897 -- * For unmarked modules (inference mode), we drop the errors
898 -- and mark the module as being Unsafe.
899
900
901 -- | Check that the safe imports of the module being compiled are valid.
902 -- If not we either issue a compilation error if the module is explicitly
903 -- using Safe Haskell, or mark the module as unsafe if we're in safe
904 -- inference mode.
905 hscCheckSafeImports :: TcGblEnv -> Hsc TcGblEnv
906 hscCheckSafeImports tcg_env = do
907 dflags <- getDynFlags
908 tcg_env' <- checkSafeImports dflags tcg_env
909 case safeLanguageOn dflags of
910 True -> do
911 -- we nuke user written RULES in -XSafe
912 logWarnings $ warns (tcg_rules tcg_env')
913 return tcg_env' { tcg_rules = [] }
914 False
915 -- user defined RULES, so not safe or already unsafe
916 | safeInferOn dflags && not (null $ tcg_rules tcg_env') ||
917 safeHaskell dflags == Sf_None
918 -> wipeTrust tcg_env' $ warns (tcg_rules tcg_env')
919
920 -- trustworthy OR safe infered with no RULES
921 | otherwise
922 -> return tcg_env'
923
924 where
925 warns rules = listToBag $ map warnRules rules
926 warnRules (L loc (HsRule n _ _ _ _ _ _)) =
927 mkPlainWarnMsg loc $
928 text "Rule \"" <> ftext n <> text "\" ignored" $+$
929 text "User defined rules are disabled under Safe Haskell"
930
931 -- | Validate that safe imported modules are actually safe. For modules in the
932 -- HomePackage (the package the module we are compiling in resides) this just
933 -- involves checking its trust type is 'Safe' or 'Trustworthy'. For modules
934 -- that reside in another package we also must check that the external pacakge
935 -- is trusted. See the Note [Safe Haskell Trust Check] above for more
936 -- information.
937 --
938 -- The code for this is quite tricky as the whole algorithm is done in a few
939 -- distinct phases in different parts of the code base. See
940 -- RnNames.rnImportDecl for where package trust dependencies for a module are
941 -- collected and unioned. Specifically see the Note [RnNames . Tracking Trust
942 -- Transitively] and the Note [RnNames . Trust Own Package].
943 checkSafeImports :: DynFlags -> TcGblEnv -> Hsc TcGblEnv
944 checkSafeImports dflags tcg_env
945 = do
946 -- We want to use the warning state specifically for detecting if safe
947 -- inference has failed, so store and clear any existing warnings.
948 oldErrs <- getWarnings
949 clearWarnings
950
951 imps <- mapM condense imports'
952 pkgs <- mapM checkSafe imps
953
954 -- grab any safe haskell specific errors and restore old warnings
955 errs <- getWarnings
956 clearWarnings
957 logWarnings oldErrs
958
959 -- See the Note [Safe Haskell Inference]
960 case (not $ isEmptyBag errs) of
961
962 -- We have errors!
963 True ->
964 -- did we fail safe inference or fail -XSafe?
965 case safeInferOn dflags of
966 True -> wipeTrust tcg_env errs
967 False -> liftIO . throwIO . mkSrcErr $ errs
968
969 -- All good matey!
970 False -> do
971 when (packageTrustOn dflags) $ checkPkgTrust dflags pkg_reqs
972 -- add in trusted package requirements for this module
973 let new_trust = emptyImportAvails { imp_trust_pkgs = catMaybes pkgs }
974 return tcg_env { tcg_imports = imp_info `plusImportAvails` new_trust }
975
976 where
977 imp_info = tcg_imports tcg_env -- ImportAvails
978 imports = imp_mods imp_info -- ImportedMods
979 imports' = moduleEnvToList imports -- (Module, [ImportedModsVal])
980 pkg_reqs = imp_trust_pkgs imp_info -- [PackageId]
981
982 condense :: (Module, [ImportedModsVal]) -> Hsc (Module, SrcSpan, IsSafeImport)
983 condense (_, []) = panic "HscMain.condense: Pattern match failure!"
984 condense (m, x:xs) = do (_,_,l,s) <- foldlM cond' x xs
985 -- we turn all imports into safe ones when
986 -- inference mode is on.
987 let s' = if safeInferOn dflags then True else s
988 return (m, l, s')
989
990 -- ImportedModsVal = (ModuleName, Bool, SrcSpan, IsSafeImport)
991 cond' :: ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal
992 cond' v1@(m1,_,l1,s1) (_,_,_,s2)
993 | s1 /= s2
994 = throwErrors $ unitBag $ mkPlainErrMsg l1
995 (text "Module" <+> ppr m1 <+>
996 (text $ "is imported both as a safe and unsafe import!"))
997 | otherwise
998 = return v1
999
1000 -- easier interface to work with
1001 checkSafe (_, _, False) = return Nothing
1002 checkSafe (m, l, True ) = fst `fmap` hscCheckSafe' dflags m l
1003
1004 -- | Check that a module is safe to import.
1005 --
1006 -- We return True to indicate the import is safe and False otherwise
1007 -- although in the False case an exception may be thrown first.
1008 hscCheckSafe :: HscEnv -> Module -> SrcSpan -> IO Bool
1009 hscCheckSafe hsc_env m l = runHsc hsc_env $ do
1010 dflags <- getDynFlags
1011 pkgs <- snd `fmap` hscCheckSafe' dflags m l
1012 when (packageTrustOn dflags) $ checkPkgTrust dflags pkgs
1013 errs <- getWarnings
1014 return $ isEmptyBag errs
1015
1016 hscCheckSafe' :: DynFlags -> Module -> SrcSpan -> Hsc (Maybe PackageId, [PackageId])
1017 hscCheckSafe' dflags m l = do
1018 (tw, pkgs) <- isModSafe m l
1019 case tw of
1020 False -> return (Nothing, pkgs)
1021 True | isHomePkg m -> return (Nothing, pkgs)
1022 | otherwise -> return (Just $ modulePackageId m, pkgs)
1023 where
1024 -- Is a module trusted? If not, throw or log errors depending on the type.
1025 -- Return (regardless of trusted or not) if the trust type requires the
1026 -- modules own package be trusted and a list of other packages required to
1027 -- be trusted (these later ones haven't been checked)
1028 isModSafe :: Module -> SrcSpan -> Hsc (Bool, [PackageId])
1029 isModSafe m l = do
1030 iface <- lookup' m
1031 case iface of
1032 -- can't load iface to check trust!
1033 Nothing -> throwErrors $ unitBag $ mkPlainErrMsg l
1034 $ text "Can't load the interface file for" <+> ppr m
1035 <> text ", to check that it can be safely imported"
1036
1037 -- got iface, check trust
1038 Just iface' -> do
1039 let trust = getSafeMode $ mi_trust iface'
1040 trust_own_pkg = mi_trust_pkg iface'
1041 -- check module is trusted
1042 safeM = trust `elem` [Sf_SafeInfered, Sf_Safe, Sf_Trustworthy]
1043 -- check package is trusted
1044 safeP = packageTrusted trust trust_own_pkg m
1045 -- pkg trust reqs
1046 pkgRs = map fst $ filter snd $ dep_pkgs $ mi_deps iface'
1047 case (safeM, safeP) of
1048 -- General errors we throw but Safe errors we log
1049 (True, True ) -> return (trust == Sf_Trustworthy, pkgRs)
1050 (True, False) -> liftIO . throwIO $ pkgTrustErr
1051 (False, _ ) -> logWarnings modTrustErr >>
1052 return (trust == Sf_Trustworthy, pkgRs)
1053
1054 where
1055 pkgTrustErr = mkSrcErr $ unitBag $ mkPlainErrMsg l $
1056 sep [ ppr (moduleName m)
1057 <> text ": Can't be safely imported!"
1058 , text "The package (" <> ppr (modulePackageId m)
1059 <> text ") the module resides in isn't trusted."
1060 ]
1061 modTrustErr = unitBag $ mkPlainErrMsg l $
1062 sep [ ppr (moduleName m)
1063 <> text ": Can't be safely imported!"
1064 , text "The module itself isn't safe." ]
1065
1066 -- | Check the package a module resides in is trusted. Safe compiled
1067 -- modules are trusted without requiring that their package is trusted. For
1068 -- trustworthy modules, modules in the home package are trusted but
1069 -- otherwise we check the package trust flag.
1070 packageTrusted :: SafeHaskellMode -> Bool -> Module -> Bool
1071 packageTrusted _ _ _
1072 | not (packageTrustOn dflags) = True
1073 packageTrusted Sf_Safe False _ = True
1074 packageTrusted Sf_SafeInfered False _ = True
1075 packageTrusted _ _ m
1076 | isHomePkg m = True
1077 | otherwise = trusted $ getPackageDetails (pkgState dflags)
1078 (modulePackageId m)
1079
1080 lookup' :: Module -> Hsc (Maybe ModIface)
1081 lookup' m = do
1082 hsc_env <- getHscEnv
1083 hsc_eps <- liftIO $ hscEPS hsc_env
1084 let pkgIfaceT = eps_PIT hsc_eps
1085 homePkgT = hsc_HPT hsc_env
1086 iface = lookupIfaceByModule dflags homePkgT pkgIfaceT m
1087 #ifdef GHCI
1088 -- the 'lookupIfaceByModule' method will always fail when calling from GHCi
1089 -- as the compiler hasn't filled in the various module tables
1090 -- so we need to call 'getModuleInterface' to load from disk
1091 iface' <- case iface of
1092 Just _ -> return iface
1093 Nothing -> snd `fmap` (liftIO $ getModuleInterface hsc_env m)
1094 return iface'
1095 #else
1096 return iface
1097 #endif
1098
1099
1100 isHomePkg :: Module -> Bool
1101 isHomePkg m
1102 | thisPackage dflags == modulePackageId m = True
1103 | otherwise = False
1104
1105 -- | Check the list of packages are trusted.
1106 checkPkgTrust :: DynFlags -> [PackageId] -> Hsc ()
1107 checkPkgTrust dflags pkgs =
1108 case errors of
1109 [] -> return ()
1110 _ -> (liftIO . throwIO . mkSrcErr . listToBag) errors
1111 where
1112 errors = catMaybes $ map go pkgs
1113 go pkg
1114 | trusted $ getPackageDetails (pkgState dflags) pkg
1115 = Nothing
1116 | otherwise
1117 = Just $ mkPlainErrMsg noSrcSpan
1118 $ text "The package (" <> ppr pkg <> text ") is required" <>
1119 text " to be trusted but it isn't!"
1120
1121 -- | Set module to unsafe and wipe trust information.
1122 --
1123 -- Make sure to call this method to set a module to infered unsafe,
1124 -- it should be a central and single failure method.
1125 wipeTrust :: TcGblEnv -> WarningMessages -> Hsc TcGblEnv
1126 wipeTrust tcg_env whyUnsafe = do
1127 env <- getHscEnv
1128 dflags <- getDynFlags
1129
1130 when (wopt Opt_WarnUnsafe dflags)
1131 (logWarnings $ unitBag $
1132 mkPlainWarnMsg (warnUnsafeOnLoc dflags) (whyUnsafe' dflags))
1133
1134 liftIO $ hscSetSafeInf env False
1135 return $ tcg_env { tcg_imports = wiped_trust }
1136
1137 where
1138 wiped_trust = (tcg_imports tcg_env) { imp_trust_pkgs = [] }
1139 pprMod = ppr $ moduleName $ tcg_mod tcg_env
1140 whyUnsafe' df = vcat [ quotes pprMod <+> text "has been infered as unsafe!"
1141 , text "Reason:"
1142 , nest 4 $ (vcat $ badFlags df) $+$
1143 (vcat $ pprErrMsgBagWithLoc whyUnsafe)
1144 ]
1145 badFlags df = concat $ map (badFlag df) unsafeFlags
1146 badFlag df (str,loc,on,_)
1147 | on df = [mkLocMessage SevOutput (loc df) $
1148 text str <+> text "is not allowed in Safe Haskell"]
1149 | otherwise = []
1150
1151 --------------------------------------------------------------
1152 -- Simplifiers
1153 --------------------------------------------------------------
1154
1155 hscSimplify :: HscEnv -> ModGuts -> IO ModGuts
1156 hscSimplify hsc_env modguts = runHsc hsc_env $ hscSimplify' modguts
1157
1158 hscSimplify' :: ModGuts -> Hsc ModGuts
1159 hscSimplify' ds_result = do
1160 hsc_env <- getHscEnv
1161 {-# SCC "Core2Core" #-}
1162 liftIO $ core2core hsc_env ds_result
1163
1164 --------------------------------------------------------------
1165 -- Interface generators
1166 --------------------------------------------------------------
1167
1168 hscSimpleIface :: TcGblEnv
1169 -> Maybe Fingerprint
1170 -> Hsc (ModIface, Bool, ModDetails)
1171 hscSimpleIface tc_result mb_old_iface = do
1172 hsc_env <- getHscEnv
1173 details <- liftIO $ mkBootModDetailsTc hsc_env tc_result
1174 (new_iface, no_change)
1175 <- {-# SCC "MkFinalIface" #-}
1176 ioMsgMaybe $
1177 mkIfaceTc hsc_env mb_old_iface details tc_result
1178 -- And the answer is ...
1179 liftIO $ dumpIfaceStats hsc_env
1180 return (new_iface, no_change, details)
1181
1182 hscNormalIface :: ModGuts
1183 -> Maybe Fingerprint
1184 -> Hsc (ModIface, Bool, ModDetails, CgGuts)
1185 hscNormalIface simpl_result mb_old_iface = do
1186 hsc_env <- getHscEnv
1187 (cg_guts, details) <- {-# SCC "CoreTidy" #-}
1188 liftIO $ tidyProgram hsc_env simpl_result
1189
1190 -- BUILD THE NEW ModIface and ModDetails
1191 -- and emit external core if necessary
1192 -- This has to happen *after* code gen so that the back-end
1193 -- info has been set. Not yet clear if it matters waiting
1194 -- until after code output
1195 (new_iface, no_change)
1196 <- {-# SCC "MkFinalIface" #-}
1197 ioMsgMaybe $
1198 mkIface hsc_env mb_old_iface details simpl_result
1199
1200 -- Emit external core
1201 -- This should definitely be here and not after CorePrep,
1202 -- because CorePrep produces unqualified constructor wrapper declarations,
1203 -- so its output isn't valid External Core (without some preprocessing).
1204 liftIO $ emitExternalCore (hsc_dflags hsc_env) cg_guts
1205 liftIO $ dumpIfaceStats hsc_env
1206
1207 -- Return the prepared code.
1208 return (new_iface, no_change, details, cg_guts)
1209
1210 --------------------------------------------------------------
1211 -- BackEnd combinators
1212 --------------------------------------------------------------
1213
1214 hscWriteIface :: ModIface -> Bool -> ModSummary -> Hsc ()
1215 hscWriteIface iface no_change mod_summary = do
1216 dflags <- getDynFlags
1217 unless no_change $
1218 {-# SCC "writeIface" #-}
1219 liftIO $ writeIfaceFile dflags (ms_location mod_summary) iface
1220
1221 -- | Compile to hard-code.
1222 hscGenHardCode :: CgGuts -> ModSummary
1223 -> Hsc (Maybe FilePath) -- ^ @Just f@ <=> _stub.c is f
1224 hscGenHardCode cgguts mod_summary = do
1225 hsc_env <- getHscEnv
1226 liftIO $ do
1227 let CgGuts{ -- This is the last use of the ModGuts in a compilation.
1228 -- From now on, we just use the bits we need.
1229 cg_module = this_mod,
1230 cg_binds = core_binds,
1231 cg_tycons = tycons,
1232 cg_foreign = foreign_stubs0,
1233 cg_dep_pkgs = dependencies,
1234 cg_hpc_info = hpc_info } = cgguts
1235 dflags = hsc_dflags hsc_env
1236 platform = targetPlatform dflags
1237 location = ms_location mod_summary
1238 data_tycons = filter isDataTyCon tycons
1239 -- cg_tycons includes newtypes, for the benefit of External Core,
1240 -- but we don't generate any code for newtypes
1241
1242 -------------------
1243 -- PREPARE FOR CODE GENERATION
1244 -- Do saturation and convert to A-normal form
1245 prepd_binds <- {-# SCC "CorePrep" #-}
1246 corePrepPgm dflags core_binds data_tycons ;
1247 ----------------- Convert to STG ------------------
1248 (stg_binds, cost_centre_info)
1249 <- {-# SCC "CoreToStg" #-}
1250 myCoreToStg dflags this_mod prepd_binds
1251
1252 let prof_init = profilingInitCode platform this_mod cost_centre_info
1253 foreign_stubs = foreign_stubs0 `appendStubC` prof_init
1254
1255 ------------------ Code generation ------------------
1256
1257 cmms <- if dopt Opt_TryNewCodeGen dflags
1258 then {-# SCC "NewCodeGen" #-}
1259 tryNewCodeGen hsc_env this_mod data_tycons
1260 cost_centre_info
1261 stg_binds hpc_info
1262 else {-# SCC "CodeGen" #-}
1263 codeGen dflags this_mod data_tycons
1264 cost_centre_info
1265 stg_binds hpc_info
1266
1267 ------------------ Code output -----------------------
1268 rawcmms <- {-# SCC "cmmToRawCmm" #-}
1269 cmmToRawCmm platform cmms
1270 dumpIfSet_dyn dflags Opt_D_dump_raw_cmm "Raw Cmm" (pprPlatform platform rawcmms)
1271 (_stub_h_exists, stub_c_exists)
1272 <- {-# SCC "codeOutput" #-}
1273 codeOutput dflags this_mod location foreign_stubs
1274 dependencies rawcmms
1275 return stub_c_exists
1276
1277 hscInteractive :: (ModIface, ModDetails, CgGuts)
1278 -> ModSummary
1279 -> Hsc (InteractiveStatus, ModIface, ModDetails)
1280 #ifdef GHCI
1281 hscInteractive (iface, details, cgguts) mod_summary = do
1282 dflags <- getDynFlags
1283 let CgGuts{ -- This is the last use of the ModGuts in a compilation.
1284 -- From now on, we just use the bits we need.
1285 cg_module = this_mod,
1286 cg_binds = core_binds,
1287 cg_tycons = tycons,
1288 cg_foreign = foreign_stubs,
1289 cg_modBreaks = mod_breaks } = cgguts
1290
1291 location = ms_location mod_summary
1292 data_tycons = filter isDataTyCon tycons
1293 -- cg_tycons includes newtypes, for the benefit of External Core,
1294 -- but we don't generate any code for newtypes
1295
1296 -------------------
1297 -- PREPARE FOR CODE GENERATION
1298 -- Do saturation and convert to A-normal form
1299 prepd_binds <- {-# SCC "CorePrep" #-}
1300 liftIO $ corePrepPgm dflags core_binds data_tycons ;
1301 ----------------- Generate byte code ------------------
1302 comp_bc <- liftIO $ byteCodeGen dflags this_mod prepd_binds
1303 data_tycons mod_breaks
1304 ------------------ Create f-x-dynamic C-side stuff ---
1305 (_istub_h_exists, istub_c_exists)
1306 <- liftIO $ outputForeignStubs dflags this_mod
1307 location foreign_stubs
1308 return (HscRecomp istub_c_exists (Just (comp_bc, mod_breaks))
1309 , iface, details)
1310 #else
1311 hscInteractive _ _ = panic "GHC not compiled with interpreter"
1312 #endif
1313
1314 ------------------------------
1315
1316 hscCompileCmmFile :: HscEnv -> FilePath -> IO ()
1317 hscCompileCmmFile hsc_env filename = runHsc hsc_env $ do
1318 let dflags = hsc_dflags hsc_env
1319 cmm <- ioMsgMaybe $ parseCmmFile dflags filename
1320 liftIO $ do
1321 rawCmms <- cmmToRawCmm (targetPlatform dflags) [cmm]
1322 _ <- codeOutput dflags no_mod no_loc NoStubs [] rawCmms
1323 return ()
1324 where
1325 no_mod = panic "hscCmmFile: no_mod"
1326 no_loc = ModLocation{ ml_hs_file = Just filename,
1327 ml_hi_file = panic "hscCmmFile: no hi file",
1328 ml_obj_file = panic "hscCmmFile: no obj file" }
1329
1330 -------------------- Stuff for new code gen ---------------------
1331
1332 tryNewCodeGen :: HscEnv -> Module -> [TyCon]
1333 -> CollectedCCs
1334 -> [(StgBinding,[(Id,[Id])])]
1335 -> HpcInfo
1336 -> IO [Old.CmmGroup]
1337 tryNewCodeGen hsc_env this_mod data_tycons
1338 cost_centre_info stg_binds hpc_info = do
1339 let dflags = hsc_dflags hsc_env
1340 platform = targetPlatform dflags
1341 prog <- StgCmm.codeGen dflags this_mod data_tycons
1342 cost_centre_info stg_binds hpc_info
1343 dumpIfSet_dyn dflags Opt_D_dump_cmmz "Cmm produced by new codegen"
1344 (pprCmms platform prog)
1345
1346 -- We are building a single SRT for the entire module, so
1347 -- we must thread it through all the procedures as we cps-convert them.
1348 us <- mkSplitUniqSupply 'S'
1349 let initTopSRT = initUs_ us emptySRT
1350 (topSRT, prog) <- foldM (cmmPipeline hsc_env) (initTopSRT, []) prog
1351
1352 let prog' = map cmmOfZgraph (srtToData topSRT : prog)
1353 dumpIfSet_dyn dflags Opt_D_dump_cmmz "Output Cmm" (pprPlatform platform prog')
1354 return prog'
1355
1356 myCoreToStg :: DynFlags -> Module -> CoreProgram
1357 -> IO ( [(StgBinding,[(Id,[Id])])] -- output program
1358 , CollectedCCs) -- cost centre info (declared and used)
1359 myCoreToStg dflags this_mod prepd_binds = do
1360 stg_binds
1361 <- {-# SCC "Core2Stg" #-}
1362 coreToStg dflags prepd_binds
1363
1364 (stg_binds2, cost_centre_info)
1365 <- {-# SCC "Stg2Stg" #-}
1366 stg2stg dflags this_mod stg_binds
1367
1368 return (stg_binds2, cost_centre_info)
1369
1370
1371 {- **********************************************************************
1372 %* *
1373 \subsection{Compiling a do-statement}
1374 %* *
1375 %********************************************************************* -}
1376
1377 {-
1378 When the UnlinkedBCOExpr is linked you get an HValue of type *IO [HValue]* When
1379 you run it you get a list of HValues that should be the same length as the list
1380 of names; add them to the ClosureEnv.
1381
1382 A naked expression returns a singleton Name [it]. The stmt is lifted into the
1383 IO monad as explained in Note [Interactively-bound Ids in GHCi] in TcRnDriver
1384 -}
1385
1386 #ifdef GHCI
1387 -- | Compile a stmt all the way to an HValue, but don't run it
1388 --
1389 -- We return Nothing to indicate an empty statement (or comment only), not a
1390 -- parse error.
1391 hscStmt :: HscEnv -> String -> IO (Maybe ([Id], IO [HValue]))
1392 hscStmt hsc_env stmt = hscStmtWithLocation hsc_env stmt "<interactive>" 1
1393
1394 -- | Compile a stmt all the way to an HValue, but don't run it
1395 --
1396 -- We return Nothing to indicate an empty statement (or comment only), not a
1397 -- parse error.
1398 hscStmtWithLocation :: HscEnv
1399 -> String -- ^ The statement
1400 -> String -- ^ The source
1401 -> Int -- ^ Starting line
1402 -> IO (Maybe ([Id], IO [HValue]))
1403 hscStmtWithLocation hsc_env0 stmt source linenumber =
1404 runInteractiveHsc hsc_env0 $ do
1405 hsc_env <- getHscEnv
1406 maybe_stmt <- hscParseStmtWithLocation source linenumber stmt
1407 case maybe_stmt of
1408 Nothing -> return Nothing
1409
1410 Just parsed_stmt -> do
1411 let icntxt = hsc_IC hsc_env
1412 rdr_env = ic_rn_gbl_env icntxt
1413 type_env = mkTypeEnvWithImplicits (ic_tythings icntxt)
1414 src_span = srcLocSpan interactiveSrcLoc
1415
1416 -- Rename and typecheck it
1417 -- Here we lift the stmt into the IO monad, see Note
1418 -- [Interactively-bound Ids in GHCi] in TcRnDriver
1419 (ids, tc_expr) <- ioMsgMaybe $ tcRnStmt hsc_env icntxt parsed_stmt
1420
1421 -- Desugar it
1422 ds_expr <- ioMsgMaybe $
1423 deSugarExpr hsc_env iNTERACTIVE rdr_env type_env tc_expr
1424 handleWarnings
1425
1426 -- Then code-gen, and link it
1427 hsc_env <- getHscEnv
1428 hval <- liftIO $ hscCompileCoreExpr hsc_env src_span ds_expr
1429 let hval_io = unsafeCoerce# hval :: IO [HValue]
1430
1431 return $ Just (ids, hval_io)
1432
1433 -- | Compile a decls
1434 hscDecls :: HscEnv
1435 -> String -- ^ The statement
1436 -> IO ([TyThing], InteractiveContext)
1437 hscDecls hsc_env str = hscDeclsWithLocation hsc_env str "<interactive>" 1
1438
1439 -- | Compile a decls
1440 hscDeclsWithLocation :: HscEnv
1441 -> String -- ^ The statement
1442 -> String -- ^ The source
1443 -> Int -- ^ Starting line
1444 -> IO ([TyThing], InteractiveContext)
1445 hscDeclsWithLocation hsc_env0 str source linenumber =
1446 runInteractiveHsc hsc_env0 $ do
1447 hsc_env <- getHscEnv
1448 L _ (HsModule{ hsmodDecls = decls }) <-
1449 hscParseThingWithLocation source linenumber parseModule str
1450
1451 {- Rename and typecheck it -}
1452 let icontext = hsc_IC hsc_env
1453 tc_gblenv <- ioMsgMaybe $ tcRnDeclsi hsc_env icontext decls
1454
1455 {- Grab the new instances -}
1456 -- We grab the whole environment because of the overlapping that may have
1457 -- been done. See the notes at the definition of InteractiveContext
1458 -- (ic_instances) for more details.
1459 let finsts = tcg_fam_insts tc_gblenv
1460 insts = tcg_insts tc_gblenv
1461
1462 {- Desugar it -}
1463 -- We use a basically null location for iNTERACTIVE
1464 let iNTERACTIVELoc = ModLocation{ ml_hs_file = Nothing,
1465 ml_hi_file = undefined,
1466 ml_obj_file = undefined}
1467 ds_result <- hscDesugar' iNTERACTIVELoc tc_gblenv
1468
1469 {- Simplify -}
1470 simpl_mg <- liftIO $ hscSimplify hsc_env ds_result
1471
1472 {- Tidy -}
1473 (tidy_cg, _mod_details) <- liftIO $ tidyProgram hsc_env simpl_mg
1474
1475 let dflags = hsc_dflags hsc_env
1476 !CgGuts{ cg_module = this_mod,
1477 cg_binds = core_binds,
1478 cg_tycons = tycons,
1479 cg_modBreaks = mod_breaks } = tidy_cg
1480 data_tycons = filter isDataTyCon tycons
1481
1482 {- Prepare For Code Generation -}
1483 -- Do saturation and convert to A-normal form
1484 prepd_binds <- {-# SCC "CorePrep" #-}
1485 liftIO $ corePrepPgm dflags core_binds data_tycons
1486
1487 {- Generate byte code -}
1488 cbc <- liftIO $ byteCodeGen dflags this_mod
1489 prepd_binds data_tycons mod_breaks
1490
1491 let src_span = srcLocSpan interactiveSrcLoc
1492 hsc_env <- getHscEnv
1493 liftIO $ linkDecls hsc_env src_span cbc
1494
1495 let tcs = filter (not . isImplicitTyCon) $ (mg_tcs simpl_mg)
1496
1497 ext_vars = filter (isExternalName . idName) $
1498 bindersOfBinds core_binds
1499
1500 (sys_vars, user_vars) = partition is_sys_var ext_vars
1501 is_sys_var id = isDFunId id
1502 || isRecordSelector id
1503 || isJust (isClassOpId_maybe id)
1504 -- we only need to keep around the external bindings
1505 -- (as decided by TidyPgm), since those are the only ones
1506 -- that might be referenced elsewhere.
1507
1508 tythings = map AnId user_vars
1509 ++ map ATyCon tcs
1510
1511 let ictxt1 = extendInteractiveContext icontext tythings
1512 ictxt = ictxt1 { ic_sys_vars = sys_vars ++ ic_sys_vars ictxt1,
1513 ic_instances = (insts, finsts) }
1514
1515 return (tythings, ictxt)
1516
1517 hscImport :: HscEnv -> String -> IO (ImportDecl RdrName)
1518 hscImport hsc_env str = runInteractiveHsc hsc_env $ do
1519 (L _ (HsModule{hsmodImports=is})) <-
1520 hscParseThing parseModule str
1521 case is of
1522 [i] -> return (unLoc i)
1523 _ -> liftIO $ throwOneError $
1524 mkPlainErrMsg noSrcSpan $
1525 ptext (sLit "parse error in import declaration")
1526
1527 -- | Typecheck an expression (but don't run it)
1528 hscTcExpr :: HscEnv
1529 -> String -- ^ The expression
1530 -> IO Type
1531 hscTcExpr hsc_env0 expr = runInteractiveHsc hsc_env0 $ do
1532 hsc_env <- getHscEnv
1533 maybe_stmt <- hscParseStmt expr
1534 case maybe_stmt of
1535 Just (L _ (ExprStmt expr _ _ _)) ->
1536 ioMsgMaybe $ tcRnExpr hsc_env (hsc_IC hsc_env) expr
1537 _ ->
1538 throwErrors $ unitBag $ mkPlainErrMsg noSrcSpan
1539 (text "not an expression:" <+> quotes (text expr))
1540
1541 -- | Find the kind of a type
1542 hscKcType
1543 :: HscEnv
1544 -> Bool -- ^ Normalise the type
1545 -> String -- ^ The type as a string
1546 -> IO (Type, Kind) -- ^ Resulting type (possibly normalised) and kind
1547 hscKcType hsc_env0 normalise str = runInteractiveHsc hsc_env0 $ do
1548 hsc_env <- getHscEnv
1549 ty <- hscParseType str
1550 ioMsgMaybe $ tcRnType hsc_env (hsc_IC hsc_env) normalise ty
1551
1552 hscParseStmt :: String -> Hsc (Maybe (LStmt RdrName))
1553 hscParseStmt = hscParseThing parseStmt
1554
1555 hscParseStmtWithLocation :: String -> Int -> String
1556 -> Hsc (Maybe (LStmt RdrName))
1557 hscParseStmtWithLocation source linenumber stmt =
1558 hscParseThingWithLocation source linenumber parseStmt stmt
1559
1560 hscParseType :: String -> Hsc (LHsType RdrName)
1561 hscParseType = hscParseThing parseType
1562 #endif
1563
1564 hscParseIdentifier :: HscEnv -> String -> IO (Located RdrName)
1565 hscParseIdentifier hsc_env str =
1566 runInteractiveHsc hsc_env $ hscParseThing parseIdentifier str
1567
1568 hscParseThing :: (Outputable thing) => Lexer.P thing -> String -> Hsc thing
1569 hscParseThing = hscParseThingWithLocation "<interactive>" 1
1570
1571 hscParseThingWithLocation :: (Outputable thing) => String -> Int
1572 -> Lexer.P thing -> String -> Hsc thing
1573 hscParseThingWithLocation source linenumber parser str
1574 = {-# SCC "Parser" #-} do
1575 dflags <- getDynFlags
1576 liftIO $ showPass dflags "Parser"
1577
1578 let buf = stringToStringBuffer str
1579 loc = mkRealSrcLoc (fsLit source) linenumber 1
1580
1581 case unP parser (mkPState dflags buf loc) of
1582 PFailed span err -> do
1583 let msg = mkPlainErrMsg span err
1584 throwErrors $ unitBag msg
1585
1586 POk pst thing -> do
1587 logWarningsReportErrors (getMessages pst)
1588 liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr thing)
1589 return thing
1590
1591 hscCompileCore :: HscEnv -> Bool -> ModSummary -> CoreProgram -> IO ()
1592 hscCompileCore hsc_env simplify mod_summary binds = runHsc hsc_env $ do
1593 guts <- maybe_simplify (mkModGuts (ms_mod mod_summary) binds)
1594 (iface, changed, _details, cgguts) <- hscNormalIface guts Nothing
1595 hscWriteIface iface changed mod_summary
1596 _ <- hscGenHardCode cgguts mod_summary
1597 return ()
1598
1599 where
1600 maybe_simplify mod_guts | simplify = hscSimplify' mod_guts
1601 | otherwise = return mod_guts
1602
1603 -- Makes a "vanilla" ModGuts.
1604 mkModGuts :: Module -> CoreProgram -> ModGuts
1605 mkModGuts mod binds =
1606 ModGuts {
1607 mg_module = mod,
1608 mg_boot = False,
1609 mg_exports = [],
1610 mg_deps = noDependencies,
1611 mg_dir_imps = emptyModuleEnv,
1612 mg_used_names = emptyNameSet,
1613 mg_used_th = False,
1614 mg_rdr_env = emptyGlobalRdrEnv,
1615 mg_fix_env = emptyFixityEnv,
1616 mg_tcs = [],
1617 mg_insts = [],
1618 mg_fam_insts = [],
1619 mg_rules = [],
1620 mg_vect_decls = [],
1621 mg_binds = binds,
1622 mg_foreign = NoStubs,
1623 mg_warns = NoWarnings,
1624 mg_anns = [],
1625 mg_hpc_info = emptyHpcInfo False,
1626 mg_modBreaks = emptyModBreaks,
1627 mg_vect_info = noVectInfo,
1628 mg_inst_env = emptyInstEnv,
1629 mg_fam_inst_env = emptyFamInstEnv,
1630 mg_trust_pkg = False,
1631 mg_dependent_files = []
1632 }
1633
1634
1635 {- **********************************************************************
1636 %* *
1637 Desugar, simplify, convert to bytecode, and link an expression
1638 %* *
1639 %********************************************************************* -}
1640
1641 #ifdef GHCI
1642 hscCompileCoreExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO HValue
1643 hscCompileCoreExpr hsc_env srcspan ds_expr
1644 | rtsIsProfiled
1645 = throwIO (InstallationError "You can't call hscCompileCoreExpr in a profiled compiler")
1646 -- Otherwise you get a seg-fault when you run it
1647
1648 | otherwise = do
1649 let dflags = hsc_dflags hsc_env
1650 let lint_on = dopt Opt_DoCoreLinting dflags
1651
1652 {- Simplify it -}
1653 simpl_expr <- simplifyExpr dflags ds_expr
1654
1655 {- Tidy it (temporary, until coreSat does cloning) -}
1656 let tidy_expr = tidyExpr emptyTidyEnv simpl_expr
1657
1658 {- Prepare for codegen -}
1659 prepd_expr <- corePrepExpr dflags tidy_expr
1660
1661 {- Lint if necessary -}
1662 -- ToDo: improve SrcLoc
1663 when lint_on $
1664 let ictxt = hsc_IC hsc_env
1665 te = mkTypeEnvWithImplicits (ic_tythings ictxt ++ map AnId (ic_sys_vars ictxt))
1666 tyvars = varSetElems $ tyThingsTyVars $ typeEnvElts $ te
1667 vars = typeEnvIds te
1668 in case lintUnfolding noSrcLoc (tyvars ++ vars) prepd_expr of
1669 Just err -> pprPanic "hscCompileCoreExpr" err
1670 Nothing -> return ()
1671
1672 {- Convert to BCOs -}
1673 bcos <- coreExprToBCOs dflags iNTERACTIVE prepd_expr
1674
1675 {- link it -}
1676 hval <- linkExpr hsc_env srcspan bcos
1677
1678 return hval
1679 #endif
1680
1681
1682 {- **********************************************************************
1683 %* *
1684 Statistics on reading interfaces
1685 %* *
1686 %********************************************************************* -}
1687
1688 dumpIfaceStats :: HscEnv -> IO ()
1689 dumpIfaceStats hsc_env = do
1690 eps <- readIORef (hsc_EPS hsc_env)
1691 dumpIfSet (dump_if_trace || dump_rn_stats)
1692 "Interface statistics"
1693 (ifaceStats eps)
1694 where
1695 dflags = hsc_dflags hsc_env
1696 dump_rn_stats = dopt Opt_D_dump_rn_stats dflags
1697 dump_if_trace = dopt Opt_D_dump_if_trace dflags
1698
1699
1700 {- **********************************************************************
1701 %* *
1702 Progress Messages: Module i of n
1703 %* *
1704 %********************************************************************* -}
1705
1706 showModuleIndex :: Maybe (Int, Int) -> String
1707 showModuleIndex Nothing = ""
1708 showModuleIndex (Just (i,n)) = "[" ++ padded ++ " of " ++ n_str ++ "] "
1709 where
1710 n_str = show n
1711 i_str = show i
1712 padded = replicate (length n_str - length i_str) ' ' ++ i_str
1713