[commit: packages/Cabal] ghc-head: Work around the low clock resolution problem of 'getModificationTime'. (a8609ae)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/Cabal

On branch  : ghc-head
Link       : http://git.haskell.org/?p=packages/Cabal.git;a=commit;h=a8609aeb9fd8e57ebda2d9607aa5a1d089ecbd04

>---------------------------------------------------------------

commit a8609aeb9fd8e57ebda2d9607aa5a1d089ecbd04
Author: Mikhail Glushenkov <the.dead.shall.rise at gmail.com>
Date:   Mon Apr 29 21:42:31 2013 +0200

    Work around the low clock resolution problem of 'getModificationTime'.
    
    See http://hackage.haskell.org/trac/ghc/ticket/7473 .


>---------------------------------------------------------------

a8609aeb9fd8e57ebda2d9607aa5a1d089ecbd04
 cabal-install/Distribution/Compat/Time.hs |   70 ++++++++++++++++++++++++-----
 1 file changed, 59 insertions(+), 11 deletions(-)

diff --git a/cabal-install/Distribution/Compat/Time.hs b/cabal-install/Distribution/Compat/Time.hs
index 63a24c2..be217dc 100644
--- a/cabal-install/Distribution/Compat/Time.hs
+++ b/cabal-install/Distribution/Compat/Time.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP, ForeignFunctionInterface #-}
 module Distribution.Compat.Time (EpochTime, getModTime, getFileAge, getCurTime)
        where
 
@@ -13,20 +13,68 @@ import System.Time (ClockTime(..), getClockTime
                    ,diffClockTimes, normalizeTimeDiff, tdDay)
 #endif
 
--- | The number of seconds since the UNIX epoch
+#if defined mingw32_HOST_OS
+
+import Data.Int         (Int32)
+import Data.Word        (Word32)
+import Foreign          (Ptr, allocaBytes, peekByteOff)
+import Foreign.C.Types  (CChar(..))
+import Foreign.C.String (withCString)
+import System.IO.Error  (mkIOError, doesNotExistErrorType)
+
+type WIN32_FILE_ATTRIBUTE_DATA = Ptr ()
+type LPCSTR = Ptr CChar
+
+foreign import stdcall "Windows.h GetFileAttributesExA"
+  c_getFileAttributesEx :: LPCSTR -> Int32
+                           -> WIN32_FILE_ATTRIBUTE_DATA -> IO Bool
+
+size_WIN32_FILE_ATTRIBUTE_DATA :: Int
+size_WIN32_FILE_ATTRIBUTE_DATA = 36
+
+index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime :: Int
+index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime = 20
+
+#else
+
+import Foreign.C.Types    (CTime(..))
+import System.Posix.Files (getFileStatus, modificationTime)
+
+#endif
+
+-- | The number of seconds since the UNIX epoch.
 type EpochTime = Int64
 
--- FIXME: 'getModificationTime' has a very low (second-level) resolution in all
--- released GHCs, which is bad for our purposes.
--- See hackage.haskell.org/trac/ghc/ticket/7473
--- We should copy the file modification utils that Shake uses.
+-- | Return modification time of given file. Works around the low clock
+-- resolution problem that 'getModificationTime' has on GHC < 7.8.
+--
+-- This is a modified version of the code originally written for OpenShake by
+-- Neil Mitchell. See module Development.Shake.FileTime.
 getModTime :: FilePath -> IO EpochTime
-getModTime path =  do
-#if MIN_VERSION_directory(1,2,0)
-  (truncate . utcTimeToPOSIXSeconds) `fmap` getModificationTime path
+
+#if defined mingw32_HOST_OS
+
+-- Directly against the Win32 API.
+getModTime path = withCString path $ \file ->
+  allocaBytes size_WIN32_FILE_ATTRIBUTE_DATA $ \info -> do
+    res <- c_getFileAttributesEx file 0 info
+    if not res
+      then do
+        let err = mkIOError doesNotExistErrorType
+                  "Distribution.Compat.Time.getModTime"
+                  Nothing (Just path)
+        ioError err
+      else do
+        dword <- peekByteOff info
+                 index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime
+        return $! fromIntegral (dword :: Word32)
 #else
-  (TOD s _) <- getModificationTime path
-  return $! fromIntegral s
+
+-- Directly against the unix library.
+getModTime path = do
+    (CTime i) <- fmap modificationTime $ getFileStatus path
+    -- CTime is Int32 in base < 4.6, but Int64 in base >= 4.6.
+    return (fromIntegral i)
 #endif
 
 -- | Return age of given file in days.