Switch to using the time package, rather than old-time
[ghc.git] / compiler / main / GhcMake.hs
index 0d41435..a2fb9ed 100644 (file)
@@ -1,3 +1,5 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
 -- -----------------------------------------------------------------------------
 --
 -- (c) The University of Glasgow, 2011
@@ -7,6 +9,13 @@
 --
 -- -----------------------------------------------------------------------------
 
+{-# OPTIONS -fno-warn-tabs #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and
+-- detab the module (please do the detabbing in a separate patch). See
+--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
+-- for details
+
 module GhcMake( 
   depanal, 
   load, LoadHowMuch(..),
@@ -29,7 +38,7 @@ import Module
 import HscTypes
 import ErrUtils
 import DynFlags
-import HsSyn hiding ((<.>))
+import HsSyn
 import Finder
 import HeaderInfo
 import TcIface         ( typecheckIface )
@@ -53,15 +62,15 @@ import UniqFM
 import qualified Data.Map as Map
 import qualified FiniteMap as Map( insertListWith)
 
-import System.Directory ( doesFileExist, getModificationTime )
+import System.Directory
 import System.IO       ( fixIO )
 import System.IO.Error ( isDoesNotExistError )
-import System.Time     ( ClockTime )
 import System.FilePath
 import Control.Monad
 import Data.Maybe
 import Data.List
 import qualified Data.List as List
+import Data.Time
 
 -- -----------------------------------------------------------------------------
 -- Loading the program
@@ -581,6 +590,9 @@ checkStability hpt sccs all_home_mods = foldl checkSCC ([],[]) sccs
                -- especially if the source was automatically generated
                -- and compiled.  Using >= is slightly unsafe, but it matches
                -- make's behaviour.
+                --
+                -- But see #5527, where someone ran into this and it caused
+                -- a problem.
 
        bco_ok ms
          = case lookupUFM hpt (ms_mod_name ms) of
@@ -735,15 +747,16 @@ upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods
                                   where 
                                     iface = hm_iface hm_info
 
-           compile_it :: Maybe Linkable -> IO HomeModInfo
-           compile_it  mb_linkable = 
+            compile_it :: Maybe Linkable -> SourceModified -> IO HomeModInfo
+            compile_it  mb_linkable src_modified =
                   compile hsc_env summary' mod_index nmods 
-                          mb_old_iface mb_linkable
+                          mb_old_iface mb_linkable src_modified
 
-            compile_it_discard_iface :: Maybe Linkable -> IO HomeModInfo
-            compile_it_discard_iface mb_linkable =
+            compile_it_discard_iface :: Maybe Linkable -> SourceModified
+                                     -> IO HomeModInfo
+            compile_it_discard_iface mb_linkable  src_modified =
                   compile hsc_env summary' mod_index nmods
-                          Nothing mb_linkable
+                          Nothing mb_linkable src_modified
 
             -- With the HscNothing target we create empty linkables to avoid
             -- recompilation.  We have to detect these to recompile anyway if
@@ -776,7 +789,7 @@ upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods
                            (text "compiling stable on-disk mod:" <+> ppr this_mod_name)
                 linkable <- liftIO $ findObjectLinkable this_mod obj_fn
                               (expectJust "upsweep1" mb_obj_date)
-                compile_it (Just linkable)
+                compile_it (Just linkable) SourceUnmodifiedAndStable
                 -- object is stable, but we need to load the interface
                 -- off disk to make a HMI.
 
@@ -797,7 +810,7 @@ upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods
             linkableTime l >= ms_hs_date summary -> do
                 liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
                            (text "compiling non-stable BCO mod:" <+> ppr this_mod_name)
-                compile_it (Just l)
+                compile_it (Just l) SourceUnmodified
                 -- we have an old BCO that is up to date with respect
                 -- to the source: do a recompilation check as normal.
 
@@ -819,17 +832,17 @@ upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods
                       isObjectLinkable l && linkableTime l == obj_date -> do
                           liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
                                      (text "compiling mod with new on-disk obj:" <+> ppr this_mod_name)
-                          compile_it (Just l)
+                          compile_it (Just l) SourceUnmodified
                   _otherwise -> do
                           liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
                                      (text "compiling mod with new on-disk obj2:" <+> ppr this_mod_name)
                           linkable <- liftIO $ findObjectLinkable this_mod obj_fn obj_date
-                          compile_it_discard_iface (Just linkable)
+                          compile_it_discard_iface (Just linkable) SourceUnmodified
 
          _otherwise -> do
                 liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
                            (text "compiling mod:" <+> ppr this_mod_name)
-                compile_it Nothing
+                compile_it Nothing SourceModified
 
 
 
@@ -1187,7 +1200,7 @@ summariseFile
        -> FilePath                     -- source file name
        -> Maybe Phase                  -- start phase
         -> Bool                         -- object code allowed?
-       -> Maybe (StringBuffer,ClockTime)
+       -> Maybe (StringBuffer,UTCTime)
        -> IO ModSummary
 
 summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf
@@ -1201,10 +1214,10 @@ summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf
                -- return the cached summary if the source didn't change
        src_timestamp <- case maybe_buf of
                           Just (_,t) -> return t
-                          Nothing    -> liftIO $ getModificationTime file
+                          Nothing    -> liftIO $ getModificationUTCTime file
                -- The file exists; we checked in getRootSummary above.
                -- If it gets removed subsequently, then this 
-               -- getModificationTime may fail, but that's the right
+               -- getModificationUTCTime may fail, but that's the right
                -- behaviour.
 
        if ms_hs_date old_summary == src_timestamp 
@@ -1238,7 +1251,7 @@ summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf
 
         src_timestamp <- case maybe_buf of
                           Just (_,t) -> return t
-                          Nothing    -> liftIO $ getModificationTime file
+                          Nothing    -> liftIO $ getModificationUTCTime file
                        -- getMofificationTime may fail
 
         -- when the user asks to load a source file by name, we only
@@ -1254,7 +1267,7 @@ summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf
                              ms_hspp_file = hspp_fn,
                              ms_hspp_opts = dflags',
                             ms_hspp_buf  = Just buf,
-                             ms_srcimps = srcimps, ms_imps = the_imps,
+                             ms_srcimps = srcimps, ms_textual_imps = the_imps,
                             ms_hs_date = src_timestamp,
                             ms_obj_date = obj_timestamp })
 
@@ -1272,7 +1285,7 @@ summariseModule
          -> IsBootInterface    -- True <=> a {-# SOURCE #-} import
          -> Located ModuleName -- Imported module to be summarised
           -> Bool               -- object code allowed?
-         -> Maybe (StringBuffer, ClockTime)
+         -> Maybe (StringBuffer, UTCTime)
          -> [ModuleName]               -- Modules to exclude
          -> IO (Maybe ModSummary)      -- Its new summary
 
@@ -1293,7 +1306,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
        case maybe_buf of
           Just (_,t) -> check_timestamp old_summary location src_fn t
           Nothing    -> do
-               m <- tryIO (getModificationTime src_fn)
+               m <- tryIO (getModificationUTCTime src_fn)
                case m of
                   Right t -> check_timestamp old_summary location src_fn t
                   Left e | isDoesNotExistError e -> find_it
@@ -1379,13 +1392,13 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
                              ms_hspp_file = hspp_fn,
                               ms_hspp_opts = dflags',
                              ms_hspp_buf  = Just buf,
-                             ms_srcimps   = srcimps,
-                             ms_imps      = the_imps,
+                             ms_srcimps      = srcimps,
+                             ms_textual_imps = the_imps,
                              ms_hs_date   = src_timestamp,
                              ms_obj_date  = obj_timestamp }))
 
 
-getObjTimestamp :: ModLocation -> Bool -> IO (Maybe ClockTime)
+getObjTimestamp :: ModLocation -> Bool -> IO (Maybe UTCTime)
 getObjTimestamp location is_boot
   = if is_boot then return Nothing
               else modificationTimeIfExists (ml_obj_file location)
@@ -1394,7 +1407,7 @@ getObjTimestamp location is_boot
 preprocessFile :: HscEnv
                -> FilePath
                -> Maybe Phase -- ^ Starting phase
-               -> Maybe (StringBuffer,ClockTime)
+               -> Maybe (StringBuffer,UTCTime)
                -> IO (DynFlags, FilePath, StringBuffer)
 preprocessFile hsc_env src_fn mb_phase Nothing
   = do
@@ -1405,17 +1418,14 @@ preprocessFile hsc_env src_fn mb_phase Nothing
 preprocessFile hsc_env src_fn mb_phase (Just (buf, _time))
   = do
         let dflags = hsc_dflags hsc_env
-       -- case we bypass the preprocessing stage?
-       let 
-           local_opts = getOptions dflags buf src_fn
-       --
+       let local_opts = getOptions dflags buf src_fn
+
        (dflags', leftovers, warns)
-            <- parseDynamicNoPackageFlags dflags local_opts
+            <- parseDynamicFilePragma dflags local_opts
         checkProcessArgsResult leftovers
         handleFlagWarnings dflags' warns
 
-       let
-           needs_preprocessing
+       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
@@ -1459,20 +1469,34 @@ multiRootsErr summs@(summ1:_)
     files = map (expectJust "checkDup" . ml_hs_file . ms_location) summs
 
 cyclicModuleErr :: [ModSummary] -> SDoc
-cyclicModuleErr ms
-  = hang (ptext (sLit "Module imports form a cycle for modules:"))
-       2 (vcat (map show_one ms))
+-- From a strongly connected component we find 
+-- a single cycle to report
+cyclicModuleErr mss
+  = ASSERT( not (null mss) )
+    case findCycle graph of
+       Nothing   -> ptext (sLit "Unexpected non-cycle") <+> ppr mss
+       Just path -> vcat [ ptext (sLit "Module imports form a cycle:")
+                         , nest 2 (show_path path) ]
   where
-    mods_in_cycle = map ms_mod_name ms
-    imp_modname = unLoc . ideclName . unLoc
-    just_in_cycle = filter ((`elem` mods_in_cycle) . imp_modname)
-
-    show_one ms = 
-           vcat [ show_mod (ms_hsc_src ms) (ms_mod_name ms) <+>
-                  maybe empty (parens . text) (ml_hs_file (ms_location ms)),
-                  nest 2 $ ptext (sLit "imports:") <+> vcat [
-                     pp_imps HsBootFile (just_in_cycle $ ms_srcimps ms),
-                     pp_imps HsSrcFile  (just_in_cycle $ ms_imps ms) ]
-                ]
-    show_mod hsc_src mod = ppr mod <> text (hscSourceString hsc_src)
-    pp_imps src imps = fsep (map (show_mod src . unLoc . ideclName . unLoc) imps)
+    graph :: [Node NodeKey ModSummary]
+    graph = [(ms, msKey ms, get_deps ms) | ms <- mss]
+
+    get_deps :: ModSummary -> [NodeKey]
+    get_deps ms = ([ (unLoc m, HsBootFile) | m <- ms_home_srcimps ms ] ++
+                   [ (unLoc m, HsSrcFile)  | m <- ms_home_imps    ms ])
+
+    show_path []         = panic "show_path"
+    show_path [m]        = ptext (sLit "module") <+> ppr_ms m
+                           <+> ptext (sLit "imports itself")
+    show_path (m1:m2:ms) = vcat ( nest 7 (ptext (sLit "module") <+> ppr_ms m1)
+                                : nest 6 (ptext (sLit "imports") <+> ppr_ms m2)
+                                : go ms )
+       where
+         go []     = [ptext (sLit "which imports") <+> ppr_ms m1]
+         go (m:ms) = (ptext (sLit "which imports") <+> ppr_ms m) : go ms
+       
+
+    ppr_ms :: ModSummary -> SDoc
+    ppr_ms ms = quotes (ppr (moduleName (ms_mod ms))) <+> 
+               (parens (text (msHsFilePath ms)))
+