diff options
Diffstat (limited to 'compiler/GHC/Driver/Pipeline.hs')
| -rw-r--r-- | compiler/GHC/Driver/Pipeline.hs | 24 |
1 files changed, 18 insertions, 6 deletions
diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs index 8589b81ee5..5496fe31a2 100644 --- a/compiler/GHC/Driver/Pipeline.hs +++ b/compiler/GHC/Driver/Pipeline.hs @@ -47,6 +47,7 @@ import GHC.Tc.Types import GHC.Driver.Main import GHC.Driver.Env hiding ( Hsc ) import GHC.Driver.Errors +import GHC.Driver.Errors.Types import GHC.Driver.Pipeline.Monad import GHC.Driver.Config import GHC.Driver.Phases @@ -81,7 +82,6 @@ import GHC.CmmToLlvm ( llvmFixupAsm, llvmVersionList ) import qualified GHC.LanguageExtensions as LangExt import GHC.Settings -import GHC.Data.Bag ( unitBag ) import GHC.Data.FastString ( mkFastString ) import GHC.Data.StringBuffer ( hGetStringBuffer, hPutStringBuffer ) import GHC.Data.Maybe ( expectJust ) @@ -89,6 +89,7 @@ import GHC.Data.Maybe ( expectJust ) import GHC.Iface.Make ( mkFullIface ) import GHC.Types.Basic ( SuccessFlag(..) ) +import GHC.Types.Error ( singleMessage, getMessages ) import GHC.Types.Target import GHC.Types.SrcLoc import GHC.Types.SourceFile @@ -130,9 +131,9 @@ preprocess :: HscEnv -> Maybe InputFileBuffer -- ^ optional buffer to use instead of reading the input file -> Maybe Phase -- ^ starting phase - -> IO (Either ErrorMessages (DynFlags, FilePath)) + -> IO (Either DriverMessages (DynFlags, FilePath)) preprocess hsc_env input_fn mb_input_buf mb_phase = - handleSourceError (\err -> return (Left (srcErrorMessages err))) $ + handleSourceError (\err -> return $ Left $ to_driver_messages $ srcErrorMessages err) $ MC.handle handler $ fmap Right $ do MASSERT2(isJust mb_phase || isHaskellSrcFilename input_fn, text input_fn) @@ -148,10 +149,21 @@ preprocess hsc_env input_fn mb_input_buf mb_phase = return (dflags, fp) where srcspan = srcLocSpan $ mkSrcLoc (mkFastString input_fn) 1 1 - handler (ProgramError msg) = return $ Left $ unitBag $ - mkPlainErrorMsgEnvelope srcspan $ text msg + handler (ProgramError msg) = + return $ Left $ singleMessage $ + mkPlainErrorMsgEnvelope srcspan $ + DriverUnknownMessage $ mkPlainError $ text msg handler ex = throwGhcExceptionIO ex + to_driver_messages :: Messages GhcMessage -> Messages DriverMessage + to_driver_messages msgs = case traverse to_driver_message msgs of + Nothing -> pprPanic "non-driver message in preprocess" + (vcat $ pprMsgEnvelopeBagWithLoc (getMessages msgs)) + Just msgs' -> msgs' + + to_driver_message (GhcDriverMessage msg) = Just msg + to_driver_message _other = Nothing + -- --------------------------------------------------------------------------- -- | Compile @@ -1259,7 +1271,7 @@ runPhase (RealPhase (Hsc src_flavour)) input_fn popts = initParserOpts dflags eimps <- getImports popts imp_prelude buf input_fn (basename <.> suff) case eimps of - Left errs -> throwErrors (fmap mkParserErr errs) + Left errs -> throwErrors (foldPsMessages mkParserErr errs) Right (src_imps,imps,L _ mod_name) -> return (Just buf, mod_name, imps, src_imps) |