diff options
author | Ben Gamari <ben@smart-cactus.org> | 2019-06-04 18:03:03 -0400 |
---|---|---|
committer | Ben Gamari <ben@smart-cactus.org> | 2019-06-04 18:03:03 -0400 |
commit | 86259c2d92d151a62eba3458b4442f47bdab395e (patch) | |
tree | 2ddbe91fdf66ecd578bd0eb3e197cab6e2e19129 | |
parent | d21c21fc9ba41b43675254d2b30cab68d936a8ae (diff) | |
parent | a0646db3e2ac65c348141b2fe92de4ca6a6573a0 (diff) | |
download | haskell-86259c2d92d151a62eba3458b4442f47bdab395e.tar.gz |
Merge branch 'hie-backports-8.8' of https://gitlab.haskell.org/DanielG/ghc into wip/ghc-8.8-merges
-rw-r--r-- | compiler/backpack/DriverBkp.hs | 2 | ||||
-rw-r--r-- | compiler/main/DriverPipeline.hs | 67 | ||||
-rw-r--r-- | compiler/main/GhcMake.hs | 426 | ||||
-rw-r--r-- | compiler/main/HeaderInfo.hs | 15 | ||||
-rw-r--r-- | compiler/main/HscMain.hs | 4 | ||||
-rw-r--r-- | compiler/main/HscTypes.hs | 23 | ||||
-rw-r--r-- | compiler/utils/StringBuffer.hs | 6 | ||||
-rw-r--r-- | testsuite/tests/driver/T8602/T8602.stderr | 4 | ||||
-rw-r--r-- | testsuite/tests/ghc-api/downsweep/OldModLocation.hs | 61 | ||||
-rw-r--r-- | testsuite/tests/ghc-api/downsweep/OldModLocation.stderr | 1 | ||||
-rw-r--r-- | testsuite/tests/ghc-api/downsweep/PartialDownsweep.darwin.stderr | 16 | ||||
-rw-r--r-- | testsuite/tests/ghc-api/downsweep/PartialDownsweep.hs | 179 | ||||
-rw-r--r-- | testsuite/tests/ghc-api/downsweep/PartialDownsweep.stderr | 16 | ||||
-rw-r--r-- | testsuite/tests/ghc-api/downsweep/all.T | 12 | ||||
-rw-r--r-- | testsuite/tests/ghc-api/target-contents/TargetContents.hs | 149 | ||||
-rw-r--r-- | testsuite/tests/ghc-api/target-contents/TargetContents.stderr | 37 | ||||
-rw-r--r-- | testsuite/tests/ghc-api/target-contents/all.T | 4 |
17 files changed, 792 insertions, 230 deletions
diff --git a/compiler/backpack/DriverBkp.hs b/compiler/backpack/DriverBkp.hs index e10d6d1de1..c770eddd6e 100644 --- a/compiler/backpack/DriverBkp.hs +++ b/compiler/backpack/DriverBkp.hs @@ -730,7 +730,7 @@ summariseDecl _pn hsc_src lmodname@(L loc modname) Nothing [] -- No exclusions case r of Nothing -> throwOneError (mkPlainErrMsg dflags loc (text "module" <+> ppr modname <+> text "was not found")) - Just (Left err) -> throwOneError err + Just (Left err) -> throwErrors err Just (Right summary) -> return summary -- | Up until now, GHC has assumed a single compilation target per source file. diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index 5fe2362973..8ffeb5e908 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -52,7 +52,7 @@ import DynFlags import Config import Panic import Util -import StringBuffer ( hGetStringBuffer ) +import StringBuffer ( hGetStringBuffer, hPutStringBuffer ) import BasicTypes ( SuccessFlag(..) ) import Maybes ( expectJust ) import SrcLoc @@ -64,6 +64,8 @@ import Hooks import qualified GHC.LanguageExtensions as LangExt import FileCleanup import Ar +import Bag ( unitBag ) +import FastString ( mkFastString ) import Exception import System.Directory @@ -87,17 +89,28 @@ import Data.Time ( UTCTime ) -- of slurping in the OPTIONS pragmas preprocess :: HscEnv - -> (FilePath, Maybe Phase) -- ^ filename and starting phase - -> IO (DynFlags, FilePath) -preprocess hsc_env (filename, mb_phase) = - ASSERT2(isJust mb_phase || isHaskellSrcFilename filename, text filename) - runPipeline anyHsc hsc_env (filename, fmap RealPhase mb_phase) + -> FilePath -- ^ input filename + -> Maybe InputFileBuffer + -- ^ optional buffer to use instead of reading the input file + -> Maybe Phase -- ^ starting phase + -> IO (Either ErrorMessages (DynFlags, FilePath)) +preprocess hsc_env input_fn mb_input_buf mb_phase = + handleSourceError (\err -> return (Left (srcErrorMessages err))) $ + ghandle handler $ + fmap Right $ + ASSERT2(isJust mb_phase || isHaskellSrcFilename input_fn, text input_fn) + runPipeline anyHsc hsc_env (input_fn, mb_input_buf, fmap RealPhase mb_phase) Nothing -- We keep the processed file for the whole session to save on -- duplicated work in ghci. (Temporary TFL_GhcSession) Nothing{-no ModLocation-} []{-no foreign objects-} + where + srcspan = srcLocSpan $ mkSrcLoc (mkFastString input_fn) 1 1 + handler (ProgramError msg) = return $ Left $ unitBag $ + mkPlainErrMsg (hsc_dflags hsc_env) srcspan $ text msg + handler ex = throwGhcExceptionIO ex -- --------------------------------------------------------------------------- @@ -186,6 +199,7 @@ compileOne' m_tc_result mHscMessage -- handled properly _ <- runPipeline StopLn hsc_env (output_fn, + Nothing, Just (HscOut src_flavour mod_name HscUpdateSig)) (Just basename) @@ -223,6 +237,7 @@ compileOne' m_tc_result mHscMessage -- We're in --make mode: finish the compilation pipeline. _ <- runPipeline StopLn hsc_env (output_fn, + Nothing, Just (HscOut src_flavour mod_name (HscRecomp cgguts summary))) (Just basename) Persistent @@ -313,7 +328,7 @@ compileForeign hsc_env lang stub_c = do LangAsm -> As True -- allow CPP RawObject -> panic "compileForeign: should be unreachable" (_, stub_o) <- runPipeline StopLn hsc_env - (stub_c, Just (RealPhase phase)) + (stub_c, Nothing, Just (RealPhase phase)) Nothing (Temporary TFL_GhcSession) Nothing{-no ModLocation-} [] @@ -335,7 +350,7 @@ compileEmptyStub dflags hsc_env basename location mod_name = do let src = text "int" <+> ppr (mkModule (thisPackage dflags) mod_name) <+> text "= 0;" writeFile empty_stub (showSDoc dflags (pprCode CStyle src)) _ <- runPipeline StopLn hsc_env - (empty_stub, Nothing) + (empty_stub, Nothing, Nothing) (Just basename) Persistent (Just location) @@ -525,9 +540,10 @@ compileFile hsc_env stop_phase (src, mb_phase) = do stop_phase' = case stop_phase of As _ | split -> SplitAs _ -> stop_phase - ( _, out_file) <- runPipeline stop_phase' hsc_env - (src, fmap RealPhase mb_phase) Nothing output + (src, Nothing, fmap RealPhase mb_phase) + Nothing + output Nothing{-no ModLocation-} [] return out_file @@ -560,13 +576,15 @@ doLink dflags stop_phase o_files runPipeline :: Phase -- ^ When to stop -> HscEnv -- ^ Compilation environment - -> (FilePath,Maybe PhasePlus) -- ^ Input filename (and maybe -x suffix) + -> (FilePath, Maybe InputFileBuffer, Maybe PhasePlus) + -- ^ Pipeline input file name, optional + -- buffer and maybe -x suffix -> Maybe FilePath -- ^ original basename (if different from ^^^) -> PipelineOutput -- ^ Output filename -> Maybe ModLocation -- ^ A ModLocation, if this is a Haskell module -> [FilePath] -- ^ foreign objects -> IO (DynFlags, FilePath) -- ^ (final flags, output filename) -runPipeline stop_phase hsc_env0 (input_fn, mb_phase) +runPipeline stop_phase hsc_env0 (input_fn, mb_input_buf, mb_phase) mb_basename output maybe_loc foreign_os = do let @@ -618,8 +636,22 @@ runPipeline stop_phase hsc_env0 (input_fn, mb_phase) ++ input_fn)) HscOut {} -> return () + -- Write input buffer to temp file if requested + input_fn' <- case (start_phase, mb_input_buf) of + (RealPhase real_start_phase, Just input_buf) -> do + let suffix = phaseInputExt real_start_phase + fn <- newTempName dflags TFL_CurrentModule suffix + hdl <- openBinaryFile fn WriteMode + -- Add a LINE pragma so reported source locations will + -- mention the real input file, not this temp file. + hPutStrLn hdl $ "{-# LINE 1 \""++ input_fn ++ "\"#-}" + hPutStringBuffer hdl input_buf + hClose hdl + return fn + (_, _) -> return input_fn + debugTraceMsg dflags 4 (text "Running the pipeline") - r <- runPipeline' start_phase hsc_env env input_fn + r <- runPipeline' start_phase hsc_env env input_fn' maybe_loc foreign_os -- If we are compiling a Haskell module, and doing @@ -633,7 +665,7 @@ runPipeline stop_phase hsc_env0 (input_fn, mb_phase) (text "Running the pipeline again for -dynamic-too") let dflags' = dynamicTooMkDynamicDynFlags dflags hsc_env' <- newHscEnv dflags' - _ <- runPipeline' start_phase hsc_env' env input_fn + _ <- runPipeline' start_phase hsc_env' env input_fn' maybe_loc foreign_os return () return r @@ -1007,8 +1039,11 @@ runPhase (RealPhase (Hsc src_flavour)) input_fn dflags0 (hspp_buf,mod_name,imps,src_imps) <- liftIO $ do do buf <- hGetStringBuffer input_fn - (src_imps,imps,L _ mod_name) <- getImports dflags buf input_fn (basename <.> suff) - return (Just buf, mod_name, imps, src_imps) + eimps <- getImports dflags buf input_fn (basename <.> suff) + case eimps of + Left errs -> throwErrors errs + Right (src_imps,imps,L _ mod_name) -> return + (Just buf, mod_name, imps, src_imps) -- Take -o into account if present -- Very like -ohi, but we must *only* do this if we aren't linking diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs index aa9f01d25a..87396b4b69 100644 --- a/compiler/main/GhcMake.hs +++ b/compiler/main/GhcMake.hs @@ -1,5 +1,5 @@ {-# LANGUAGE BangPatterns, CPP, NondecreasingIndentation, ScopedTypeVariables #-} -{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards, NamedFieldPuns #-} -- ----------------------------------------------------------------------------- -- @@ -10,9 +10,11 @@ -- -- ----------------------------------------------------------------------------- module GhcMake( - depanal, + depanal, depanalPartial, load, load', LoadHowMuch(..), + downsweep, + topSortModuleGraph, ms_home_srcimps, ms_home_imps, @@ -46,7 +48,7 @@ import TcIface ( typecheckIface ) import TcRnMonad ( initIfaceCheck ) import HscMain -import Bag ( listToBag ) +import Bag ( unitBag, listToBag, unionManyBags, isEmptyBag ) import BasicTypes import Digraph import Exception ( tryIO, gbracket, gfinally ) @@ -64,7 +66,6 @@ import TcBackpack import Packages import UniqSet import Util -import qualified GHC.LanguageExtensions as LangExt import NameEnv import FileCleanup @@ -80,6 +81,7 @@ import Control.Concurrent.MVar import Control.Concurrent.QSem import Control.Exception import Control.Monad +import Control.Monad.Trans.Except ( ExceptT(..), runExceptT, throwE ) import Data.IORef import Data.List import qualified Data.List as List @@ -119,6 +121,32 @@ depanal :: GhcMonad m => -> Bool -- ^ allow duplicate roots -> m ModuleGraph depanal excluded_mods allow_dup_roots = do + hsc_env <- getSession + (errs, mod_graph) <- depanalPartial excluded_mods allow_dup_roots + if isEmptyBag errs + then do + warnMissingHomeModules hsc_env mod_graph + setSession hsc_env { hsc_mod_graph = mod_graph } + return mod_graph + else throwErrors errs + + +-- | Perform dependency analysis like 'depanal' but return a partial module +-- graph even in the face of problems with some modules. +-- +-- Modules which have parse errors in the module header, failing +-- preprocessors or other issues preventing them from being summarised will +-- simply be absent from the returned module graph. +-- +-- Unlike 'depanal' this function will not update 'hsc_mod_graph' with the +-- new module graph. +depanalPartial + :: GhcMonad m + => [ModuleName] -- ^ excluded modules + -> Bool -- ^ allow duplicate roots + -> m (ErrorMessages, ModuleGraph) + -- ^ possibly empty 'Bag' of errors and a module graph. +depanalPartial excluded_mods allow_dup_roots = do hsc_env <- getSession let dflags = hsc_dflags hsc_env @@ -138,14 +166,10 @@ depanal excluded_mods allow_dup_roots = do mod_summariesE <- liftIO $ downsweep hsc_env (mgModSummaries old_graph) excluded_mods allow_dup_roots - mod_summaries <- reportImportErrors mod_summariesE - - let mod_graph = mkModuleGraph mod_summaries - - warnMissingHomeModules hsc_env mod_graph - - setSession hsc_env { hsc_mod_graph = mod_graph } - return mod_graph + let + (errs, mod_summaries) = partitionEithers mod_summariesE + mod_graph = mkModuleGraph mod_summaries + return (unionManyBags errs, mod_graph) -- Note [Missing home modules] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1909,14 +1933,11 @@ warnUnnecessarySourceImports sccs = do <+> quotes (ppr mod)) -reportImportErrors :: MonadIO m => [Either ErrMsg b] -> m [b] +reportImportErrors :: MonadIO m => [Either ErrorMessages b] -> m [b] reportImportErrors xs | null errs = return oks - | otherwise = throwManyErrors errs + | otherwise = throwErrors $ unionManyBags errs where (errs, oks) = partitionEithers xs -throwManyErrors :: MonadIO m => [ErrMsg] -> m ab -throwManyErrors errs = liftIO $ throwIO $ mkSrcErr $ listToBag errs - ----------------------------------------------------------------------------- -- @@ -1940,7 +1961,7 @@ downsweep :: HscEnv -> Bool -- True <=> allow multiple targets to have -- the same module name; this is -- very useful for ghc -M - -> IO [Either ErrMsg ModSummary] + -> IO [Either ErrorMessages ModSummary] -- The elts of [ModSummary] all have distinct -- (Modules, IsBoot) identifiers, unless the Bool is true -- in which case there can be repeats @@ -1970,13 +1991,13 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots old_summary_map :: NodeMap ModSummary old_summary_map = mkNodeMap old_summaries - getRootSummary :: Target -> IO (Either ErrMsg ModSummary) + getRootSummary :: Target -> IO (Either ErrorMessages ModSummary) getRootSummary (Target (TargetFile file mb_phase) obj_allowed maybe_buf) = do exists <- liftIO $ doesFileExist file - if exists - then Right `fmap` summariseFile hsc_env old_summaries file mb_phase + if exists || isJust maybe_buf + then summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf - else return $ Left $ mkPlainErrMsg dflags noSrcSpan $ + else return $ Left $ unitBag $ mkPlainErrMsg dflags noSrcSpan $ text "can't find file:" <+> text file getRootSummary (Target (TargetModule modl) obj_allowed maybe_buf) = do maybe_summary <- summariseModule hsc_env old_summary_map NotBoot @@ -1992,7 +2013,7 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots -- name, so we have to check that there aren't multiple root files -- defining the same module (otherwise the duplicates will be silently -- ignored, leading to confusing behaviour). - checkDuplicates :: NodeMap [Either ErrMsg ModSummary] -> IO () + checkDuplicates :: NodeMap [Either ErrorMessages ModSummary] -> IO () checkDuplicates root_map | allow_dup_roots = return () | null dup_roots = return () @@ -2003,11 +2024,11 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots loop :: [(Located ModuleName,IsBoot)] -- Work list: process these modules - -> NodeMap [Either ErrMsg ModSummary] + -> NodeMap [Either ErrorMessages ModSummary] -- Visited set; the range is a list because -- the roots can have the same module names -- if allow_dup_roots is True - -> IO (NodeMap [Either ErrMsg ModSummary]) + -> IO (NodeMap [Either ErrorMessages ModSummary]) -- The result is the completed NodeMap loop [] done = return done loop ((wanted_mod, is_boot) : ss) done @@ -2036,8 +2057,8 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots -- and .o file locations to be temporary files. -- See Note [-fno-code mode] enableCodeGenForTH :: HscTarget - -> NodeMap [Either ErrMsg ModSummary] - -> IO (NodeMap [Either ErrMsg ModSummary]) + -> NodeMap [Either ErrorMessages ModSummary] + -> IO (NodeMap [Either ErrorMessages ModSummary]) enableCodeGenForTH target nodemap = traverse (traverse (traverse enable_code_gen)) nodemap where @@ -2102,7 +2123,7 @@ enableCodeGenForTH target nodemap = new_marked_mods = Set.insert ms_mod marked_mods in foldl' go new_marked_mods deps -mkRootMap :: [ModSummary] -> NodeMap [Either ErrMsg ModSummary] +mkRootMap :: [ModSummary] -> NodeMap [Either ErrorMessages ModSummary] mkRootMap summaries = Map.insertListWith (flip (++)) [ (msKey s, [Right s]) | s <- summaries ] Map.empty @@ -2162,13 +2183,13 @@ summariseFile -> Maybe Phase -- start phase -> Bool -- object code allowed? -> Maybe (StringBuffer,UTCTime) - -> IO ModSummary + -> IO (Either ErrorMessages ModSummary) -summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf +summariseFile hsc_env old_summaries src_fn mb_phase obj_allowed maybe_buf -- we can use a cached summary if one is available and the -- source file hasn't changed, But we have to look up the summary -- by source file, rather than module name as we do in summarise. - | Just old_summary <- findSummaryBySourceFile old_summaries file + | Just old_summary <- findSummaryBySourceFile old_summaries src_fn = do let location = ms_location old_summary dflags = hsc_dflags hsc_env @@ -2180,82 +2201,44 @@ summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf -- behaviour. -- return the cached summary if the source didn't change - if ms_hs_date old_summary == src_timestamp && - not (gopt Opt_ForceRecomp (hsc_dflags hsc_env)) - then do -- update the object-file timestamp - obj_timestamp <- - if isObjectTarget (hscTarget (hsc_dflags hsc_env)) - || obj_allowed -- bug #1205 - then liftIO $ getObjTimestamp location NotBoot - else return Nothing - hi_timestamp <- maybeGetIfaceDate dflags location - let hie_location = ml_hie_file location - hie_timestamp <- modificationTimeIfExists hie_location - - -- We have to repopulate the Finder's cache because it - -- was flushed before the downsweep. - _ <- liftIO $ addHomeModuleToFinder hsc_env - (moduleName (ms_mod old_summary)) (ms_location old_summary) - - return old_summary{ ms_obj_date = obj_timestamp - , ms_iface_date = hi_timestamp - , ms_hie_date = hie_timestamp } - else - new_summary src_timestamp + checkSummaryTimestamp + hsc_env dflags obj_allowed NotBoot (new_summary src_fn) + old_summary location src_timestamp | otherwise = do src_timestamp <- get_src_timestamp - new_summary src_timestamp + new_summary src_fn src_timestamp where get_src_timestamp = case maybe_buf of Just (_,t) -> return t - Nothing -> liftIO $ getModificationUTCTime file + Nothing -> liftIO $ getModificationUTCTime src_fn -- getModificationUTCTime may fail - new_summary src_timestamp = do - let dflags = hsc_dflags hsc_env + new_summary src_fn src_timestamp = runExceptT $ do + preimps@PreprocessedImports {..} + <- getPreprocessedImports hsc_env src_fn mb_phase maybe_buf - let hsc_src = if isHaskellSigFilename file then HsigFile else HsSrcFile - - (dflags', hspp_fn, buf) - <- preprocessFile hsc_env file mb_phase maybe_buf - - (srcimps,the_imps, L _ mod_name) <- getImports dflags' buf hspp_fn file -- Make a ModLocation for this file - location <- liftIO $ mkHomeModLocation dflags mod_name file + location <- liftIO $ mkHomeModLocation (hsc_dflags hsc_env) pi_mod_name src_fn -- Tell the Finder cache where it is, so that subsequent calls -- to findModule will find it, even if it's not on any search path - mod <- liftIO $ addHomeModuleToFinder hsc_env mod_name location - - -- when the user asks to load a source file by name, we only - -- use an object file if -fobject-code is on. See #1205. - obj_timestamp <- - if isObjectTarget (hscTarget (hsc_dflags hsc_env)) - || obj_allowed -- bug #1205 - then liftIO $ modificationTimeIfExists (ml_obj_file location) - else return Nothing - - hi_timestamp <- maybeGetIfaceDate dflags location - hie_timestamp <- modificationTimeIfExists (ml_hie_file location) - - extra_sig_imports <- findExtraSigImports hsc_env hsc_src mod_name - required_by_imports <- implicitRequirements hsc_env the_imps - - return (ModSummary { ms_mod = mod, - ms_hsc_src = hsc_src, - ms_location = location, - ms_hspp_file = hspp_fn, - ms_hspp_opts = dflags', - ms_hspp_buf = Just buf, - ms_parsed_mod = Nothing, - ms_srcimps = srcimps, - ms_textual_imps = the_imps ++ extra_sig_imports ++ required_by_imports, - ms_hs_date = src_timestamp, - ms_iface_date = hi_timestamp, - ms_hie_date = hie_timestamp, - ms_obj_date = obj_timestamp }) + mod <- liftIO $ addHomeModuleToFinder hsc_env pi_mod_name location + + liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary + { nms_src_fn = src_fn + , nms_src_timestamp = src_timestamp + , nms_is_boot = NotBoot + , nms_hsc_src = + if isHaskellSigFilename src_fn + then HsigFile + else HsSrcFile + , nms_location = location + , nms_mod = mod + , nms_obj_allowed = obj_allowed + , nms_preimps = preimps + } findSummaryBySourceFile :: [ModSummary] -> FilePath -> Maybe ModSummary findSummaryBySourceFile summaries file @@ -2264,6 +2247,44 @@ findSummaryBySourceFile summaries file [] -> Nothing (x:_) -> Just x +checkSummaryTimestamp + :: HscEnv -> DynFlags -> Bool -> IsBoot + -> (UTCTime -> IO (Either e ModSummary)) + -> ModSummary -> ModLocation -> UTCTime + -> IO (Either e ModSummary) +checkSummaryTimestamp + hsc_env dflags obj_allowed is_boot new_summary + old_summary location src_timestamp + | ms_hs_date old_summary == src_timestamp && + not (gopt Opt_ForceRecomp (hsc_dflags hsc_env)) = do + -- update the object-file timestamp + obj_timestamp <- + if isObjectTarget (hscTarget (hsc_dflags hsc_env)) + || obj_allowed -- bug #1205 + then liftIO $ getObjTimestamp location is_boot + else return Nothing + + -- We have to repopulate the Finder's cache for file targets + -- because the file might not even be on the regular serach path + -- and it was likely flushed in depanal. This is not technically + -- needed when we're called from sumariseModule but it shouldn't + -- hurt. + _ <- addHomeModuleToFinder hsc_env + (moduleName (ms_mod old_summary)) location + + hi_timestamp <- maybeGetIfaceDate dflags location + hie_timestamp <- modificationTimeIfExists (ml_hie_file location) + + return $ Right old_summary + { ms_obj_date = obj_timestamp + , ms_iface_date = hi_timestamp + , ms_hie_date = hie_timestamp + } + + | otherwise = + -- source changed: re-summarise. + new_summary src_timestamp + -- Summarise a module, and pick up source and timestamp. summariseModule :: HscEnv @@ -2273,7 +2294,7 @@ summariseModule -> Bool -- object code allowed? -> Maybe (StringBuffer, UTCTime) -> [ModuleName] -- Modules to exclude - -> IO (Maybe (Either ErrMsg ModSummary)) -- Its new summary + -> IO (Maybe (Either ErrorMessages ModSummary)) -- Its new summary summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) obj_allowed maybe_buf excl_mods @@ -2290,11 +2311,13 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) -- return the cached summary if it hasn't changed. If the -- file has disappeared, we need to call the Finder again. case maybe_buf of - Just (_,t) -> check_timestamp old_summary location src_fn t + Just (_,t) -> + Just <$> check_timestamp old_summary location src_fn t Nothing -> do m <- tryIO (getModificationUTCTime src_fn) case m of - Right t -> check_timestamp old_summary location src_fn t + Right t -> + Just <$> check_timestamp old_summary location src_fn t Left e | isDoesNotExistError e -> find_it | otherwise -> ioError e @@ -2302,23 +2325,11 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) where dflags = hsc_dflags hsc_env - check_timestamp old_summary location src_fn src_timestamp - | ms_hs_date old_summary == src_timestamp && - not (gopt Opt_ForceRecomp dflags) = do - -- update the object-file timestamp - obj_timestamp <- - if isObjectTarget (hscTarget (hsc_dflags hsc_env)) - || obj_allowed -- bug #1205 - then getObjTimestamp location is_boot - else return Nothing - hi_timestamp <- maybeGetIfaceDate dflags location - hie_timestamp <- modificationTimeIfExists (ml_hie_file location) - return (Just (Right old_summary{ ms_obj_date = obj_timestamp - , ms_iface_date = hi_timestamp - , ms_hie_date = hie_timestamp })) - | otherwise = - -- source changed: re-summarise. - new_summary location (ms_mod old_summary) src_fn src_timestamp + check_timestamp old_summary location src_fn = + checkSummaryTimestamp + hsc_env dflags obj_allowed is_boot + (new_summary location (ms_mod old_summary) src_fn) + old_summary location find_it = do found <- findImportedModule hsc_env wanted_mod Nothing @@ -2326,7 +2337,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) Found location mod | isJust (ml_hs_file location) -> -- Home package - just_found location mod + Just <$> just_found location mod _ -> return Nothing -- Not found @@ -2344,16 +2355,13 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) -- It might have been deleted since the Finder last found it maybe_t <- modificationTimeIfExists src_fn case maybe_t of - Nothing -> return $ Just $ Left $ noHsFileErr dflags loc src_fn + Nothing -> return $ Left $ noHsFileErr dflags loc src_fn Just t -> new_summary location' mod src_fn t - new_summary location mod src_fn src_timestamp - = do - -- Preprocess the source file and get its imports - -- The dflags' contains the OPTIONS pragmas - (dflags', hspp_fn, buf) <- preprocessFile hsc_env src_fn Nothing maybe_buf - (srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn src_fn + = runExceptT $ do + preimps@PreprocessedImports {..} + <- getPreprocessedImports hsc_env src_fn Nothing maybe_buf -- NB: Despite the fact that is_boot is a top-level parameter, we -- don't actually know coming into this function what the HscSource @@ -2367,97 +2375,123 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) _ | isHaskellSigFilename src_fn -> HsigFile | otherwise -> HsSrcFile - when (mod_name /= wanted_mod) $ - throwOneError $ mkPlainErrMsg dflags' mod_loc $ + when (pi_mod_name /= wanted_mod) $ + throwE $ unitBag $ mkPlainErrMsg pi_local_dflags pi_mod_name_loc $ text "File name does not match module name:" - $$ text "Saw:" <+> quotes (ppr mod_name) + $$ text "Saw:" <+> quotes (ppr pi_mod_name) $$ text "Expected:" <+> quotes (ppr wanted_mod) - when (hsc_src == HsigFile && isNothing (lookup mod_name (thisUnitIdInsts dflags))) $ + when (hsc_src == HsigFile && isNothing (lookup pi_mod_name (thisUnitIdInsts dflags))) $ let suggested_instantiated_with = hcat (punctuate comma $ [ ppr k <> text "=" <> ppr v - | (k,v) <- ((mod_name, mkHoleModule mod_name) + | (k,v) <- ((pi_mod_name, mkHoleModule pi_mod_name) : thisUnitIdInsts dflags) ]) - in throwOneError $ mkPlainErrMsg dflags' mod_loc $ - text "Unexpected signature:" <+> quotes (ppr mod_name) + in throwE $ unitBag $ mkPlainErrMsg pi_local_dflags pi_mod_name_loc $ + text "Unexpected signature:" <+> quotes (ppr pi_mod_name) $$ if gopt Opt_BuildingCabalPackage dflags - then parens (text "Try adding" <+> quotes (ppr mod_name) + then parens (text "Try adding" <+> quotes (ppr pi_mod_name) <+> text "to the" <+> quotes (text "signatures") <+> text "field in your Cabal file.") else parens (text "Try passing -instantiated-with=\"" <> suggested_instantiated_with <> text "\"" $$ - text "replacing <" <> ppr mod_name <> text "> as necessary.") - - -- Find the object timestamp, and return the summary - obj_timestamp <- - if isObjectTarget (hscTarget (hsc_dflags hsc_env)) - || obj_allowed -- bug #1205 - then getObjTimestamp location is_boot - else return Nothing - - hi_timestamp <- maybeGetIfaceDate dflags location - hie_timestamp <- modificationTimeIfExists (ml_hie_file location) - - extra_sig_imports <- findExtraSigImports hsc_env hsc_src mod_name - required_by_imports <- implicitRequirements hsc_env the_imps - - return (Just (Right (ModSummary { ms_mod = mod, - ms_hsc_src = hsc_src, - ms_location = location, - ms_hspp_file = hspp_fn, - ms_hspp_opts = dflags', - ms_hspp_buf = Just buf, - ms_parsed_mod = Nothing, - ms_srcimps = srcimps, - ms_textual_imps = the_imps ++ extra_sig_imports ++ required_by_imports, - ms_hs_date = src_timestamp, - ms_iface_date = hi_timestamp, - ms_hie_date = hie_timestamp, - ms_obj_date = obj_timestamp }))) - + text "replacing <" <> ppr pi_mod_name <> text "> as necessary.") + + liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary + { nms_src_fn = src_fn + , nms_src_timestamp = src_timestamp + , nms_is_boot = is_boot + , nms_hsc_src = hsc_src + , nms_location = location + , nms_mod = mod + , nms_obj_allowed = obj_allowed + , nms_preimps = preimps + } + +-- | Convenience named arguments for 'makeNewModSummary' only used to make +-- code more readable, not exported. +data MakeNewModSummary + = MakeNewModSummary + { nms_src_fn :: FilePath + , nms_src_timestamp :: UTCTime + , nms_is_boot :: IsBoot + , nms_hsc_src :: HscSource + , nms_location :: ModLocation + , nms_mod :: Module + , nms_obj_allowed :: Bool + , nms_preimps :: PreprocessedImports + } + +makeNewModSummary :: HscEnv -> MakeNewModSummary -> IO ModSummary +makeNewModSummary hsc_env MakeNewModSummary{..} = do + let PreprocessedImports{..} = nms_preimps + let dflags = hsc_dflags hsc_env + + -- when the user asks to load a source file by name, we only + -- use an object file if -fobject-code is on. See #1205. + obj_timestamp <- liftIO $ + if isObjectTarget (hscTarget dflags) + || nms_obj_allowed -- bug #1205 + then getObjTimestamp nms_location nms_is_boot + else return Nothing + + hi_timestamp <- maybeGetIfaceDate dflags nms_location + hie_timestamp <- modificationTimeIfExists (ml_hie_file nms_location) + + extra_sig_imports <- findExtraSigImports hsc_env nms_hsc_src pi_mod_name + required_by_imports <- implicitRequirements hsc_env pi_theimps + + return $ ModSummary + { ms_mod = nms_mod + , ms_hsc_src = nms_hsc_src + , ms_location = nms_location + , ms_hspp_file = pi_hspp_fn + , ms_hspp_opts = pi_local_dflags + , ms_hspp_buf = Just pi_hspp_buf + , ms_parsed_mod = Nothing + , ms_srcimps = pi_srcimps + , ms_textual_imps = + pi_theimps ++ extra_sig_imports ++ required_by_imports + , ms_hs_date = nms_src_timestamp + , ms_iface_date = hi_timestamp + , ms_hie_date = hie_timestamp + , ms_obj_date = obj_timestamp + } getObjTimestamp :: ModLocation -> IsBoot -> IO (Maybe UTCTime) getObjTimestamp location is_boot = if is_boot == IsBoot then return Nothing else modificationTimeIfExists (ml_obj_file location) - -preprocessFile :: HscEnv - -> FilePath - -> Maybe Phase -- ^ Starting phase - -> Maybe (StringBuffer,UTCTime) - -> IO (DynFlags, FilePath, StringBuffer) -preprocessFile hsc_env src_fn mb_phase Nothing - = do - (dflags', hspp_fn) <- preprocess hsc_env (src_fn, mb_phase) - buf <- hGetStringBuffer hspp_fn - return (dflags', hspp_fn, buf) - -preprocessFile hsc_env src_fn mb_phase (Just (buf, _time)) - = do - let dflags = hsc_dflags hsc_env - let local_opts = getOptions dflags buf src_fn - - (dflags', leftovers, warns) - <- parseDynamicFilePragma dflags local_opts - checkProcessArgsResult dflags leftovers - handleFlagWarnings dflags' warns - - let needs_preprocessing - | Just (Unlit _) <- mb_phase = True - | Nothing <- mb_phase, Unlit _ <- startPhase src_fn = True - -- note: local_opts is only required if there's no Unlit phase - | xopt LangExt.Cpp dflags' = True - | gopt Opt_Pp dflags' = True - | otherwise = False - - when needs_preprocessing $ - throwGhcExceptionIO (ProgramError "buffer needs preprocesing; interactive check disabled") - - return (dflags', src_fn, buf) +data PreprocessedImports + = PreprocessedImports + { pi_local_dflags :: DynFlags + , pi_srcimps :: [(Maybe FastString, Located ModuleName)] + , pi_theimps :: [(Maybe FastString, Located ModuleName)] + , pi_hspp_fn :: FilePath + , pi_hspp_buf :: StringBuffer + , pi_mod_name_loc :: SrcSpan + , pi_mod_name :: ModuleName + } + +-- Preprocess the source file and get its imports +-- The pi_local_dflags contains the OPTIONS pragmas +getPreprocessedImports + :: HscEnv + -> FilePath + -> Maybe Phase + -> Maybe (StringBuffer, UTCTime) + -- ^ optional source code buffer and modification time + -> ExceptT ErrorMessages IO PreprocessedImports +getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do + (pi_local_dflags, pi_hspp_fn) + <- ExceptT $ preprocess hsc_env src_fn (fst <$> maybe_buf) mb_phase + pi_hspp_buf <- liftIO $ hGetStringBuffer pi_hspp_fn + (pi_srcimps, pi_theimps, L pi_mod_name_loc pi_mod_name) + <- ExceptT $ getImports pi_local_dflags pi_hspp_buf pi_hspp_fn src_fn + return PreprocessedImports {..} ----------------------------------------------------------------------------- @@ -2469,13 +2503,13 @@ noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> ErrMsg noModError dflags loc wanted_mod err = mkPlainErrMsg dflags loc $ cannotFindModule dflags wanted_mod err -noHsFileErr :: DynFlags -> SrcSpan -> String -> ErrMsg +noHsFileErr :: DynFlags -> SrcSpan -> String -> ErrorMessages noHsFileErr dflags loc path - = mkPlainErrMsg dflags loc $ text "Can't find" <+> text path + = unitBag $ mkPlainErrMsg dflags loc $ text "Can't find" <+> text path -moduleNotFoundErr :: DynFlags -> ModuleName -> ErrMsg +moduleNotFoundErr :: DynFlags -> ModuleName -> ErrorMessages moduleNotFoundErr dflags mod - = mkPlainErrMsg dflags noSrcSpan $ + = unitBag $ mkPlainErrMsg dflags noSrcSpan $ text "module" <+> quotes (ppr mod) <+> text "cannot be found locally" multiRootsErr :: DynFlags -> [ModSummary] -> IO () diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs index 3fd510bb86..b5079c184a 100644 --- a/compiler/main/HeaderInfo.hs +++ b/compiler/main/HeaderInfo.hs @@ -59,17 +59,19 @@ getImports :: DynFlags -- reporting parse error locations. -> FilePath -- ^ The original source filename (used for locations -- in the function result) - -> IO ([(Maybe FastString, Located ModuleName)], - [(Maybe FastString, Located ModuleName)], - Located ModuleName) + -> IO (Either + ErrorMessages + ([(Maybe FastString, Located ModuleName)], + [(Maybe FastString, Located ModuleName)], + Located ModuleName)) -- ^ The source imports, normal imports, and the module name. getImports dflags buf filename source_filename = do let loc = mkRealSrcLoc (mkFastString filename) 1 1 case unP parseHeader (mkPState dflags buf loc) of PFailed _ span err -> do -- assuming we're not logging warnings here as per below - parseError dflags span err - POk pst rdr_module -> do + return $ Left $ unitBag $ mkPlainErrMsg dflags span err + POk pst rdr_module -> fmap Right $ do let _ms@(_warns, errs) = getMessages pst dflags -- don't log warnings: they'll be reported when we parse the file -- for real. See #2500. @@ -136,9 +138,6 @@ mkPrelImports this_mod loc implicit_prelude import_decls ideclAs = Nothing, ideclHiding = Nothing } -parseError :: DynFlags -> SrcSpan -> MsgDoc -> IO a -parseError dflags span err = throwOneError $ mkPlainErrMsg dflags span err - -------------------------------------------------------------- -- Get options -------------------------------------------------------------- diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index 674afc9f47..1c83d93b24 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -233,10 +233,6 @@ logWarningsReportErrors (warns,errs) = do logWarnings warns when (not $ isEmptyBag errs) $ throwErrors errs --- | Throw some errors. -throwErrors :: ErrorMessages -> Hsc a -throwErrors = liftIO . throwIO . mkSrcErr - -- | Deal with errors and warnings returned by a compilation step -- -- In order to reduce dependencies to other parts of the compiler, functions diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs index d17fa5fcef..ce97e3ae02 100644 --- a/compiler/main/HscTypes.hs +++ b/compiler/main/HscTypes.hs @@ -13,7 +13,7 @@ module HscTypes ( -- * compilation state HscEnv(..), hscEPS, FinderCache, FindResult(..), InstalledFindResult(..), - Target(..), TargetId(..), pprTarget, pprTargetId, + Target(..), TargetId(..), InputFileBuffer, pprTarget, pprTargetId, HscStatus(..), IServ(..), @@ -133,7 +133,7 @@ module HscTypes ( -- * Compilation errors and warnings SourceError, GhcApiError, mkSrcErr, srcErrorMessages, mkApiErr, - throwOneError, handleSourceError, + throwErrors, throwOneError, handleSourceError, handleFlagWarnings, printOrThrowWarnings, -- * COMPLETE signature @@ -278,6 +278,10 @@ srcErrorMessages (SourceError msgs) = msgs mkApiErr :: DynFlags -> SDoc -> GhcApiError mkApiErr dflags msg = GhcApiError (showSDoc dflags msg) +-- | Throw some errors. +throwErrors :: MonadIO io => ErrorMessages -> io a +throwErrors = liftIO . throwIO . mkSrcErr + throwOneError :: MonadIO m => ErrMsg -> m ab throwOneError err = liftIO $ throwIO $ mkSrcErr $ unitBag err @@ -499,8 +503,17 @@ data Target = Target { targetId :: TargetId, -- ^ module or filename targetAllowObjCode :: Bool, -- ^ object code allowed? - targetContents :: Maybe (StringBuffer,UTCTime) - -- ^ in-memory text buffer? + targetContents :: Maybe (InputFileBuffer, UTCTime) + -- ^ Optional in-memory buffer containing the source code GHC should + -- use for this target instead of reading it from disk. + -- + -- Since GHC version 8.10 modules which require preprocessors such as + -- Literate Haskell or CPP to run are also supported. + -- + -- If a corresponding source file does not exist on disk this will + -- result in a 'SourceError' exception if @targetId = TargetModule _@ + -- is used. However together with @targetId = TargetFile _@ GHC will + -- not complain about the file missing. } data TargetId @@ -513,6 +526,8 @@ data TargetId -- should be determined from the suffix of the filename. deriving Eq +type InputFileBuffer = StringBuffer + pprTarget :: Target -> SDoc pprTarget (Target id obj _) = (if obj then char '*' else empty) <> pprTargetId id diff --git a/compiler/utils/StringBuffer.hs b/compiler/utils/StringBuffer.hs index 64578bffde..a9fab79e83 100644 --- a/compiler/utils/StringBuffer.hs +++ b/compiler/utils/StringBuffer.hs @@ -19,6 +19,7 @@ module StringBuffer -- * Creation\/destruction hGetStringBuffer, hGetStringBufferBlock, + hPutStringBuffer, appendStringBuffers, stringToStringBuffer, @@ -121,6 +122,11 @@ hGetStringBufferBlock handle wanted then ioError (userError $ "short read of file: "++show(r,size,size_i,handle)) else newUTF8StringBuffer buf ptr size +hPutStringBuffer :: Handle -> StringBuffer -> IO () +hPutStringBuffer hdl (StringBuffer buf len cur) + = do withForeignPtr (plusForeignPtr buf cur) $ \ptr -> + hPutBuf hdl ptr len + -- | Skip the byte-order mark if there is one (see #1744 and #6016), -- and return the new position of the handle in bytes. -- diff --git a/testsuite/tests/driver/T8602/T8602.stderr b/testsuite/tests/driver/T8602/T8602.stderr index eb28842f54..4b0c4a5373 100644 --- a/testsuite/tests/driver/T8602/T8602.stderr +++ b/testsuite/tests/driver/T8602/T8602.stderr @@ -1,2 +1,4 @@ A B C -`t8602.sh' failed in phase `Haskell pre-processor'. (Exit code: 1) + +A.hs:1:1: error: + `t8602.sh' failed in phase `Haskell pre-processor'. (Exit code: 1) diff --git a/testsuite/tests/ghc-api/downsweep/OldModLocation.hs b/testsuite/tests/ghc-api/downsweep/OldModLocation.hs new file mode 100644 index 0000000000..a96bd42d24 --- /dev/null +++ b/testsuite/tests/ghc-api/downsweep/OldModLocation.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE ViewPatterns #-} + +import GHC +import GhcMake +import DynFlags +import Finder + +import Control.Monad.IO.Class (liftIO) +import Data.List +import Data.Either + +import System.Environment +import System.Directory +import System.IO + +main :: IO () +main = do + libdir:args <- getArgs + + runGhc (Just libdir) $ + defaultErrorHandler defaultFatalMessager defaultFlushOut $ do + + dflags0 <- getSessionDynFlags + (dflags1, _, _) <- parseDynamicFlags dflags0 $ map noLoc $ + [ "-i", "-i.", "-imydir" + -- , "-v3" + ] ++ args + _ <- setSessionDynFlags dflags1 + + liftIO $ mapM_ writeMod + [ [ "module A where" + , "import B" + ] + , [ "module B where" + ] + ] + + tgt <- guessTarget "A" Nothing + setTargets [tgt] + hsc_env <- getSession + + liftIO $ do + + _emss <- downsweep hsc_env [] [] False + + flushFinderCaches hsc_env + createDirectoryIfMissing False "mydir" + renameFile "B.hs" "mydir/B.hs" + + emss <- downsweep hsc_env [] [] False + + -- If 'checkSummaryTimestamp' were to call 'addHomeModuleToFinder' with + -- (ms_location old_summary) like summariseFile used to instead of + -- using the 'location' parameter we'd end up using the old location of + -- the "B" module in this test. Make sure that doesn't happen. + + hPrint stderr $ sort (map (ml_hs_file . ms_location) (rights emss)) + +writeMod :: [String] -> IO () +writeMod src@(head -> stripPrefix "module " -> Just (takeWhile (/=' ') -> mod)) + = writeFile (mod++".hs") $ unlines src diff --git a/testsuite/tests/ghc-api/downsweep/OldModLocation.stderr b/testsuite/tests/ghc-api/downsweep/OldModLocation.stderr new file mode 100644 index 0000000000..1bb974a936 --- /dev/null +++ b/testsuite/tests/ghc-api/downsweep/OldModLocation.stderr @@ -0,0 +1 @@ +[Just "A.hs",Just "mydir/B.hs"] diff --git a/testsuite/tests/ghc-api/downsweep/PartialDownsweep.darwin.stderr b/testsuite/tests/ghc-api/downsweep/PartialDownsweep.darwin.stderr new file mode 100644 index 0000000000..c9cd0f216d --- /dev/null +++ b/testsuite/tests/ghc-api/downsweep/PartialDownsweep.darwin.stderr @@ -0,0 +1,16 @@ +== Parse error in export list +== Parse error in export list with bypass module +== Parse error in import list +== CPP preprocessor error + +B.hs:2:2: #elif without #if + #elif <- cpp error here + ^ +1 error generated. +== CPP preprocessor error with bypass + +B.hs:2:2: #elif without #if + #elif <- cpp error here + ^ +1 error generated. +== Import error diff --git a/testsuite/tests/ghc-api/downsweep/PartialDownsweep.hs b/testsuite/tests/ghc-api/downsweep/PartialDownsweep.hs new file mode 100644 index 0000000000..335963be4e --- /dev/null +++ b/testsuite/tests/ghc-api/downsweep/PartialDownsweep.hs @@ -0,0 +1,179 @@ +{-# LANGUAGE ScopedTypeVariables, ViewPatterns #-} + +-- | This test checks if 'downsweep can return partial results when vaious +-- kinds of parse errors occur in modules. + +import GHC +import GhcMake +import DynFlags +import Outputable +import Exception (ExceptionMonad, ghandle) +import Bag + +import Control.Monad +import Control.Monad.IO.Class (liftIO) +import Control.Exception +import Data.IORef +import Data.List +import Data.Either + +import System.Environment +import System.Exit +import System.IO +import System.IO.Unsafe (unsafePerformIO) + +any_failed :: IORef Bool +any_failed = unsafePerformIO $ newIORef False +{-# NOINLINE any_failed #-} + +it :: ExceptionMonad m => [Char] -> m Bool -> m () +it msg act = + ghandle (\(_ex :: AssertionFailed) -> dofail) $ + ghandle (\(_ex :: ExitCode) -> dofail) $ do + res <- act + case res of + False -> dofail + True -> return () + where + dofail = do + liftIO $ hPutStrLn stderr $ "FAILED: " ++ msg + liftIO $ writeIORef any_failed True + +main :: IO () +main = do + libdir:args <- getArgs + + runGhc (Just libdir) $ do + dflags0 <- getSessionDynFlags + (dflags1, _, _) <- parseDynamicFlags dflags0 $ map noLoc $ + [ "-fno-diagnostics-show-caret" + -- , "-v3" + ] ++ args + _ <- setSessionDynFlags dflags1 + + go "Parse error in export list" + [ [ "module A where" + , "import B" + ] + , [ "module B !parse_error where" + -- ^ this used to cause getImports to throw an exception instead + -- of having downsweep return an error for just this module + , "import C" + ] + , [ "module C where" + ] + ] + (\mss -> return $ + sort (map (moduleNameString . moduleName . ms_mod) mss) == ["A"] + ) + + go "Parse error in export list with bypass module" + [ [ "module A where" + , "import B" + , "import C" + ] + , [ "module B !parse_error where" + , "import D" + ] + , [ "module C where" + , "import D" + ] + , [ "module D where" + ] + ] + (\mss -> return $ + sort (map (moduleNameString . moduleName . ms_mod) mss) == ["A", "C", "D"] + ) + go "Parse error in import list" + [ [ "module A where" + , "import B" + ] + , [ "module B where" + , "!parse_error" + -- ^ this is silently ignored, getImports assumes the import + -- list is just empty. This smells like a parser bug to me but + -- I'm still documenting this behaviour here. + , "import C" + ] + , [ "module C where" + ] + ] + (\mss -> return $ + sort (map (moduleNameString . moduleName . ms_mod) mss) == ["A", "B"] + ) + + go "CPP preprocessor error" + [ [ "module A where" + , "import B" + ] + , [ "{-# LANGUAGE CPP #-}" + , "#elif <- cpp error here" + , "module B where" + , "import C" + ] + , [ "module C where" + ] + ] + (\mss -> return $ + sort (map (moduleNameString . moduleName . ms_mod) mss) == ["A"] + ) + + go "CPP preprocessor error with bypass" + [ [ "module A where" + , "import B" + , "import C" + ] + , [ "{-# LANGUAGE CPP #-}" + , "#elif <- cpp error here" + , "module B where" + , "import C" + ] + , [ "module C where" + ] + ] + (\mss -> return $ + sort (map (moduleNameString . moduleName . ms_mod) mss) == ["A", "C"] + ) + + go "Import error" + [ [ "module A where" + , "import B" + , "import DoesNotExist_FooBarBaz" + ] + , [ "module B where" + ] + ] + (\mss -> return $ + sort (map (moduleNameString . moduleName . ms_mod) mss) == ["A", "B"] + ) + + errored <- readIORef any_failed + when errored $ exitFailure + return () + + +go :: String -> [[String]] -> ([ModSummary] -> Ghc Bool) -> Ghc () +go label mods cnd = + defaultErrorHandler defaultFatalMessager defaultFlushOut $ do + liftIO $ hPutStrLn stderr $ "== " ++ label + + liftIO $ mapM_ writeMod mods + + tgt <- guessTarget "A" Nothing + + setTargets [tgt] + + hsc_env <- getSession + emss <- liftIO $ downsweep hsc_env [] [] False + -- liftIO $ hPutStrLn stderr $ showSDocUnsafe $ ppr $ rights emss + -- liftIO $ hPrint stderr $ bagToList $ unionManyBags $ lefts emss + + it label $ cnd (rights emss) + + +writeMod :: [String] -> IO () +writeMod src = + writeFile (mod++".hs") $ unlines src + where + Just modline = find ("module" `isPrefixOf`) src + Just (takeWhile (/=' ') -> mod) = stripPrefix "module " modline diff --git a/testsuite/tests/ghc-api/downsweep/PartialDownsweep.stderr b/testsuite/tests/ghc-api/downsweep/PartialDownsweep.stderr new file mode 100644 index 0000000000..14c1b6c19a --- /dev/null +++ b/testsuite/tests/ghc-api/downsweep/PartialDownsweep.stderr @@ -0,0 +1,16 @@ +== Parse error in export list +== Parse error in export list with bypass module +== Parse error in import list +== CPP preprocessor error + +B.hs:2:0: error: + error: #elif without #if + #elif <- cpp error here + +== CPP preprocessor error with bypass + +B.hs:2:0: error: + error: #elif without #if + #elif <- cpp error here + +== Import error diff --git a/testsuite/tests/ghc-api/downsweep/all.T b/testsuite/tests/ghc-api/downsweep/all.T new file mode 100644 index 0000000000..8ca54b0bc6 --- /dev/null +++ b/testsuite/tests/ghc-api/downsweep/all.T @@ -0,0 +1,12 @@ +test('PartialDownsweep', + [ extra_run_opts('"' + config.libdir + '"') + , when(opsys('darwin'), skip) # use_specs doesn't exist on this branch yet + ], + compile_and_run, + ['-package ghc']) + +test('OldModLocation', + [ extra_run_opts('"' + config.libdir + '"') + ], + compile_and_run, + ['-package ghc']) diff --git a/testsuite/tests/ghc-api/target-contents/TargetContents.hs b/testsuite/tests/ghc-api/target-contents/TargetContents.hs new file mode 100644 index 0000000000..eaa30697f8 --- /dev/null +++ b/testsuite/tests/ghc-api/target-contents/TargetContents.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Main where + +import DynFlags +import GHC + +import Control.Monad +import Control.Monad.IO.Class (liftIO) +import Data.List +import Data.Maybe +import Data.Time.Calendar +import Data.Time.Clock +import Exception +import HeaderInfo +import HscTypes +import Outputable +import StringBuffer +import System.Directory +import System.Environment +import System.Process +import System.IO +import Text.Printf + +main :: IO () +main = do + libdir:args <- getArgs + createDirectoryIfMissing False "outdir" + runGhc (Just libdir) $ do + dflags0 <- getSessionDynFlags + (dflags1, xs, warn) <- parseDynamicFlags dflags0 $ map noLoc $ + [ "-outputdir", "./outdir" + , "-fno-diagnostics-show-caret" + ] ++ args + _ <- setSessionDynFlags dflags1 + + -- This test fails on purpose to check if the error message mentions + -- the source file and not the intermediary preprocessor input file + -- even when no preprocessor is in use. Just a sanity check. + go "Error" ["A"] + -- ^ ^-- targets + -- ^-- test name + [("A" -- this module's name + , "" -- pragmas + , [] -- imports/non exported decls + , [("x", "z")] -- exported decls + , OnDisk -- write this module to disk? + ) + ] + + forM_ [OnDisk, InMemory] $ \sync -> + -- This one fails unless CPP actually preprocessed the source + go ("CPP_" ++ ppSync sync) ["A"] + [( "A" + , "{-# LANGUAGE CPP #-}" + , ["#define y 1"] + , [("x", "y")] + , sync + ) + ] + + -- These check if on-disk modules can import in-memory targets and + -- vice-verca. + forM_ (words "DD MM DM MD") $ \sync@[a_sync, b_sync] -> do + dep <- return $ \y -> + [( "A" + , "{-# LANGUAGE CPP #-}" + , ["import B"] + , [("x", "y")] + , readSync a_sync + ), + ( "B" + , "{-# LANGUAGE CPP #-}" + , [] + , [("y", y)] + , readSync b_sync + ) + ] + go ("Dep_" ++ sync ++ "_AB") ["A", "B"] (dep "()") + + -- This checks if error messages are correctly referring to the real + -- source file and not the temp preprocessor input file. + go ("Dep_Error_" ++ sync ++ "_AB") ["A", "B"] (dep "z") + + -- Try with only one target, this is expected to fail with a module + -- not found error where module B is not OnDisk. + go ("Dep_Error_" ++ sync ++ "_A") ["A"] (dep "z") + + return () + +data Sync + = OnDisk -- | Write generated module to disk + | InMemory -- | Only fill in targetContents. + +ppSync OnDisk = "D" +ppSync InMemory = "M" + +readSync 'D' = OnDisk +readSync 'M' = InMemory + +go label targets mods = do + liftIO $ createDirectoryIfMissing False "./outdir" + setTargets []; _ <- load LoadAllTargets + + liftIO $ hPutStrLn stderr $ "== " ++ label + t <- liftIO getCurrentTime + setTargets =<< catMaybes <$> mapM (mkTarget t) mods + ex <- gtry $ load LoadAllTargets + case ex of + Left ex -> liftIO $ hPutStrLn stderr $ show (ex :: SourceError) + Right _ -> return () + + mapM_ (liftIO . cleanup) mods + liftIO $ removeDirectoryRecursive "./outdir" + + where + mkTarget t mod@(name,_,_,_,sync) = do + src <- liftIO $ genMod mod + return $ if not (name `elem` targets) + then Nothing + else Just $ Target + { targetId = TargetFile (name++".hs") Nothing + , targetAllowObjCode = False + , targetContents = + case sync of + OnDisk -> Nothing + InMemory -> + Just ( stringToStringBuffer src + , t + ) + } + +genMod :: (String, String, [String], [(String, String)], Sync) -> IO String +genMod (mod, pragmas, internal, binders, sync) = do + case sync of + OnDisk -> writeFile (mod++".hs") src + InMemory -> return () + return src + where + exports = intercalate ", " $ map fst binders + decls = map (\(b,v) -> b ++ " = " ++ v) binders + src = unlines $ + [ pragmas + , "module " ++ mod ++ " ("++ exports ++") where" + ] ++ internal ++ decls + +cleanup :: (String, String, [String], [(String, String)], Sync) -> IO () +cleanup (mod,_,_,_,OnDisk) = removeFile (mod++".hs") +cleanup _ = return () diff --git a/testsuite/tests/ghc-api/target-contents/TargetContents.stderr b/testsuite/tests/ghc-api/target-contents/TargetContents.stderr new file mode 100644 index 0000000000..2743f5135e --- /dev/null +++ b/testsuite/tests/ghc-api/target-contents/TargetContents.stderr @@ -0,0 +1,37 @@ +== Error + +A.hs:3:5: error: Variable not in scope: z +== CPP_D +== CPP_M +== Dep_DD_AB +== Dep_Error_DD_AB + +B.hs:3:5: error: Variable not in scope: z +== Dep_Error_DD_A + +B.hs:3:5: error: Variable not in scope: z +== Dep_MM_AB +== Dep_Error_MM_AB + +B.hs:3:5: error: Variable not in scope: z +== Dep_Error_MM_A + +A.hs:3:1: error: + Could not find module ‘B’ + Use -v (or `:set -v` in ghci) to see a list of the files searched for. +== Dep_DM_AB +== Dep_Error_DM_AB + +B.hs:3:5: error: Variable not in scope: z +== Dep_Error_DM_A + +A.hs:3:1: error: + Could not find module ‘B’ + Use -v (or `:set -v` in ghci) to see a list of the files searched for. +== Dep_MD_AB +== Dep_Error_MD_AB + +B.hs:3:5: error: Variable not in scope: z +== Dep_Error_MD_A + +B.hs:3:5: error: Variable not in scope: z diff --git a/testsuite/tests/ghc-api/target-contents/all.T b/testsuite/tests/ghc-api/target-contents/all.T new file mode 100644 index 0000000000..94cbfce9f0 --- /dev/null +++ b/testsuite/tests/ghc-api/target-contents/all.T @@ -0,0 +1,4 @@ +test('TargetContents', + [extra_run_opts('"' + config.libdir + '"')] + , compile_and_run, + ['-package ghc']) |