summaryrefslogtreecommitdiff
path: root/compiler/main
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/main')
-rw-r--r--compiler/main/CodeOutput.lhs4
-rw-r--r--compiler/main/DriverMkDepend.hs4
-rw-r--r--compiler/main/DriverPipeline.hs6
-rw-r--r--compiler/main/DynamicLoading.hs21
-rw-r--r--compiler/main/ErrUtils.lhs4
-rw-r--r--compiler/main/GHC.hs9
-rw-r--r--compiler/main/HscMain.hs5
-rw-r--r--compiler/main/HscTypes.lhs10
-rw-r--r--compiler/main/InteractiveEval.hs8
-rw-r--r--compiler/main/Packages.lhs50
10 files changed, 66 insertions, 55 deletions
diff --git a/compiler/main/CodeOutput.lhs b/compiler/main/CodeOutput.lhs
index b2c201cb41..8cac6b03f7 100644
--- a/compiler/main/CodeOutput.lhs
+++ b/compiler/main/CodeOutput.lhs
@@ -183,11 +183,11 @@ outputForeignStubs dflags mod location stubs
ForeignStubs h_code c_code -> do
let
stub_c_output_d = pprCode CStyle c_code
- stub_c_output_w = showSDoc stub_c_output_d
+ stub_c_output_w = showSDoc dflags stub_c_output_d
-- Header file protos for "foreign export"ed functions.
stub_h_output_d = pprCode CStyle h_code
- stub_h_output_w = showSDoc stub_h_output_d
+ stub_h_output_w = showSDoc dflags stub_h_output_d
-- in
createDirectoryIfMissing True (takeDirectory stub_h)
diff --git a/compiler/main/DriverMkDepend.hs b/compiler/main/DriverMkDepend.hs
index 5db927a952..953b2c4568 100644
--- a/compiler/main/DriverMkDepend.hs
+++ b/compiler/main/DriverMkDepend.hs
@@ -176,9 +176,9 @@ processDeps :: DynFlags
--
-- For {-# SOURCE #-} imports the "hi" will be "hi-boot".
-processDeps _ _ _ _ _ (CyclicSCC nodes)
+processDeps dflags _ _ _ _ (CyclicSCC nodes)
= -- There shouldn't be any cycles; report them
- ghcError (ProgramError (showSDoc $ GHC.cyclicModuleErr nodes))
+ ghcError (ProgramError (showSDoc dflags $ GHC.cyclicModuleErr nodes))
processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC node)
= do { let extra_suffixes = depSuffixes dflags
diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index 201a38cdb4..be06fbc61b 100644
--- a/compiler/main/DriverPipeline.hs
+++ b/compiler/main/DriverPipeline.hs
@@ -326,7 +326,7 @@ link' dflags batch_attempt_linking hpt
return Succeeded
else do
- compilationProgressMsg dflags $ showSDoc $
+ compilationProgressMsg dflags $ showSDoc dflags $
(ptext (sLit "Linking") <+> text exe_file <+> text "...")
-- Don't showPass in Batch mode; doLink will do that for us.
@@ -1497,7 +1497,7 @@ mkExtraObjToLinkIntoBinary dflags = do
(text "Warning: -rtsopts and -with-rtsopts have no effect with -no-hs-main." $$
text " Call hs_init_ghc() from your main() function to set these options.")
- mkExtraObj dflags "c" (showSDoc main)
+ mkExtraObj dflags "c" (showSDoc dflags main)
where
main
@@ -1528,7 +1528,7 @@ mkNoteObjsToLinkIntoBinary dflags dep_packages = do
link_info <- getLinkInfo dflags dep_packages
if (platformSupportsSavingLinkOpts (platformOS (targetPlatform dflags)))
- then fmap (:[]) $ mkExtraObj dflags "s" (showSDoc (link_opts link_info))
+ then fmap (:[]) $ mkExtraObj dflags "s" (showSDoc dflags (link_opts link_info))
else return []
where
diff --git a/compiler/main/DynamicLoading.hs b/compiler/main/DynamicLoading.hs
index cc382a74fe..84eb2612e0 100644
--- a/compiler/main/DynamicLoading.hs
+++ b/compiler/main/DynamicLoading.hs
@@ -70,9 +70,10 @@ forceLoadTyCon hsc_env con_name = do
mb_con_thing <- lookupTypeHscEnv hsc_env con_name
case mb_con_thing of
- Nothing -> throwCmdLineErrorS $ missingTyThingError con_name
+ Nothing -> throwCmdLineErrorS dflags $ missingTyThingError con_name
Just (ATyCon tycon) -> return tycon
- Just con_thing -> throwCmdLineErrorS $ wrongTyThingError con_name con_thing
+ Just con_thing -> throwCmdLineErrorS dflags $ wrongTyThingError con_name con_thing
+ where dflags = hsc_dflags hsc_env
-- | Loads the value corresponding to a 'Name' if that value has the given 'Type'. This only provides limited safety
-- in that it is up to the user to ensure that that type corresponds to the type you try to use the return value at!
@@ -91,7 +92,7 @@ getValueSafely hsc_env val_name expected_type = do
-- Now look up the names for the value and type constructor in the type environment
mb_val_thing <- lookupTypeHscEnv hsc_env val_name
case mb_val_thing of
- Nothing -> throwCmdLineErrorS $ missingTyThingError val_name
+ Nothing -> throwCmdLineErrorS dflags $ missingTyThingError val_name
Just (AnId id) -> do
-- Check the value type in the interface against the type recovered from the type constructor
-- before finally casting the value to the type we assume corresponds to that constructor
@@ -107,7 +108,8 @@ getValueSafely hsc_env val_name expected_type = do
value <- lessUnsafeCoerce (hsc_dflags hsc_env) "getValueSafely" hval
return $ Just value
else return Nothing
- Just val_thing -> throwCmdLineErrorS $ wrongTyThingError val_name val_thing
+ Just val_thing -> throwCmdLineErrorS dflags $ wrongTyThingError val_name val_thing
+ where dflags = hsc_dflags hsc_env
-- | Coerce a value as usual, but:
@@ -149,10 +151,9 @@ lookupRdrNameInModule hsc_env mod_name rdr_name = do
[] -> return Nothing
_ -> panic "lookupRdrNameInModule"
- Nothing -> throwCmdLineErrorS $ hsep [ptext (sLit "Could not determine the exports of the module"), ppr mod_name]
- err -> throwCmdLineErrorS $ cannotFindModule dflags mod_name err
- where
- dflags = hsc_dflags hsc_env
+ Nothing -> throwCmdLineErrorS dflags $ hsep [ptext (sLit "Could not determine the exports of the module"), ppr mod_name]
+ err -> throwCmdLineErrorS dflags $ cannotFindModule dflags mod_name err
+ where dflags = hsc_dflags hsc_env
wrongTyThingError :: Name -> TyThing -> SDoc
@@ -161,8 +162,8 @@ wrongTyThingError name got_thing = hsep [ptext (sLit "The name"), ppr name, ptex
missingTyThingError :: Name -> SDoc
missingTyThingError name = hsep [ptext (sLit "The name"), ppr name, ptext (sLit "is not in the type environment: are you sure it exists?")]
-throwCmdLineErrorS :: SDoc -> IO a
-throwCmdLineErrorS = throwCmdLineError . showSDoc
+throwCmdLineErrorS :: DynFlags -> SDoc -> IO a
+throwCmdLineErrorS dflags = throwCmdLineError . showSDoc dflags
throwCmdLineError :: String -> IO a
throwCmdLineError = throwGhcException . CmdLineError
diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs
index 83f57c3888..301ed1b613 100644
--- a/compiler/main/ErrUtils.lhs
+++ b/compiler/main/ErrUtils.lhs
@@ -109,9 +109,9 @@ makeIntoWarning err = err { errMsgSeverity = SevWarning }
-- Collecting up messages for later ordering and printing.
mk_err_msg :: DynFlags -> Severity -> SrcSpan -> PrintUnqualified -> MsgDoc -> SDoc -> ErrMsg
-mk_err_msg _ sev locn print_unqual msg extra
+mk_err_msg dflags sev locn print_unqual msg extra
= ErrMsg { errMsgSpans = [locn], errMsgContext = print_unqual
- , errMsgShortDoc = msg , errMsgShortString = showSDoc msg
+ , errMsgShortDoc = msg , errMsgShortString = showSDoc dflags msg
, errMsgExtraInfo = extra
, errMsgSeverity = sev }
diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index dc0730fafa..bedb30002a 100644
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -590,8 +590,9 @@ guessTarget str Nothing
if looksLikeModuleName file
then return (target (TargetModule (mkModuleName file)))
else do
+ dflags <- getDynFlags
throwGhcException
- (ProgramError (showSDoc $
+ (ProgramError (showSDoc dflags $
text "target" <+> quotes (text file) <+>
text "is not a module name or a source file"))
where
@@ -1291,11 +1292,11 @@ findModule mod_name maybe_pkg = withSession $ \hsc_env -> do
res <- findImportedModule hsc_env mod_name maybe_pkg
case res of
Found loc m | modulePackageId m /= this_pkg -> return m
- | otherwise -> modNotLoadedError m loc
+ | otherwise -> modNotLoadedError dflags m loc
err -> noModError dflags noSrcSpan mod_name err
-modNotLoadedError :: Module -> ModLocation -> IO a
-modNotLoadedError m loc = ghcError $ CmdLineError $ showSDoc $
+modNotLoadedError :: DynFlags -> Module -> ModLocation -> IO a
+modNotLoadedError dflags m loc = ghcError $ CmdLineError $ showSDoc dflags $
text "module is not loaded:" <+>
quotes (ppr (moduleName m)) <+>
parens (text (expectJust "modNotLoadedError" (ml_hs_file loc)))
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index 0c09603ae0..3941588714 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -853,10 +853,11 @@ batchMsg hsc_env mb_mod_index recomp mod_summary =
RecompBecause reason -> showMsg "Compiling " (" [" ++ reason ++ "]")
RecompForcedByTH -> showMsg "Compiling " " [TH]"
where
+ dflags = hsc_dflags hsc_env
showMsg msg reason =
- compilationProgressMsg (hsc_dflags hsc_env) $
+ compilationProgressMsg dflags $
(showModuleIndex mb_mod_index ++
- msg ++ showModMsg (hscTarget (hsc_dflags hsc_env))
+ msg ++ showModMsg dflags (hscTarget dflags)
(recompileRequired recomp) mod_summary)
++ reason
diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs
index 6298192d42..aac5ba5bd3 100644
--- a/compiler/main/HscTypes.lhs
+++ b/compiler/main/HscTypes.lhs
@@ -182,7 +182,7 @@ srcErrorMessages :: SourceError -> ErrorMessages
srcErrorMessages (SourceError msgs) = msgs
mkApiErr :: DynFlags -> SDoc -> GhcApiError
-mkApiErr _ msg = GhcApiError (showSDoc msg)
+mkApiErr dflags msg = GhcApiError (showSDoc dflags msg)
throwOneError :: MonadIO m => ErrMsg -> m ab
throwOneError err = liftIO $ throwIO $ mkSrcErr $ unitBag err
@@ -1870,9 +1870,9 @@ instance Outputable ModSummary where
char '}'
]
-showModMsg :: HscTarget -> Bool -> ModSummary -> String
-showModMsg target recomp mod_summary
- = showSDoc $
+showModMsg :: DynFlags -> HscTarget -> Bool -> ModSummary -> String
+showModMsg dflags target recomp mod_summary
+ = showSDoc dflags $
hsep [text (mod_str ++ replicate (max 0 (16 - length mod_str)) ' '),
char '(', text (normalise $ msHsFilePath mod_summary) <> comma,
case target of
@@ -1883,7 +1883,7 @@ showModMsg target recomp mod_summary
char ')']
where
mod = moduleName (ms_mod mod_summary)
- mod_str = showSDoc (ppr mod) ++ hscSourceString (ms_hsc_src mod_summary)
+ mod_str = showPpr dflags mod ++ hscSourceString (ms_hsc_src mod_summary)
\end{code}
%************************************************************************
diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs
index 5fa0f6bd57..60681fc6e7 100644
--- a/compiler/main/InteractiveEval.hs
+++ b/compiler/main/InteractiveEval.hs
@@ -814,9 +814,10 @@ fromListBL bound l = BL (length l) bound l []
setContext :: GhcMonad m => [InteractiveImport] -> m ()
setContext imports
= do { hsc_env <- getSession
+ ; let dflags = hsc_dflags hsc_env
; all_env_err <- liftIO $ findGlobalRdrEnv hsc_env imports
; case all_env_err of
- Left (mod, err) -> ghcError (formatError mod err)
+ Left (mod, err) -> ghcError (formatError dflags mod err)
Right all_env -> do {
; let old_ic = hsc_IC hsc_env
final_rdr_env = ic_tythings old_ic `icPlusGblRdrEnv` all_env
@@ -824,7 +825,7 @@ setContext imports
hsc_env{ hsc_IC = old_ic { ic_imports = imports
, ic_rn_gbl_env = final_rdr_env }}}}
where
- formatError mod err = ProgramError . showSDoc $
+ formatError dflags mod err = ProgramError . showSDoc dflags $
text "Cannot add module" <+> ppr mod <+>
text "to context:" <+> text err
@@ -1009,7 +1010,8 @@ showModule :: GhcMonad m => ModSummary -> m String
showModule mod_summary =
withSession $ \hsc_env -> do
interpreted <- isModuleInterpreted mod_summary
- return (showModMsg (hscTarget(hsc_dflags hsc_env)) interpreted mod_summary)
+ let dflags = hsc_dflags hsc_env
+ return (showModMsg dflags (hscTarget dflags) interpreted mod_summary)
isModuleInterpreted :: GhcMonad m => ModSummary -> m Bool
isModuleInterpreted mod_summary = withSession $ \hsc_env ->
diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs
index 42e5cf5557..9831367fff 100644
--- a/compiler/main/Packages.lhs
+++ b/compiler/main/Packages.lhs
@@ -318,16 +318,17 @@ mungePackagePaths top_dir pkgroot pkg =
-- (-package, -hide-package, -ignore-package).
applyPackageFlag
- :: UnusablePackages
+ :: DynFlags
+ -> UnusablePackages
-> [PackageConfig] -- Initial database
-> PackageFlag -- flag to apply
-> IO [PackageConfig] -- new database
-applyPackageFlag unusable pkgs flag =
+applyPackageFlag dflags unusable pkgs flag =
case flag of
ExposePackage str ->
case selectPackages (matchingStr str) pkgs unusable of
- Left ps -> packageFlagErr flag ps
+ Left ps -> packageFlagErr dflags flag ps
Right (p:ps,qs) -> return (p':ps')
where p' = p {exposed=True}
ps' = hideAll (pkgName (sourcePackageId p)) (ps++qs)
@@ -335,7 +336,7 @@ applyPackageFlag unusable pkgs flag =
ExposePackageId str ->
case selectPackages (matchingId str) pkgs unusable of
- Left ps -> packageFlagErr flag ps
+ Left ps -> packageFlagErr dflags flag ps
Right (p:ps,qs) -> return (p':ps')
where p' = p {exposed=True}
ps' = hideAll (pkgName (sourcePackageId p)) (ps++qs)
@@ -343,7 +344,7 @@ applyPackageFlag unusable pkgs flag =
HidePackage str ->
case selectPackages (matchingStr str) pkgs unusable of
- Left ps -> packageFlagErr flag ps
+ Left ps -> packageFlagErr dflags flag ps
Right (ps,qs) -> return (map hide ps ++ qs)
where hide p = p {exposed=False}
@@ -351,13 +352,13 @@ applyPackageFlag unusable pkgs flag =
-- and leave others the same or set them untrusted
TrustPackage str ->
case selectPackages (matchingStr str) pkgs unusable of
- Left ps -> packageFlagErr flag ps
+ Left ps -> packageFlagErr dflags flag ps
Right (ps,qs) -> return (map trust ps ++ qs)
where trust p = p {trusted=True}
DistrustPackage str ->
case selectPackages (matchingStr str) pkgs unusable of
- Left ps -> packageFlagErr flag ps
+ Left ps -> packageFlagErr dflags flag ps
Right (ps,qs) -> return (map distrust ps ++ qs)
where distrust p = p {trusted=False}
@@ -402,19 +403,20 @@ sortByVersion = sortBy (flip (comparing (pkgVersion.sourcePackageId)))
comparing :: Ord a => (t -> a) -> t -> t -> Ordering
comparing f a b = f a `compare` f b
-packageFlagErr :: PackageFlag
+packageFlagErr :: DynFlags
+ -> PackageFlag
-> [(PackageConfig, UnusablePackageReason)]
-> IO a
-- for missing DPH package we emit a more helpful error message, because
-- this may be the result of using -fdph-par or -fdph-seq.
-packageFlagErr (ExposePackage pkg) [] | is_dph_package pkg
- = ghcError (CmdLineError (showSDoc $ dph_err))
+packageFlagErr dflags (ExposePackage pkg) [] | is_dph_package pkg
+ = ghcError (CmdLineError (showSDoc dflags $ dph_err))
where dph_err = text "the " <> text pkg <> text " package is not installed."
$$ text "To install it: \"cabal install dph\"."
is_dph_package pkg = "dph" `isPrefixOf` pkg
-packageFlagErr flag reasons = ghcError (CmdLineError (showSDoc $ err))
+packageFlagErr dflags flag reasons = ghcError (CmdLineError (showSDoc dflags $ err))
where err = text "cannot satisfy " <> ppr_flag <>
(if null reasons then empty else text ": ") $$
nest 4 (ppr_reasons $$
@@ -754,7 +756,7 @@ mkPackageState dflags pkgs0 preload0 this_package = do
-- Modify the package database according to the command-line flags
-- (-package, -hide-package, -ignore-package, -hide-all-packages).
--
- pkgs1 <- foldM (applyPackageFlag unusable) pkgs0_unique other_flags
+ pkgs1 <- foldM (applyPackageFlag dflags unusable) pkgs0_unique other_flags
let pkgs2 = filter (not . (`Map.member` unusable) . installedPackageId) pkgs1
-- Here we build up a set of the packages mentioned in -package
@@ -782,7 +784,7 @@ mkPackageState dflags pkgs0 preload0 this_package = do
lookupIPID ipid@(InstalledPackageId str)
| Just pid <- Map.lookup ipid ipid_map = return pid
- | otherwise = missingPackageErr str
+ | otherwise = missingPackageErr dflags str
preload2 <- mapM lookupIPID preload1
@@ -799,7 +801,7 @@ mkPackageState dflags pkgs0 preload0 this_package = do
$ (basicLinkedPackages ++ preload2)
-- Close the preload packages with their dependencies
- dep_preload <- closeDeps pkg_db ipid_map (zip preload3 (repeat Nothing))
+ dep_preload <- closeDeps dflags pkg_db ipid_map (zip preload3 (repeat Nothing))
let new_dep_preload = filter (`notElem` preload0) dep_preload
let pstate = PackageState{ preloadPackages = dep_preload,
@@ -964,20 +966,23 @@ getPreloadPackagesAnd dflags pkgids =
preload = preloadPackages state
pairs = zip pkgids (repeat Nothing)
in do
- all_pkgs <- throwErr (foldM (add_package pkg_map ipid_map) preload pairs)
+ all_pkgs <- throwErr dflags (foldM (add_package pkg_map ipid_map) preload pairs)
return (map (getPackageDetails state) all_pkgs)
-- Takes a list of packages, and returns the list with dependencies included,
-- in reverse dependency order (a package appears before those it depends on).
-closeDeps :: PackageConfigMap
+closeDeps :: DynFlags
+ -> PackageConfigMap
-> Map InstalledPackageId PackageId
-> [(PackageId, Maybe PackageId)]
-> IO [PackageId]
-closeDeps pkg_map ipid_map ps = throwErr (closeDepsErr pkg_map ipid_map ps)
+closeDeps dflags pkg_map ipid_map ps
+ = throwErr dflags (closeDepsErr pkg_map ipid_map ps)
-throwErr :: MaybeErr MsgDoc a -> IO a
-throwErr m = case m of
- Failed e -> ghcError (CmdLineError (showSDoc e))
+throwErr :: DynFlags -> MaybeErr MsgDoc a -> IO a
+throwErr dflags m
+ = case m of
+ Failed e -> ghcError (CmdLineError (showSDoc dflags e))
Succeeded r -> return r
closeDepsErr :: PackageConfigMap
@@ -1009,8 +1014,9 @@ add_package pkg_db ipid_map ps (p, mb_parent)
| otherwise
= Failed (missingPackageMsg str <> missingDependencyMsg mb_parent)
-missingPackageErr :: String -> IO a
-missingPackageErr p = ghcError (CmdLineError (showSDoc (missingPackageMsg p)))
+missingPackageErr :: DynFlags -> String -> IO a
+missingPackageErr dflags p
+ = ghcError (CmdLineError (showSDoc dflags (missingPackageMsg p)))
missingPackageMsg :: String -> SDoc
missingPackageMsg p = ptext (sLit "unknown package:") <+> text p
View Lorry Controller Status