Refactor summarise{File,Module} to reduce code duplication
[ghc.git] / compiler / main / GhcMake.hs
index ac92f3b..760d9d4 100644 (file)
@@ -1,5 +1,5 @@
 {-# LANGUAGE BangPatterns, CPP, NondecreasingIndentation, ScopedTypeVariables #-}
-{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}
 
 -- -----------------------------------------------------------------------------
 --
@@ -13,6 +13,8 @@ module GhcMake(
         depanal,
         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 )
 import BasicTypes
 import Digraph
 import Exception        ( tryIO, gbracket, gfinally )
@@ -184,6 +186,10 @@ warnMissingHomeModules hsc_env mod_graph =
     is_my_target mod (TargetFile target_file _)
       | Just mod_file <- ml_hs_file (ms_location mod)
       = target_file == mod_file ||
+
+           --  Don't warn on B.hs-boot if B.hs is specified (#16551)
+           addBootSuffix target_file == mod_file ||
+
            --  We can get a file target even if a module name was
            --  originally specified in a command line because it can
            --  be converted in guessTarget (by appending .hs/.lhs).
@@ -1906,14 +1912,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
-
 
 -----------------------------------------------------------------------------
 --
@@ -1937,7 +1940,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
@@ -1954,11 +1957,11 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots
        -- See Note [-fno-code mode] #8025
        map1 <- if hscTarget dflags == HscNothing
          then enableCodeGenForTH
-           (defaultObjectTarget (settings dflags))
+           (defaultObjectTarget dflags)
            map0
          else if hscTarget dflags == HscInterpreted
            then enableCodeGenForUnboxedTuples
-             (defaultObjectTarget (settings dflags))
+             (defaultObjectTarget dflags)
              map0
            else return map0
        return $ concat $ nodeMapElts map1
@@ -1971,13 +1974,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
@@ -1993,7 +1996,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 ()
@@ -2004,11 +2007,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
@@ -2037,8 +2040,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 =
   enableCodeGenWhen condition should_modify TFL_CurrentModule TFL_GhcSession
   where
@@ -2057,8 +2060,8 @@ enableCodeGenForTH =
 -- This is used used in order to load code that uses unboxed tuples
 -- into GHCi while still allowing some code to be interpreted.
 enableCodeGenForUnboxedTuples :: HscTarget
-  -> NodeMap [Either ErrMsg ModSummary]
-  -> IO (NodeMap [Either ErrMsg ModSummary])
+  -> NodeMap [Either ErrorMessages ModSummary]
+  -> IO (NodeMap [Either ErrorMessages ModSummary])
 enableCodeGenForUnboxedTuples =
   enableCodeGenWhen condition should_modify TFL_GhcSession TFL_CurrentModule
   where
@@ -2080,8 +2083,8 @@ enableCodeGenWhen
   -> TempFileLifetime
   -> TempFileLifetime
   -> HscTarget
-  -> NodeMap [Either ErrMsg ModSummary]
-  -> IO (NodeMap [Either ErrMsg ModSummary])
+  -> NodeMap [Either ErrorMessages ModSummary]
+  -> IO (NodeMap [Either ErrorMessages ModSummary])
 enableCodeGenWhen condition should_modify staticLife dynLife target nodemap =
   traverse (traverse (traverse enable_code_gen)) nodemap
   where
@@ -2143,7 +2146,7 @@ enableCodeGenWhen condition should_modify staticLife dynLife 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
@@ -2203,13 +2206,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
@@ -2238,7 +2241,8 @@ summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf
                   _ <- liftIO $ addHomeModuleToFinder hsc_env
                     (moduleName (ms_mod old_summary)) (ms_location old_summary)
 
-                  return old_summary{ ms_obj_date = obj_timestamp
+                  return $ Right
+                         old_summary{ ms_obj_date = obj_timestamp
                                     , ms_iface_date = hi_timestamp
                                     , ms_hie_date = hie_timestamp }
            else
@@ -2250,53 +2254,34 @@ summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf
   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_timestamp = fmap Right $ 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
+
+        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
@@ -2314,7 +2299,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
@@ -2390,11 +2375,9 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
 
 
     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
+      = fmap Just $ fmap Right $ 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
@@ -2408,57 +2391,90 @@ 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) $
+                throwOneError $ 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 throwOneError $ 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.")
+
+        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
@@ -2471,34 +2487,39 @@ preprocessFile :: HscEnv
                -> Maybe Phase -- ^ Starting phase
                -> Maybe (StringBuffer,UTCTime)
                -> IO (DynFlags, FilePath, StringBuffer)
-preprocessFile hsc_env src_fn mb_phase Nothing
+preprocessFile hsc_env src_fn mb_phase maybe_buf
   = do
-        (dflags', hspp_fn) <- preprocess hsc_env (src_fn, mb_phase)
+        (dflags', hspp_fn)
+            <- preprocess hsc_env src_fn (fst <$> maybe_buf) 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)
+    -> IO PreprocessedImports
+getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do
+  (pi_local_dflags, pi_hspp_fn)
+      <- preprocess hsc_env src_fn (fst <$> maybe_buf) mb_phase
+  pi_hscpp_buf <- hGetStringBuffer pi_hspp_fn
+  (pi_srcimps, pi_theimps, L pi_mod_name_loc pi_mod_name)
+      <- getImports pi_local_dflags pi_hspp_buf pi_hspp_fn src_fn
+  return PreprocessedImports {..}
 
 
 -----------------------------------------------------------------------------
@@ -2545,13 +2566,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 ()