cabal-install-bundle 0.16.0.2 → 0.16.0.2.1

raw patch · 3 files changed

+132/−1 lines, 3 files

Files

• Distribution/Client/JobControl.hs +92/−0
• Distribution/Compat/Time.hs +37/−0
• cabal-install-bundle.cabal +3/−1

@@ -0,0 +1,92 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.JobControl+-- Copyright   :  (c) Duncan Coutts 2012+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- A job control concurrency abstraction+-----------------------------------------------------------------------------+module Distribution.Client.JobControl (+    JobControl,+    newSerialJobControl,+    newParallelJobControl,+    spawnJob,+    collectJob,++    JobLimit,+    newJobLimit,+    withJobLimit,++    Lock,+    newLock,+    criticalSection+  ) where++import Control.Monad+import Control.Concurrent+import Control.Exception++data JobControl m a = JobControl {+       spawnJob    :: m a -> m (),+       collectJob  :: m a+     }+++newSerialJobControl :: IO (JobControl IO a)+newSerialJobControl = do+    queue <- newChan+    return JobControl {+      spawnJob   = spawn queue,+      collectJob = collect queue+    }+  where+    spawn :: Chan (IO a) -> IO a -> IO ()+    spawn = writeChan++    collect :: Chan (IO a) -> IO a+    collect = join . readChan++newParallelJobControl :: IO (JobControl IO a)+#if MIN_VERSION_base(4,3,0)+newParallelJobControl = do+    resultVar <- newEmptyMVar+    return JobControl {+      spawnJob   = spawn resultVar,+      collectJob = collect resultVar+    }+  where+    spawn :: MVar (Either SomeException a) -> IO a -> IO ()+    spawn resultVar job =+      mask $ \restore ->+        forkIO (do res <- try (restore job)+                   putMVar resultVar res)+         >> return ()++    collect :: MVar (Either SomeException a) -> IO a+    collect resultVar =+      takeMVar resultVar >>= either throw return+#else+newParallelJobControl = newSerialJobControl+#endif++data JobLimit = JobLimit QSem++newJobLimit :: Int -> IO JobLimit+newJobLimit n =+  fmap JobLimit (newQSem n)++withJobLimit :: JobLimit -> IO a -> IO a+withJobLimit (JobLimit sem) =+  bracket_ (waitQSem sem) (signalQSem sem)++newtype Lock = Lock (MVar ())++newLock :: IO Lock+newLock = fmap Lock $ newMVar ()++criticalSection :: Lock -> IO a -> IO a+criticalSection (Lock lck) act = bracket_ (takeMVar lck) (putMVar lck ()) act

@@ -0,0 +1,37 @@+{-# LANGUAGE CPP #-}+module Distribution.Compat.Time where++import Data.Int (Int64)+import System.Directory (getModificationTime)++#if MIN_VERSION_directory(1,2,0)+import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, posixDayLength)+import Data.Time (getCurrentTime, diffUTCTime)+#else+import System.Time (ClockTime(..), getClockTime, diffClockTimes, normalizeTimeDiff, tdDay)+#endif++-- | The number of seconds since the UNIX epoch+type EpochTime = Int64++getModTime :: FilePath -> IO EpochTime+getModTime path =  do+#if MIN_VERSION_directory(1,2,0)+  (truncate . utcTimeToPOSIXSeconds) `fmap` getModificationTime path+#else+  (TOD s _) <- getModificationTime path+  return $! fromIntegral s+#endif++-- | Return age of given file in days.+getFileAge :: FilePath -> IO Int+getFileAge file = do+  t0 <- getModificationTime file+#if MIN_VERSION_directory(1,2,0)+  t1 <- getCurrentTime+  let days = truncate $ (t1 `diffUTCTime` t0) / posixDayLength+#else+  t1 <- getClockTime+  let days = (tdDay . normalizeTimeDiff) (t1 `diffClockTimes` t0)+#endif+  return days

@@ -1,5 +1,5 @@ Name:               cabal-install-bundle-Version:            0.16.0.2+Version:            0.16.0.2.1 Synopsis:           The (bundled) command-line interface for Cabal and Hackage. Description:        This is cabal-install with bundled dependencies. Easier to bootstrap. License:            BSD3@@ -177,6 +177,7 @@         Distribution.Client.Install         Distribution.Client.InstallPlan         Distribution.Client.InstallSymlink+        Distribution.Client.JobControl         Distribution.Client.List         Distribution.Client.PackageIndex         Distribution.Client.PackageUtils@@ -194,6 +195,7 @@         Distribution.Client.Win32SelfUpgrade         Distribution.Compat.Exception         Distribution.Compat.FilePerms+        Distribution.Compat.Time         Paths_cabal_install_bundle      build-depends: base >= 2 && < 99, Cabal >= 1.16, filepath, time, process, directory, pretty, containers, array, old-time, bytestring, unix