packages feed

cabal-install-bundle 0.16.0.2.1 → 1.18.0.2

raw patch · 69 files changed

+6928/−1399 lines, 69 files

Files

+ Control/Concurrent/STM.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE CPP #-}++#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif++-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Concurrent.STM+-- Copyright   :  (c) The University of Glasgow 2004+-- License     :  BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer  :  libraries@haskell.org+-- Stability   :  experimental+-- Portability :  non-portable (requires STM)+--+-- Software Transactional Memory: a modular composable concurrency+-- abstraction.  See+--+--  * /Composable memory transactions/, by Tim Harris, Simon Marlow, Simon+--    Peyton Jones, and Maurice Herlihy, in /ACM Conference on Principles+--    and Practice of Parallel Programming/ 2005.+--    <http://research.microsoft.com/Users/simonpj/papers/stm/index.htm>+--+-----------------------------------------------------------------------------++module Control.Concurrent.STM (+	module Control.Monad.STM,+	module Control.Concurrent.STM.TVar,+#ifdef __GLASGOW_HASKELL__+	module Control.Concurrent.STM.TMVar,+        module Control.Concurrent.STM.TChan,+        module Control.Concurrent.STM.TQueue,+        module Control.Concurrent.STM.TBQueue,+#endif+	module Control.Concurrent.STM.TArray+  ) where++import Control.Monad.STM+import Control.Concurrent.STM.TVar+#ifdef __GLASGOW_HASKELL__+import Control.Concurrent.STM.TMVar+import Control.Concurrent.STM.TChan+#endif+import Control.Concurrent.STM.TArray+import Control.Concurrent.STM.TQueue+import Control.Concurrent.STM.TBQueue
+ Control/Concurrent/STM/TArray.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleInstances, MultiParamTypeClasses #-}++#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif++-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Concurrent.STM.TArray+-- Copyright   :  (c) The University of Glasgow 2005+-- License     :  BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer  :  libraries@haskell.org+-- Stability   :  experimental+-- Portability :  non-portable (requires STM)+--+-- TArrays: transactional arrays, for use in the STM monad+--+-----------------------------------------------------------------------------++module Control.Concurrent.STM.TArray (+    TArray+) where++import Data.Array (Array, bounds)+import Data.Array.Base (listArray, arrEleBottom, unsafeAt, MArray(..),+                        IArray(numElements))+import Data.Ix (rangeSize)+import Data.Typeable (Typeable)+import Control.Concurrent.STM.TVar (TVar, newTVar, readTVar, writeTVar)+#ifdef __GLASGOW_HASKELL__+import GHC.Conc (STM)+#else+import Control.Sequential.STM (STM)+#endif++-- |TArray is a transactional array, supporting the usual 'MArray'+-- interface for mutable arrays.+--+-- It is currently implemented as @Array ix (TVar e)@,+-- but it may be replaced by a more efficient implementation in the future+-- (the interface will remain the same, however).+--+newtype TArray i e = TArray (Array i (TVar e)) deriving (Eq, Typeable)++instance MArray TArray e STM where+    getBounds (TArray a) = return (bounds a)+    newArray b e = do+        a <- rep (rangeSize b) (newTVar e)+        return $ TArray (listArray b a)+    newArray_ b = do+        a <- rep (rangeSize b) (newTVar arrEleBottom)+        return $ TArray (listArray b a)+    unsafeRead (TArray a) i = readTVar $ unsafeAt a i+    unsafeWrite (TArray a) i e = writeTVar (unsafeAt a i) e+    getNumElements (TArray a) = return (numElements a)++-- | Like 'replicateM' but uses an accumulator to prevent stack overflows.+-- Unlike 'replicateM' the returned list is in reversed order.+-- This doesn't matter though since this function is only used to create+-- arrays with identical elements.+rep :: Monad m => Int -> m a -> m [a]+rep n m = go n []+    where+      go 0 xs = return xs+      go i xs = do+          x <- m+          go (i-1) (x:xs)
+ Control/Concurrent/STM/TBQueue.hs view
@@ -0,0 +1,179 @@+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# LANGUAGE CPP, DeriveDataTypeable #-}++#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif++-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Concurrent.STM.TBQueue+-- Copyright   :  (c) The University of Glasgow 2012+-- License     :  BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer  :  libraries@haskell.org+-- Stability   :  experimental+-- Portability :  non-portable (requires STM)+--+-- 'TBQueue' is a bounded version of 'TQueue'. The queue has a maximum+-- capacity set when it is created.  If the queue already contains the+-- maximum number of elements, then 'writeTBQueue' blocks until an+-- element is removed from the queue.+--+-- The implementation is based on the traditional purely-functional+-- queue representation that uses two lists to obtain amortised /O(1)/+-- enqueue and dequeue operations.+--+-----------------------------------------------------------------------------++module Control.Concurrent.STM.TBQueue (+        -- * TBQueue+	TBQueue,+	newTBQueue,+	newTBQueueIO,+	readTBQueue,+	tryReadTBQueue,+	peekTBQueue,+	tryPeekTBQueue,+	writeTBQueue,+        unGetTBQueue,+        isEmptyTBQueue,+  ) where++import Data.Typeable+import GHC.Conc++#define _UPK_(x) {-# UNPACK #-} !(x)++-- | 'TBQueue' is an abstract type representing a bounded FIFO channel.+data TBQueue a+   = TBQueue _UPK_(TVar Int)  -- CR: read capacity+             _UPK_(TVar [a])  -- R:  elements waiting to be read+             _UPK_(TVar Int)  -- CW: write capacity+             _UPK_(TVar [a])  -- W:  elements written (head is most recent)+  deriving Typeable++instance Eq (TBQueue a) where+  TBQueue a _ _ _ == TBQueue b _ _ _ = a == b++-- Total channel capacity remaining is CR + CW. Reads only need to+-- access CR, writes usually need to access only CW but sometimes need+-- CR.  So in the common case we avoid contention between CR and CW.+--+--   - when removing an element from R:+--     CR := CR + 1+--+--   - when adding an element to W:+--     if CW is non-zero+--         then CW := CW - 1+--         then if CR is non-zero+--                 then CW := CR - 1; CR := 0+--                 else **FULL**++-- |Build and returns a new instance of 'TBQueue'+newTBQueue :: Int   -- ^ maximum number of elements the queue can hold+           -> STM (TBQueue a)+newTBQueue size = do+  read  <- newTVar []+  write <- newTVar []+  rsize <- newTVar 0+  wsize <- newTVar size+  return (TBQueue rsize read wsize write)++-- |@IO@ version of 'newTBQueue'.  This is useful for creating top-level+-- 'TBQueue's using 'System.IO.Unsafe.unsafePerformIO', because using+-- 'atomically' inside 'System.IO.Unsafe.unsafePerformIO' isn't+-- possible.+newTBQueueIO :: Int -> IO (TBQueue a)+newTBQueueIO size = do+  read  <- newTVarIO []+  write <- newTVarIO []+  rsize <- newTVarIO 0+  wsize <- newTVarIO size+  return (TBQueue rsize read wsize write)++-- |Write a value to a 'TBQueue'; blocks if the queue is full.+writeTBQueue :: TBQueue a -> a -> STM ()+writeTBQueue (TBQueue rsize _read wsize write) a = do+  w <- readTVar wsize+  if (w /= 0)+     then do writeTVar wsize (w - 1)+     else do+          r <- readTVar rsize+          if (r /= 0)+             then do writeTVar rsize 0+                     writeTVar wsize (r - 1)+             else retry+  listend <- readTVar write+  writeTVar write (a:listend)++-- |Read the next value from the 'TBQueue'.+readTBQueue :: TBQueue a -> STM a+readTBQueue (TBQueue rsize read _wsize write) = do+  xs <- readTVar read+  r <- readTVar rsize+  writeTVar rsize (r + 1)+  case xs of+    (x:xs') -> do+      writeTVar read xs'+      return x+    [] -> do+      ys <- readTVar write+      case ys of+        [] -> retry+        _  -> do+          let (z:zs) = reverse ys -- NB. lazy: we want the transaction to be+                                  -- short, otherwise it will conflict+          writeTVar write []+          writeTVar read zs+          return z++-- | A version of 'readTBQueue' which does not retry. Instead it+-- returns @Nothing@ if no value is available.+tryReadTBQueue :: TBQueue a -> STM (Maybe a)+tryReadTBQueue c = fmap Just (readTBQueue c) `orElse` return Nothing++-- | Get the next value from the @TBQueue@ without removing it,+-- retrying if the channel is empty.+peekTBQueue :: TBQueue a -> STM a+peekTBQueue c = do+  x <- readTBQueue c+  unGetTBQueue c x+  return x++-- | A version of 'peekTBQueue' which does not retry. Instead it+-- returns @Nothing@ if no value is available.+tryPeekTBQueue :: TBQueue a -> STM (Maybe a)+tryPeekTBQueue c = do+  m <- tryReadTBQueue c+  case m of+    Nothing -> return Nothing+    Just x  -> do+      unGetTBQueue c x+      return m++-- |Put a data item back onto a channel, where it will be the next item read.+-- Blocks if the queue is full.+unGetTBQueue :: TBQueue a -> a -> STM ()+unGetTBQueue (TBQueue rsize read wsize _write) a = do+  r <- readTVar rsize+  if (r > 0)+     then do writeTVar rsize (r - 1)+     else do+          w <- readTVar wsize+          if (w > 0)+             then writeTVar wsize (w - 1)+             else retry+  xs <- readTVar read+  writeTVar read (a:xs)++-- |Returns 'True' if the supplied 'TBQueue' is empty.+isEmptyTBQueue :: TBQueue a -> STM Bool+isEmptyTBQueue (TBQueue _rsize read _wsize write) = do+  xs <- readTVar read+  case xs of+    (_:_) -> return False+    [] -> do ys <- readTVar write+             case ys of+               [] -> return True+               _  -> return False
+ Control/Concurrent/STM/TChan.hs view
@@ -0,0 +1,198 @@+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# LANGUAGE CPP, DeriveDataTypeable #-}++#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif++-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Concurrent.STM.TChan+-- Copyright   :  (c) The University of Glasgow 2004+-- License     :  BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer  :  libraries@haskell.org+-- Stability   :  experimental+-- Portability :  non-portable (requires STM)+--+-- TChan: Transactional channels+-- (GHC only)+--+-----------------------------------------------------------------------------++module Control.Concurrent.STM.TChan (+#ifdef __GLASGOW_HASKELL__+	-- * TChans+	TChan,++        -- ** Construction+        newTChan,+	newTChanIO,+	newBroadcastTChan,+	newBroadcastTChanIO,+        dupTChan,++        -- ** Reading and writing+	readTChan,+	tryReadTChan,+	peekTChan,+	tryPeekTChan,+	writeTChan,+        unGetTChan,+        isEmptyTChan,+        cloneTChan+#endif+  ) where++#ifdef __GLASGOW_HASKELL__+import GHC.Conc++import Data.Typeable (Typeable)++#define _UPK_(x) {-# UNPACK #-} !(x)++-- | 'TChan' is an abstract type representing an unbounded FIFO channel.+data TChan a = TChan _UPK_(TVar (TVarList a))+                     _UPK_(TVar (TVarList a))+  deriving (Eq, Typeable)++type TVarList a = TVar (TList a)+data TList a = TNil | TCons a _UPK_(TVarList a)++-- |Build and return a new instance of 'TChan'+newTChan :: STM (TChan a)+newTChan = do+  hole <- newTVar TNil+  read <- newTVar hole+  write <- newTVar hole+  return (TChan read write)++-- |@IO@ version of 'newTChan'.  This is useful for creating top-level+-- 'TChan's using 'System.IO.Unsafe.unsafePerformIO', because using+-- 'atomically' inside 'System.IO.Unsafe.unsafePerformIO' isn't+-- possible.+newTChanIO :: IO (TChan a)+newTChanIO = do+  hole <- newTVarIO TNil+  read <- newTVarIO hole+  write <- newTVarIO hole+  return (TChan read write)++-- | Create a write-only 'TChan'.  More precisely, 'readTChan' will 'retry'+-- even after items have been written to the channel.  The only way to read+-- a broadcast channel is to duplicate it with 'dupTChan'.+--+-- Consider a server that broadcasts messages to clients:+--+-- >serve :: TChan Message -> Client -> IO loop+-- >serve broadcastChan client = do+-- >    myChan <- dupTChan broadcastChan+-- >    forever $ do+-- >        message <- readTChan myChan+-- >        send client message+--+-- The problem with using 'newTChan' to create the broadcast channel is that if+-- it is only written to and never read, items will pile up in memory.  By+-- using 'newBroadcastTChan' to create the broadcast channel, items can be+-- garbage collected after clients have seen them.+newBroadcastTChan :: STM (TChan a)+newBroadcastTChan = do+    write_hole <- newTVar TNil+    read <- newTVar (error "reading from a TChan created by newBroadcastTChan; use dupTChan first")+    write <- newTVar write_hole+    return (TChan read write)++-- | @IO@ version of 'newBroadcastTChan'.+newBroadcastTChanIO :: IO (TChan a)+newBroadcastTChanIO = do+    dummy_hole <- newTVarIO TNil+    write_hole <- newTVarIO TNil+    read <- newTVarIO dummy_hole+    write <- newTVarIO write_hole+    return (TChan read write)++-- |Write a value to a 'TChan'.+writeTChan :: TChan a -> a -> STM ()+writeTChan (TChan _read write) a = do+  listend <- readTVar write -- listend == TVar pointing to TNil+  new_listend <- newTVar TNil+  writeTVar listend (TCons a new_listend)+  writeTVar write new_listend++-- |Read the next value from the 'TChan'.+readTChan :: TChan a -> STM a+readTChan (TChan read _write) = do+  listhead <- readTVar read+  head <- readTVar listhead+  case head of+    TNil -> retry+    TCons a tail -> do+	writeTVar read tail+	return a++-- | A version of 'readTChan' which does not retry. Instead it+-- returns @Nothing@ if no value is available.+tryReadTChan :: TChan a -> STM (Maybe a)+tryReadTChan (TChan read _write) = do+  listhead <- readTVar read+  head <- readTVar listhead+  case head of+    TNil       -> return Nothing+    TCons a tl -> do+      writeTVar read tl+      return (Just a)++-- | Get the next value from the @TChan@ without removing it,+-- retrying if the channel is empty.+peekTChan :: TChan a -> STM a+peekTChan (TChan read _write) = do+  listhead <- readTVar read+  head <- readTVar listhead+  case head of+    TNil      -> retry+    TCons a _ -> return a++-- | A version of 'peekTChan' which does not retry. Instead it+-- returns @Nothing@ if no value is available.+tryPeekTChan :: TChan a -> STM (Maybe a)+tryPeekTChan (TChan read _write) = do+  listhead <- readTVar read+  head <- readTVar listhead+  case head of+    TNil      -> return Nothing+    TCons a _ -> return (Just a)++-- |Duplicate a 'TChan': the duplicate channel begins empty, but data written to+-- either channel from then on will be available from both.  Hence this creates+-- a kind of broadcast channel, where data written by anyone is seen by+-- everyone else.+dupTChan :: TChan a -> STM (TChan a)+dupTChan (TChan _read write) = do+  hole <- readTVar write  +  new_read <- newTVar hole+  return (TChan new_read write)++-- |Put a data item back onto a channel, where it will be the next item read.+unGetTChan :: TChan a -> a -> STM ()+unGetTChan (TChan read _write) a = do+   listhead <- readTVar read+   newhead <- newTVar (TCons a listhead)+   writeTVar read newhead++-- |Returns 'True' if the supplied 'TChan' is empty.+isEmptyTChan :: TChan a -> STM Bool+isEmptyTChan (TChan read _write) = do+  listhead <- readTVar read+  head <- readTVar listhead+  case head of+    TNil -> return True+    TCons _ _ -> return False++-- |Clone a 'TChan': similar to dupTChan, but the cloned channel starts with the+-- same content available as the original channel.+cloneTChan :: TChan a -> STM (TChan a)+cloneTChan (TChan read write) = do+  readpos <- readTVar read+  new_read <- newTVar readpos+  return (TChan new_read write)+#endif
+ Control/Concurrent/STM/TMVar.hs view
@@ -0,0 +1,153 @@+{-# LANGUAGE CPP, DeriveDataTypeable #-}++#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif++-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Concurrent.STM.TMVar+-- Copyright   :  (c) The University of Glasgow 2004+-- License     :  BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer  :  libraries@haskell.org+-- Stability   :  experimental+-- Portability :  non-portable (requires STM)+--+-- TMVar: Transactional MVars, for use in the STM monad+-- (GHC only)+--+-----------------------------------------------------------------------------++module Control.Concurrent.STM.TMVar (+#ifdef __GLASGOW_HASKELL__+	-- * TMVars+	TMVar,+	newTMVar,+	newEmptyTMVar,+	newTMVarIO,+	newEmptyTMVarIO,+	takeTMVar,+	putTMVar,+	readTMVar,	+	tryReadTMVar,+	swapTMVar,+	tryTakeTMVar,+	tryPutTMVar,+	isEmptyTMVar+#endif+  ) where++#ifdef __GLASGOW_HASKELL__+import GHC.Conc++import Data.Typeable (Typeable)++newtype TMVar a = TMVar (TVar (Maybe a)) deriving (Eq, Typeable)+{- ^+A 'TMVar' is a synchronising variable, used+for communication between concurrent threads.  It can be thought of+as a box, which may be empty or full.+-}++-- |Create a 'TMVar' which contains the supplied value.+newTMVar :: a -> STM (TMVar a)+newTMVar a = do+  t <- newTVar (Just a)+  return (TMVar t)++-- |@IO@ version of 'newTMVar'.  This is useful for creating top-level+-- 'TMVar's using 'System.IO.Unsafe.unsafePerformIO', because using+-- 'atomically' inside 'System.IO.Unsafe.unsafePerformIO' isn't+-- possible.+newTMVarIO :: a -> IO (TMVar a)+newTMVarIO a = do+  t <- newTVarIO (Just a)+  return (TMVar t)++-- |Create a 'TMVar' which is initially empty.+newEmptyTMVar :: STM (TMVar a)+newEmptyTMVar = do+  t <- newTVar Nothing+  return (TMVar t)++-- |@IO@ version of 'newEmptyTMVar'.  This is useful for creating top-level+-- 'TMVar's using 'System.IO.Unsafe.unsafePerformIO', because using+-- 'atomically' inside 'System.IO.Unsafe.unsafePerformIO' isn't+-- possible.+newEmptyTMVarIO :: IO (TMVar a)+newEmptyTMVarIO = do+  t <- newTVarIO Nothing+  return (TMVar t)++-- |Return the contents of the 'TMVar'.  If the 'TMVar' is currently+-- empty, the transaction will 'retry'.  After a 'takeTMVar', +-- the 'TMVar' is left empty.+takeTMVar :: TMVar a -> STM a+takeTMVar (TMVar t) = do+  m <- readTVar t+  case m of+    Nothing -> retry+    Just a  -> do writeTVar t Nothing; return a++-- | A version of 'takeTMVar' that does not 'retry'.  The 'tryTakeTMVar'+-- function returns 'Nothing' if the 'TMVar' was empty, or @'Just' a@ if+-- the 'TMVar' was full with contents @a@.  After 'tryTakeTMVar', the+-- 'TMVar' is left empty.+tryTakeTMVar :: TMVar a -> STM (Maybe a)+tryTakeTMVar (TMVar t) = do+  m <- readTVar t+  case m of+    Nothing -> return Nothing+    Just a  -> do writeTVar t Nothing; return (Just a)++-- |Put a value into a 'TMVar'.  If the 'TMVar' is currently full,+-- 'putTMVar' will 'retry'.+putTMVar :: TMVar a -> a -> STM ()+putTMVar (TMVar t) a = do+  m <- readTVar t+  case m of+    Nothing -> do writeTVar t (Just a); return ()+    Just _  -> retry++-- | A version of 'putTMVar' that does not 'retry'.  The 'tryPutTMVar'+-- function attempts to put the value @a@ into the 'TMVar', returning+-- 'True' if it was successful, or 'False' otherwise.+tryPutTMVar :: TMVar a -> a -> STM Bool+tryPutTMVar (TMVar t) a = do+  m <- readTVar t+  case m of+    Nothing -> do writeTVar t (Just a); return True+    Just _  -> return False++-- | This is a combination of 'takeTMVar' and 'putTMVar'; ie. it+-- takes the value from the 'TMVar', puts it back, and also returns+-- it.+readTMVar :: TMVar a -> STM a+readTMVar (TMVar t) = do+  m <- readTVar t+  case m of+    Nothing -> retry+    Just a  -> return a++-- | A version of 'readTMVar' which does not retry. Instead it+-- returns @Nothing@ if no value is available.+tryReadTMVar :: TMVar a -> STM (Maybe a)+tryReadTMVar (TMVar t) = readTVar t++-- |Swap the contents of a 'TMVar' for a new value.+swapTMVar :: TMVar a -> a -> STM a+swapTMVar (TMVar t) new = do+  m <- readTVar t+  case m of+    Nothing -> retry+    Just old -> do writeTVar t (Just new); return old++-- |Check whether a given 'TMVar' is empty.+isEmptyTMVar :: TMVar a -> STM Bool+isEmptyTMVar (TMVar t) = do+  m <- readTVar t+  case m of+    Nothing -> return True+    Just _  -> return False+#endif
+ Control/Concurrent/STM/TQueue.hs view
@@ -0,0 +1,137 @@+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# LANGUAGE CPP, DeriveDataTypeable #-}++#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif++-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Concurrent.STM.TQueue+-- Copyright   :  (c) The University of Glasgow 2012+-- License     :  BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer  :  libraries@haskell.org+-- Stability   :  experimental+-- Portability :  non-portable (requires STM)+--+-- A 'TQueue' is like a 'TChan', with two important differences:+--+--  * it has faster throughput than both 'TChan' and 'Chan' (although+--    the costs are amortised, so the cost of individual operations+--    can vary a lot).+--+--  * it does /not/ provide equivalents of the 'dupTChan' and+--    'cloneTChan' operations.+--+-- The implementation is based on the traditional purely-functional+-- queue representation that uses two lists to obtain amortised /O(1)/+-- enqueue and dequeue operations.+--+-----------------------------------------------------------------------------++module Control.Concurrent.STM.TQueue (+        -- * TQueue+	TQueue,+	newTQueue,+	newTQueueIO,+	readTQueue,+	tryReadTQueue,+	peekTQueue,+	tryPeekTQueue,+	writeTQueue,+        unGetTQueue,+        isEmptyTQueue,+  ) where++import GHC.Conc++import Data.Typeable (Typeable)++-- | 'TQueue' is an abstract type representing an unbounded FIFO channel.+data TQueue a = TQueue {-# UNPACK #-} !(TVar [a])+                       {-# UNPACK #-} !(TVar [a])+  deriving Typeable++instance Eq (TQueue a) where+  TQueue a _ == TQueue b _ = a == b++-- |Build and returns a new instance of 'TQueue'+newTQueue :: STM (TQueue a)+newTQueue = do+  read  <- newTVar []+  write <- newTVar []+  return (TQueue read write)++-- |@IO@ version of 'newTQueue'.  This is useful for creating top-level+-- 'TQueue's using 'System.IO.Unsafe.unsafePerformIO', because using+-- 'atomically' inside 'System.IO.Unsafe.unsafePerformIO' isn't+-- possible.+newTQueueIO :: IO (TQueue a)+newTQueueIO = do+  read  <- newTVarIO []+  write <- newTVarIO []+  return (TQueue read write)++-- |Write a value to a 'TQueue'.+writeTQueue :: TQueue a -> a -> STM ()+writeTQueue (TQueue _read write) a = do+  listend <- readTVar write+  writeTVar write (a:listend)++-- |Read the next value from the 'TQueue'.+readTQueue :: TQueue a -> STM a+readTQueue (TQueue read write) = do+  xs <- readTVar read+  case xs of+    (x:xs') -> do writeTVar read xs'+                  return x+    [] -> do ys <- readTVar write+             case ys of+               [] -> retry+               _  -> case reverse ys of+                       [] -> error "readTQueue"+                       (z:zs) -> do writeTVar write []+                                    writeTVar read zs+                                    return z++-- | A version of 'readTQueue' which does not retry. Instead it+-- returns @Nothing@ if no value is available.+tryReadTQueue :: TQueue a -> STM (Maybe a)+tryReadTQueue c = fmap Just (readTQueue c) `orElse` return Nothing++-- | Get the next value from the @TQueue@ without removing it,+-- retrying if the channel is empty.+peekTQueue :: TQueue a -> STM a+peekTQueue c = do+  x <- readTQueue c+  unGetTQueue c x+  return x++-- | A version of 'peekTQueue' which does not retry. Instead it+-- returns @Nothing@ if no value is available.+tryPeekTQueue :: TQueue a -> STM (Maybe a)+tryPeekTQueue c = do+  m <- tryReadTQueue c+  case m of+    Nothing -> return Nothing+    Just x  -> do+      unGetTQueue c x+      return m++-- |Put a data item back onto a channel, where it will be the next item read.+unGetTQueue :: TQueue a -> a -> STM ()+unGetTQueue (TQueue read _write) a = do+  xs <- readTVar read+  writeTVar read (a:xs)++-- |Returns 'True' if the supplied 'TQueue' is empty.+isEmptyTQueue :: TQueue a -> STM Bool+isEmptyTQueue (TQueue read write) = do+  xs <- readTVar read+  case xs of+    (_:_) -> return False+    [] -> do ys <- readTVar write+             case ys of+               [] -> return True+               _  -> return False
+ Control/Concurrent/STM/TVar.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE CPP #-}++#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif++-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Concurrent.STM.TVar+-- Copyright   :  (c) The University of Glasgow 2004+-- License     :  BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer  :  libraries@haskell.org+-- Stability   :  experimental+-- Portability :  non-portable (requires STM)+--+-- TVar: Transactional variables+--+-----------------------------------------------------------------------------++module Control.Concurrent.STM.TVar (+	-- * TVars+	TVar,+	newTVar,+	newTVarIO,+	readTVar,+	readTVarIO,+	writeTVar,+	modifyTVar,+	modifyTVar',+	swapTVar,+#ifdef __GLASGOW_HASKELL__+	registerDelay+#endif+  ) where++#ifdef __GLASGOW_HASKELL__+import GHC.Conc+#else+import Control.Sequential.STM+#endif++#if ! (MIN_VERSION_base(4,2,0))+readTVarIO = atomically . readTVar+#endif+++-- Like 'modifyIORef' but for 'TVar'.+-- | Mutate the contents of a 'TVar'. /N.B./, this version is+-- non-strict.+modifyTVar :: TVar a -> (a -> a) -> STM ()+modifyTVar var f = do+    x <- readTVar var+    writeTVar var (f x)+{-# INLINE modifyTVar #-}+++-- | Strict version of 'modifyTVar'.+modifyTVar' :: TVar a -> (a -> a) -> STM ()+modifyTVar' var f = do+    x <- readTVar var+    writeTVar var $! f x+{-# INLINE modifyTVar' #-}+++-- Like 'swapTMVar' but for 'TVar'.+-- | Swap the contents of a 'TVar' for a new value.+swapTVar :: TVar a -> a -> STM a+swapTVar var new = do+    old <- readTVar var+    writeTVar var new+    return old+{-# INLINE swapTVar #-}+
+ Control/Monad/STM.hs view
@@ -0,0 +1,126 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-}++#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif++-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Monad.STM+-- Copyright   :  (c) The University of Glasgow 2004+-- License     :  BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer  :  libraries@haskell.org+-- Stability   :  experimental+-- Portability :  non-portable (requires STM)+--+-- Software Transactional Memory: a modular composable concurrency+-- abstraction.  See+--+--  * /Composable memory transactions/, by Tim Harris, Simon Marlow, Simon+--    Peyton Jones, and Maurice Herlihy, in /ACM Conference on Principles+--    and Practice of Parallel Programming/ 2005.+--    <http://research.microsoft.com/Users/simonpj/papers/stm/index.htm>+--+-- This module only defines the 'STM' monad; you probably want to +-- import "Control.Concurrent.STM" (which exports "Control.Monad.STM").+-----------------------------------------------------------------------------++module Control.Monad.STM (+  	STM,+	atomically,+#ifdef __GLASGOW_HASKELL__+        always,+        alwaysSucceeds,+	retry,+	orElse,+	check,+#endif+        throwSTM,+        catchSTM+  ) where++#ifdef __GLASGOW_HASKELL__+#if ! (MIN_VERSION_base(4,3,0))+import GHC.Conc hiding (catchSTM)+import Control.Monad    ( MonadPlus(..) )+import Control.Exception+#else+import GHC.Conc+#endif+import GHC.Exts+import Control.Monad.Fix+#else+import Control.Sequential.STM+#endif++#ifdef __GLASGOW_HASKELL__+#if ! (MIN_VERSION_base(4,3,0))+import Control.Applicative+import Control.Monad (ap)+#endif+#endif+++#ifdef __GLASGOW_HASKELL__+#if ! (MIN_VERSION_base(4,3,0))+instance MonadPlus STM where+  mzero = retry+  mplus = orElse++instance Applicative STM where+  pure = return+  (<*>) = ap++instance Alternative STM where+  empty = retry+  (<|>) = orElse+#endif++check :: Bool -> STM ()+check b = if b then return () else retry+#endif++#if ! (MIN_VERSION_base(4,3,0))+-- |Exception handling within STM actions.+catchSTM :: Exception e => STM a -> (e -> STM a) -> STM a+catchSTM (STM m) handler = STM $ catchSTM# m handler'+    where+      handler' e = case fromException e of+                     Just e' -> case handler e' of STM m' -> m'+                     Nothing -> raiseIO# e++-- | A variant of 'throw' that can only be used within the 'STM' monad.+--+-- Throwing an exception in @STM@ aborts the transaction and propagates the+-- exception.+--+-- Although 'throwSTM' has a type that is an instance of the type of 'throw', the+-- two functions are subtly different:+--+-- > throw e    `seq` x  ===> throw e+-- > throwSTM e `seq` x  ===> x+--+-- The first example will cause the exception @e@ to be raised,+-- whereas the second one won\'t.  In fact, 'throwSTM' will only cause+-- an exception to be raised when it is used within the 'STM' monad.+-- The 'throwSTM' variant should be used in preference to 'throw' to+-- raise an exception within the 'STM' monad because it guarantees+-- ordering with respect to other 'STM' operations, whereas 'throw'+-- does not.+throwSTM :: Exception e => e -> STM a+throwSTM e = STM $ raiseIO# (toException e)+#endif+++data STMret a = STMret (State# RealWorld) a++liftSTM :: STM a -> State# RealWorld -> STMret a+liftSTM (STM m) = \s -> case m s of (# s', r #) -> STMret s' r++instance MonadFix STM where+  mfix k = STM $ \s ->+    let ans        = liftSTM (k r) s+        STMret _ r = ans+    in case ans of STMret s' x -> (# s', x #)
Distribution/Client/BuildReports/Storage.hs view
@@ -74,8 +74,8 @@       [ (report, repo, remoteRepo)       | (report, repo@Repo { repoKind = Left remoteRepo }) <- rs ] -storeLocal :: [PathTemplate] -> [(BuildReport, Repo)] -> IO ()-storeLocal templates reports = sequence_+storeLocal :: [PathTemplate] -> [(BuildReport, Repo)] -> Platform -> IO ()+storeLocal templates reports platform = sequence_   [ do createDirectoryIfMissing True (takeDirectory file)        appendFile file output        --TODO: make this concurrency safe, either lock the report file or make@@ -94,6 +94,7 @@       where env = initialPathTemplateEnv                     (BuildReport.package  report)                     (BuildReport.compiler report)+                    platform      groupByFileName = map (\grp@((filename,_):_) -> (filename, map snd grp))                     . groupBy (equating  fst)
Distribution/Client/Check.hs view
@@ -72,10 +72,10 @@         isDistError _                          = True         errors = filter isDistError packageChecks -    unless (null errors) $ do+    unless (null errors) $         putStrLn "Hackage would reject this package." -    when (null packageChecks) $ do+    when (null packageChecks) $         putStrLn "No errors or warnings could be found in the package."      return (null packageChecks)
+ Distribution/Client/Compat/Environment.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE CPP, ForeignFunctionInterface #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Compat.Environment+-- Copyright   :  (c) Simon Hengel 2012+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  cabal-devel@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- A cross-platform library for setting environment variables.+--+-----------------------------------------------------------------------------++module Distribution.Client.Compat.Environment (+  lookupEnv, setEnv+) where++#ifdef mingw32_HOST_OS+import GHC.Windows+import Foreign.Safe+import Foreign.C+import Control.Monad+#else+import Foreign.C.Types+import Foreign.C.String+import Foreign.C.Error (throwErrnoIfMinus1_)+import System.Posix.Internals ( withFilePath )+#endif /* mingw32_HOST_OS */++#if MIN_VERSION_base(4,6,0)+import System.Environment (lookupEnv)+#else+import System.Environment (getEnv)+import Distribution.Compat.Exception (catchIO)+#endif++#if !MIN_VERSION_base(4,6,0)+-- | @lookupEnv var@ returns the value of the environment variable @var@, or+-- @Nothing@ if there is no such value.+lookupEnv :: String -> IO (Maybe String)+lookupEnv name = (Just `fmap` getEnv name) `catchIO` const (return Nothing)+#endif /* !MIN_VERSION_base(4,6,0) */++-- | @setEnv name value@ sets the specified environment variable to @value@.+--+-- Throws `Control.Exception.IOException` if either @name@ or @value@ is the+-- empty string or contains an equals sign.+setEnv :: String -> String -> IO ()+setEnv key value_+  | null value = error "Distribuiton.Compat.setEnv: empty string"+  | otherwise  = setEnv_ key value+  where+    -- NOTE: Anything that follows NUL is ignored on both POSIX and Windows. We+    -- still strip it manually so that the null check above succeds if a value+    -- starts with NUL.+    value = takeWhile (/= '\NUL') value_++setEnv_ :: String -> String -> IO ()++#ifdef mingw32_HOST_OS++setEnv_ key value = withCWString key $ \k -> withCWString value $ \v -> do+  success <- c_SetEnvironmentVariable k v+  unless success (throwGetLastError "setEnv")++# if defined(i386_HOST_ARCH)+#  define WINDOWS_CCONV stdcall+# elif defined(x86_64_HOST_ARCH)+#  define WINDOWS_CCONV ccall+# else+#  error Unknown mingw32 arch+# endif /* i386_HOST_ARCH */++foreign import WINDOWS_CCONV unsafe "windows.h SetEnvironmentVariableW"+  c_SetEnvironmentVariable :: LPTSTR -> LPTSTR -> IO Bool+#else+setEnv_ key value = do+  withFilePath key $ \ keyP ->+    withFilePath value $ \ valueP ->+      throwErrnoIfMinus1_ "setenv" $+        c_setenv keyP valueP (fromIntegral (fromEnum True))++foreign import ccall unsafe "setenv"+   c_setenv :: CString -> CString -> CInt -> IO CInt+#endif /* mingw32_HOST_OS */
+ Distribution/Client/Compat/FilePerms.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_HADDOCK hide #-}+module Distribution.Client.Compat.FilePerms (+  setFileOrdinary,+  setFileExecutable,+  setFileHidden,+  ) where++#ifndef mingw32_HOST_OS+import System.Posix.Types+         ( FileMode )+import System.Posix.Internals+         ( c_chmod )+import Foreign.C+         ( withCString )+import Foreign.C+         ( throwErrnoPathIfMinus1_ )+#else+import System.Win32.File (setFileAttributes, fILE_ATTRIBUTE_HIDDEN)+#endif /* mingw32_HOST_OS */++setFileHidden, setFileOrdinary,  setFileExecutable  :: FilePath -> IO ()+#ifndef mingw32_HOST_OS+setFileOrdinary   path = setFileMode path 0o644 -- file perms -rw-r--r--+setFileExecutable path = setFileMode path 0o755 -- file perms -rwxr-xr-x+setFileHidden     _    = return ()++setFileMode :: FilePath -> FileMode -> IO ()+setFileMode name m =+  withCString name $ \s ->+    throwErrnoPathIfMinus1_ "setFileMode" name (c_chmod s m)+#else+setFileOrdinary   _ = return ()+setFileExecutable _ = return ()+setFileHidden  path = setFileAttributes path fILE_ATTRIBUTE_HIDDEN+#endif
+ Distribution/Client/Compat/Semaphore.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# OPTIONS_GHC -funbox-strict-fields #-}+module Distribution.Client.Compat.Semaphore+    ( QSem+    , newQSem+    , waitQSem+    , signalQSem+    ) where++import Control.Concurrent.STM (TVar, atomically, newTVar, readTVar, retry,+                               writeTVar)+import Control.Exception (mask_, onException)+import Control.Monad (join, when)+import Data.Typeable (Typeable)++-- | 'QSem' is a quantity semaphore in which the resource is aqcuired+-- and released in units of one. It provides guaranteed FIFO ordering+-- for satisfying blocked `waitQSem` calls.+--+data QSem = QSem !(TVar Int) !(TVar [TVar Bool]) !(TVar [TVar Bool])+  deriving (Eq, Typeable)++newQSem :: Int -> IO QSem+newQSem i = atomically $ do+  q <- newTVar i+  b1 <- newTVar []+  b2 <- newTVar []+  return (QSem q b1 b2)++waitQSem :: QSem -> IO ()+waitQSem s@(QSem q _b1 b2) =+  mask_ $ join $ atomically $ do+        -- join, because if we need to block, we have to add a TVar to+        -- the block queue.+        -- mask_, because we need a chance to set up an exception handler+        -- after the join returns.+     v <- readTVar q+     if v == 0+        then do b <- newTVar False+                ys <- readTVar b2+                writeTVar b2 (b:ys)+                return (wait b)+        else do writeTVar q $! v - 1+                return (return ())+  where+    --+    -- very careful here: if we receive an exception, then we need to+    --  (a) write True into the TVar, so that another signalQSem doesn't+    --      try to wake up this thread, and+    --  (b) if the TVar is *already* True, then we need to do another+    --      signalQSem to avoid losing a unit of the resource.+    --+    -- The 'wake' function does both (a) and (b), so we can just call+    -- it here.+    --+    wait t =+      flip onException (wake s t) $+      atomically $ do+        b <- readTVar t+        when (not b) retry+++wake :: QSem -> TVar Bool -> IO ()+wake s x = join $ atomically $ do+      b <- readTVar x+      if b then return (signalQSem s)+           else do writeTVar x True+                   return (return ())++{-+ property we want:++   bracket waitQSem (\_ -> signalQSem) (\_ -> ...)++ never loses a unit of the resource.+-}++signalQSem :: QSem -> IO ()+signalQSem s@(QSem q b1 b2) =+  mask_ $ join $ atomically $ do+      -- join, so we don't force the reverse inside the txn+      -- mask_ is needed so we don't lose a wakeup+    v <- readTVar q+    if v /= 0+       then do writeTVar q $! v + 1+               return (return ())+       else do xs <- readTVar b1+               checkwake1 xs+  where+    checkwake1 [] = do+      ys <- readTVar b2+      checkwake2 ys+    checkwake1 (x:xs) = do+      writeTVar b1 xs+      return (wake s x)++    checkwake2 [] = do+      writeTVar q 1+      return (return ())+    checkwake2 ys = do+      let (z:zs) = reverse ys+      writeTVar b1 zs+      writeTVar b2 []+      return (wake s z)
+ Distribution/Client/Compat/Time.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE CPP, ForeignFunctionInterface #-}+module Distribution.Client.Compat.Time+       (EpochTime, getModTime, getFileAge, getCurTime)+       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++#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++#if MIN_VERSION_base(4,5,0)+import Foreign.C.Types    (CTime(..))+#else+import Foreign.C.Types    (CTime)+#endif+import System.Posix.Files (getFileStatus, modificationTime)++#endif++-- | The number of seconds since the UNIX epoch.+type EpochTime = Int64++-- | 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++#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.Client.Compat.Time.getModTime"+                  Nothing (Just path)+        ioError err+      else do+        dword <- peekByteOff info+                 index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime+        -- TODO: Convert Windows seconds to POSIX seconds. ATM we don't care+        -- since we only use the value for comparisons.+        return $! fromIntegral (dword :: Word32)+#else++-- Directly against the unix library.+getModTime path = do+    -- CTime is Int32 in base 4.5, Int64 in base >= 4.6, and an abstract type in+    -- base < 4.5.+    t <- fmap modificationTime $ getFileStatus path+#if MIN_VERSION_base(4,5,0)+    let CTime i = t+    return (fromIntegral i)+#else+    return (read . show $ t)+#endif+#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++getCurTime :: IO EpochTime+getCurTime =  do+#if MIN_VERSION_directory(1,2,0)+  (truncate . utcTimeToPOSIXSeconds) `fmap` getCurrentTime+#else+  (TOD s _) <- getClockTime+  return $! fromIntegral s+#endif
Distribution/Client/Config.hs view
@@ -8,7 +8,8 @@ -- Stability   :  provisional -- Portability :  portable ----- Utilities for handling saved state such as known packages, known servers and downloaded packages.+-- Utilities for handling saved state such as known packages, known servers and+-- downloaded packages. ----------------------------------------------------------------------------- module Distribution.Client.Config (     SavedConfig(..),@@ -21,7 +22,15 @@     defaultCabalDir,     defaultConfigFile,     defaultCacheDir,+    defaultCompiler,     defaultLogsDir,+    defaultUserInstall,++    baseSavedConfig,+    commentSavedConfig,+    initialSavedConfig,+    configFieldDescriptions,+    installDirsFields   ) where  @@ -42,6 +51,7 @@ import Distribution.Simple.Setup          ( ConfigFlags(..), configureOptions, defaultConfigFlags          , installDirsOptions+         , programConfigurationPaths', programConfigurationOptions          , Flag(..), toFlag, flagToMaybe, fromFlagOrDefault ) import Distribution.Simple.InstallDirs          ( InstallDirs(..), defaultInstallDirs@@ -52,6 +62,8 @@          , locatedErrorMsg, showPWarning          , readFields, warning, lineNo          , simpleField, listField, parseFilePathQ, parseTokenQ )+import Distribution.Client.ParseUtils+         ( parseFields, ppFields, ppSection ) import qualified Distribution.ParseUtils as ParseUtils          ( Field(..) ) import qualified Distribution.Text as Text@@ -75,24 +87,23 @@ import Data.Monoid          ( Monoid(..) ) import Control.Monad-         ( when, foldM, liftM )-import qualified Data.Map as Map+         ( unless, foldM, liftM ) import qualified Distribution.Compat.ReadP as Parse          ( option ) import qualified Text.PrettyPrint as Disp-         ( Doc, render, text, colon, vcat, empty, isEmpty, nest )+         ( render, text, empty ) import Text.PrettyPrint-         ( (<>), (<+>), ($$), ($+$) )+         ( ($+$) ) import System.Directory-         ( createDirectoryIfMissing, getAppUserDataDirectory )+         ( createDirectoryIfMissing, getAppUserDataDirectory, renameFile ) import Network.URI          ( URI(..), URIAuth(..) ) import System.FilePath-         ( (</>), takeDirectory )-import System.Environment-         ( getEnvironment )+         ( (<.>), (</>), takeDirectory ) import System.IO.Error          ( isDoesNotExistError )+import Distribution.Compat.Environment+         ( getEnvironment ) import Distribution.Compat.Exception          ( catchIO ) @@ -192,16 +203,20 @@   cacheDir   <- defaultCacheDir   logsDir    <- defaultLogsDir   worldFile  <- defaultWorldFile+  extraPath  <- defaultExtraPath   return mempty {     savedGlobalFlags     = mempty {       globalCacheDir     = toFlag cacheDir,       globalRemoteRepos  = [defaultRemoteRepo],       globalWorldFile    = toFlag worldFile     },+    savedConfigureFlags  = mempty {+      configProgramPathExtra = extraPath+    },     savedInstallFlags    = mempty {       installSummaryFile = [toPathTemplate (logsDir </> "build.log")],-      installBuildReports= toFlag AnonymousReports-      --installNumJobs     = toFlag (Just numberOfProcessors)+      installBuildReports= toFlag AnonymousReports,+      installNumJobs     = toFlag Nothing     }   } @@ -231,6 +246,11 @@   dir <- defaultCabalDir   return $ dir </> "world" +defaultExtraPath :: IO [FilePath]+defaultExtraPath = do+  dir <- defaultCabalDir+  return [dir </> "bin"]+ defaultCompiler :: CompilerFlavor defaultCompiler = fromMaybe GHC defaultCompilerFlavor @@ -257,7 +277,7 @@         ("default config file",  Just `liftM` defaultConfigFile) ]        getSource [] = error "no config file path candidate found."-      getSource ((msg,action): xs) = +      getSource ((msg,action): xs) =                         action >>= maybe (getSource xs) (return . (,) msg)    (source, configFile) <- getSource sources@@ -272,15 +292,15 @@       writeConfigFile configFile commentConf initialConf       return initialConf     Just (ParseOk ws conf) -> do-      when (not $ null ws) $ warn verbosity $+      unless (null ws) $ warn verbosity $         unlines (map (showPWarning configFile) ws)       return conf     Just (ParseFailed err) -> do       let (line, msg) = locatedErrorMsg err       warn verbosity $           "Error parsing config file " ++ configFile-        ++ maybe "" (\n -> ":" ++ show n) line ++ ":\n" ++ msg-      warn verbosity $ "Using default configuration."+        ++ maybe "" (\n -> ':' : show n) line ++ ":\n" ++ msg+      warn verbosity "Using default configuration."       initialSavedConfig    where@@ -301,8 +321,10 @@  writeConfigFile :: FilePath -> SavedConfig -> SavedConfig -> IO () writeConfigFile file comments vals = do+  let tmpFile = file <.> "tmp"   createDirectoryIfMissing True (takeDirectory file)-  writeFile file $ explanation ++ showConfigWithComments comments vals ++ "\n"+  writeFile tmpFile $ explanation ++ showConfigWithComments comments vals ++ "\n"+  renameFile tmpFile file   where     explanation = unlines       ["-- This is the configuration file for the 'cabal' command line tool."@@ -345,7 +367,7 @@       toSavedConfig liftGlobalFlag        (commandOptions globalCommand ParseArgs)-       ["version", "numeric-version", "config-file"] []+       ["version", "numeric-version", "config-file", "sandbox-config-file"] []    ++ toSavedConfig liftConfigFlag        (configureOptions ParseArgs)@@ -390,7 +412,7 @@    ++ toSavedConfig liftInstallFlag        (installOptions ParseArgs)-       ["dry-run", "only"] []+       ["dry-run", "only", "only-dependencies", "dependencies-only"] []    ++ toSavedConfig liftUploadFlag        (commandOptions uploadCommand ParseArgs)@@ -485,28 +507,49 @@   config <- parse others   let user0   = savedUserInstallDirs config       global0 = savedGlobalInstallDirs config-  (user, global) <- foldM parseSections (user0, global0) knownSections+  (user, global, paths, args) <-+    foldM parseSections (user0, global0, [], []) knownSections   return config {+    savedConfigureFlags    = (savedConfigureFlags config) {+       configProgramPaths  = paths,+       configProgramArgs   = args+       },     savedUserInstallDirs   = user,     savedGlobalInstallDirs = global   }    where-    isKnownSection (ParseUtils.Section _ "install-dirs" _ _) = True-    isKnownSection _                                          = False+    isKnownSection (ParseUtils.Section _ "install-dirs" _ _)            = True+    isKnownSection (ParseUtils.Section _ "program-locations" _ _)       = True+    isKnownSection (ParseUtils.Section _ "program-default-options" _ _) = True+    isKnownSection _                                                    = False      parse = parseFields (configFieldDescriptions                       ++ deprecatedFieldDescriptions) initial -    parseSections accum@(u,g) (ParseUtils.Section _ "install-dirs" name fs)+    parseSections accum@(u,g,p,a) (ParseUtils.Section _ "install-dirs" name fs)       | name' == "user"   = do u' <- parseFields installDirsFields u fs-                               return (u', g)+                               return (u', g, p, a)       | name' == "global" = do g' <- parseFields installDirsFields g fs-                               return (u, g')+                               return (u, g', p, a)       | otherwise         = do           warning "The install-paths section should be for 'user' or 'global'"           return accum       where name' = lowercase name+    parseSections accum@(u,g,p,a)+                 (ParseUtils.Section _ "program-locations" name fs)+      | name == ""        = do p' <- parseFields withProgramsFields p fs+                               return (u, g, p', a)+      | otherwise         = do+          warning "The 'program-locations' section should be unnamed"+          return accum+    parseSections accum@(u, g, p, a)+                  (ParseUtils.Section _ "program-default-options" name fs)+      | name == ""        = do a' <- parseFields withProgramOptionsFields a fs+                               return (u, g, p, a')+      | otherwise         = do+          warning "The 'program-default-options' section should be unnamed"+          return accum     parseSections accum f = do       warning $ "Unrecognized stanza on line " ++ show (lineNo f)       return accum@@ -516,52 +559,40 @@  showConfigWithComments :: SavedConfig -> SavedConfig -> String showConfigWithComments comment vals = Disp.render $-      ppFields configFieldDescriptions comment vals+      ppFields configFieldDescriptions mcomment vals   $+$ Disp.text ""   $+$ installDirsSection "user"   savedUserInstallDirs   $+$ Disp.text ""   $+$ installDirsSection "global" savedGlobalInstallDirs+  $+$ Disp.text ""+  $+$ configFlagsSection "program-locations" withProgramsFields+                         configProgramPaths+  $+$ Disp.text ""+  $+$ configFlagsSection "program-default-options" withProgramOptionsFields+                         configProgramArgs   where+    mcomment = Just comment     installDirsSection name field =       ppSection "install-dirs" name installDirsFields-                (field comment) (field vals)+                (fmap field mcomment) (field vals)+    configFlagsSection name fields field =+      ppSection name "" fields+               (fmap (field . savedConfigureFlags) mcomment)+               ((field . savedConfigureFlags) vals) ---------------------------- * Parsing utils--- ---FIXME: replace this with something better in Cabal-1.5-parseFields :: [FieldDescr a] -> a -> [ParseUtils.Field] -> ParseResult a-parseFields fields initial = foldM setField initial-  where-    fieldMap = Map.fromList-      [ (name, f) | f@(FieldDescr name _ _) <- fields ]-    setField accum (ParseUtils.F line name value) = case Map.lookup name fieldMap of-      Just (FieldDescr _ _ set) -> set line value accum-      Nothing -> do-        warning $ "Unrecognized field " ++ name ++ " on line " ++ show line-        return accum-    setField accum f = do-      warning $ "Unrecognized stanza on line " ++ show (lineNo f)-      return accum---- | This is a customised version of the function from Cabal that also prints--- default values for empty fields as comments.----ppFields :: [FieldDescr a] -> a -> a -> Disp.Doc-ppFields fields def cur = Disp.vcat [ ppField name (getter def) (getter cur)-                                    | FieldDescr name getter _ <- fields]--ppField :: String -> Disp.Doc -> Disp.Doc -> Disp.Doc-ppField name def cur-  | Disp.isEmpty cur = Disp.text "--" <+> Disp.text name <> Disp.colon <+> def-  | otherwise        =                    Disp.text name <> Disp.colon <+> cur--ppSection :: String -> String -> [FieldDescr a] -> a -> a -> Disp.Doc-ppSection name arg fields def cur =-     Disp.text name <+> Disp.text arg-  $$ Disp.nest 2 (ppFields fields def cur)- installDirsFields :: [FieldDescr (InstallDirs (Flag PathTemplate))] installDirsFields = map viewAsFieldDescr installDirsOptions +-- | Fields for the 'program-locations' section.+withProgramsFields :: [FieldDescr [(String, FilePath)]]+withProgramsFields =+  map viewAsFieldDescr $+  programConfigurationPaths' (++ "-location") defaultProgramConfiguration+                             ParseArgs id (++)++-- | Fields for the 'program-default-options' section.+withProgramOptionsFields :: [FieldDescr [(String, [String])]]+withProgramOptionsFields =+  map viewAsFieldDescr $+  programConfigurationOptions defaultProgramConfiguration ParseArgs id (++)
Distribution/Client/Configure.hs view
@@ -47,7 +47,7 @@ import Distribution.Simple.Utils as Utils          ( notice, info, debug, die ) import Distribution.System-         ( Platform, buildPlatform )+         ( Platform ) import Distribution.Verbosity as Verbosity          ( Verbosity ) @@ -58,18 +58,19 @@           -> PackageDBStack           -> [Repo]           -> Compiler+          -> Platform           -> ProgramConfiguration           -> ConfigFlags           -> ConfigExFlags           -> [String]           -> IO ()-configure verbosity packageDBs repos comp conf+configure verbosity packageDBs repos comp platform conf   configFlags configExFlags extraArgs = do    installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf   sourcePkgDb       <- getSourcePackages    verbosity repos -  progress <- planLocalPackage verbosity comp configFlags configExFlags+  progress <- planLocalPackage verbosity comp platform configFlags configExFlags                                installedPkgIndex sourcePkgDb    notice verbosity "Resolving dependencies..."@@ -97,6 +98,7 @@       useCabalVersion  = maybe anyVersion thisVersion                          (flagToMaybe (configCabalVersion configExFlags)),       useCompiler      = Just comp,+      usePlatform      = Just platform,       usePackageDB     = packageDBs',       usePackageIndex  = index',       useProgramConfig = conf,@@ -125,11 +127,12 @@ -- and all its dependencies. -- planLocalPackage :: Verbosity -> Compiler+                 -> Platform                  -> ConfigFlags -> ConfigExFlags                  -> PackageIndex                  -> SourcePackageDb                  -> IO (Progress String String InstallPlan)-planLocalPackage verbosity comp configFlags configExFlags installedPkgIndex+planLocalPackage verbosity comp platform configFlags configExFlags installedPkgIndex   (SourcePackageDb _ packagePrefs) = do   pkg <- readPackageDescription verbosity =<< defaultPackageDesc verbosity   solver <- chooseSolver verbosity (fromFlag $ configSolver configExFlags) (compilerId comp)@@ -167,10 +170,9 @@         . addConstraints             -- '--enable-tests' and '--enable-benchmarks' constraints from             -- command line-            [ PackageConstraintStanzas (packageName pkg) $ concat-                [ if testsEnabled then [TestStanzas] else []-                , if benchmarksEnabled then [BenchStanzas] else []-                ]+            [ PackageConstraintStanzas (packageName pkg) $+                [ TestStanzas  | testsEnabled ] +++                [ BenchStanzas | benchmarksEnabled ]             ]          $ standardInstallPolicy@@ -178,7 +180,7 @@             (SourcePackageDb mempty packagePrefs)             [SpecificSourcePackage localPkg] -  return (resolveDependencies buildPlatform (compilerId comp) solver resolverParams)+  return (resolveDependencies platform (compilerId comp) solver resolverParams)   -- | Call an installer for an 'SourcePackage' but override the configure
Distribution/Client/Dependency.hs view
@@ -33,6 +33,9 @@     standardInstallPolicy,     PackageSpecifier(..), +    -- ** Sandbox policy+    applySandboxInstallPolicy,+     -- ** Extra policy options     dontUpgradeBasePackage,     hideBrokenInstalledPackages,@@ -70,13 +73,16 @@          , PackagePreferences(..), InstalledPreference(..)          , PackagesPreferenceDefault(..)          , Progress(..), foldProgress )+import Distribution.Client.Sandbox.Types+         ( SandboxPackageInfo(..) ) import Distribution.Client.Targets import qualified Distribution.InstalledPackageInfo as Installed import Distribution.Package-         ( PackageName(..), PackageId, Package(..), packageVersion+         ( PackageName(..), PackageId, Package(..), packageName, packageVersion          , InstalledPackageId, Dependency(Dependency)) import Distribution.Version-         ( Version(..), VersionRange, anyVersion, withinRange, simplifyVersionRange )+         ( Version(..), VersionRange, anyVersion, thisVersion, withinRange+         , simplifyVersionRange ) import Distribution.Compiler          ( CompilerId(..), CompilerFlavor(..) ) import Distribution.System@@ -235,7 +241,8 @@     }  hideInstalledPackagesSpecificByInstalledPackageId :: [InstalledPackageId]-                                                     -> DepResolverParams -> DepResolverParams+                                                     -> DepResolverParams+                                                     -> DepResolverParams hideInstalledPackagesSpecificByInstalledPackageId pkgids params =     --TODO: this should work using exclude constraints instead     params {@@ -245,7 +252,8 @@     }  hideInstalledPackagesSpecificBySourcePackageId :: [PackageId]-                                                  -> DepResolverParams -> DepResolverParams+                                                  -> DepResolverParams+                                                  -> DepResolverParams hideInstalledPackagesSpecificBySourcePackageId pkgids params =     --TODO: this should work using exclude constraints instead     params {@@ -313,7 +321,44 @@   $ basicDepResolverParams       installedPkgIndex sourcePkgIndex +applySandboxInstallPolicy :: SandboxPackageInfo+                             -> DepResolverParams+                             -> DepResolverParams+applySandboxInstallPolicy+  (SandboxPackageInfo modifiedDeps otherDeps allSandboxPkgs _allDeps)+  params +  = addPreferences [ PackageInstalledPreference n PreferInstalled+                   | n <- installedNotModified ]++  . addTargets installedNotModified++  . addPreferences+      [ PackageVersionPreference (packageName pkg)+        (thisVersion (packageVersion pkg)) | pkg <- otherDeps ]++  . addConstraints+      [ PackageConstraintVersion (packageName pkg)+        (thisVersion (packageVersion pkg)) | pkg <- modifiedDeps ]++  . addTargets [ packageName pkg | pkg <- modifiedDeps ]++  . hideInstalledPackagesSpecificBySourcePackageId+      [ packageId pkg | pkg <- modifiedDeps ]++  -- We don't need to add source packages for add-source deps to the+  -- 'installedPkgIndex' since 'getSourcePackages' did that for us.++  $ params++  where+    installedPkgIds =+      map fst . InstalledPackageIndex.allPackagesBySourcePackageId+      $ allSandboxPkgs+    modifiedPkgIds       = map packageId modifiedDeps+    installedNotModified = [ packageName pkg | pkg <- installedPkgIds,+                             pkg `notElem` modifiedPkgIds ]+ -- ------------------------------------------------------------ -- * Interface to the standard resolver -- ------------------------------------------------------------@@ -353,7 +398,8 @@ resolveDependencies platform comp  solver params =      fmap (mkInstallPlan platform comp)-  $ runSolver solver (SolverConfig reorderGoals indGoals noReinstalls shadowing maxBkjumps)+  $ runSolver solver (SolverConfig reorderGoals indGoals noReinstalls+                      shadowing maxBkjumps)                      platform comp installedPkgIndex sourcePkgIndex                      preferences constraints targets   where@@ -368,10 +414,10 @@       shadowing       maxBkjumps      = dontUpgradeBasePackage                       -- TODO:-                      -- The modular solver can properly deal with broken packages-                      -- and won't select them. So the 'hideBrokenInstalledPackages'-                      -- function should be moved into a module that is specific-                      -- to the Topdown solver.+                      -- The modular solver can properly deal with broken+                      -- packages and won't select them. So the+                      -- 'hideBrokenInstalledPackages' function should be moved+                      -- into a module that is specific to the Topdown solver.                       . (if solver /= Modular then hideBrokenInstalledPackages                                               else id)                       $ params@@ -448,7 +494,8 @@                            -> Either [ResolveNoDepsError] [SourcePackage] resolveWithoutDependencies (DepResolverParams targets constraints                               prefs defpref installedPkgIndex sourcePkgIndex-                              _reorderGoals _indGoals _avoidReinstalls _shadowing _maxBjumps) =+                              _reorderGoals _indGoals _avoidReinstalls+                              _shadowing _maxBjumps) =     collectEithers (map selectPackage targets)   where     selectPackage :: PackageName -> Either ResolveNoDepsError SourcePackage@@ -471,7 +518,8 @@                           (installPref pkg, versionPref pkg, packageVersion pkg)         installPref   = case preferInstalled of           PreferLatest    -> const False-          PreferInstalled -> not . null . InstalledPackageIndex.lookupSourcePackageId+          PreferInstalled -> not . null+                           . InstalledPackageIndex.lookupSourcePackageId                                                      installedPkgIndex                            . packageId         versionPref   pkg = packageVersion pkg `withinRange` preferredVersions
Distribution/Client/Dependency/Modular/Builder.hs view
@@ -43,6 +43,7 @@ extendOpen :: QPN -> [OpenGoal] -> BuildState -> BuildState extendOpen qpn' gs s@(BS { rdeps = gs', open = o' }) = go gs' o' gs   where+    go :: RevDepMap -> PSQ OpenGoal () -> [OpenGoal] -> BuildState     go g o []                                             = s { rdeps = g, open = o }     go g o (ng@(OpenGoal (Flagged _ _ _ _)    _gr) : ngs) = go g (cons ng () o) ngs     go g o (ng@(OpenGoal (Stanza  _   _  )    _gr) : ngs) = go g (cons ng () o) ngs@@ -63,7 +64,7 @@  -- | Given the current scope, qualify all the package names in the given set of -- dependencies and then extend the set of open goals accordingly.-scopedExtendOpen :: QPN -> I -> QGoalReasons -> FlaggedDeps PN -> FlagInfo ->+scopedExtendOpen :: QPN -> I -> QGoalReasonChain -> FlaggedDeps PN -> FlagInfo ->                     BuildState -> BuildState scopedExtendOpen qpn i gr fdeps fdefs s = extendOpen qpn gs s   where@@ -72,12 +73,12 @@     qfdefs = L.map (\ (fn, b) -> Flagged (FN (PI qpn i) fn) b [] []) $ M.toList fdefs     gs     = L.map (flip OpenGoal gr) (qfdeps ++ qfdefs) -data BuildType = Goals | OneGoal OpenGoal | Instance QPN I PInfo QGoalReasons+data BuildType = Goals | OneGoal OpenGoal | Instance QPN I PInfo QGoalReasonChain -build :: BuildState -> Tree (QGoalReasons, Scope)+build :: BuildState -> Tree (QGoalReasonChain, Scope) build = ana go   where-    go :: BuildState -> TreeF (QGoalReasons, Scope) BuildState+    go :: BuildState -> TreeF (QGoalReasonChain, Scope) BuildState      -- If we have a choice between many goals, we just record the choice in     -- the tree. We select each open goal in turn, and before we descend, remove@@ -131,7 +132,7 @@  -- | Interface to the tree builder. Just takes an index and a list of package names, -- and computes the initial state and then the tree from there.-buildTree :: Index -> Bool -> [PN] -> Tree (QGoalReasons, Scope)+buildTree :: Index -> Bool -> [PN] -> Tree (QGoalReasonChain, Scope) buildTree idx ind igs =     build (BS idx sc                   (M.fromList (L.map (\ qpn -> (qpn, []))                                                     qpns))
Distribution/Client/Dependency/Modular/Dependency.hs view
@@ -135,11 +135,11 @@  -- | Goals are solver variables paired with information about -- why they have been introduced.-data Goal qpn = Goal (Var qpn) (GoalReasons qpn)+data Goal qpn = Goal (Var qpn) (GoalReasonChain qpn)   deriving (Eq, Show)  instance Functor Goal where-  fmap f (Goal v gr) = Goal (fmap f v) (fmap (fmap f) gr)+  fmap f (Goal v grs) = Goal (fmap f v) (fmap (fmap f) grs)  class ResetGoal f where   resetGoal :: Goal qpn -> f qpn -> f qpn@@ -149,7 +149,7 @@  -- | For open goals as they occur during the build phase, we need to store -- additional information about flags.-data OpenGoal = OpenGoal (FlaggedDep QPN) QGoalReasons+data OpenGoal = OpenGoal (FlaggedDep QPN) QGoalReasonChain   deriving (Eq, Show)  -- | Reasons why a goal can be added to a goal set.@@ -168,9 +168,9 @@  -- | The first element is the immediate reason. The rest are the reasons -- for the reasons ...-type GoalReasons qpn = [GoalReason qpn]+type GoalReasonChain qpn = [GoalReason qpn] -type QGoalReasons = GoalReasons QPN+type QGoalReasonChain = GoalReasonChain QPN  goalReasonToVars :: GoalReason qpn -> ConflictSet qpn goalReasonToVars UserGoal                 = S.empty@@ -178,9 +178,12 @@ goalReasonToVars (FDependency qfn _)      = S.singleton (F qfn) goalReasonToVars (SDependency qsn)        = S.singleton (S qsn) -goalReasonsToVars :: Ord qpn => GoalReasons qpn -> ConflictSet qpn-goalReasonsToVars = S.unions . L.map goalReasonToVars+goalReasonChainToVars :: Ord qpn => GoalReasonChain qpn -> ConflictSet qpn+goalReasonChainToVars = S.unions . L.map goalReasonToVars +goalReasonChainsToVars :: Ord qpn => [GoalReasonChain qpn] -> ConflictSet qpn+goalReasonChainsToVars = S.unions . L.map goalReasonChainToVars+ -- | Closes a goal, i.e., removes all the extraneous information that we -- need only during the build phase. close :: OpenGoal -> Goal QPN@@ -191,4 +194,4 @@ -- | Compute a conflic set from a goal. The conflict set contains the -- closure of goal reasons as well as the variable of the goal itself. toConflictSet :: Ord qpn => Goal qpn -> ConflictSet qpn-toConflictSet (Goal g gr) = S.insert g (goalReasonsToVars gr)+toConflictSet (Goal g grs) = S.insert g (goalReasonChainToVars grs)
Distribution/Client/Dependency/Modular/Explore.hs view
@@ -80,24 +80,25 @@     go (PChoiceF qpn _     ts) (A pa fa sa)   =       asum $                                      -- try children in order,       P.mapWithKey                                -- when descending ...-        (\ k r -> r (A (M.insert qpn k pa) fa sa)) $ -- record the pkg choice+        (\ k r -> r (A (M.insert qpn k pa) fa sa)) -- record the pkg choice       ts     go (FChoiceF qfn _ _ _ ts) (A pa fa sa)   =       asum $                                      -- try children in order,       P.mapWithKey                                -- when descending ...-        (\ k r -> r (A pa (M.insert qfn k fa) sa)) $ -- record the flag choice+        (\ k r -> r (A pa (M.insert qfn k fa) sa)) -- record the flag choice       ts     go (SChoiceF qsn _ _   ts) (A pa fa sa)   =       asum $                                      -- try children in order,       P.mapWithKey                                -- when descending ...-        (\ k r -> r (A pa fa (M.insert qsn k sa))) $ -- record the flag choice+        (\ k r -> r (A pa fa (M.insert qsn k sa))) -- record the flag choice       ts     go (GoalChoiceF        ts) a              =       casePSQ ts A.empty                      -- empty goal choice is an internal error         (\ _k v _xs -> v a)                   -- commit to the first goal choice  -- | Version of 'explore' that returns a 'Log'.-exploreLog :: Tree (Maybe (ConflictSet QPN)) -> (Assignment -> Log Message (Assignment, RevDepMap))+exploreLog :: Tree (Maybe (ConflictSet QPN)) ->+              (Assignment -> Log Message (Assignment, RevDepMap)) exploreLog = cata go   where     go (FailF c fr)          _           = failWith (Failure c fr)
Distribution/Client/Dependency/Modular/IndexConversion.hs view
@@ -114,10 +114,10 @@     PInfo       (maybe []    (convCondTree os arch cid pi fds (const True)          ) libs    ++        concatMap   (convCondTree os arch cid pi fds (const True)     . snd) exes    ++-      (prefix (Stanza (SN pi TestStanzas))-        (L.map     (convCondTree os arch cid pi fds (const True)     . snd) tests)) ++-      (prefix (Stanza (SN pi BenchStanzas))-        (L.map     (convCondTree os arch cid pi fds (const True)     . snd) benchs)))+      prefix (Stanza (SN pi TestStanzas))+        (L.map     (convCondTree os arch cid pi fds (const True)     . snd) tests)  +++      prefix (Stanza (SN pi BenchStanzas))+        (L.map     (convCondTree os arch cid pi fds (const True)     . snd) benchs))       fds       [] -- TODO: add encaps       Nothing
Distribution/Client/Dependency/Modular/Log.hs view
@@ -18,6 +18,10 @@ -- Parameterized over the type of actual messages and the final result. type Log m a = Progress m () a +-- | Turns a log into a list of messages paired with a final result. A final result+-- of 'Nothing' indicates failure. A final result of 'Just' indicates success.+-- Keep in mind that forcing the second component of the returned pair will force the+-- entire log. runLog :: Log m a -> ([m], Maybe a) runLog (Done x)       = ([], Just x) runLog (Fail _)       = ([], Nothing)@@ -32,19 +36,24 @@ logToProgress :: Maybe Int -> Log Message a -> Progress String String a logToProgress mbj l = let                         (ms, s) = runLog l+                        -- 'Nothing' for 's' means search tree exhaustively searched and failed                         (es, e) = proc 0 ms -- catch first error (always)+                        -- 'Nothing' in 'e' means no backjump found                         (ns, t) = case mbj of                                      Nothing -> (ms, Nothing)                                      Just n  -> proc n ms+                        -- 'Nothing' in 't' means backjump limit not reached                         -- prefer first error over later error-                        r       = case t of-                                    Nothing -> case s of-                                                 Nothing -> e-                                                 Just _  -> Nothing-                                    Just _  -> e+                        (exh, r) = case t of+                                     -- backjump limit not reached+                                     Nothing -> case s of+                                                  Nothing -> (True, e) -- failed after exhaustive search+                                                  Just _  -> (True, Nothing) -- success+                                     -- backjump limit reached; prefer first error+                                     Just _  -> (False, e) -- failed after backjump limit was reached                       in go es es -- trace for first error                             (showMessages (const True) True ns) -- shortened run-                            r s+                            r s exh   where     -- Proc takes the allowed number of backjumps and a list of messages and explores the     -- message list until the maximum number of backjumps has been reached. The log until@@ -63,18 +72,22 @@     -- in parallel with the full log, but we also want to retain the reference to its     -- beginning for when we print it. This trick prevents a space leak!     ---    -- The thirs argument is the full log, the fifth and six error conditions.+    -- The third argument is the full log, the fifth and six error conditions.+    -- The seventh argument indicates whether the search was exhaustive.     --     -- The order of arguments is important! In particular 's' must not be evaluated     -- unless absolutely necessary. It contains the final result, and if we shortcut     -- with an error due to backjumping, evaluating 's' would still require traversing     -- the entire tree.-    go ms (_ : ns) (x : xs) r         s        = Step x (go ms ns xs r s)-    go ms []       (x : xs) r         s        = Step x (go ms [] xs r s)-    go ms _        []       (Just cs) _        = Fail ("Could not resolve dependencies:\n" ++-                                                 unlines (showMessages (L.foldr (\ v _ -> v `S.member` cs) True) False ms))-    go _  _        []       _         (Just s) = Done s-    go _  _        []       _         _        = Fail ("Could not resolve dependencies.") -- should not happen+    go ms (_ : ns) (x : xs) r         s        exh = Step x (go ms ns xs r s exh)+    go ms []       (x : xs) r         s        exh = Step x (go ms [] xs r s exh)+    go ms _        []       (Just cs) _        exh = Fail $+                                                     "Could not resolve dependencies:\n" +++                                                     unlines (showMessages (L.foldr (\ v _ -> v `S.member` cs) True) False ms) +++                                                     (if exh then "Dependency tree exhaustively searched.\n"+                                                             else "Backjump limit reached (change with --max-backjumps).\n")+    go _  _        []       _         (Just s) _   = Done s+    go _  _        []       _         _        _   = Fail ("Could not resolve dependencies; something strange happened.") -- should not happen  logToProgress' :: Log Message a -> Progress String String a logToProgress' l = let
Distribution/Client/Dependency/Modular/Message.hs view
@@ -66,7 +66,7 @@       | p v       = x : xs       | otherwise = xs -showGRs :: QGoalReasons -> String+showGRs :: QGoalReasonChain -> String showGRs (gr : _) = showGR gr showGRs []       = ""
Distribution/Client/Dependency/Modular/PSQ.hs view
@@ -5,7 +5,7 @@ -- I am not yet sure what exactly is needed. But we need a datastructure with -- key-based lookup that can be sorted. We're using a sequence right now with -- (inefficiently implemented) lookup, because I think that queue-based--- opertions and sorting turn out to be more efficiency-critical in practice.+-- operations and sorting turn out to be more efficiency-critical in practice.  import Control.Applicative import Data.Foldable@@ -66,10 +66,11 @@     (k, v) : ys -> c k v (PSQ ys)  splits :: PSQ k a -> PSQ k (a, PSQ k a)-splits xs =-  casePSQ xs-    (PSQ [])-    (\ k v ys -> cons k (v, ys) (fmap (\ (w, zs) -> (w, cons k v zs)) (splits ys)))+splits = go id +  where+    go f xs = casePSQ xs+        (PSQ [])+        (\ k v ys -> cons k (v, f ys) (go (f . cons k v) ys))  sortBy :: (a -> a -> Ordering) -> PSQ k a -> PSQ k a sortBy cmp (PSQ xs) = PSQ (S.sortBy (cmp `on` snd) xs)
Distribution/Client/Dependency/Modular/Preference.hs view
@@ -105,7 +105,7 @@ -- | Traversal that tries to establish various kinds of user constraints. Works -- by selectively disabling choices that have been ruled out by global user -- constraints.-enforcePackageConstraints :: M.Map PN [PackageConstraint] -> Tree QGoalReasons -> Tree QGoalReasons+enforcePackageConstraints :: M.Map PN [PackageConstraint] -> Tree QGoalReasonChain -> Tree QGoalReasonChain enforcePackageConstraints pcs = trav go   where     go (PChoiceF qpn@(Q _ pn)               gr      ts) =@@ -132,7 +132,7 @@ -- can only be re-set explicitly by the user. This transformation should -- be run after user preferences have been enforced. For manual flags, -- it disables all but the first non-disabled choice.-enforceManualFlags :: Tree QGoalReasons -> Tree QGoalReasons+enforceManualFlags :: Tree QGoalReasonChain -> Tree QGoalReasonChain enforceManualFlags = trav go   where     go (FChoiceF qfn gr tr True ts) = FChoiceF qfn gr tr True $@@ -162,7 +162,7 @@ preferLatest = preferLatestFor (const True)  -- | Require installed packages.-requireInstalled :: (PN -> Bool) -> Tree (QGoalReasons, a) -> Tree (QGoalReasons, a)+requireInstalled :: (PN -> Bool) -> Tree (QGoalReasonChain, a) -> Tree (QGoalReasonChain, a) requireInstalled p = trav go   where     go (PChoiceF v@(Q _ pn) i@(gr, _) cs)@@ -186,7 +186,7 @@ -- they are, perhaps this should just result in trying to reinstall those other -- packages as well. However, doing this all neatly in one pass would require to -- change the builder, or at least to change the goal set after building.-avoidReinstalls :: (PN -> Bool) -> Tree (QGoalReasons, a) -> Tree (QGoalReasons, a)+avoidReinstalls :: (PN -> Bool) -> Tree (QGoalReasonChain, a) -> Tree (QGoalReasonChain, a) avoidReinstalls p = trav go   where     go (PChoiceF qpn@(Q _ pn) i@(gr, _) cs)@@ -211,7 +211,8 @@ firstGoal :: Tree a -> Tree a firstGoal = trav go   where-    go (GoalChoiceF xs) = casePSQ xs (GoalChoiceF xs) (\ _ t _ -> out t)+    go (GoalChoiceF xs) = -- casePSQ xs (GoalChoiceF xs) (\ _ t _ -> out t) -- more space efficient, but removes valuable debug info+                          casePSQ xs (GoalChoiceF (fromList [])) (\ g t _ -> GoalChoiceF (fromList [(g, t)]))     go x                = x     -- Note that we keep empty choice nodes, because they mean success.
Distribution/Client/Dependency/Modular/Validate.hs view
@@ -80,10 +80,10 @@  type Validate = Reader ValidateState -validate :: Tree (QGoalReasons, Scope) -> Validate (Tree QGoalReasons)+validate :: Tree (QGoalReasonChain, Scope) -> Validate (Tree QGoalReasonChain) validate = cata go   where-    go :: TreeF (QGoalReasons, Scope) (Validate (Tree QGoalReasons)) -> Validate (Tree QGoalReasons)+    go :: TreeF (QGoalReasonChain, Scope) (Validate (Tree QGoalReasonChain)) -> Validate (Tree QGoalReasonChain)      go (PChoiceF qpn (gr,  sc)     ts) = PChoice qpn gr <$> sequence (P.mapWithKey (goP qpn gr sc) ts)     go (FChoiceF qfn (gr, _sc) b m ts) =@@ -117,7 +117,7 @@     go (FailF    c fr              ) = pure (Fail c fr)      -- What to do for package nodes ...-    goP :: QPN -> QGoalReasons -> Scope -> I -> Validate (Tree QGoalReasons) -> Validate (Tree QGoalReasons)+    goP :: QPN -> QGoalReasonChain -> Scope -> I -> Validate (Tree QGoalReasonChain) -> Validate (Tree QGoalReasonChain)     goP qpn@(Q _pp pn) gr sc i r = do       PA ppa pfa psa <- asks pa    -- obtain current preassignment       idx            <- asks index -- obtain the index@@ -142,7 +142,7 @@                                     local (\ s -> s { pa = PA nppa pfa psa, saved = nsvd }) r      -- What to do for flag nodes ...-    goF :: QFN -> QGoalReasons -> Bool -> Validate (Tree QGoalReasons) -> Validate (Tree QGoalReasons)+    goF :: QFN -> QGoalReasonChain -> Bool -> Validate (Tree QGoalReasonChain) -> Validate (Tree QGoalReasonChain)     goF qfn@(FN (PI qpn _i) _f) gr b r = do       PA ppa pfa psa <- asks pa -- obtain current preassignment       svd <- asks saved         -- obtain saved dependencies@@ -164,7 +164,7 @@         Right nppa  -> local (\ s -> s { pa = PA nppa npfa psa }) r      -- What to do for stanza nodes (similar to flag nodes) ...-    goS :: QSN -> QGoalReasons -> Bool -> Validate (Tree QGoalReasons) -> Validate (Tree QGoalReasons)+    goS :: QSN -> QGoalReasonChain -> Bool -> Validate (Tree QGoalReasonChain) -> Validate (Tree QGoalReasonChain)     goS qsn@(SN (PI qpn _i) _f) gr b r = do       PA ppa pfa psa <- asks pa -- obtain current preassignment       svd <- asks saved         -- obtain saved dependencies@@ -205,7 +205,7 @@ -- | We try to find new dependencies that become available due to the given -- flag or stanza choice. We therefore look for the choice in question, and then call -- 'extractDeps' for everything underneath.-extractNewDeps :: Var QPN -> QGoalReasons -> Bool -> FAssignment -> SAssignment -> FlaggedDeps QPN -> [Dep QPN]+extractNewDeps :: Var QPN -> QGoalReasonChain -> Bool -> FAssignment -> SAssignment -> FlaggedDeps QPN -> [Dep QPN] extractNewDeps v gr b fa sa = go   where     go deps = do@@ -228,5 +228,5 @@                                   Just False -> []  -- | Interface.-validateTree :: Index -> Tree (QGoalReasons, Scope) -> Tree QGoalReasons+validateTree :: Index -> Tree (QGoalReasonChain, Scope) -> Tree QGoalReasonChain validateTree idx t = runReader (validate t) (VS idx M.empty (PA M.empty M.empty M.empty))
Distribution/Client/Dependency/TopDown.hs view
@@ -406,7 +406,7 @@    dependencySatisfiable = not . null . PackageIndex.lookupDependency available --- | Annotate each installed packages with its set of transative dependencies+-- | Annotate each installed packages with its set of transitive dependencies -- and its topological sort number. -- annotateInstalledPackages :: (PackageName -> TopologicalSortNumber)
Distribution/Client/Dependency/TopDown/Types.hs view
@@ -43,7 +43,7 @@    = InstalledPackageEx        InstalledPackage        !TopologicalSortNumber-       [PackageIdentifier]    -- transative closure of installed deps+       [PackageIdentifier]    -- transitive closure of installed deps  data UnconfiguredPackage    = UnconfiguredPackage
Distribution/Client/Dependency/Types.hs view
@@ -138,7 +138,7 @@ -- data PackagePreferences = PackagePreferences VersionRange InstalledPreference --- | Wether we prefer an installed version of a package or simply the latest+-- | Whether we prefer an installed version of a package or simply the latest -- version. -- data InstalledPreference = PreferInstalled | PreferLatest@@ -175,8 +175,8 @@                              | Fail fail                              | Done done --- | Consume a 'Progres' calculation. Much like 'foldr' for lists but with--- two base cases, one for a final result and one for failure.+-- | Consume a 'Progress' calculation. Much like 'foldr' for lists but with two+-- base cases, one for a final result and one for failure. -- -- Eg to convert into a simple 'Either' result use: --
Distribution/Client/Fetch.hs view
@@ -37,7 +37,7 @@ import Distribution.Simple.Utils          ( die, notice, debug ) import Distribution.System-         ( buildPlatform )+         ( Platform ) import Distribution.Text          ( display ) import Distribution.Verbosity@@ -66,15 +66,16 @@       -> PackageDBStack       -> [Repo]       -> Compiler+      -> Platform       -> ProgramConfiguration       -> GlobalFlags       -> FetchFlags       -> [UserTarget]       -> IO ()-fetch verbosity _ _ _ _ _ _ [] =+fetch verbosity _ _ _ _ _ _ _ [] =     notice verbosity "No packages requested. Nothing to do." -fetch verbosity packageDBs repos comp conf+fetch verbosity packageDBs repos comp platform conf       globalFlags fetchFlags userTargets = do      mapM_ checkTarget userTargets@@ -88,7 +89,7 @@                        userTargets      pkgs  <- planPackages-               verbosity comp fetchFlags+               verbosity comp platform fetchFlags                installedPkgIndex sourcePkgDb pkgSpecifiers      pkgs' <- filterM (fmap not . isFetched . packageSource) pkgs@@ -111,20 +112,22 @@  planPackages :: Verbosity              -> Compiler+             -> Platform              -> FetchFlags              -> PackageIndex              -> SourcePackageDb              -> [PackageSpecifier SourcePackage]              -> IO [SourcePackage]-planPackages verbosity comp fetchFlags+planPackages verbosity comp platform fetchFlags              installedPkgIndex sourcePkgDb pkgSpecifiers    | includeDependencies = do-      solver <- chooseSolver verbosity (fromFlag (fetchSolver fetchFlags)) (compilerId comp)+      solver <- chooseSolver verbosity+                (fromFlag (fetchSolver fetchFlags)) (compilerId comp)       notice verbosity "Resolving dependencies..."       installPlan <- foldProgress logMsg die return $                        resolveDependencies-                         buildPlatform (compilerId comp)+                         platform (compilerId comp)                          solver                          resolverParams
Distribution/Client/FetchUtils.hs view
@@ -27,7 +27,7 @@  import Distribution.Client.Types import Distribution.Client.HttpUtils-         ( downloadURI, isOldHackageURI )+         ( downloadURI, isOldHackageURI, DownloadResult(..) )  import Distribution.Package          ( PackageId, packageName, packageVersion )@@ -113,7 +113,7 @@       tmpdir <- getTemporaryDirectory       (path, hnd) <- openTempFile tmpdir "cabal-.tar.gz"       hClose hnd-      downloadURI verbosity uri path+      _ <- downloadURI verbosity uri path       return path  @@ -136,12 +136,12 @@             dir  = packageDir       repo pkgid             path = packageFile      repo pkgid         createDirectoryIfMissing True dir-        downloadURI verbosity uri path+        _ <- downloadURI verbosity uri path         return path  -- | Downloads an index file to [config-dir/packages/serv-id]. ---downloadIndex :: Verbosity -> RemoteRepo -> FilePath -> IO FilePath+downloadIndex :: Verbosity -> RemoteRepo -> FilePath -> IO DownloadResult downloadIndex verbosity repo cacheDir = do   let uri = (remoteRepoURI repo) {               uriPath = uriPath (remoteRepoURI repo)@@ -150,7 +150,6 @@       path = cacheDir </> "00-index" <.> "tar.gz"   createDirectoryIfMissing True cacheDir   downloadURI verbosity uri path-  return path   -- ------------------------------------------------------------
Distribution/Client/GZipUtils.hs view
@@ -27,7 +27,7 @@ -- -- This is to deal with http proxies that lie to us and transparently -- decompress without removing the content-encoding header. See:--- <http://hackage.haskell.org/trac/hackage/ticket/686>+-- <https://github.com/haskell/cabal/issues/678> -- maybeDecompress :: ByteString -> ByteString maybeDecompress bytes = foldStream $ decompressWithErrors gzipOrZlibFormat defaultDecompressParams bytes
+ Distribution/Client/Get.hs view
@@ -0,0 +1,350 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Get+-- Copyright   :  (c) Andrea Vezzosi 2008+--                    Duncan Coutts 2011+--                    John Millikin 2012+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- The 'cabal get' command.+-----------------------------------------------------------------------------++module Distribution.Client.Get (+    get+  ) where++import Distribution.Package+         ( PackageId, packageId, packageName )+import Distribution.Simple.Setup+         ( Flag(..), fromFlag, fromFlagOrDefault )+import Distribution.Simple.Utils+         ( notice, die, info, writeFileAtomic )+import Distribution.Verbosity+         ( Verbosity )+import Distribution.Text(display)+import qualified Distribution.PackageDescription as PD++import Distribution.Client.Setup+         ( GlobalFlags(..), GetFlags(..) )+import Distribution.Client.Types+import Distribution.Client.Targets+import Distribution.Client.Dependency+import Distribution.Client.FetchUtils+import qualified Distribution.Client.Tar as Tar (extractTarGzFile)+import Distribution.Client.IndexUtils as IndexUtils+        ( getSourcePackages )+import Distribution.Compat.Exception+        ( catchIO )++import Control.Exception+         ( finally )+import Control.Monad+         ( filterM, forM_, unless, when )+import Data.List+         ( sortBy )+import qualified Data.Map+import Data.Maybe+         ( listToMaybe, mapMaybe )+import Data.Monoid+         ( mempty )+import Data.Ord+         ( comparing )+import System.Directory+         ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist+         , getCurrentDirectory, setCurrentDirectory+         )+import System.Exit+         ( ExitCode(..) )+import System.FilePath+         ( (</>), (<.>), addTrailingPathSeparator )+import System.Process+         ( rawSystem, readProcessWithExitCode )+++-- | Entry point for the 'cabal get' command.+get :: Verbosity+    -> [Repo]+    -> GlobalFlags+    -> GetFlags+    -> [UserTarget]+    -> IO ()+get verbosity _ _ _ [] =+    notice verbosity "No packages requested. Nothing to do."++get verbosity repos globalFlags getFlags userTargets = do+  let useFork = case (getSourceRepository getFlags) of+        NoFlag -> False+        _      -> True++  unless useFork $+    mapM_ checkTarget userTargets++  sourcePkgDb <- getSourcePackages verbosity repos++  pkgSpecifiers <- resolveUserTargets verbosity+                   (fromFlag $ globalWorldFile globalFlags)+                   (packageIndex sourcePkgDb)+                   userTargets++  pkgs <- either (die . unlines . map show) return $+            resolveWithoutDependencies+              (resolverParams sourcePkgDb pkgSpecifiers)++  unless (null prefix) $+    createDirectoryIfMissing True prefix++  if useFork+    then fork pkgs+    else unpack pkgs++  where+    resolverParams sourcePkgDb pkgSpecifiers =+        --TODO: add commandline constraint and preference args for unpack+        standardInstallPolicy mempty sourcePkgDb pkgSpecifiers++    prefix = fromFlagOrDefault "" (getDestDir getFlags)++    fork :: [SourcePackage] -> IO ()+    fork pkgs = do+      let kind = fromFlag . getSourceRepository $ getFlags+      branchers <- findUsableBranchers+      mapM_ (forkPackage verbosity branchers prefix kind) pkgs++    unpack :: [SourcePackage] -> IO ()+    unpack pkgs = do+      forM_ pkgs $ \pkg -> do+        location <- fetchPackage verbosity (packageSource pkg)+        let pkgid = packageId pkg+            descOverride | usePristine = Nothing+                         | otherwise   = packageDescrOverride pkg+        case location of+          LocalTarballPackage tarballPath ->+            unpackPackage verbosity prefix pkgid descOverride tarballPath++          RemoteTarballPackage _tarballURL tarballPath ->+            unpackPackage verbosity prefix pkgid descOverride tarballPath++          RepoTarballPackage _repo _pkgid tarballPath ->+            unpackPackage verbosity prefix pkgid descOverride tarballPath++          LocalUnpackedPackage _ ->+            error "Distribution.Client.Get.unpack: the impossible happened."+      where+        usePristine = fromFlagOrDefault False (getPristine getFlags)++checkTarget :: UserTarget -> IO ()+checkTarget target = case target of+    UserTargetLocalDir       dir  -> die (notTarball dir)+    UserTargetLocalCabalFile file -> die (notTarball file)+    _                             -> return ()+  where+    notTarball t =+        "The 'get' command is for tarball packages. "+     ++ "The target '" ++ t ++ "' is not a tarball."++-- ------------------------------------------------------------+-- * Unpacking the source tarball+-- ------------------------------------------------------------++unpackPackage :: Verbosity -> FilePath -> PackageId+              -> PackageDescriptionOverride+              -> FilePath  -> IO ()+unpackPackage verbosity prefix pkgid descOverride pkgPath = do+    let pkgdirname = display pkgid+        pkgdir     = prefix </> pkgdirname+        pkgdir'    = addTrailingPathSeparator pkgdir+    existsDir  <- doesDirectoryExist pkgdir+    when existsDir $ die $+     "The directory \"" ++ pkgdir' ++ "\" already exists, not unpacking."+    existsFile  <- doesFileExist pkgdir+    when existsFile $ die $+     "A file \"" ++ pkgdir ++ "\" is in the way, not unpacking."+    notice verbosity $ "Unpacking to " ++ pkgdir'+    Tar.extractTarGzFile prefix pkgdirname pkgPath++    case descOverride of+      Nothing     -> return ()+      Just pkgtxt -> do+        let descFilePath = pkgdir </> display (packageName pkgid) <.> "cabal"+        info verbosity $+          "Updating " ++ descFilePath+                      ++ " with the latest revision from the index."+        writeFileAtomic descFilePath pkgtxt+++-- ------------------------------------------------------------+-- * Forking the source repository+-- ------------------------------------------------------------++data BranchCmd = BranchCmd (Verbosity -> FilePath -> IO ExitCode)++data Brancher = Brancher+    { brancherBinary :: String+    , brancherBuildCmd :: PD.SourceRepo -> Maybe BranchCmd+    }++-- | The set of all supported branch drivers.+allBranchers :: [(PD.RepoType, Brancher)]+allBranchers =+    [ (PD.Bazaar, branchBzr)+    , (PD.Darcs, branchDarcs)+    , (PD.Git, branchGit)+    , (PD.Mercurial, branchHg)+    , (PD.SVN, branchSvn)+    ]++-- | Find which usable branch drivers (selected from 'allBranchers') are+-- available and usable on the local machine.+--+-- Each driver's main command is run with @--help@, and if the child process+-- exits successfully, that brancher is considered usable.+findUsableBranchers :: IO (Data.Map.Map PD.RepoType Brancher)+findUsableBranchers = do+    let usable (_, brancher) = flip catchIO (const (return False)) $ do+         let cmd = brancherBinary brancher+         (exitCode, _, _) <- readProcessWithExitCode cmd ["--help"] ""+         return (exitCode == ExitSuccess)+    pairs <- filterM usable allBranchers+    return (Data.Map.fromList pairs)++-- | Fork a single package from a remote source repository to the local+-- filesystem.+forkPackage :: Verbosity+            -> Data.Map.Map PD.RepoType Brancher+               -- ^ Branchers supported by the local machine.+            -> FilePath+               -- ^ The directory in which new branches or repositories will+               -- be created.+            -> (Maybe PD.RepoKind)+               -- ^ Which repo to choose.+            -> SourcePackage+               -- ^ The package to fork.+            -> IO ()+forkPackage verbosity branchers prefix kind src = do+    let desc    = PD.packageDescription (packageDescription src)+        pkgid   = display (packageId src)+        pkgname = display (packageName src)+        destdir = prefix </> pkgname++    destDirExists <- doesDirectoryExist destdir+    when destDirExists $ do+        die ("The directory " ++ show destdir ++ " already exists, not forking.")++    destFileExists  <- doesFileExist destdir+    when destFileExists $ do+        die ("A file " ++ show destdir ++ " is in the way, not forking.")++    let repos = PD.sourceRepos desc+    case findBranchCmd branchers repos kind of+        Just (BranchCmd io) -> do+            exitCode <- io verbosity destdir+            case exitCode of+                ExitSuccess -> return ()+                ExitFailure _ -> die ("Couldn't fork package " ++ pkgid)+        Nothing -> case repos of+            [] -> die ("Package " ++ pkgid+                       ++ " does not have any source repositories.")+            _ -> die ("Package " ++ pkgid+                      ++ " does not have any usable source repositories.")++-- | Given a set of possible branchers, and a set of possible source+-- repositories, find a repository that is both 1) likely to be specific to+-- this source version and 2) is supported by the local machine.+findBranchCmd :: Data.Map.Map PD.RepoType Brancher -> [PD.SourceRepo]+                 -> (Maybe PD.RepoKind) -> Maybe BranchCmd+findBranchCmd branchers allRepos maybeKind = cmd where+    -- Sort repositories by kind, from This to Head to Unknown. Repositories+    -- with equivalent kinds are selected based on the order they appear in+    -- the Cabal description file.+    repos' = sortBy (comparing thisFirst) allRepos+    thisFirst r = case PD.repoKind r of+        PD.RepoThis -> 0 :: Int+        PD.RepoHead -> case PD.repoTag r of+            -- If the type is 'head' but the author specified a tag, they+            -- probably meant to create a 'this' repository but screwed up.+            Just _ -> 0+            Nothing -> 1+        PD.RepoKindUnknown _ -> 2++    -- If the user has specified the repo kind, filter out the repositories+    -- she's not interested in.+    repos = maybe repos' (\k -> filter ((==) k . PD.repoKind) repos') maybeKind++    repoBranchCmd repo = do+        t <- PD.repoType repo+        brancher <- Data.Map.lookup t branchers+        brancherBuildCmd brancher repo++    cmd = listToMaybe (mapMaybe repoBranchCmd repos)++-- | Branch driver for Bazaar.+branchBzr :: Brancher+branchBzr = Brancher "bzr" $ \repo -> do+    src <- PD.repoLocation repo+    let args dst = case PD.repoTag repo of+         Just tag -> ["branch", src, dst, "-r", "tag:" ++ tag]+         Nothing -> ["branch", src, dst]+    return $ BranchCmd $ \verbosity dst -> do+        notice verbosity ("bzr: branch " ++ show src)+        rawSystem "bzr" (args dst)++-- | Branch driver for Darcs.+branchDarcs :: Brancher+branchDarcs = Brancher "darcs" $ \repo -> do+    src <- PD.repoLocation repo+    let args dst = case PD.repoTag repo of+         Just tag -> ["get", src, dst, "-t", tag]+         Nothing -> ["get", src, dst]+    return $ BranchCmd $ \verbosity dst -> do+        notice verbosity ("darcs: get " ++ show src)+        rawSystem "darcs" (args dst)++-- | Branch driver for Git.+branchGit :: Brancher+branchGit = Brancher "git" $ \repo -> do+    src <- PD.repoLocation repo+    let branchArgs = case PD.repoBranch repo of+         Just b -> ["--branch", b]+         Nothing -> []+    let postClone dst = case PD.repoTag repo of+         Just t -> do+             cwd <- getCurrentDirectory+             setCurrentDirectory dst+             finally+                 (rawSystem "git" (["checkout", t] ++ branchArgs))+                 (setCurrentDirectory cwd)+         Nothing -> return ExitSuccess+    return $ BranchCmd $ \verbosity dst -> do+        notice verbosity ("git: clone " ++ show src)+        code <- rawSystem "git" (["clone", src, dst] ++ branchArgs)+        case code of+            ExitFailure _ -> return code+            ExitSuccess -> postClone dst++-- | Branch driver for Mercurial.+branchHg :: Brancher+branchHg = Brancher "hg" $ \repo -> do+    src <- PD.repoLocation repo+    let branchArgs = case PD.repoBranch repo of+         Just b -> ["--branch", b]+         Nothing -> []+    let tagArgs = case PD.repoTag repo of+         Just t -> ["--rev", t]+         Nothing -> []+    let args dst = ["clone", src, dst] ++ branchArgs ++ tagArgs+    return $ BranchCmd $ \verbosity dst -> do+        notice verbosity ("hg: clone " ++ show src)+        rawSystem "hg" (args dst)++-- | Branch driver for Subversion.+branchSvn :: Brancher+branchSvn = Brancher "svn" $ \repo -> do+    src <- PD.repoLocation repo+    let args dst = ["checkout", src, dst]+    return $ BranchCmd $ \verbosity dst -> do+        notice verbosity ("svn: checkout " ++ show src)+        rawSystem "svn" (args dst)
Distribution/Client/Haddock.hs view
@@ -21,7 +21,7 @@ import Control.Monad (guard) import System.Directory (createDirectoryIfMissing, doesFileExist,                          renameFile)-import System.FilePath ((</>), splitFileName)+import System.FilePath ((</>), splitFileName, isAbsolute) import Distribution.Package          ( Package(..), packageVersion ) import Distribution.Simple.Program (haddockProgram, ProgramConfiguration@@ -57,7 +57,7 @@                     , "--gen-index"                     , "--odir=" ++ tempDir                     , "--title=Haskell modules on this system" ]-                 ++ [ "--read-interface=" ++ html ++ "," ++ interface+                 ++ [ "--read-interface=" ++ mkUrl html ++ "," ++ interface                     | (interface, html) <- paths ]         rawSystemProgram verbosity confHaddock flags         renameFile (tempDir </> "index.html") (tempDir </> destFile)@@ -69,6 +69,11 @@             | (_pname, pkgvers) <- allPackagesByName pkgs             , let pkgvers' = filter exposed pkgvers             , not (null pkgvers') ]+    -- See https://github.com/haskell/cabal/issues/1064+    mkUrl f =+      if isAbsolute f+        then "file://" ++ f+        else f  haddockPackagePaths :: [InstalledPackageInfo]                        -> IO ([(FilePath, FilePath)], Maybe String)
Distribution/Client/HttpUtils.hs view
@@ -1,8 +1,8 @@-{-# OPTIONS -cpp #-} -------------------------------------------------------------------------------- | Separate module for HTTP actions, using a proxy server if one exists +-- | Separate module for HTTP actions, using a proxy server if one exists ----------------------------------------------------------------------------- module Distribution.Client.HttpUtils (+    DownloadResult(..),     downloadURI,     getHTTP,     cabalBrowse,@@ -12,148 +12,71 @@  import Network.HTTP          ( Request (..), Response (..), RequestMethod (..)-         , Header(..), HeaderName(..) )+         , Header(..), HeaderName(..), lookupHeader )+import Network.HTTP.Proxy ( Proxy(..), fetchProxy) import Network.URI-         ( URI (..), URIAuth (..), parseAbsoluteURI )-import Network.Stream-         ( Result, ConnError(..) )+         ( URI (..), URIAuth (..) ) import Network.Browser-         ( Proxy (..), Authority (..), BrowserAction, browse+         ( BrowserAction, browse          , setOutHandler, setErrHandler, setProxy, setAuthorityGen, request)+import Network.Stream+         ( Result, ConnError(..) ) import Control.Monad-         ( mplus, join, liftM, liftM2 )+         ( liftM ) import qualified Data.ByteString.Lazy.Char8 as ByteString import Data.ByteString.Lazy (ByteString)-#ifdef WIN32-import System.Win32.Types-         ( DWORD, HKEY )-import System.Win32.Registry-         ( hKEY_CURRENT_USER, regOpenKey, regCloseKey-         , regQueryValue, regQueryValueEx )-import Control.Exception-         ( bracket )-import Distribution.Compat.Exception-         ( handleIO )-import Foreign-         ( toBool, Storable(peek, sizeOf), castPtr, alloca )-#endif-import System.Environment (getEnvironment)  import qualified Paths_cabal_install_bundle (version) import Distribution.Verbosity (Verbosity) import Distribution.Simple.Utils-         ( die, info, warn, debug+         ( die, info, warn, debug, notice          , copyFileVerbose, writeFileAtomic ) import Distribution.Text          ( display )+import Data.Char ( isSpace ) import qualified System.FilePath.Posix as FilePath.Posix          ( splitDirectories )---- FIXME: all this proxy stuff is far too complicated, especially parsing--- the proxy strings. Network.Browser should have a way to pick up the--- proxy settings hiding all this system-dependent stuff below.---- try to read the system proxy settings on windows or unix-proxyString, envProxyString, registryProxyString :: IO (Maybe String)-#ifdef WIN32--- read proxy settings from the windows registry-registryProxyString = handleIO (\_ -> return Nothing) $-  bracket (regOpenKey hive path) regCloseKey $ \hkey -> do-    enable <- fmap toBool $ regQueryValueDWORD hkey "ProxyEnable"-    if enable-        then fmap Just $ regQueryValue hkey (Just "ProxyServer")-        else return Nothing-  where-    -- some sources say proxy settings should be at -    -- HKEY_LOCAL_MACHINE\SOFTWARE\Policies\Microsoft\Windows-    --                   \CurrentVersion\Internet Settings\ProxyServer-    -- but if the user sets them with IE connection panel they seem to-    -- end up in the following place:-    hive  = hKEY_CURRENT_USER-    path = "Software\\Microsoft\\Windows\\CurrentVersion\\Internet Settings"--    regQueryValueDWORD :: HKEY -> String -> IO DWORD-    regQueryValueDWORD hkey name = alloca $ \ptr -> do-      regQueryValueEx hkey name (castPtr ptr) (sizeOf (undefined :: DWORD))-      peek ptr-#else-registryProxyString = return Nothing-#endif---- read proxy settings by looking for an env var-envProxyString = do-  env <- getEnvironment-  return (lookup "http_proxy" env `mplus` lookup "HTTP_PROXY" env)+import System.FilePath+         ( (<.>) )+import System.Directory+         ( doesFileExist ) -proxyString = liftM2 mplus envProxyString registryProxyString+data DownloadResult = FileAlreadyInCache | FileDownloaded FilePath deriving (Eq) +-- Trime+trim :: String -> String+trim = f . f+      where f = reverse . dropWhile isSpace --- |Get the local proxy settings  +-- |Get the local proxy settings+--TODO: print info message when we're using a proxy based on verbosity proxy :: Verbosity -> IO Proxy-proxy verbosity = do-  mstr <- proxyString-  case mstr of-    Nothing   -> return NoProxy-    Just str  -> case parseHttpProxy str of-      Nothing -> do-        warn verbosity $ "invalid http proxy uri: " ++ show str-        warn verbosity $ "proxy uri must be http with a hostname"-        warn verbosity $ "ignoring http proxy, trying a direct connection"-        return NoProxy-      Just p  -> return p---TODO: print info message when we're using a proxy---- | We need to be able to parse non-URIs like @\"wwwcache.example.com:80\"@--- which lack the @\"http://\"@ URI scheme. The problem is that--- @\"wwwcache.example.com:80\"@ is in fact a valid URI but with scheme--- @\"wwwcache.example.com:\"@, no authority part and a path of @\"80\"@.------ So our strategy is to try parsing as normal uri first and if it lacks the--- 'uriAuthority' then we try parsing again with a @\"http://\"@ prefix.----parseHttpProxy :: String -> Maybe Proxy-parseHttpProxy str = join-                   . fmap uri2proxy-                   $ parseHttpURI str-             `mplus` parseHttpURI ("http://" ++ str)-  where-    parseHttpURI str' = case parseAbsoluteURI str' of-      Just uri@URI { uriAuthority = Just _ }-         -> Just (fixUserInfo uri)-      _  -> Nothing--fixUserInfo :: URI -> URI-fixUserInfo uri = uri{ uriAuthority = f `fmap` uriAuthority uri }-    where-      f a@URIAuth{ uriUserInfo = s } =-          a{ uriUserInfo = case reverse s of-                             '@':s' -> reverse s'-                             _      -> s-           }-uri2proxy :: URI -> Maybe Proxy-uri2proxy uri@URI{ uriScheme = "http:"-                 , uriAuthority = Just (URIAuth auth' host port)-                 } = Just (Proxy (host ++ port) auth)-  where auth = if null auth'-                 then Nothing-                 else Just (AuthBasic "" usr pwd uri)-        (usr,pwd') = break (==':') auth'-        pwd        = case pwd' of-                       ':':cs -> cs-                       _      -> pwd'-uri2proxy _ = Nothing+proxy _verbosity = do+  p <- fetchProxy True+  -- Handle empty proxy strings+  return $ case p of+    Proxy uri auth ->+      let uri' = trim uri in+      if uri' == "" then NoProxy else Proxy uri' auth+    _ -> p -mkRequest :: URI -> Request ByteString-mkRequest uri = Request{ rqURI     = uri-                       , rqMethod  = GET-                       , rqHeaders = [Header HdrUserAgent userAgent]-                       , rqBody    = ByteString.empty }+mkRequest :: URI+          -> Maybe String -- ^ Optional etag to be set in the If-None-Match HTTP header.+          -> Request ByteString+mkRequest uri etag = Request{ rqURI     = uri+                            , rqMethod  = GET+                            , rqHeaders = Header HdrUserAgent userAgent : ifNoneMatchHdr+                            , rqBody    = ByteString.empty }   where userAgent = "cabal-install/" ++ display Paths_cabal_install_bundle.version+        ifNoneMatchHdr = maybe [] (\t -> [Header HdrIfNoneMatch t]) etag  -- |Carry out a GET request, using the local proxy settings-getHTTP :: Verbosity -> URI -> IO (Result (Response ByteString))-getHTTP verbosity uri = liftM (\(_, resp) -> Right resp) $-                              cabalBrowse verbosity (return ()) (request (mkRequest uri))+getHTTP :: Verbosity+        -> URI+        -> Maybe String -- ^ Optional etag to check if we already have the latest file.+        -> IO (Result (Response ByteString))+getHTTP verbosity uri etag = liftM (\(_, resp) -> Right resp) $+                                   cabalBrowse verbosity (return ()) (request (mkRequest uri etag))  cabalBrowse :: Verbosity             -> BrowserAction s ()@@ -172,29 +95,56 @@ downloadURI :: Verbosity             -> URI      -- ^ What to download             -> FilePath -- ^ Where to put it-            -> IO ()-downloadURI verbosity uri path | uriScheme uri == "file:" =+            -> IO DownloadResult+downloadURI verbosity uri path | uriScheme uri == "file:" = do   copyFileVerbose verbosity (uriPath uri) path+  return (FileDownloaded path)+  -- Can we store the hash of the file so we can safely return path when the+  -- hash matches to avoid unnecessary computation? downloadURI verbosity uri path = do-  result <- getHTTP verbosity uri+  let etagPath = path <.> "etag"+  targetExists   <- doesFileExist path+  etagPathExists <- doesFileExist etagPath+  -- In rare cases the target file doesn't exist, but the etag does.+  etag <- if targetExists && etagPathExists+            then liftM Just $ readFile etagPath+            else return Nothing++  result <- getHTTP verbosity uri etag   let result' = case result of         Left  err -> Left err         Right rsp -> case rspCode rsp of-          (2,0,0) -> Right (rspBody rsp)+          (2,0,0) -> Right rsp+          (3,0,4) -> Right rsp           (a,b,c) -> Left err             where-              err = ErrorMisc $ "Unsucessful HTTP code: "-                             ++ concatMap show [a,b,c]+              err = ErrorMisc $ "Error HTTP code: "+                                ++ concatMap show [a,b,c] +  -- Only write the etag if we get a 200 response code.+  -- A 304 still sends us an etag header.   case result' of+    Left _ -> return ()+    Right rsp -> case rspCode rsp of+      (2,0,0) -> case lookupHeader HdrETag (rspHeaders rsp) of+        Nothing -> return ()+        Just newEtag -> writeFile etagPath newEtag+      (_,_,_) -> return ()++  case result' of     Left err   -> die $ "Failed to download " ++ show uri ++ " : " ++ show err-    Right body -> do-      info verbosity ("Downloaded to " ++ path)-      writeFileAtomic path (ByteString.unpack body)+    Right rsp -> case rspCode rsp of+      (2,0,0) -> do+        info verbosity ("Downloaded to " ++ path)+        writeFileAtomic path $ rspBody rsp+        return (FileDownloaded path)+      (3,0,4) -> do+        notice verbosity "Skipping download: Local and remote files match."+        return FileAlreadyInCache+      (_,_,_) -> return (FileDownloaded path)       --FIXME: check the content-length header matches the body length.       --TODO: stream the download into the file rather than buffering the whole       --      thing in memory.-      --      remember the ETag so we can not re-download if nothing changed.  -- Utility function for legacy support. isOldHackageURI :: URI -> Bool
Distribution/Client/IndexUtils.hs view
@@ -13,12 +13,15 @@ module Distribution.Client.IndexUtils (   getInstalledPackages,   getSourcePackages,+  getSourcePackagesStrict,   convert,    readPackageIndexFile,   parsePackageIndex,   readRepoIndex,   updateRepoIndexCache,++  BuildTreeRefType(..), refTypeFromTypeCode, typeCodeFromRefType   ) where  import qualified Distribution.Client.Tar as Tar@@ -29,9 +32,10 @@          , Package(..), packageVersion, packageName          , Dependency(Dependency), InstalledPackageId(..) ) import Distribution.Client.PackageIndex (PackageIndex)-import qualified Distribution.Client.PackageIndex as PackageIndex-import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex-import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo+import qualified Distribution.Client.PackageIndex      as PackageIndex+import qualified Distribution.Simple.PackageIndex      as InstalledPackageIndex+import qualified Distribution.InstalledPackageInfo     as InstalledPackageInfo+import qualified Distribution.PackageDescription.Parse as PackageDesc.Parse import Distribution.PackageDescription          ( GenericPackageDescription ) import Distribution.PackageDescription.Parse@@ -49,32 +53,32 @@ import Distribution.Text          ( display, simpleParse ) import Distribution.Verbosity-         ( Verbosity, lessVerbose )+         ( Verbosity, normal, lessVerbose ) import Distribution.Simple.Utils-         ( die, warn, info, fromUTF8 )+         ( die, warn, info, fromUTF8, findPackageDesc )  import Data.Char   (isAlphaNum)-import Data.Maybe  (catMaybes, fromMaybe)+import Data.Maybe  (mapMaybe, fromMaybe) import Data.List   (isPrefixOf) import Data.Monoid (Monoid(..)) import qualified Data.Map as Map-import Control.Monad (MonadPlus(mplus), when, unless, liftM)+import Control.Monad (MonadPlus(mplus), when, liftM) import Control.Exception (evaluate) import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Lazy.Char8 as BS.Char8 import qualified Data.ByteString.Char8 as BSS import Data.ByteString.Lazy (ByteString) import Distribution.Client.GZipUtils (maybeDecompress)+import Distribution.Client.Utils (byteStringToFilePath)+import Distribution.Compat.Exception (catchIO)+import Distribution.Client.Compat.Time+import System.Directory (doesFileExist) import System.FilePath ((</>), takeExtension, splitDirectories, normalise) import System.FilePath.Posix as FilePath.Posix          ( takeFileName ) import System.IO import System.IO.Unsafe (unsafeInterleaveIO) import System.IO.Error (isDoesNotExistError)-import Distribution.Compat.Exception (catchIO)-import System.Directory-         ( getModificationTime, doesFileExist )-import Distribution.Compat.Time   getInstalledPackages :: Verbosity -> Compiler@@ -128,16 +132,29 @@ -- This is a higher level wrapper used internally in cabal-install. -- getSourcePackages :: Verbosity -> [Repo] -> IO SourcePackageDb-getSourcePackages verbosity [] = do+getSourcePackages verbosity repos = getSourcePackages' verbosity repos+                                    ReadPackageIndexLazyIO++-- | Like 'getSourcePackages', but reads the package index strictly. Useful if+-- you want to write to the package index after having read it.+getSourcePackagesStrict :: Verbosity -> [Repo] -> IO SourcePackageDb+getSourcePackagesStrict verbosity repos = getSourcePackages' verbosity repos+                                          ReadPackageIndexStrict++-- | Common implementation used by getSourcePackages and+-- getSourcePackagesStrict.+getSourcePackages' :: Verbosity -> [Repo] -> ReadPackageIndexMode+                      -> IO SourcePackageDb+getSourcePackages' verbosity [] _mode = do   warn verbosity $ "No remote package servers have been specified. Usually "                 ++ "you would have one specified in the config file."   return SourcePackageDb {     packageIndex       = mempty,     packagePreferences = mempty   }-getSourcePackages verbosity repos = do+getSourcePackages' verbosity repos mode = do   info verbosity "Reading available packages..."-  pkgss <- mapM (readRepoIndex verbosity) repos+  pkgss <- mapM (\r -> readRepoIndex verbosity r mode) repos   let (pkgs, prefs) = mconcat pkgss       prefs' = Map.fromListWith intersectVersionRanges                  [ (name, range) | Dependency name range <- prefs ]@@ -148,7 +165,6 @@     packagePreferences = prefs'   } - -- | Read a repository index from disk, from the local file specified by -- the 'Repo'. --@@ -156,26 +172,32 @@ -- -- This is a higher level wrapper used internally in cabal-install. ---readRepoIndex :: Verbosity -> Repo+readRepoIndex :: Verbosity -> Repo -> ReadPackageIndexMode               -> IO (PackageIndex SourcePackage, [Dependency])-readRepoIndex verbosity repo =+readRepoIndex verbosity repo mode =   let indexFile = repoLocalDir repo </> "00-index.tar"       cacheFile = repoLocalDir repo </> "00-index.cache"   in handleNotFound $ do     warnIfIndexIsOld indexFile     whenCacheOutOfDate indexFile cacheFile $ do-      info verbosity $ "Updating the index cache file..."+      info verbosity "Updating the index cache file..."       updatePackageIndexCacheFile indexFile cacheFile-    readPackageIndexCacheFile mkAvailablePackage indexFile cacheFile+    readPackageIndexCacheFile mkAvailablePackage indexFile cacheFile mode    where-    mkAvailablePackage pkgid pkgtxt pkg =+    mkAvailablePackage pkgEntry =       SourcePackage {         packageInfoId      = pkgid,-        packageDescription = pkg,-        packageSource      = RepoTarballPackage repo pkgid Nothing,-        packageDescrOverride = Just pkgtxt+        packageDescription = packageDesc pkgEntry,+        packageSource      = case pkgEntry of+          NormalPackage _ _ _ _       -> RepoTarballPackage repo pkgid Nothing+          BuildTreeRef  _  _ _ path _ -> LocalUnpackedPackage path,+        packageDescrOverride = case pkgEntry of+          NormalPackage _ _ pkgtxt _ -> Just pkgtxt+          _                          -> Nothing       }+      where+        pkgid = packageId pkgEntry      handleNotFound action = catchIO action $ \e -> if isDoesNotExistError e       then do@@ -205,27 +227,57 @@ updateRepoIndexCache :: Verbosity -> Repo -> IO () updateRepoIndexCache verbosity repo =     whenCacheOutOfDate indexFile cacheFile $ do-      info verbosity $ "Updating the index cache file..."+      info verbosity "Updating the index cache file..."       updatePackageIndexCacheFile indexFile cacheFile   where     indexFile = repoLocalDir repo </> "00-index.tar"     cacheFile = repoLocalDir repo </> "00-index.cache" -whenCacheOutOfDate :: FilePath-> FilePath -> IO () -> IO ()+whenCacheOutOfDate :: FilePath -> FilePath -> IO () -> IO () whenCacheOutOfDate origFile cacheFile action = do   exists <- doesFileExist cacheFile   if not exists     then action     else do-      origTime  <- getModificationTime origFile-      cacheTime <- getModificationTime cacheFile-      unless (cacheTime >= origTime) action-+      origTime  <- getModTime origFile+      cacheTime <- getModTime cacheFile+      when (origTime >= cacheTime) action  ------------------------------------------------------------------------ -- Reading the index file -- +-- | An index entry is either a normal package, or a local build tree reference.+data PackageEntry =+  NormalPackage  PackageId GenericPackageDescription ByteString BlockNo+  | BuildTreeRef BuildTreeRefType+                 PackageId GenericPackageDescription FilePath   BlockNo++-- | A build tree reference is either a link or a snapshot.+data BuildTreeRefType = SnapshotRef | LinkRef+                      deriving Eq++refTypeFromTypeCode :: Tar.TypeCode -> BuildTreeRefType+refTypeFromTypeCode t+  | t == Tar.buildTreeRefTypeCode      = LinkRef+  | t == Tar.buildTreeSnapshotTypeCode = SnapshotRef+  | otherwise                          =+    error "Distribution.Client.IndexUtils.refTypeFromTypeCode: unknown type code"++typeCodeFromRefType :: BuildTreeRefType -> Tar.TypeCode+typeCodeFromRefType LinkRef     = Tar.buildTreeRefTypeCode+typeCodeFromRefType SnapshotRef = Tar.buildTreeSnapshotTypeCode++type MkPackageEntry = IO PackageEntry++instance Package PackageEntry where+  packageId (NormalPackage  pkgid _ _ _) = pkgid+  packageId (BuildTreeRef _ pkgid _ _ _) = pkgid++packageDesc :: PackageEntry -> GenericPackageDescription+packageDesc (NormalPackage  _ descr _ _) = descr+packageDesc (BuildTreeRef _ _ descr _ _) = descr+ -- | Read a compressed \"00-index.tar.gz\" file into a 'PackageIndex'. -- -- This is supposed to be an \"all in one\" way to easily get at the info in@@ -236,26 +288,24 @@ -- case you can just use @\_ p -> p@ here. -- readPackageIndexFile :: Package pkg-                     => (PackageId -> GenericPackageDescription -> pkg)+                     => (PackageEntry -> pkg)                      -> FilePath                      -> IO (PackageIndex pkg, [Dependency]) readPackageIndexFile mkPkg indexFile = do-  (pkgs, prefs) <- either fail return-                 . parsePackageIndex-                 . maybeDecompress-               =<< BS.readFile indexFile+  (mkPkgs, prefs) <- either fail return+                     . parsePackageIndex+                     . maybeDecompress+                     =<< BS.readFile indexFile -  pkgs' <- evaluate $ PackageIndex.fromList-            [ mkPkg pkgid pkg | (pkgid, pkg, _) <- pkgs]-  return (pkgs', prefs)+  pkgEntries  <- sequence mkPkgs+  pkgs <- evaluate $ PackageIndex.fromList (map mkPkg pkgEntries)+  return (pkgs, prefs)  -- | Parse an uncompressed \"00-index.tar\" repository index file represented -- as a 'ByteString'. -- parsePackageIndex :: ByteString-                  -> Either String-                            ( [(PackageId, GenericPackageDescription, BlockNo)]-                            , [Dependency] )+                  -> Either String ([MkPackageEntry], [Dependency]) parsePackageIndex = accum 0 [] [] . Tar.read   where     accum blockNo pkgs prefs es = case es of@@ -264,7 +314,7 @@       Tar.Next e es' -> accum blockNo' pkgs' prefs' es'         where           (pkgs', prefs') = extract blockNo pkgs prefs e-          blockNo'        = blockNo + sizeInBlocks e+          blockNo'        = blockNo + Tar.entrySizeInBlocks e      extract blockNo pkgs prefs entry =        fromMaybe (pkgs, prefs) $@@ -272,28 +322,20 @@          `mplus` tryExtractPrefs       where         tryExtractPkg = do-          (pkgid, pkg) <- extractPkg entry-          return ((pkgid, pkg, blockNo):pkgs, prefs)+          mkPkgEntry <- extractPkg entry blockNo+          return (mkPkgEntry:pkgs, prefs)          tryExtractPrefs = do           prefs' <- extractPrefs entry           return (pkgs, prefs'++prefs) -    sizeInBlocks entry =-        1 + case Tar.entryContent entry of-              Tar.NormalFile     _   size -> bytesToBlocks size-              Tar.OtherEntryType _ _ size -> bytesToBlocks size-              _                           -> 0-      where-        bytesToBlocks s = 1 + ((fromIntegral s - 1) `div` 512)--extractPkg :: Tar.Entry -> Maybe (PackageId, GenericPackageDescription)-extractPkg entry = case Tar.entryContent entry of+extractPkg :: Tar.Entry -> BlockNo -> Maybe MkPackageEntry+extractPkg entry blockNo = case Tar.entryContent entry of   Tar.NormalFile content _      | takeExtension fileName == ".cabal"     -> case splitDirectories (normalise fileName) of         [pkgname,vers,_] -> case simpleParse vers of-          Just ver -> Just (pkgid, descr)+          Just ver -> Just $ return (NormalPackage pkgid descr content blockNo)             where               pkgid  = PackageIdentifier (PackageName pkgname) ver               parsed = parsePackageDescription . fromUTF8 . BS.Char8.unpack@@ -304,7 +346,18 @@                                     ++ show fileName           _ -> Nothing         _ -> Nothing++  Tar.OtherEntryType typeCode content _+    | Tar.isBuildTreeRefTypeCode typeCode ->+      Just $ do+        let path   = byteStringToFilePath content+        cabalFile <- findPackageDesc path+        descr     <- PackageDesc.Parse.readPackageDescription normal cabalFile+        return $ BuildTreeRef (refTypeFromTypeCode typeCode) (packageId descr)+                              descr path blockNo+   _ -> Nothing+   where     fileName = Tar.entryPath entry @@ -317,8 +370,7 @@   _ -> Nothing  parsePreferredVersions :: String -> [Dependency]-parsePreferredVersions = catMaybes-                       . map simpleParse+parsePreferredVersions = mapMaybe simpleParse                        . filter (not . isPrefixOf "--")                        . lines @@ -328,36 +380,48 @@  updatePackageIndexCacheFile :: FilePath -> FilePath -> IO () updatePackageIndexCacheFile indexFile cacheFile = do-    (pkgs, prefs) <- either fail return-                   . parsePackageIndex-                   . maybeDecompress-                 =<< BS.readFile indexFile-    let cache = mkCache pkgs prefs+    (mkPkgs, prefs) <- either fail return+                       . parsePackageIndex+                       . maybeDecompress+                       =<< BS.readFile indexFile+    pkgEntries <- sequence mkPkgs+    let cache = mkCache pkgEntries prefs     writeFile cacheFile (showIndexCache cache)   where     mkCache pkgs prefs =         [ CachePreference pref          | pref <- prefs ]-     ++ [ CachePackageId pkgid blockNo | (pkgid, _, blockNo) <- pkgs ]+     ++ [ CachePackageId pkgid blockNo+        | (NormalPackage pkgid _ _ blockNo) <- pkgs ]+     ++ [ CacheBuildTreeRef refType blockNo+        | (BuildTreeRef refType _ _ _ blockNo) <- pkgs] +data ReadPackageIndexMode = ReadPackageIndexStrict+                          | ReadPackageIndexLazyIO+ readPackageIndexCacheFile :: Package pkg-                          => (PackageId -> ByteString-                                        -> GenericPackageDescription -> pkg)+                          => (PackageEntry -> pkg)                           -> FilePath                           -> FilePath+                          -> ReadPackageIndexMode                           -> IO (PackageIndex pkg, [Dependency])-readPackageIndexCacheFile mkPkg indexFile cacheFile = do-  indexHnd <- openFile indexFile ReadMode+readPackageIndexCacheFile mkPkg indexFile cacheFile mode = do   cache    <- liftM readIndexCache (BSS.readFile cacheFile)-  packageIndexFromCache mkPkg indexHnd cache+  myWithFile indexFile ReadMode $ \indexHnd ->+    packageIndexFromCache mkPkg indexHnd cache mode+  where+    myWithFile f m act = case mode of+      ReadPackageIndexStrict -> withFile f m act+      ReadPackageIndexLazyIO -> do indexHnd <- openFile f m+                                   act indexHnd   packageIndexFromCache :: Package pkg-                      => (PackageId -> ByteString-                                    -> GenericPackageDescription -> pkg)+                      => (PackageEntry -> pkg)                       -> Handle                       -> [IndexCacheEntry]+                      -> ReadPackageIndexMode                       -> IO (PackageIndex pkg, [Dependency])-packageIndexFromCache mkPkg hnd = accum mempty []+packageIndexFromCache mkPkg hnd entrs mode = accum mempty [] entrs   where     accum srcpkgs prefs [] = do       -- Have to reverse entries, since in a tar file, later entries mask@@ -375,27 +439,47 @@         pkgtxt <- getEntryContent blockno         pkg    <- readPackageDescription pkgtxt         return (pkg, pkgtxt)+      let srcpkg = case mode of+            ReadPackageIndexLazyIO ->+              mkPkg (NormalPackage pkgid pkg pkgtxt blockno)+            ReadPackageIndexStrict ->+              pkg `seq` pkgtxt `seq` mkPkg (NormalPackage pkgid pkg+                                            pkgtxt blockno)+      accum (srcpkg:srcpkgs) prefs entries -      let srcpkg = mkPkg pkgid pkgtxt pkg+    accum srcpkgs prefs (CacheBuildTreeRef refType blockno : entries) = do+      -- We have to read the .cabal file eagerly here because we can't cache the+      -- package id for build tree references - the user might edit the .cabal+      -- file after the reference was added to the index.+      path <- liftM byteStringToFilePath . getEntryContent $ blockno+      pkg  <- do cabalFile <- findPackageDesc path+                 PackageDesc.Parse.readPackageDescription normal cabalFile+      let srcpkg = mkPkg (BuildTreeRef refType (packageId pkg) pkg path blockno)       accum (srcpkg:srcpkgs) prefs entries      accum srcpkgs prefs (CachePreference pref : entries) =       accum srcpkgs (pref:prefs) entries +    getEntryContent :: BlockNo -> IO ByteString     getEntryContent blockno = do       hSeek hnd AbsoluteSeek (fromIntegral (blockno * 512))       header  <- BS.hGet hnd 512       size    <- getEntrySize header       BS.hGet hnd (fromIntegral size) +    getEntrySize :: ByteString -> IO Tar.FileSize     getEntrySize header =       case Tar.read header of         Tar.Next e _ ->           case Tar.entryContent e of             Tar.NormalFile _ size -> return size+            Tar.OtherEntryType typecode _ size+              | Tar.isBuildTreeRefTypeCode typecode+                                  -> return size             _                     -> interror "unexpected tar entry type"         _ -> interror "could not read tar file entry" +    readPackageDescription :: ByteString -> IO GenericPackageDescription     readPackageDescription content =       case parsePackageDescription . fromUTF8 . BS.Char8.unpack $ content of         ParseOk _ d -> return d@@ -415,8 +499,9 @@ type BlockNo = Int  data IndexCacheEntry = CachePackageId PackageId BlockNo+                     | CacheBuildTreeRef BuildTreeRefType BlockNo                      | CachePreference Dependency-  deriving (Eq, Show)+  deriving (Eq)  readIndexCacheEntry :: BSS.ByteString -> Maybe IndexCacheEntry readIndexCacheEntry = \line ->@@ -428,12 +513,19 @@         (Just pkgname, Just pkgver, Just blockno)           -> Just (CachePackageId (PackageIdentifier pkgname pkgver) blockno)         _ -> Nothing+    [key, typecodestr, blocknostr] | key == buildTreeRefKey ->+      case (parseRefType typecodestr, parseBlockNo blocknostr) of+        (Just refType, Just blockno)+          -> Just (CacheBuildTreeRef refType blockno)+        _ -> Nothing+     (key: remainder) | key == preferredVersionKey ->       fmap CachePreference (simpleParse (BSS.unpack (BSS.unwords remainder)))     _  -> Nothing   where     packageKey = BSS.pack "pkg:"     blocknoKey = BSS.pack "b#"+    buildTreeRefKey     = BSS.pack "build-tree-ref:"     preferredVersionKey = BSS.pack "pref-ver:"      parseName str@@ -454,15 +546,24 @@         Just (blockno, remainder) | BSS.null remainder -> Just blockno         _                                              -> Nothing +    parseRefType str =+      case BSS.uncons str of+        Just (typeCode, remainder)+          | BSS.null remainder && Tar.isBuildTreeRefTypeCode typeCode+            -> Just (refTypeFromTypeCode typeCode)+        _   -> Nothing+ showIndexCacheEntry :: IndexCacheEntry -> String showIndexCacheEntry entry = case entry of    CachePackageId pkgid b -> "pkg: " ++ display (packageName pkgid)                                   ++ " " ++ display (packageVersion pkgid)                           ++ " b# " ++ show b-   CachePreference dep     -> "pref-ver: " ++ display dep+   CacheBuildTreeRef t b  -> "build-tree-ref: " ++ (typeCodeFromRefType t:" ")+                             ++ show b+   CachePreference dep    -> "pref-ver: " ++ display dep  readIndexCache :: BSS.ByteString -> [IndexCacheEntry]-readIndexCache = catMaybes . map readIndexCacheEntry . BSS.lines+readIndexCache = mapMaybe readIndexCacheEntry . BSS.lines  showIndexCache :: [IndexCacheEntry] -> String showIndexCache = unlines . map showIndexCacheEntry
Distribution/Client/Init.hs view
@@ -24,14 +24,17 @@ import System.IO   ( hSetBuffering, stdout, BufferMode(..) ) import System.Directory-  ( getCurrentDirectory, doesDirectoryExist )+  ( getCurrentDirectory, doesDirectoryExist, doesFileExist, copyFile+  , getDirectoryContents ) import System.FilePath-  ( (</>) )+  ( (</>), (<.>), takeBaseName ) import Data.Time   ( getCurrentTime, utcToLocalTime, toGregorian, localDay, getCurrentTimeZone ) +import Data.Char+  ( toUpper ) import Data.List-  ( intersperse, intercalate, nub, groupBy, (\\) )+  ( intercalate, nub, groupBy, (\\) ) import Data.Maybe   ( fromMaybe, isJust, catMaybes ) import Data.Function@@ -42,39 +45,35 @@ import Control.Applicative   ( (<$>) ) import Control.Monad-  ( when )-#if MIN_VERSION_base(3,0,0)-import Control.Monad-  ( (>=>), join )-#endif+  ( when, unless, (>=>), join ) import Control.Arrow-  ( (&&&) )+  ( (&&&), (***) )  import Text.PrettyPrint hiding (mode, cat)  import Data.Version   ( Version(..) ) import Distribution.Version-  ( orLaterVersion, withinVersion, VersionRange )+  ( orLaterVersion, earlierVersion, intersectVersionRanges, VersionRange ) import Distribution.Verbosity   ( Verbosity ) import Distribution.ModuleName-  ( ModuleName, fromString )+  ( ModuleName, fromString )  -- And for the Text instance import Distribution.InstalledPackageInfo   ( InstalledPackageInfo, sourcePackageId, exposed ) import qualified Distribution.Package as P+import Language.Haskell.Extension ( Language(..) )  import Distribution.Client.Init.Types   ( InitFlags(..), PackageType(..), Category(..) ) import Distribution.Client.Init.Licenses-  ( bsd3, gplv2, gplv3, lgpl2, lgpl3, apache20 )+  ( bsd3, gplv2, gplv3, lgpl2, lgpl3, agplv3, apache20 ) import Distribution.Client.Init.Heuristics-  ( guessPackageName, guessAuthorNameMail, SourceFileEntry(..), scanForModules, neededBuildPrograms )+  ( guessPackageName, guessAuthorNameMail, SourceFileEntry(..),+    scanForModules, neededBuildPrograms )  import Distribution.License   ( License(..), knownLicenses )-import Distribution.ModuleName-  ( ) -- for the Text instance  import Distribution.ReadE   ( runReadE, readP_to_E )@@ -126,7 +125,9 @@   >=> getHomepage   >=> getSynopsis   >=> getCategory+  >=> getExtraSourceFiles   >=> getLibOrExec+  >=> getLanguage   >=> getGenComments   >=> getSrcDir   >=> getModulesBuildToolsAndDeps pkgIx@@ -178,13 +179,15 @@   return $ flags { license = maybeToFlag lic }   where     listedLicenses =-      knownLicenses \\ [GPL Nothing, LGPL Nothing, Apache Nothing, OtherLicense]+      knownLicenses \\ [GPL Nothing, LGPL Nothing, AGPL Nothing+                       , Apache Nothing, OtherLicense]  -- | The author's name and email. Prompt, or try to guess from an existing --   darcs repo. getAuthorInfo :: InitFlags -> IO InitFlags getAuthorInfo flags = do-  (authorName, authorEmail)  <- (\(a,e) -> (flagToMaybe a, flagToMaybe e)) `fmap` guessAuthorNameMail+  (authorName, authorEmail)  <-+    (flagToMaybe *** flagToMaybe) `fmap` guessAuthorNameMail   authorName'  <-     return (flagToMaybe $ author flags)                   ?>> maybePrompt flags (promptStr "Author name" authorName)                   ?>> return authorName@@ -230,22 +233,59 @@                          (promptListOptional "Project category" [Codec ..]))   return $ flags { category = maybeToFlag cat } +-- | Try to guess extra source files (don't prompt the user).+getExtraSourceFiles :: InitFlags -> IO InitFlags+getExtraSourceFiles flags = do+  extraSrcFiles <-     return (extraSrc flags)+                   ?>> Just `fmap` guessExtraSourceFiles flags++  return $ flags { extraSrc = extraSrcFiles }++-- | Try to guess things to include in the extra-source-files field.+--   For now, we just look for things in the root directory named+--   'readme', 'changes', or 'changelog', with any sort of+--   capitalization and any extension.+guessExtraSourceFiles :: InitFlags -> IO [FilePath]+guessExtraSourceFiles flags = do+  dir <-+    maybe getCurrentDirectory return . flagToMaybe $ packageDir flags+  files <- getDirectoryContents dir+  return $ filter isExtra files++  where+    isExtra = (`elem` ["README", "CHANGES", "CHANGELOG"])+            . map toUpper+            . takeBaseName+ -- | Ask whether the project builds a library or executable. getLibOrExec :: InitFlags -> IO InitFlags getLibOrExec flags = do   isLib <-     return (flagToMaybe $ packageType flags)            ?>> maybePrompt flags (either (const Library) id `fmap`-                                   (promptList "What does the package build"-                                               [Library, Executable]-                                               Nothing display False))+                                   promptList "What does the package build"+                                   [Library, Executable]+                                   Nothing display False)            ?>> return (Just Library)    return $ flags { packageType = maybeToFlag isLib } --- | Ask whether to generate explanitory comments.+-- | Ask for the base language of the package.+getLanguage :: InitFlags -> IO InitFlags+getLanguage flags = do+  lang <-     return (flagToMaybe $ language flags)+          ?>> maybePrompt flags+                (either UnknownLanguage id `fmap`+                  promptList "What base language is the package written in"+                  [Haskell2010, Haskell98]+                  (Just Haskell2010) display True)+          ?>> return (Just Haskell2010)++  return $ flags { language = maybeToFlag lang }++-- | Ask whether to generate explanatory comments. getGenComments :: InitFlags -> IO InitFlags getGenComments flags = do-  genComments <-     return (flagToMaybe $ noComments flags)+  genComments <-     return (not <$> flagToMaybe (noComments flags))                  ?>> maybePrompt flags (promptYesNo promptMsg (Just False))                  ?>> return (Just False)   return $ flags { noComments = maybeToFlag (fmap not genComments) }@@ -256,7 +296,7 @@ getSrcDir :: InitFlags -> IO InitFlags getSrcDir flags = do   srcDirs <-     return (sourceDirs flags)-             ?>> Just `fmap` (guessSourceDirs flags)+             ?>> Just `fmap` guessSourceDirs flags    return $ flags { sourceDirs = srcDirs } @@ -264,8 +304,8 @@ --   moment just looks to see whether there is a directory called 'src'. guessSourceDirs :: InitFlags -> IO [String] guessSourceDirs flags = do-  dir      <- fromMaybe getCurrentDirectory-                (fmap return . flagToMaybe $ packageDir flags)+  dir      <-+    maybe getCurrentDirectory return . flagToMaybe $ packageDir flags   srcIsDir <- doesDirectoryExist (dir </> "src")   if srcIsDir     then return ["src"]@@ -274,8 +314,7 @@ -- | Get the list of exposed modules and extra tools needed to build them. getModulesBuildToolsAndDeps :: PackageIndex -> InitFlags -> IO InitFlags getModulesBuildToolsAndDeps pkgIx flags = do-  dir <- fromMaybe getCurrentDirectory-                   (fmap return . flagToMaybe $ packageDir flags)+  dir <- maybe getCurrentDirectory return . flagToMaybe $ packageDir flags    -- XXX really should use guessed source roots.   sourceFiles <- scanForModules dir@@ -288,12 +327,23 @@    deps <-      return (dependencies flags)            ?>> Just <$> importsToDeps flags-                        (fromString "Prelude" : concatMap imports sourceFiles)+                        (fromString "Prelude" :  -- to ensure we get base as a dep+                           (   nub   -- only need to consider each imported package once+                             . filter (`notElem` mods)  -- don't consider modules from+                                                        -- this package itself+                             . concatMap imports+                             $ sourceFiles+                           )+                        )                         pkgIx +  exts <-     return (otherExts flags)+          ?>> (return . Just . nub . concatMap extensions $ sourceFiles)+   return $ flags { exposedModules = Just mods                  , buildTools     = tools                  , dependencies   = deps+                 , otherExts      = exts                  }  importsToDeps :: InitFlags -> [ModuleName] -> PackageIndex -> IO [P.Dependency]@@ -333,7 +383,7 @@       grps  -> do message flags ("\nWarning: multiple packages found providing "                                  ++ display m                                  ++ ": " ++ intercalate ", " (map (display . P.pkgName . head) grps))-                  message flags ("You will need to pick one and manually add it to the Build-depends: field.")+                  message flags "You will need to pick one and manually add it to the Build-depends: field."                   return Nothing   where     pkgGroups = groupBy ((==) `on` P.pkgName) (map sourcePackageId ps)@@ -351,8 +401,19 @@                             (pvpize . maximum . map P.pkgVersion $ pids)      pvpize :: Version -> VersionRange-    pvpize v = withinVersion $ v { versionBranch = take 2 (versionBranch v) }+    pvpize v = orLaterVersion v'+               `intersectVersionRanges`+               earlierVersion (incVersion 1 v')+      where v' = (v { versionBranch = take 2 (versionBranch v) }) +incVersion :: Int -> Version -> Version+incVersion n (Version vlist tags) = Version (incVersion' n vlist) tags+  where+    incVersion' 0 []     = [1]+    incVersion' 0 (v:_)  = [v+1]+    incVersion' m []     = replicate m 0 ++ [1]+    incVersion' m (v:vs) = v : incVersion' (m-1) vs+ --------------------------------------------------------------------------- --  Prompting/user interaction  ------------------------------------------- ---------------------------------------------------------------------------@@ -421,7 +482,7 @@   $ promptList pr (Nothing : map Just choices) (Just Nothing)                (maybe "(none)" display) True   where-    rearrange = either (Just . Left) (maybe Nothing (Just . Right))+    rearrange = either (Just . Left) (fmap Right)  -- | Create a prompt from a list of items. promptList :: Eq t@@ -435,8 +496,7 @@   putStrLn $ pr ++ ":"   let options1 = map (\c -> (Just c == def, displayItem c)) choices       options2 = zip ([1..]::[Int])-                     (options1 ++ if other then [(False, "Other (specify)")]-                                           else [])+                     (options1 ++ [(False, "Other (specify)") | other])   mapM_ (putStrLn . \(n,(i,s)) -> showOption n i ++ s) options2   promptList' displayItem (length options2) choices def other  where showOption n i | n < 10 = " " ++ star i ++ " " ++ rest@@ -495,13 +555,16 @@           Flag (LGPL (Just (Version {versionBranch = [3]})))             -> Just lgpl3 +          Flag (AGPL (Just (Version {versionBranch = [3]})))+            -> Just agplv3+           Flag (Apache (Just (Version {versionBranch = [2, 0]})))             -> Just apache20            _ -> Nothing    case licenseFile of-    Just licenseText -> writeFile "LICENSE" licenseText+    Just licenseText -> writeFileSafe flags "LICENSE" licenseText     Nothing -> message flags "Warning: unknown license type, you must put a copy in LICENSE yourself."  getYear :: IO Integer@@ -515,15 +578,13 @@ writeSetupFile :: InitFlags -> IO () writeSetupFile flags = do   message flags "Generating Setup.hs..."-  writeFile "Setup.hs" setupFile+  writeFileSafe flags "Setup.hs" setupFile  where   setupFile = unlines     [ "import Distribution.Simple"     , "main = defaultMain"     ] --- XXX ought to do something sensible if a .cabal file already exists,--- instead of overwriting. writeCabalFile :: InitFlags -> IO Bool writeCabalFile flags@(InitFlags{packageName = NoFlag}) = do   message flags "Error: no package name provided."@@ -531,9 +592,36 @@ writeCabalFile flags@(InitFlags{packageName = Flag p}) = do   let cabalFileName = p ++ ".cabal"   message flags $ "Generating " ++ cabalFileName ++ "..."-  writeFile cabalFileName (generateCabalFile cabalFileName flags)+  writeFileSafe flags cabalFileName (generateCabalFile cabalFileName flags)   return True +-- | Write a file \"safely\", backing up any existing version (unless+--   the overwrite flag is set).+writeFileSafe :: InitFlags -> FilePath -> String -> IO ()+writeFileSafe flags fileName content = do+  moveExistingFile flags fileName+  writeFile fileName content++-- | Move an existing file, if there is one, and the overwrite flag is+--   not set.+moveExistingFile :: InitFlags -> FilePath -> IO ()+moveExistingFile flags fileName =+  unless (overwrite flags == Flag True) $ do+    e <- doesFileExist fileName+    when e $ do+      newName <- findNewName fileName+      message flags $ "Warning: " ++ fileName ++ " already exists, backing up old version in " ++ newName+      copyFile fileName newName++findNewName :: FilePath -> IO FilePath+findNewName oldName = findNewName' 0+  where+    findNewName' :: Integer -> IO FilePath+    findNewName' n = do+      let newName = oldName <.> ("save" ++ show n)+      e <- doesFileExist newName+      if e then findNewName' (n+1) else return newName+ -- | Generate a .cabal file from an InitFlags structure.  NOTE: this --   is rather ad-hoc!  What we would REALLY like is to have a --   standard low-level AST type representing .cabal files, which@@ -545,7 +633,7 @@ generateCabalFile :: String -> InitFlags -> String generateCabalFile fileName c =   renderStyle style { lineLength = 79, ribbonsPerLine = 1.1 } $-  (if (minimal c /= Flag True)+  (if minimal c /= Flag True     then showComment (Just $ "Initial " ++ fileName ++ " generated by cabal "                           ++ "init.  For further documentation, see "                           ++ "http://haskell.org/cabal/users-guide/")@@ -607,22 +695,22 @@                 Nothing                 True -       , fieldS "extra-source-files" NoFlag+       , fieldS "extra-source-files" (listFieldS (extraSrc c))                 (Just "Extra files to be distributed with the package, such as examples or a README.")-                False+                True -       , field  "cabal-version" (Flag $ orLaterVersion (Version [1,8] []))+       , field  "cabal-version" (Flag $ orLaterVersion (Version [1,10] []))                 (Just "Constraint on the version of Cabal needed to build this package.")                 False         , case packageType c of            Flag Executable ->-             text "\nexecutable" <+> text (fromMaybe "" . flagToMaybe $ packageName c) $$ (nest 2 $ vcat+             text "\nexecutable" <+> text (fromMaybe "" . flagToMaybe $ packageName c) $$ nest 2 (vcat              [ fieldS "main-is" NoFlag (Just ".hs or .lhs file containing the Main module.") True               , generateBuildInfo Executable c              ])-           Flag Library    -> text "\nlibrary" $$ (nest 2 $ vcat+           Flag Library    -> text "\nlibrary" $$ nest 2 (vcat              [ fieldS "exposed-modules" (listField (exposedModules c))                       (Just "Modules exported by the library.")                       True@@ -640,24 +728,32 @@                  Executable -> "Modules included in this executable, other than Main.")               True +     , fieldS "other-extensions" (listField (otherExts c'))+              (Just "LANGUAGE extensions used by modules in this package.")+              True+      , fieldS "build-depends" (listField (dependencies c'))               (Just "Other library packages from which modules are imported.")               True       , fieldS "hs-source-dirs" (listFieldS (sourceDirs c'))               (Just "Directories containing source files.")-              False+              True       , fieldS "build-tools" (listFieldS (buildTools c'))               (Just "Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.")               False++     , field  "default-language" (language c')+              (Just "Base language which the package is written in.")+              True      ]     listField :: Text s => Maybe [s] -> Flag String    listField = listFieldS . fmap (map display)     listFieldS :: Maybe [String] -> Flag String-   listFieldS = Flag . maybe "" (concat . intersperse ", ")+   listFieldS = Flag . maybe "" (intercalate ", ")     field :: Text t => String -> Flag t -> Maybe String -> Bool -> Doc    field s f = fieldS s (fmap display f)@@ -676,15 +772,15 @@                         (False, _, _)     -> ($$ text "")                       $                       comment f <> text s <> colon-                                <> text (take (20 - length s) (repeat ' '))+                                <> text (replicate (20 - length s) ' ')                                 <> text (fromMaybe "" . flagToMaybe $ f)    comment NoFlag    = text "-- "    comment (Flag "") = text "-- "    comment _         = text ""     showComment :: Maybe String -> Doc-   showComment (Just t) = vcat . map text-                        . map ("-- "++) . lines+   showComment (Just t) = vcat+                        . map (text . ("-- "++)) . lines                         . renderStyle style {                             lineLength = 76,                             ribbonsPerLine = 1.05@@ -714,9 +810,3 @@ message :: InitFlags -> String -> IO () message (InitFlags{quiet = Flag True}) _ = return () message _ s = putStrLn s--#if MIN_VERSION_base(3,0,0)-#else-(>=>)       :: Monad m => (a -> m b) -> (b -> m c) -> (a -> m c)-f >=> g     = \x -> f x >>= g-#endif
Distribution/Client/Init/Heuristics.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.Init.Heuristics@@ -22,33 +21,37 @@ import Distribution.Text         (simpleParse) import Distribution.Simple.Setup (Flag(..)) import Distribution.ModuleName-    ( ModuleName, fromString, toFilePath )+    ( ModuleName, toFilePath ) import Distribution.Client.PackageIndex     ( allPackagesByName ) import qualified Distribution.PackageDescription as PD     ( category, packageDescription ) import Distribution.Simple.Utils          ( intercalate )+import Distribution.Client.Utils+         ( tryCanonicalizePath )+import Language.Haskell.Extension ( Extension )  import Distribution.Client.Types ( packageDescription, SourcePackageDb(..) )-import Control.Monad (liftM )+import Control.Applicative ( pure, (<$>), (<*>) )+import Control.Monad ( liftM ) import Data.Char   ( isUpper, isLower, isSpace )-#if MIN_VERSION_base(3,0,3) import Data.Either ( partitionEithers )-#endif import Data.List   ( isPrefixOf )-import Data.Maybe  ( catMaybes )-import Data.Monoid ( mempty, mappend )+import Data.Maybe  ( mapMaybe, catMaybes, maybeToList )+import Data.Monoid ( mempty, mconcat ) import qualified Data.Set as Set ( fromList, toList )-import System.Directory ( getDirectoryContents, doesDirectoryExist, doesFileExist,-                          getHomeDirectory, canonicalizePath )-import System.Environment ( getEnvironment )+import System.Directory ( getDirectoryContents,+                          doesDirectoryExist, doesFileExist, getHomeDirectory, )+import Distribution.Compat.Environment ( getEnvironment ) import System.FilePath ( takeExtension, takeBaseName, dropExtension,                          (</>), (<.>), splitDirectories, makeRelative )+import System.Process ( readProcessWithExitCode )+import System.Exit ( ExitCode(..) )  -- |Guess the package name based on the given root directory guessPackageName :: FilePath -> IO String-guessPackageName = liftM (last . splitDirectories) . canonicalizePath+guessPackageName = liftM (last . splitDirectories) . tryCanonicalizePath  -- |Data type of source files found in the working directory data SourceFileEntry = SourceFileEntry@@ -56,10 +59,11 @@     , moduleName         :: ModuleName     , fileExtension      :: String     , imports            :: [ModuleName]+    , extensions         :: [Extension]     } deriving Show  sfToFileName :: FilePath -> SourceFileEntry -> FilePath-sfToFileName projectRoot (SourceFileEntry relPath m ext _)+sfToFileName projectRoot (SourceFileEntry relPath m ext _ _)   = projectRoot </> relPath </> toFilePath m <.> ext  -- |Search for source files in the given directory@@ -77,7 +81,7 @@         let modules = catMaybes [ guessModuleName hierarchy file                                 | file <- files                                 , isUpper (head file) ]-        modules' <- mapM (findImports projectRoot) modules+        modules' <- mapM (findImportsAndExts projectRoot) modules         recMods <- mapM (scanRecursive dir hierarchy) dirs         return $ concat (modules' : recMods)     tagIsDir parent entry = do@@ -85,32 +89,34 @@         return $ (if isDir then Right else Left) entry     guessModuleName hierarchy entry         | takeBaseName entry == "Setup" = Nothing-        | ext `elem` sourceExtensions = Just $ SourceFileEntry relRoot modName ext []+        | ext `elem` sourceExtensions   =+            SourceFileEntry <$> pure relRoot <*> modName <*> pure ext <*> pure [] <*> pure []         | otherwise = Nothing       where-        relRoot = makeRelative projectRoot srcRoot+        relRoot       = makeRelative projectRoot srcRoot         unqualModName = dropExtension entry-        modName = fromString $ intercalate "." . reverse $ (unqualModName : hierarchy)-        ext = case takeExtension entry of '.':e -> e; e -> e+        modName       = simpleParse+                      $ intercalate "." . reverse $ (unqualModName : hierarchy)+        ext           = case takeExtension entry of '.':e -> e; e -> e     scanRecursive parent hierarchy entry       | isUpper (head entry) = scan (parent </> entry) (entry : hierarchy)       | isLower (head entry) && not (ignoreDir entry) =-          scanForModulesIn projectRoot $ foldl (</>) srcRoot (entry : hierarchy)+          scanForModulesIn projectRoot $ foldl (</>) srcRoot (reverse (entry : hierarchy))       | otherwise = return []     ignoreDir ('.':_)  = True     ignoreDir dir      = dir `elem` ["dist", "_darcs"] -findImports :: FilePath -> SourceFileEntry -> IO SourceFileEntry-findImports projectRoot sf = do+findImportsAndExts :: FilePath -> SourceFileEntry -> IO SourceFileEntry+findImportsAndExts projectRoot sf = do   s <- readFile (sfToFileName projectRoot sf) -  let modules = catMaybes-              . map ( getModName-                    . drop 1-                    . filter (not . null)-                    . dropWhile (/= "import")-                    . words-                    )+  let modules = mapMaybe+                ( getModName+                . drop 1+                . filter (not . null)+                . dropWhile (/= "import")+                . words+                )               . filter (not . ("--" `isPrefixOf`)) -- poor man's comment filtering               . lines               $ s@@ -120,8 +126,30 @@       -- Haskell parser since cabal's dependencies must be kept at a       -- minimum. -  return sf { imports = modules }+      -- A poor man's LANGUAGE pragma parser.+      exts = mapMaybe simpleParse+           . concatMap getPragmas+           . filter isLANGUAGEPragma+           . map fst+           . drop 1+           . takeWhile (not . null . snd)+           . iterate (takeBraces . snd)+           $ ("",s) +      takeBraces = break (== '}') . dropWhile (/= '{')++      isLANGUAGEPragma = ("{-# LANGUAGE " `isPrefixOf`)++      getPragmas = map trim . splitCommas . takeWhile (/= '#') . drop 13++      splitCommas "" = []+      splitCommas xs = x : splitCommas (drop 1 y)+        where (x,y) = break (==',') xs++  return sf { imports    = modules+            , extensions = exts+            }+  where getModName :: [String] -> Maybe ModuleName        getModName []               = Nothing        getModName ("qualified":ws) = getModName ws@@ -148,32 +176,111 @@ neededBuildPrograms entries =     [ handler     | ext <- nubSet (map fileExtension entries)-    , handler <- maybe [] (:[]) (lookup ext knownSuffixHandlers)+    , handler <- maybeToList (lookup ext knownSuffixHandlers)     ] --- |Guess author and email+-- | Guess author and email using darcs and git configuration options. Use+-- the following in decreasing order of preference:+--+-- 1. vcs env vars ($DARCS_EMAIL, $GIT_AUTHOR_*)+-- 2. Local repo configs+-- 3. Global vcs configs+-- 4. The generic $EMAIL+--+-- Name and email are processed separately, so the guess might end up being+-- a name from DARCS_EMAIL and an email from git config.+--+-- Darcs has preference, for tradition's sake. guessAuthorNameMail :: IO (Flag String, Flag String)-guessAuthorNameMail =-  update (readFromFile authorRepoFile) mempty >>=-  update (getAuthorHome >>= readFromFile) >>=-  update readFromEnvironment+guessAuthorNameMail = fmap authorGuessPure authorGuessIO++-- Ordered in increasing preference, since Flag-as-monoid is identical to+-- Last.+authorGuessPure :: AuthorGuessIO -> AuthorGuess+authorGuessPure (AuthorGuessIO env darcsLocalF darcsGlobalF gitLocal gitGlobal)+    = mconcat+        [ emailEnv env+        , gitGlobal+        , darcsCfg darcsGlobalF+        , gitLocal+        , darcsCfg darcsLocalF+        , gitEnv env+        , darcsEnv env+        ]++authorGuessIO :: IO AuthorGuessIO+authorGuessIO = AuthorGuessIO+    <$> getEnvironment+    <*> (maybeReadFile $ "_darcs" </> "prefs" </> "author")+    <*> (maybeReadFile =<< liftM (</> (".darcs" </> "author")) getHomeDirectory)+    <*> gitCfg Local+    <*> gitCfg Global++-- Types and functions used for guessing the author are now defined:++type AuthorGuess   = (Flag String, Flag String)+type Enviro        = [(String, String)]+data GitLoc        = Local | Global+data AuthorGuessIO = AuthorGuessIO+    Enviro         -- ^ Environment lookup table+    (Maybe String) -- ^ Contents of local darcs author info+    (Maybe String) -- ^ Contents of global darcs author info+    AuthorGuess    -- ^ Git config --local+    AuthorGuess    -- ^ Git config --global++darcsEnv :: Enviro -> AuthorGuess+darcsEnv = maybe mempty nameAndMail . lookup "DARCS_EMAIL"++gitEnv :: Enviro -> AuthorGuess+gitEnv env = (name, email)   where-    update _ info@(Flag _, Flag _) = return info-    update extract info = liftM (`mappend` info) extract -- prefer info-    readFromFile file = do-      exists <- doesFileExist file-      if exists then liftM nameAndMail (readFile file) else return mempty-    readFromEnvironment = fmap extractFromEnvironment getEnvironment-    extractFromEnvironment env =-        let darcsEmailEnv = maybe mempty nameAndMail (lookup "DARCS_EMAIL" env)-            emailEnv      = maybe mempty (\e -> (mempty, Flag e)) (lookup "EMAIL" env)-        in darcsEmailEnv `mappend` emailEnv-    getAuthorHome   = liftM (</> (".darcs" </> "author")) getHomeDirectory-    authorRepoFile  = "_darcs" </> "prefs" </> "author"+    name  = maybeFlag "GIT_AUTHOR_NAME" env+    email = maybeFlag "GIT_AUTHOR_EMAIL" env +darcsCfg :: Maybe String -> AuthorGuess+darcsCfg = maybe mempty nameAndMail++emailEnv :: Enviro -> AuthorGuess+emailEnv env = (mempty, email)+  where+    email = maybeFlag "EMAIL" env++gitCfg :: GitLoc -> IO AuthorGuess+gitCfg which = do+  name <- gitVar which "user.name"+  mail <- gitVar which "user.email"+  return (name, mail)++gitVar :: GitLoc -> String -> IO (Flag String)+gitVar which = fmap happyOutput . gitConfigQuery which++happyOutput :: (ExitCode, a, t) -> Flag a+happyOutput v = case v of+  (ExitSuccess, s, _) -> Flag s+  _                   -> mempty++gitConfigQuery :: GitLoc -> String -> IO (ExitCode, String, String)+gitConfigQuery which key =+    fmap trim' $ readProcessWithExitCode "git" ["config", w, key] ""+  where+    w = case which of+        Local  -> "--local"+        Global -> "--global"+    trim' (a, b, c) = (a, trim b, c)++maybeFlag :: String -> Enviro -> Flag String+maybeFlag k = maybe mempty Flag . lookup k++maybeReadFile :: String -> IO (Maybe String)+maybeReadFile f = do+    exists <- doesFileExist f+    if exists+        then fmap Just $ readFile f+        else return Nothing+ -- |Get list of categories used in hackage. NOTE: Very slow, needs to be cached knownCategories :: SourcePackageDb -> [String]-knownCategories (SourcePackageDb sourcePkgIndex _) = nubSet $+knownCategories (SourcePackageDb sourcePkgIndex _) = nubSet     [ cat | pkg <- map head (allPackagesByName sourcePkgIndex)           , let catList = (PD.category . PD.packageDescription . packageDescription) pkg           , cat <- splitString ',' catList@@ -188,7 +295,10 @@   where     (nameOrEmail,erest) = break (== '<') str     (email,_)           = break (== '>') (tail erest)-    trim                = removeLeadingSpace . reverse . removeLeadingSpace . reverse++trim :: String -> String+trim = removeLeadingSpace . reverse . removeLeadingSpace . reverse+  where     removeLeadingSpace  = dropWhile isSpace  -- split string at given character, and remove whitespaces@@ -218,12 +328,3 @@   putStrLn "List of known categories"   print $ knownCategories db -}--#if MIN_VERSION_base(3,0,3)-#else-partitionEithers :: [Either a b] -> ([a],[b])-partitionEithers = foldr (either left right) ([],[])- where-   left  a (l, r) = (a:l, r)-   right a (l, r) = (l, a:r)-#endif
Distribution/Client/Init/Licenses.hs view
@@ -5,6 +5,7 @@   , gplv3   , lgpl2   , lgpl3+  , agplv3   , apache20    ) where@@ -1065,6 +1066,671 @@     , "Public License instead of this License.  But first, please read"     , "<http://www.gnu.org/philosophy/why-not-lgpl.html>."     , ""+    ]++agplv3 :: License+agplv3 = unlines+    [ "                    GNU AFFERO GENERAL PUBLIC LICENSE"+    , "                       Version 3, 19 November 2007"+    , ""+    , " Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>"+    , " Everyone is permitted to copy and distribute verbatim copies"+    , " of this license document, but changing it is not allowed."+    , ""+    , "                            Preamble"+    , ""+    , "  The GNU Affero General Public License is a free, copyleft license for"+    , "software and other kinds of works, specifically designed to ensure"+    , "cooperation with the community in the case of network server software."+    , ""+    , "  The licenses for most software and other practical works are designed"+    , "to take away your freedom to share and change the works.  By contrast,"+    , "our General Public Licenses are intended to guarantee your freedom to"+    , "share and change all versions of a program--to make sure it remains free"+    , "software for all its users."+    , ""+    , "  When we speak of free software, we are referring to freedom, not"+    , "price.  Our General Public Licenses are designed to make sure that you"+    , "have the freedom to distribute copies of free software (and charge for"+    , "them if you wish), that you receive source code or can get it if you"+    , "want it, that you can change the software or use pieces of it in new"+    , "free programs, and that you know you can do these things."+    , ""+    , "  Developers that use our General Public Licenses protect your rights"+    , "with two steps: (1) assert copyright on the software, and (2) offer"+    , "you this License which gives you legal permission to copy, distribute"+    , "and/or modify the software."+    , ""+    , "  A secondary benefit of defending all users' freedom is that"+    , "improvements made in alternate versions of the program, if they"+    , "receive widespread use, become available for other developers to"+    , "incorporate.  Many developers of free software are heartened and"+    , "encouraged by the resulting cooperation.  However, in the case of"+    , "software used on network servers, this result may fail to come about."+    , "The GNU General Public License permits making a modified version and"+    , "letting the public access it on a server without ever releasing its"+    , "source code to the public."+    , ""+    , "  The GNU Affero General Public License is designed specifically to"+    , "ensure that, in such cases, the modified source code becomes available"+    , "to the community.  It requires the operator of a network server to"+    , "provide the source code of the modified version running there to the"+    , "users of that server.  Therefore, public use of a modified version, on"+    , "a publicly accessible server, gives the public access to the source"+    , "code of the modified version."+    , ""+    , "  An older license, called the Affero General Public License and"+    , "published by Affero, was designed to accomplish similar goals.  This is"+    , "a different license, not a version of the Affero GPL, but Affero has"+    , "released a new version of the Affero GPL which permits relicensing under"+    , "this license."+    , ""+    , "  The precise terms and conditions for copying, distribution and"+    , "modification follow."+    , ""+    , "                       TERMS AND CONDITIONS"+    , ""+    , "  0. Definitions."+    , ""+    , "  \"This License\" refers to version 3 of the GNU Affero General Public License."+    , ""+    , "  \"Copyright\" also means copyright-like laws that apply to other kinds of"+    , "works, such as semiconductor masks."+    , ""+    , "  \"The Program\" refers to any copyrightable work licensed under this"+    , "License.  Each licensee is addressed as \"you\".  \"Licensees\" and"+    , "\"recipients\" may be individuals or organizations."+    , ""+    , "  To \"modify\" a work means to copy from or adapt all or part of the work"+    , "in a fashion requiring copyright permission, other than the making of an"+    , "exact copy.  The resulting work is called a \"modified version\" of the"+    , "earlier work or a work \"based on\" the earlier work."+    , ""+    , "  A \"covered work\" means either the unmodified Program or a work based"+    , "on the Program."+    , ""+    , "  To \"propagate\" a work means to do anything with it that, without"+    , "permission, would make you directly or secondarily liable for"+    , "infringement under applicable copyright law, except executing it on a"+    , "computer or modifying a private copy.  Propagation includes copying,"+    , "distribution (with or without modification), making available to the"+    , "public, and in some countries other activities as well."+    , ""+    , "  To \"convey\" a work means any kind of propagation that enables other"+    , "parties to make or receive copies.  Mere interaction with a user through"+    , "a computer network, with no transfer of a copy, is not conveying."+    , ""+    , "  An interactive user interface displays \"Appropriate Legal Notices\""+    , "to the extent that it includes a convenient and prominently visible"+    , "feature that (1) displays an appropriate copyright notice, and (2)"+    , "tells the user that there is no warranty for the work (except to the"+    , "extent that warranties are provided), that licensees may convey the"+    , "work under this License, and how to view a copy of this License.  If"+    , "the interface presents a list of user commands or options, such as a"+    , "menu, a prominent item in the list meets this criterion."+    , ""+    , "  1. Source Code."+    , ""+    , "  The \"source code\" for a work means the preferred form of the work"+    , "for making modifications to it.  \"Object code\" means any non-source"+    , "form of a work."+    , ""+    , "  A \"Standard Interface\" means an interface that either is an official"+    , "standard defined by a recognized standards body, or, in the case of"+    , "interfaces specified for a particular programming language, one that"+    , "is widely used among developers working in that language."+    , ""+    , "  The \"System Libraries\" of an executable work include anything, other"+    , "than the work as a whole, that (a) is included in the normal form of"+    , "packaging a Major Component, but which is not part of that Major"+    , "Component, and (b) serves only to enable use of the work with that"+    , "Major Component, or to implement a Standard Interface for which an"+    , "implementation is available to the public in source code form.  A"+    , "\"Major Component\", in this context, means a major essential component"+    , "(kernel, window system, and so on) of the specific operating system"+    , "(if any) on which the executable work runs, or a compiler used to"+    , "produce the work, or an object code interpreter used to run it."+    , ""+    , "  The \"Corresponding Source\" for a work in object code form means all"+    , "the source code needed to generate, install, and (for an executable"+    , "work) run the object code and to modify the work, including scripts to"+    , "control those activities.  However, it does not include the work's"+    , "System Libraries, or general-purpose tools or generally available free"+    , "programs which are used unmodified in performing those activities but"+    , "which are not part of the work.  For example, Corresponding Source"+    , "includes interface definition files associated with source files for"+    , "the work, and the source code for shared libraries and dynamically"+    , "linked subprograms that the work is specifically designed to require,"+    , "such as by intimate data communication or control flow between those"+    , "subprograms and other parts of the work."+    , ""+    , "  The Corresponding Source need not include anything that users"+    , "can regenerate automatically from other parts of the Corresponding"+    , "Source."+    , ""+    , "  The Corresponding Source for a work in source code form is that"+    , "same work."+    , ""+    , "  2. Basic Permissions."+    , ""+    , "  All rights granted under this License are granted for the term of"+    , "copyright on the Program, and are irrevocable provided the stated"+    , "conditions are met.  This License explicitly affirms your unlimited"+    , "permission to run the unmodified Program.  The output from running a"+    , "covered work is covered by this License only if the output, given its"+    , "content, constitutes a covered work.  This License acknowledges your"+    , "rights of fair use or other equivalent, as provided by copyright law."+    , ""+    , "  You may make, run and propagate covered works that you do not"+    , "convey, without conditions so long as your license otherwise remains"+    , "in force.  You may convey covered works to others for the sole purpose"+    , "of having them make modifications exclusively for you, or provide you"+    , "with facilities for running those works, provided that you comply with"+    , "the terms of this License in conveying all material for which you do"+    , "not control copyright.  Those thus making or running the covered works"+    , "for you must do so exclusively on your behalf, under your direction"+    , "and control, on terms that prohibit them from making any copies of"+    , "your copyrighted material outside their relationship with you."+    , ""+    , "  Conveying under any other circumstances is permitted solely under"+    , "the conditions stated below.  Sublicensing is not allowed; section 10"+    , "makes it unnecessary."+    , ""+    , "  3. Protecting Users' Legal Rights From Anti-Circumvention Law."+    , ""+    , "  No covered work shall be deemed part of an effective technological"+    , "measure under any applicable law fulfilling obligations under article"+    , "11 of the WIPO copyright treaty adopted on 20 December 1996, or"+    , "similar laws prohibiting or restricting circumvention of such"+    , "measures."+    , ""+    , "  When you convey a covered work, you waive any legal power to forbid"+    , "circumvention of technological measures to the extent such circumvention"+    , "is effected by exercising rights under this License with respect to"+    , "the covered work, and you disclaim any intention to limit operation or"+    , "modification of the work as a means of enforcing, against the work's"+    , "users, your or third parties' legal rights to forbid circumvention of"+    , "technological measures."+    , ""+    , "  4. Conveying Verbatim Copies."+    , ""+    , "  You may convey verbatim copies of the Program's source code as you"+    , "receive it, in any medium, provided that you conspicuously and"+    , "appropriately publish on each copy an appropriate copyright notice;"+    , "keep intact all notices stating that this License and any"+    , "non-permissive terms added in accord with section 7 apply to the code;"+    , "keep intact all notices of the absence of any warranty; and give all"+    , "recipients a copy of this License along with the Program."+    , ""+    , "  You may charge any price or no price for each copy that you convey,"+    , "and you may offer support or warranty protection for a fee."+    , ""+    , "  5. Conveying Modified Source Versions."+    , ""+    , "  You may convey a work based on the Program, or the modifications to"+    , "produce it from the Program, in the form of source code under the"+    , "terms of section 4, provided that you also meet all of these conditions:"+    , ""+    , "    a) The work must carry prominent notices stating that you modified"+    , "    it, and giving a relevant date."+    , ""+    , "    b) The work must carry prominent notices stating that it is"+    , "    released under this License and any conditions added under section"+    , "    7.  This requirement modifies the requirement in section 4 to"+    , "    \"keep intact all notices\"."+    , ""+    , "    c) You must license the entire work, as a whole, under this"+    , "    License to anyone who comes into possession of a copy.  This"+    , "    License will therefore apply, along with any applicable section 7"+    , "    additional terms, to the whole of the work, and all its parts,"+    , "    regardless of how they are packaged.  This License gives no"+    , "    permission to license the work in any other way, but it does not"+    , "    invalidate such permission if you have separately received it."+    , ""+    , "    d) If the work has interactive user interfaces, each must display"+    , "    Appropriate Legal Notices; however, if the Program has interactive"+    , "    interfaces that do not display Appropriate Legal Notices, your"+    , "    work need not make them do so."+    , ""+    , "  A compilation of a covered work with other separate and independent"+    , "works, which are not by their nature extensions of the covered work,"+    , "and which are not combined with it such as to form a larger program,"+    , "in or on a volume of a storage or distribution medium, is called an"+    , "\"aggregate\" if the compilation and its resulting copyright are not"+    , "used to limit the access or legal rights of the compilation's users"+    , "beyond what the individual works permit.  Inclusion of a covered work"+    , "in an aggregate does not cause this License to apply to the other"+    , "parts of the aggregate."+    , ""+    , "  6. Conveying Non-Source Forms."+    , ""+    , "  You may convey a covered work in object code form under the terms"+    , "of sections 4 and 5, provided that you also convey the"+    , "machine-readable Corresponding Source under the terms of this License,"+    , "in one of these ways:"+    , ""+    , "    a) Convey the object code in, or embodied in, a physical product"+    , "    (including a physical distribution medium), accompanied by the"+    , "    Corresponding Source fixed on a durable physical medium"+    , "    customarily used for software interchange."+    , ""+    , "    b) Convey the object code in, or embodied in, a physical product"+    , "    (including a physical distribution medium), accompanied by a"+    , "    written offer, valid for at least three years and valid for as"+    , "    long as you offer spare parts or customer support for that product"+    , "    model, to give anyone who possesses the object code either (1) a"+    , "    copy of the Corresponding Source for all the software in the"+    , "    product that is covered by this License, on a durable physical"+    , "    medium customarily used for software interchange, for a price no"+    , "    more than your reasonable cost of physically performing this"+    , "    conveying of source, or (2) access to copy the"+    , "    Corresponding Source from a network server at no charge."+    , ""+    , "    c) Convey individual copies of the object code with a copy of the"+    , "    written offer to provide the Corresponding Source.  This"+    , "    alternative is allowed only occasionally and noncommercially, and"+    , "    only if you received the object code with such an offer, in accord"+    , "    with subsection 6b."+    , ""+    , "    d) Convey the object code by offering access from a designated"+    , "    place (gratis or for a charge), and offer equivalent access to the"+    , "    Corresponding Source in the same way through the same place at no"+    , "    further charge.  You need not require recipients to copy the"+    , "    Corresponding Source along with the object code.  If the place to"+    , "    copy the object code is a network server, the Corresponding Source"+    , "    may be on a different server (operated by you or a third party)"+    , "    that supports equivalent copying facilities, provided you maintain"+    , "    clear directions next to the object code saying where to find the"+    , "    Corresponding Source.  Regardless of what server hosts the"+    , "    Corresponding Source, you remain obligated to ensure that it is"+    , "    available for as long as needed to satisfy these requirements."+    , ""+    , "    e) Convey the object code using peer-to-peer transmission, provided"+    , "    you inform other peers where the object code and Corresponding"+    , "    Source of the work are being offered to the general public at no"+    , "    charge under subsection 6d."+    , ""+    , "  A separable portion of the object code, whose source code is excluded"+    , "from the Corresponding Source as a System Library, need not be"+    , "included in conveying the object code work."+    , ""+    , "  A \"User Product\" is either (1) a \"consumer product\", which means any"+    , "tangible personal property which is normally used for personal, family,"+    , "or household purposes, or (2) anything designed or sold for incorporation"+    , "into a dwelling.  In determining whether a product is a consumer product,"+    , "doubtful cases shall be resolved in favor of coverage.  For a particular"+    , "product received by a particular user, \"normally used\" refers to a"+    , "typical or common use of that class of product, regardless of the status"+    , "of the particular user or of the way in which the particular user"+    , "actually uses, or expects or is expected to use, the product.  A product"+    , "is a consumer product regardless of whether the product has substantial"+    , "commercial, industrial or non-consumer uses, unless such uses represent"+    , "the only significant mode of use of the product."+    , ""+    , "  \"Installation Information\" for a User Product means any methods,"+    , "procedures, authorization keys, or other information required to install"+    , "and execute modified versions of a covered work in that User Product from"+    , "a modified version of its Corresponding Source.  The information must"+    , "suffice to ensure that the continued functioning of the modified object"+    , "code is in no case prevented or interfered with solely because"+    , "modification has been made."+    , ""+    , "  If you convey an object code work under this section in, or with, or"+    , "specifically for use in, a User Product, and the conveying occurs as"+    , "part of a transaction in which the right of possession and use of the"+    , "User Product is transferred to the recipient in perpetuity or for a"+    , "fixed term (regardless of how the transaction is characterized), the"+    , "Corresponding Source conveyed under this section must be accompanied"+    , "by the Installation Information.  But this requirement does not apply"+    , "if neither you nor any third party retains the ability to install"+    , "modified object code on the User Product (for example, the work has"+    , "been installed in ROM)."+    , ""+    , "  The requirement to provide Installation Information does not include a"+    , "requirement to continue to provide support service, warranty, or updates"+    , "for a work that has been modified or installed by the recipient, or for"+    , "the User Product in which it has been modified or installed.  Access to a"+    , "network may be denied when the modification itself materially and"+    , "adversely affects the operation of the network or violates the rules and"+    , "protocols for communication across the network."+    , ""+    , "  Corresponding Source conveyed, and Installation Information provided,"+    , "in accord with this section must be in a format that is publicly"+    , "documented (and with an implementation available to the public in"+    , "source code form), and must require no special password or key for"+    , "unpacking, reading or copying."+    , ""+    , "  7. Additional Terms."+    , ""+    , "  \"Additional permissions\" are terms that supplement the terms of this"+    , "License by making exceptions from one or more of its conditions."+    , "Additional permissions that are applicable to the entire Program shall"+    , "be treated as though they were included in this License, to the extent"+    , "that they are valid under applicable law.  If additional permissions"+    , "apply only to part of the Program, that part may be used separately"+    , "under those permissions, but the entire Program remains governed by"+    , "this License without regard to the additional permissions."+    , ""+    , "  When you convey a copy of a covered work, you may at your option"+    , "remove any additional permissions from that copy, or from any part of"+    , "it.  (Additional permissions may be written to require their own"+    , "removal in certain cases when you modify the work.)  You may place"+    , "additional permissions on material, added by you to a covered work,"+    , "for which you have or can give appropriate copyright permission."+    , ""+    , "  Notwithstanding any other provision of this License, for material you"+    , "add to a covered work, you may (if authorized by the copyright holders of"+    , "that material) supplement the terms of this License with terms:"+    , ""+    , "    a) Disclaiming warranty or limiting liability differently from the"+    , "    terms of sections 15 and 16 of this License; or"+    , ""+    , "    b) Requiring preservation of specified reasonable legal notices or"+    , "    author attributions in that material or in the Appropriate Legal"+    , "    Notices displayed by works containing it; or"+    , ""+    , "    c) Prohibiting misrepresentation of the origin of that material, or"+    , "    requiring that modified versions of such material be marked in"+    , "    reasonable ways as different from the original version; or"+    , ""+    , "    d) Limiting the use for publicity purposes of names of licensors or"+    , "    authors of the material; or"+    , ""+    , "    e) Declining to grant rights under trademark law for use of some"+    , "    trade names, trademarks, or service marks; or"+    , ""+    , "    f) Requiring indemnification of licensors and authors of that"+    , "    material by anyone who conveys the material (or modified versions of"+    , "    it) with contractual assumptions of liability to the recipient, for"+    , "    any liability that these contractual assumptions directly impose on"+    , "    those licensors and authors."+    , ""+    , "  All other non-permissive additional terms are considered \"further"+    , "restrictions\" within the meaning of section 10.  If the Program as you"+    , "received it, or any part of it, contains a notice stating that it is"+    , "governed by this License along with a term that is a further"+    , "restriction, you may remove that term.  If a license document contains"+    , "a further restriction but permits relicensing or conveying under this"+    , "License, you may add to a covered work material governed by the terms"+    , "of that license document, provided that the further restriction does"+    , "not survive such relicensing or conveying."+    , ""+    , "  If you add terms to a covered work in accord with this section, you"+    , "must place, in the relevant source files, a statement of the"+    , "additional terms that apply to those files, or a notice indicating"+    , "where to find the applicable terms."+    , ""+    , "  Additional terms, permissive or non-permissive, may be stated in the"+    , "form of a separately written license, or stated as exceptions;"+    , "the above requirements apply either way."+    , ""+    , "  8. Termination."+    , ""+    , "  You may not propagate or modify a covered work except as expressly"+    , "provided under this License.  Any attempt otherwise to propagate or"+    , "modify it is void, and will automatically terminate your rights under"+    , "this License (including any patent licenses granted under the third"+    , "paragraph of section 11)."+    , ""+    , "  However, if you cease all violation of this License, then your"+    , "license from a particular copyright holder is reinstated (a)"+    , "provisionally, unless and until the copyright holder explicitly and"+    , "finally terminates your license, and (b) permanently, if the copyright"+    , "holder fails to notify you of the violation by some reasonable means"+    , "prior to 60 days after the cessation."+    , ""+    , "  Moreover, your license from a particular copyright holder is"+    , "reinstated permanently if the copyright holder notifies you of the"+    , "violation by some reasonable means, this is the first time you have"+    , "received notice of violation of this License (for any work) from that"+    , "copyright holder, and you cure the violation prior to 30 days after"+    , "your receipt of the notice."+    , ""+    , "  Termination of your rights under this section does not terminate the"+    , "licenses of parties who have received copies or rights from you under"+    , "this License.  If your rights have been terminated and not permanently"+    , "reinstated, you do not qualify to receive new licenses for the same"+    , "material under section 10."+    , ""+    , "  9. Acceptance Not Required for Having Copies."+    , ""+    , "  You are not required to accept this License in order to receive or"+    , "run a copy of the Program.  Ancillary propagation of a covered work"+    , "occurring solely as a consequence of using peer-to-peer transmission"+    , "to receive a copy likewise does not require acceptance.  However,"+    , "nothing other than this License grants you permission to propagate or"+    , "modify any covered work.  These actions infringe copyright if you do"+    , "not accept this License.  Therefore, by modifying or propagating a"+    , "covered work, you indicate your acceptance of this License to do so."+    , ""+    , "  10. Automatic Licensing of Downstream Recipients."+    , ""+    , "  Each time you convey a covered work, the recipient automatically"+    , "receives a license from the original licensors, to run, modify and"+    , "propagate that work, subject to this License.  You are not responsible"+    , "for enforcing compliance by third parties with this License."+    , ""+    , "  An \"entity transaction\" is a transaction transferring control of an"+    , "organization, or substantially all assets of one, or subdividing an"+    , "organization, or merging organizations.  If propagation of a covered"+    , "work results from an entity transaction, each party to that"+    , "transaction who receives a copy of the work also receives whatever"+    , "licenses to the work the party's predecessor in interest had or could"+    , "give under the previous paragraph, plus a right to possession of the"+    , "Corresponding Source of the work from the predecessor in interest, if"+    , "the predecessor has it or can get it with reasonable efforts."+    , ""+    , "  You may not impose any further restrictions on the exercise of the"+    , "rights granted or affirmed under this License.  For example, you may"+    , "not impose a license fee, royalty, or other charge for exercise of"+    , "rights granted under this License, and you may not initiate litigation"+    , "(including a cross-claim or counterclaim in a lawsuit) alleging that"+    , "any patent claim is infringed by making, using, selling, offering for"+    , "sale, or importing the Program or any portion of it."+    , ""+    , "  11. Patents."+    , ""+    , "  A \"contributor\" is a copyright holder who authorizes use under this"+    , "License of the Program or a work on which the Program is based.  The"+    , "work thus licensed is called the contributor's \"contributor version\"."+    , ""+    , "  A contributor's \"essential patent claims\" are all patent claims"+    , "owned or controlled by the contributor, whether already acquired or"+    , "hereafter acquired, that would be infringed by some manner, permitted"+    , "by this License, of making, using, or selling its contributor version,"+    , "but do not include claims that would be infringed only as a"+    , "consequence of further modification of the contributor version.  For"+    , "purposes of this definition, \"control\" includes the right to grant"+    , "patent sublicenses in a manner consistent with the requirements of"+    , "this License."+    , ""+    , "  Each contributor grants you a non-exclusive, worldwide, royalty-free"+    , "patent license under the contributor's essential patent claims, to"+    , "make, use, sell, offer for sale, import and otherwise run, modify and"+    , "propagate the contents of its contributor version."+    , ""+    , "  In the following three paragraphs, a \"patent license\" is any express"+    , "agreement or commitment, however denominated, not to enforce a patent"+    , "(such as an express permission to practice a patent or covenant not to"+    , "sue for patent infringement).  To \"grant\" such a patent license to a"+    , "party means to make such an agreement or commitment not to enforce a"+    , "patent against the party."+    , ""+    , "  If you convey a covered work, knowingly relying on a patent license,"+    , "and the Corresponding Source of the work is not available for anyone"+    , "to copy, free of charge and under the terms of this License, through a"+    , "publicly available network server or other readily accessible means,"+    , "then you must either (1) cause the Corresponding Source to be so"+    , "available, or (2) arrange to deprive yourself of the benefit of the"+    , "patent license for this particular work, or (3) arrange, in a manner"+    , "consistent with the requirements of this License, to extend the patent"+    , "license to downstream recipients.  \"Knowingly relying\" means you have"+    , "actual knowledge that, but for the patent license, your conveying the"+    , "covered work in a country, or your recipient's use of the covered work"+    , "in a country, would infringe one or more identifiable patents in that"+    , "country that you have reason to believe are valid."+    , ""+    , "  If, pursuant to or in connection with a single transaction or"+    , "arrangement, you convey, or propagate by procuring conveyance of, a"+    , "covered work, and grant a patent license to some of the parties"+    , "receiving the covered work authorizing them to use, propagate, modify"+    , "or convey a specific copy of the covered work, then the patent license"+    , "you grant is automatically extended to all recipients of the covered"+    , "work and works based on it."+    , ""+    , "  A patent license is \"discriminatory\" if it does not include within"+    , "the scope of its coverage, prohibits the exercise of, or is"+    , "conditioned on the non-exercise of one or more of the rights that are"+    , "specifically granted under this License.  You may not convey a covered"+    , "work if you are a party to an arrangement with a third party that is"+    , "in the business of distributing software, under which you make payment"+    , "to the third party based on the extent of your activity of conveying"+    , "the work, and under which the third party grants, to any of the"+    , "parties who would receive the covered work from you, a discriminatory"+    , "patent license (a) in connection with copies of the covered work"+    , "conveyed by you (or copies made from those copies), or (b) primarily"+    , "for and in connection with specific products or compilations that"+    , "contain the covered work, unless you entered into that arrangement,"+    , "or that patent license was granted, prior to 28 March 2007."+    , ""+    , "  Nothing in this License shall be construed as excluding or limiting"+    , "any implied license or other defenses to infringement that may"+    , "otherwise be available to you under applicable patent law."+    , ""+    , "  12. No Surrender of Others' Freedom."+    , ""+    , "  If conditions are imposed on you (whether by court order, agreement or"+    , "otherwise) that contradict the conditions of this License, they do not"+    , "excuse you from the conditions of this License.  If you cannot convey a"+    , "covered work so as to satisfy simultaneously your obligations under this"+    , "License and any other pertinent obligations, then as a consequence you may"+    , "not convey it at all.  For example, if you agree to terms that obligate you"+    , "to collect a royalty for further conveying from those to whom you convey"+    , "the Program, the only way you could satisfy both those terms and this"+    , "License would be to refrain entirely from conveying the Program."+    , ""+    , "  13. Remote Network Interaction; Use with the GNU General Public License."+    , ""+    , "  Notwithstanding any other provision of this License, if you modify the"+    , "Program, your modified version must prominently offer all users"+    , "interacting with it remotely through a computer network (if your version"+    , "supports such interaction) an opportunity to receive the Corresponding"+    , "Source of your version by providing access to the Corresponding Source"+    , "from a network server at no charge, through some standard or customary"+    , "means of facilitating copying of software.  This Corresponding Source"+    , "shall include the Corresponding Source for any work covered by version 3"+    , "of the GNU General Public License that is incorporated pursuant to the"+    , "following paragraph."+    , ""+    , "  Notwithstanding any other provision of this License, you have"+    , "permission to link or combine any covered work with a work licensed"+    , "under version 3 of the GNU General Public License into a single"+    , "combined work, and to convey the resulting work.  The terms of this"+    , "License will continue to apply to the part which is the covered work,"+    , "but the work with which it is combined will remain governed by version"+    , "3 of the GNU General Public License."+    , ""+    , "  14. Revised Versions of this License."+    , ""+    , "  The Free Software Foundation may publish revised and/or new versions of"+    , "the GNU Affero General Public License from time to time.  Such new versions"+    , "will be similar in spirit to the present version, but may differ in detail to"+    , "address new problems or concerns."+    , ""+    , "  Each version is given a distinguishing version number.  If the"+    , "Program specifies that a certain numbered version of the GNU Affero General"+    , "Public License \"or any later version\" applies to it, you have the"+    , "option of following the terms and conditions either of that numbered"+    , "version or of any later version published by the Free Software"+    , "Foundation.  If the Program does not specify a version number of the"+    , "GNU Affero General Public License, you may choose any version ever published"+    , "by the Free Software Foundation."+    , ""+    , "  If the Program specifies that a proxy can decide which future"+    , "versions of the GNU Affero General Public License can be used, that proxy's"+    , "public statement of acceptance of a version permanently authorizes you"+    , "to choose that version for the Program."+    , ""+    , "  Later license versions may give you additional or different"+    , "permissions.  However, no additional obligations are imposed on any"+    , "author or copyright holder as a result of your choosing to follow a"+    , "later version."+    , ""+    , "  15. Disclaimer of Warranty."+    , ""+    , "  THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY"+    , "APPLICABLE LAW.  EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT"+    , "HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM \"AS IS\" WITHOUT WARRANTY"+    , "OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,"+    , "THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR"+    , "PURPOSE.  THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM"+    , "IS WITH YOU.  SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF"+    , "ALL NECESSARY SERVICING, REPAIR OR CORRECTION."+    , ""+    , "  16. Limitation of Liability."+    , ""+    , "  IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING"+    , "WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS"+    , "THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY"+    , "GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE"+    , "USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF"+    , "DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD"+    , "PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),"+    , "EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF"+    , "SUCH DAMAGES."+    , ""+    , "  17. Interpretation of Sections 15 and 16."+    , ""+    , "  If the disclaimer of warranty and limitation of liability provided"+    , "above cannot be given local legal effect according to their terms,"+    , "reviewing courts shall apply local law that most closely approximates"+    , "an absolute waiver of all civil liability in connection with the"+    , "Program, unless a warranty or assumption of liability accompanies a"+    , "copy of the Program in return for a fee."+    , ""+    , "                     END OF TERMS AND CONDITIONS"+    , ""+    , "            How to Apply These Terms to Your New Programs"+    , ""+    , "  If you develop a new program, and you want it to be of the greatest"+    , "possible use to the public, the best way to achieve this is to make it"+    , "free software which everyone can redistribute and change under these terms."+    , ""+    , "  To do so, attach the following notices to the program.  It is safest"+    , "to attach them to the start of each source file to most effectively"+    , "state the exclusion of warranty; and each file should have at least"+    , "the \"copyright\" line and a pointer to where the full notice is found."+    , ""+    , "    <one line to give the program's name and a brief idea of what it does.>"+    , "    Copyright (C) <year>  <name of author>"+    , ""+    , "    This program is free software: you can redistribute it and/or modify"+    , "    it under the terms of the GNU Affero General Public License as published by"+    , "    the Free Software Foundation, either version 3 of the License, or"+    , "    (at your option) any later version."+    , ""+    , "    This program is distributed in the hope that it will be useful,"+    , "    but WITHOUT ANY WARRANTY; without even the implied warranty of"+    , "    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the"+    , "    GNU Affero General Public License for more details."+    , ""+    , "    You should have received a copy of the GNU Affero General Public License"+    , "    along with this program.  If not, see <http://www.gnu.org/licenses/>."+    , ""+    , "Also add information on how to contact you by electronic and paper mail."+    , ""+    , "  If your software can interact with users remotely through a computer"+    , "network, you should also make sure that it provides a way for users to"+    , "get its source.  For example, if your program is a web application, its"+    , "interface could display a \"Source\" link that leads users to an archive"+    , "of the code.  There are many ways you could offer source, and different"+    , "solutions will be better for different programs; see section 13 for the"+    , "specific requirements."+    , ""+    , "  You should also get your employer (if you work as a programmer) or school,"+    , "if any, to sign a \"copyright disclaimer\" for the program, if necessary."+    , "For more information on this, and how to apply and follow the GNU AGPL, see"+    , "<http://www.gnu.org/licenses/>."     ]  lgpl2 :: License
Distribution/Client/Init/Types.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.Init.Types@@ -22,6 +21,7 @@ import qualified Distribution.Package as P import Distribution.License import Distribution.ModuleName+import Language.Haskell.Extension ( Language(..), Extension )  import qualified Text.PrettyPrint as Disp import qualified Distribution.Compat.ReadP as Parse@@ -51,20 +51,28 @@                , synopsis     :: Flag String               , category     :: Flag (Either String Category)+              , extraSrc     :: Maybe [String]                , packageType  :: Flag PackageType+              , language     :: Flag Language                , exposedModules :: Maybe [ModuleName]               , otherModules   :: Maybe [ModuleName]+              , otherExts      :: Maybe [Extension]                , dependencies :: Maybe [P.Dependency]               , sourceDirs   :: Maybe [String]               , buildTools   :: Maybe [String]                , initVerbosity :: Flag Verbosity+              , overwrite     :: Flag Bool               }   deriving (Show) +  -- the Monoid instance for Flag has later values override earlier+  -- ones, which is why we want Maybe [foo] for collecting foo values,+  -- not Flag [foo].+ data PackageType = Library | Executable   deriving (Show, Read, Eq) @@ -88,13 +96,17 @@     , homepage       = mempty     , synopsis       = mempty     , category       = mempty+    , extraSrc       = mempty     , packageType    = mempty+    , language       = mempty     , exposedModules = mempty     , otherModules   = mempty+    , otherExts      = mempty     , dependencies   = mempty     , sourceDirs     = mempty     , buildTools     = mempty     , initVerbosity  = mempty+    , overwrite      = mempty     }   mappend  a b = InitFlags     { nonInteractive = combine nonInteractive@@ -111,13 +123,17 @@     , homepage       = combine homepage     , synopsis       = combine synopsis     , category       = combine category+    , extraSrc       = combine extraSrc     , packageType    = combine packageType+    , language       = combine language     , exposedModules = combine exposedModules     , otherModules   = combine otherModules+    , otherExts      = combine otherExts     , dependencies   = combine dependencies     , sourceDirs     = combine sourceDirs     , buildTools     = combine buildTools     , initVerbosity  = combine initVerbosity+    , overwrite      = combine overwrite     }     where combine field = field a `mappend` field b @@ -146,12 +162,3 @@   disp  = Disp.text . show   parse = Parse.choice $ map (fmap read . Parse.string . show) [Codec .. ] -#if MIN_VERSION_base(3,0,0)-#else--- Compat instance for ghc-6.6 era-instance Monoid a => Monoid (Maybe a) where-  mempty = Nothing-  Nothing `mappend` m = m-  m `mappend` Nothing = m-  Just m1 `mappend` Just m2 = Just (m1 `mappend` m2)-#endif
Distribution/Client/Install.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.Install@@ -14,29 +13,32 @@ -- High level interface to package installation. ----------------------------------------------------------------------------- module Distribution.Client.Install (+    -- * High-level interface     install,-    upgrade,++    -- * Lower-level interface that allows to manipulate the install plan+    makeInstallContext,+    makeInstallPlan,+    processInstallPlan,+    InstallArgs,+    InstallContext,++    -- * Prune certain packages from the install plan+    pruneInstallPlan   ) where  import Data.List          ( unfoldr, nub, sort, (\\) )+import qualified Data.Set as S import Data.Maybe          ( isJust, fromMaybe, maybeToList )-import qualified Data.ByteString.Lazy.Char8 as BS-         ( unpack ) import Control.Exception as Exception-         ( bracket, handleJust )-#if MIN_VERSION_base(4,0,0)-import Control.Exception as Exception-         ( Exception(toException), catches, Handler(Handler), IOException )+         ( Exception(toException), bracket, catches, Handler(Handler), handleJust+         , IOException, SomeException ) import System.Exit          ( ExitCode )-#else-import Control.Exception as Exception-         ( Exception(IOException, ExitException) )-#endif import Distribution.Compat.Exception-         ( SomeException, catchIO, catchExit )+         ( catchIO, catchExit ) import Control.Monad          ( when, unless ) import System.Directory@@ -44,7 +46,7 @@ import System.FilePath          ( (</>), (<.>), takeDirectory ) import System.IO-         ( openFile, IOMode(AppendMode), stdout, hFlush, hClose )+         ( openFile, IOMode(WriteMode), hClose ) import System.IO.Error          ( isDoesNotExistError, ioeGetFileName ) @@ -54,7 +56,6 @@          ( Solver(..) ) import Distribution.Client.FetchUtils import qualified Distribution.Client.Haddock as Haddock (regenerateHaddockIndex)--- import qualified Distribution.Client.Info as Info import Distribution.Client.IndexUtils as IndexUtils          ( getSourcePackages, getInstalledPackages ) import qualified Distribution.Client.InstallPlan as InstallPlan@@ -64,7 +65,12 @@          , ConfigFlags(..), configureCommand, filterConfigureFlags          , ConfigExFlags(..), InstallFlags(..) ) import Distribution.Client.Config-         ( defaultCabalDir )+         ( defaultCabalDir, defaultUserInstall )+import Distribution.Client.Sandbox.Timestamp+         ( withUpdateTimestamps )+import Distribution.Client.Sandbox.Types+         ( SandboxPackageInfo(..), UseSandbox(..), isUseSandbox+         , whenUsingSandbox ) import Distribution.Client.Tar (extractTarGzFile) import Distribution.Client.Types as Source import Distribution.Client.BuildReports.Types@@ -76,6 +82,7 @@          ( storeAnonymous, storeLocal, fromInstallPlan ) import qualified Distribution.Client.InstallSymlink as InstallSymlink          ( symlinkBinaries )+import qualified Distribution.Client.PackageIndex as SourcePackageIndex import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade import qualified Distribution.Client.World as World import qualified Distribution.InstalledPackageInfo as Installed@@ -85,7 +92,8 @@ import Distribution.Simple.Compiler          ( CompilerId(..), Compiler(compilerId), compilerFlavor          , PackageDB(..), PackageDBStack )-import Distribution.Simple.Program (ProgramConfiguration, defaultProgramConfiguration)+import Distribution.Simple.Program (ProgramConfiguration,+                                    defaultProgramConfiguration) import qualified Distribution.Simple.InstallDirs as InstallDirs import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Simple.PackageIndex (PackageIndex)@@ -94,7 +102,7 @@          , buildCommand, BuildFlags(..), emptyBuildFlags          , toFlag, fromFlag, fromFlagOrDefault, flagToMaybe ) import qualified Distribution.Simple.Setup as Cabal-         ( installCommand, InstallFlags(..), emptyInstallFlags+         ( installCommand, InstallFlags(..), TestFlags(..), emptyInstallFlags          , emptyTestFlags, testCommand, Flag(..) ) import Distribution.Simple.Utils          ( rawSystemExit, comparing, writeFileAtomic )@@ -114,15 +122,16 @@ import Distribution.Version          ( Version, anyVersion, thisVersion ) import Distribution.Simple.Utils as Utils-         ( notice, info, warn, die, intercalate, withTempDirectory )+         ( notice, info, warn, debugNoWrap, die, intercalate, withTempDirectory ) import Distribution.Client.Utils-         ( numberOfProcessors, inDir, mergeBy, MergeResult(..) )+         ( numberOfProcessors, inDir, mergeBy, MergeResult(..)+         , tryCanonicalizePath ) import Distribution.System-         ( Platform, buildPlatform, OS(Windows), buildOS )+         ( Platform, OS(Windows), buildOS ) import Distribution.Text          ( display ) import Distribution.Verbosity as Verbosity-         ( Verbosity, showForCabal, verbose, deafening )+         ( Verbosity, showForCabal, normal, verbose ) import Distribution.Simple.BuildPaths ( exeExtension )  --TODO:@@ -143,12 +152,15 @@  -- | Installs the packages needed to satisfy a list of dependencies. ---install, upgrade+install   :: Verbosity   -> PackageDBStack   -> [Repo]   -> Compiler+  -> Platform   -> ProgramConfiguration+  -> UseSandbox+  -> Maybe SandboxPackageInfo   -> GlobalFlags   -> ConfigFlags   -> ConfigExFlags@@ -156,77 +168,124 @@   -> HaddockFlags   -> [UserTarget]   -> IO ()-install verbosity packageDBs repos comp conf-  globalFlags configFlags configExFlags installFlags haddockFlags userTargets0 = do+install verbosity packageDBs repos comp platform conf useSandbox mSandboxPkgInfo+  globalFlags configFlags configExFlags installFlags haddockFlags+  userTargets0 = do +    installContext <- makeInstallContext verbosity args (Just userTargets0)+    installPlan    <- foldProgress logMsg die' return =<<+                      makeInstallPlan verbosity args installContext++    processInstallPlan verbosity args installContext installPlan+  where+    args :: InstallArgs+    args = (packageDBs, repos, comp, platform, conf, useSandbox, mSandboxPkgInfo,+            globalFlags, configFlags, configExFlags, installFlags,+            haddockFlags)++    die' message = die (message ++ if isUseSandbox useSandbox+                                   then installFailedInSandbox else [])+    -- TODO: use a better error message, remove duplication.+    installFailedInSandbox =+      "\nNote: when using a sandbox, all packages are required to have \+      consistent dependencies. \+      Try reinstalling/unregistering the offending packages or \+      recreating the sandbox."+    logMsg message rest = debugNoWrap verbosity message >> rest++-- TODO: Make InstallContext a proper datatype with documented fields.+-- | Common context for makeInstallPlan and processInstallPlan.+type InstallContext = ( PackageIndex, SourcePackageDb+                      , [UserTarget], [PackageSpecifier SourcePackage] )++-- TODO: Make InstallArgs a proper datatype with documented fields or just get+-- rid of it completely.+-- | Initial arguments given to 'install' or 'makeInstallContext'.+type InstallArgs = ( PackageDBStack+                   , [Repo]+                   , Compiler+                   , Platform+                   , ProgramConfiguration+                   , UseSandbox+                   , Maybe SandboxPackageInfo+                   , GlobalFlags+                   , ConfigFlags+                   , ConfigExFlags+                   , InstallFlags+                   , HaddockFlags )++-- | Make an install context given install arguments.+makeInstallContext :: Verbosity -> InstallArgs -> Maybe [UserTarget]+                      -> IO InstallContext+makeInstallContext verbosity+  (packageDBs, repos, comp, _, conf,_,_,+   globalFlags, _, _, _, _) mUserTargets = do+     installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf     sourcePkgDb       <- getSourcePackages    verbosity repos -    solver <- chooseSolver verbosity (fromFlag (configSolver  configExFlags)) (compilerId comp)+    (userTargets, pkgSpecifiers) <- case mUserTargets of+      Nothing           ->+        -- We want to distinguish between the case where the user has given an+        -- empty list of targets on the command-line and the case where we+        -- specifically want to have an empty list of targets.+        return ([], [])+      Just userTargets0 -> do+        -- For install, if no target is given it means we use the current+        -- directory as the single target.+        let userTargets | null userTargets0 = [UserTargetLocalDir "."]+                        | otherwise         = userTargets0 -    let -- For install, if no target is given it means we use the-        -- current directory as the single target-        userTargets | null userTargets0 = [UserTargetLocalDir "."]-                    | otherwise         = userTargets0+        pkgSpecifiers <- resolveUserTargets verbosity+                         (fromFlag $ globalWorldFile globalFlags)+                         (packageIndex sourcePkgDb)+                         userTargets+        return (userTargets, pkgSpecifiers) -    pkgSpecifiers <- resolveUserTargets verbosity-                       (fromFlag $ globalWorldFile globalFlags)-                       (packageIndex sourcePkgDb)-                       userTargets+    return (installedPkgIndex, sourcePkgDb, userTargets, pkgSpecifiers) +-- | Make an install plan given install context and install arguments.+makeInstallPlan :: Verbosity -> InstallArgs -> InstallContext+                -> IO (Progress String String InstallPlan)+makeInstallPlan verbosity+  (_, _, comp, platform, _, _, mSandboxPkgInfo,+   _, configFlags, configExFlags, installFlags,+   _)+  (installedPkgIndex, sourcePkgDb,+   _, pkgSpecifiers) = do++    solver <- chooseSolver verbosity (fromFlag (configSolver configExFlags))+              (compilerId comp)     notice verbosity "Resolving dependencies..."-    installPlan   <- foldProgress logMsg die return $-                       planPackages-                         comp solver configFlags configExFlags installFlags-                         installedPkgIndex sourcePkgDb pkgSpecifiers+    return $ planPackages comp platform mSandboxPkgInfo solver+      configFlags configExFlags installFlags+      installedPkgIndex sourcePkgDb pkgSpecifiers -    checkPrintPlan verbosity installedPkgIndex installPlan installFlags pkgSpecifiers+-- | Given an install plan, perform the actual installations.+processInstallPlan :: Verbosity -> InstallArgs -> InstallContext+                   -> InstallPlan+                   -> IO ()+processInstallPlan verbosity+  args@(_,_, _, _, _, _, _, _, _, _, installFlags, _)+  (installedPkgIndex, sourcePkgDb,+   userTargets, pkgSpecifiers) installPlan = do+    checkPrintPlan verbosity installedPkgIndex installPlan sourcePkgDb+      installFlags pkgSpecifiers      unless dryRun $ do       installPlan' <- performInstallations verbosity-                        context installedPkgIndex installPlan-      postInstallActions verbosity context userTargets installPlan'-+                      args installedPkgIndex installPlan+      postInstallActions verbosity args userTargets installPlan'   where-    context :: InstallContext-    context = (packageDBs, repos, comp, conf,-               globalFlags, configFlags, configExFlags, installFlags, haddockFlags)--    dryRun      = fromFlag (installDryRun installFlags)-    logMsg message rest = debugNoWrap message >> rest-    -- Solver debug output really looks better without automatic-    -- line wrapping. TODO: This should probably be moved into-    -- the utilities module.-    debugNoWrap xs = when (verbosity >= deafening) (putStrLn xs >> hFlush stdout)--upgrade _ _ _ _ _ _ _ _ _ _ _ = die $-    "Use the 'cabal install' command instead of 'cabal upgrade'.\n"- ++ "You can install the latest version of a package using 'cabal install'. "- ++ "The 'cabal upgrade' command has been removed because people found it "- ++ "confusing and it often led to broken packages.\n"- ++ "If you want the old upgrade behaviour then use the install command "- ++ "with the --upgrade-dependencies flag (but check first with --dry-run "- ++ "to see what would happen). This will try to pick the latest versions "- ++ "of all dependencies, rather than the usual behaviour of trying to pick "- ++ "installed versions of all dependencies. If you do use "- ++ "--upgrade-dependencies, it is recommended that you do not upgrade core "- ++ "packages (e.g. by using appropriate --constraint= flags)."--type InstallContext = ( PackageDBStack-                      , [Repo]-                      , Compiler-                      , ProgramConfiguration-                      , GlobalFlags-                      , ConfigFlags-                      , ConfigExFlags-                      , InstallFlags-                      , HaddockFlags )+    dryRun = fromFlag (installDryRun installFlags)  -- ------------------------------------------------------------ -- * Installation planning -- ------------------------------------------------------------  planPackages :: Compiler+             -> Platform+             -> Maybe SandboxPackageInfo              -> Solver              -> ConfigFlags              -> ConfigExFlags@@ -235,15 +294,16 @@              -> SourcePackageDb              -> [PackageSpecifier SourcePackage]              -> Progress String String InstallPlan-planPackages comp solver configFlags configExFlags installFlags+planPackages comp platform mSandboxPkgInfo solver+             configFlags configExFlags installFlags              installedPkgIndex sourcePkgDb pkgSpecifiers =          resolveDependencies-          buildPlatform (compilerId comp)+          platform (compilerId comp)           solver           resolverParams -    >>= if onlyDeps then adjustPlanOnlyDeps else return+    >>= if onlyDeps then pruneInstallPlan pkgSpecifiers else return    where     resolverParams =@@ -283,9 +343,12 @@           [ PackageConstraintStanzas (pkgSpecifierTarget pkgSpecifier) stanzas           | pkgSpecifier <- pkgSpecifiers ] +      . maybe id applySandboxInstallPolicy mSandboxPkgInfo+       . (if reinstall then reinstallTargets else id) -      $ standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers+      $ standardInstallPolicy+        installedPkgIndex sourcePkgDb pkgSpecifiers      stanzas = concat         [ if testsEnabled then [TestStanzas] else []@@ -294,33 +357,6 @@     testsEnabled = fromFlagOrDefault False $ configTests configFlags     benchmarksEnabled = fromFlagOrDefault False $ configBenchmarks configFlags -    --TODO: this is a general feature and should be moved to D.C.Dependency-    -- Also, the InstallPlan.remove should return info more precise to the-    -- problem, rather than the very general PlanProblem type.-    adjustPlanOnlyDeps :: InstallPlan -> Progress String String InstallPlan-    adjustPlanOnlyDeps =-        either (Fail . explain) Done-      . InstallPlan.remove (isTarget pkgSpecifiers)-      where-        explain :: [InstallPlan.PlanProblem] -> String-        explain problems =-            "Cannot select only the dependencies (as requested by the "-         ++ "'--only-dependencies' flag), "-         ++ (case pkgids of-               [pkgid] -> "the package " ++ display pkgid ++ " is "-               _       -> "the packages "-                       ++ intercalate ", " (map display pkgids) ++ " are ")-         ++ "required by a dependency of one of the other targets."-          where-            pkgids =-              nub [ depid-                  | InstallPlan.PackageMissingDeps _ depids <- problems-                  , depid <- depids-                  , packageName depid `elem` targetnames ]--        targetnames  = map pkgSpecifierTarget pkgSpecifiers--     reinstall        = fromFlag (installReinstall        installFlags)     reorderGoals     = fromFlag (installReorderGoals     installFlags)     independentGoals = fromFlag (installIndependentGoals installFlags)@@ -330,6 +366,34 @@     upgradeDeps      = fromFlag (installUpgradeDeps      installFlags)     onlyDeps         = fromFlag (installOnlyDeps         installFlags) +-- | Remove the provided targets from the install plan.+pruneInstallPlan :: Package pkg => [PackageSpecifier pkg] -> InstallPlan+                    -> Progress String String InstallPlan+pruneInstallPlan pkgSpecifiers =+  -- TODO: this is a general feature and should be moved to D.C.Dependency+  -- Also, the InstallPlan.remove should return info more precise to the+  -- problem, rather than the very general PlanProblem type.+  either (Fail . explain) Done+  . InstallPlan.remove (\pkg -> packageName pkg `elem` targetnames)+  where+    explain :: [InstallPlan.PlanProblem] -> String+    explain problems =+      "Cannot select only the dependencies (as requested by the "+      ++ "'--only-dependencies' flag), "+      ++ (case pkgids of+             [pkgid] -> "the package " ++ display pkgid ++ " is "+             _       -> "the packages "+                        ++ intercalate ", " (map display pkgids) ++ " are ")+      ++ "required by a dependency of one of the other targets."+      where+        pkgids =+          nub [ depid+              | InstallPlan.PackageMissingDeps _ depids <- problems+              , depid <- depids+              , packageName depid `elem` targetnames ]++    targetnames  = map pkgSpecifierTarget pkgSpecifiers+ -- ------------------------------------------------------------ -- * Informational messages -- ------------------------------------------------------------@@ -339,10 +403,12 @@ checkPrintPlan :: Verbosity                -> PackageIndex                -> InstallPlan+               -> SourcePackageDb                -> InstallFlags                -> [PackageSpecifier SourcePackage]                -> IO ()-checkPrintPlan verbosity installed installPlan installFlags pkgSpecifiers = do+checkPrintPlan verbosity installed installPlan sourcePkgDb+  installFlags pkgSpecifiers = do    -- User targets that are already installed.   let preExistingTargets =@@ -384,7 +450,8 @@   -- We print the install plan if we are in a dry-run or if we are confronted   -- with a dangerous install plan.   when (dryRun || containsReinstalls && not overrideReinstall) $-    printPlan (dryRun || breaksPkgs && not overrideReinstall) adaptedVerbosity lPlan+    printPlan (dryRun || breaksPkgs && not overrideReinstall)+      adaptedVerbosity lPlan sourcePkgDb    -- If the install plan is dangerous, we print various warning messages. In   -- particular, if we can see that packages are likely to be broken, we even@@ -433,11 +500,6 @@  type PackageChange = MergeResult PackageIdentifier PackageIdentifier -isTarget :: Package pkg => [PackageSpecifier SourcePackage] -> pkg -> Bool-isTarget pkgSpecifiers pkg = packageName pkg `elem` targetnames-  where-    targetnames  = map pkgSpecifierTarget pkgSpecifiers- extractReinstalls :: PackageStatus -> [InstalledPackageId] extractReinstalls (Reinstall ipids _) = ipids extractReinstalls _                   = []@@ -447,7 +509,8 @@   case PackageIndex.lookupPackageName installedPkgIndex                                       (packageName cpkg) of     [] -> NewPackage-    ps ->  case filter ((==packageId cpkg) . Installed.sourcePackageId) (concatMap snd ps) of+    ps ->  case filter ((==packageId cpkg)+                        . Installed.sourcePackageId) (concatMap snd ps) of       []           -> NewVersion (map fst ps)       pkgs@(pkg:_) -> Reinstall (map Installed.installedPackageId pkgs)                                 (changes pkg cpkg)@@ -457,15 +520,17 @@     changes :: Installed.InstalledPackageInfo             -> ConfiguredPackage             -> [MergeResult PackageIdentifier PackageIdentifier]-    changes pkg pkg' = filter changed-                     $ mergeBy (comparing packageName)-                         -- get dependencies of installed package (convert to source pkg ids via index)-                         (nub . sort . concatMap (maybeToList .-                                                  fmap Installed.sourcePackageId .-                                                  PackageIndex.lookupInstalledPackageId installedPkgIndex) .-                                                  Installed.depends $ pkg)-                         -- get dependencies of configured package-                         (nub . sort . depends $ pkg')+    changes pkg pkg' =+      filter changed+      $ mergeBy (comparing packageName)+        -- get dependencies of installed package (convert to source pkg ids via+        -- index)+        (nub . sort . concatMap+         (maybeToList . fmap Installed.sourcePackageId .+          PackageIndex.lookupInstalledPackageId installedPkgIndex) .+         Installed.depends $ pkg)+        -- get dependencies of configured package+        (nub . sort . depends $ pkg')      changed (InBoth    pkgid pkgid') = pkgid /= pkgid'     changed _                        = True@@ -473,21 +538,27 @@ printPlan :: Bool -- is dry run           -> Verbosity           -> [(ConfiguredPackage, PackageStatus)]+          -> SourcePackageDb           -> IO ()-printPlan dryRun verbosity plan = case plan of+printPlan dryRun verbosity plan sourcePkgDb = case plan of   []   -> return ()   pkgs     | verbosity >= Verbosity.verbose -> notice verbosity $ unlines $         ("In order, the following " ++ wouldWill ++ " be installed:")       : map showPkgAndReason pkgs     | otherwise -> notice verbosity $ unlines $-        ("In order, the following " ++ wouldWill ++ " be installed (use -v for more details):")-      : map (display . packageId) (map fst pkgs)+        ("In order, the following " ++ wouldWill+         ++ " be installed (use -v for more details):")+      : map showPkg pkgs   where     wouldWill | dryRun    = "would"               | otherwise = "will" +    showPkg (pkg, _) = display (packageId pkg) +++                       showLatest (pkg)+     showPkgAndReason (pkg', pr) = display (packageId pkg') +++          showLatest pkg' ++           showFlagAssignment (nonDefaultFlags pkg') ++           showStanzas (stanzas pkg') ++ " " ++           case pr of@@ -497,6 +568,22 @@                 []   -> ""                 diff -> " changes: "  ++ intercalate ", " (map change diff) +    showLatest :: ConfiguredPackage -> String+    showLatest pkg = case mLatestVersion of+        Just latestVersion ->+            if pkgVersion /= latestVersion+            then (" (latest: " ++ display latestVersion ++ ")")+            else ""+        Nothing -> ""+      where+        pkgVersion    = packageVersion pkg+        mLatestVersion :: Maybe Version+        mLatestVersion = case SourcePackageIndex.lookupPackageName+                                (packageIndex sourcePkgDb)+                                (packageName pkg) of+            [] -> Nothing+            x -> Just $ packageVersion $ last x+     toFlagAssignment :: [Flag] -> FlagAssignment     toFlagAssignment = map (\ f -> (flagName f, flagDefault f)) @@ -541,12 +628,13 @@ --  * error reporting -- postInstallActions :: Verbosity-                   -> InstallContext+                   -> InstallArgs                    -> [UserTarget]                    -> InstallPlan                    -> IO () postInstallActions verbosity-  (packageDBs, _, comp, conf, globalFlags, configFlags, _, installFlags, _)+  (packageDBs, _, comp, platform, conf, useSandbox, mSandboxPkgInfo+  ,globalFlags, configFlags, _, installFlags, _)   targets installPlan = do    unless oneShot $@@ -557,18 +645,22 @@    let buildReports = BuildReports.fromInstallPlan installPlan   BuildReports.storeLocal (installSummaryFile installFlags) buildReports+    (InstallPlan.planPlatform installPlan)   when (reportingLevel >= AnonymousReports) $     BuildReports.storeAnonymous buildReports   when (reportingLevel == DetailedReports) $     storeDetailedBuildReports verbosity logsDir buildReports -  regenerateHaddockIndex verbosity packageDBs comp conf+  regenerateHaddockIndex verbosity packageDBs comp platform conf                          configFlags installFlags installPlan    symlinkBinaries verbosity configFlags installFlags installPlan    printBuildFailures installPlan +  updateSandboxTimestampsFile useSandbox mSandboxPkgInfo+                              comp platform installPlan+   where     reportingLevel = fromFlag (installBuildReports installFlags)     logsDir        = fromFlag (globalLogsDir globalFlags)@@ -603,11 +695,7 @@       warn verbosity $ "Missing log file for build report: "                     ++ fromMaybe ""  (ioeGetFileName ioe) -#if MIN_VERSION_base(4,0,0)     missingFile ioe-#else-    missingFile (IOException ioe)-#endif       | isDoesNotExistError ioe  = Just ioe     missingFile _                = Nothing @@ -615,12 +703,13 @@ regenerateHaddockIndex :: Verbosity                        -> [PackageDB]                        -> Compiler+                       -> Platform                        -> ProgramConfiguration                        -> ConfigFlags                        -> InstallFlags                        -> InstallPlan                        -> IO ()-regenerateHaddockIndex verbosity packageDBs comp conf+regenerateHaddockIndex verbosity packageDBs comp platform conf                        configFlags installFlags installPlan   | haddockIndexFileIsRequested && shouldRegenerateHaddockIndex = do @@ -664,7 +753,7 @@       where         env  = env0 ++ installDirsTemplateEnv absoluteDirs         env0 = InstallDirs.compilerTemplateEnv (compilerId comp)-            ++ InstallDirs.platformTemplateEnv (buildPlatform)+            ++ InstallDirs.platformTemplateEnv platform         absoluteDirs = InstallDirs.substituteInstallDirTemplates                          env0 templateDirs         templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault@@ -724,7 +813,25 @@       InstallFailed   e -> " failed during the final install step."                         ++ " The exception was:\n  " ++ show e +-- | If we're working inside a sandbox and some add-source deps were installed,+-- update the timestamps of those deps.+updateSandboxTimestampsFile :: UseSandbox -> Maybe SandboxPackageInfo+                        -> Compiler -> Platform -> InstallPlan+                        -> IO ()+updateSandboxTimestampsFile (UseSandbox sandboxDir)+                            (Just (SandboxPackageInfo _ _ _ allAddSourceDeps))+                            comp platform installPlan =+  withUpdateTimestamps sandboxDir (compilerId comp) platform $ \_ -> do+    let allInstalled = [ pkg | InstallPlan.Installed pkg _+                            <- InstallPlan.toList installPlan ]+        allSrcPkgs   = [ pkg | ConfiguredPackage pkg _ _ _ <- allInstalled ]+        allPaths     = [ pth | LocalUnpackedPackage pth+                            <- map packageSource allSrcPkgs]+    allPathsCanonical <- mapM tryCanonicalizePath allPaths+    return $! filter (`S.member` allAddSourceDeps) allPathsCanonical +updateSandboxTimestampsFile _ _ _ _ _ = return ()+ -- ------------------------------------------------------------ -- * Actually do the installations -- ------------------------------------------------------------@@ -739,15 +846,21 @@ type UseLogFile = Maybe (PackageIdentifier -> FilePath, Verbosity)  performInstallations :: Verbosity-                     -> InstallContext+                     -> InstallArgs                      -> PackageIndex                      -> InstallPlan                      -> IO InstallPlan performInstallations verbosity-  (packageDBs, _, comp, conf,+  (packageDBs, _, comp, _, conf, useSandbox, _,    globalFlags, configFlags, configExFlags, installFlags, haddockFlags)   installedPkgIndex installPlan = do +  -- With 'install -j' it can be a bit hard to tell whether a sandbox is used.+  whenUsingSandbox useSandbox $ \sandboxDir ->+    when parallelBuild $+      notice verbosity $ "Notice: installing into a sandbox located at "+                         ++ sandboxDir+   jobControl   <- if parallelBuild then newParallelJobControl                                    else newSerialJobControl   buildLimit   <- newJobLimit numJobs@@ -763,7 +876,7 @@           installUnpackedPackage verbosity buildLimit installLock numJobs                                  (setupScriptOptions installedPkgIndex cacheLock)                                  miscOptions configFlags' installFlags haddockFlags-                                 compid pkg pkgoverride mpath useLogFile+                                 compid platform pkg pkgoverride mpath useLogFile    where     platform = InstallPlan.planPlatform installPlan@@ -773,12 +886,13 @@       Cabal.NoFlag        -> 1       Cabal.Flag Nothing  -> numberOfProcessors       Cabal.Flag (Just n) -> n-    numFetchJobs = 2+    numFetchJobs  = 2     parallelBuild = numJobs >= 2      setupScriptOptions index lock = SetupScriptOptions {       useCabalVersion  = maybe anyVersion thisVersion (libVersion miscOptions),       useCompiler      = Just comp,+      usePlatform      = Just platform,       -- Hack: we typically want to allow the UserPackageDB for finding the       -- Cabal lib when compiling any Setup.hs even if we're doing a global       -- install. However we also allow looking in a specific package db.@@ -844,11 +958,14 @@     substLogFileName template pkg = fromPathTemplate                                   . substPathTemplate env                                   $ template-      where env = initialPathTemplateEnv (packageId pkg) (compilerId comp)+      where env = initialPathTemplateEnv (packageId pkg)+                  (compilerId comp) platform      miscOptions  = InstallMisc {       rootCmd    = if fromFlag (configUserInstall configFlags)-                     then Nothing      -- ignore --root-cmd if --user.+                      || (isUseSandbox useSandbox)+                     then Nothing      -- ignore --root-cmd if --user+                                       -- or working inside a sandbox.                      else flagToMaybe (installRootCmd installFlags),       libVersion = flagToMaybe (configCabalVersion configExFlags)     }@@ -908,20 +1025,22 @@         (Right _) -> notice verbosity $ "Installed " ++ display pkgid         (Left _)  -> do           notice verbosity $ "Failed to install " ++ display pkgid-          case useLogFile of-            Nothing                   -> return ()-            Just (mkLogFileName, _) -> do-              let (logName, n) = (mkLogFileName pkgid, 10)-              notice verbosity $ "Last " ++ (show n)-                ++ " lines of the build log ( " ++ logName ++ " ):"-              printLastNLines logName n+          when (verbosity >= normal) $+            case useLogFile of+              Nothing                 -> return ()+              Just (mkLogFileName, _) -> do+                let logName = mkLogFileName pkgid+                    n       = 10+                putStr $ "Last " ++ (show n)+                  ++ " lines of the build log ( " ++ logName ++ " ):\n"+                printLastNLines logName n      printLastNLines :: FilePath -> Int -> IO ()     printLastNLines path n = do       lns <- fmap lines $ readFile path       let len = length lns-      let toDrop = if len > n && n > 0 then (len - n) else 0-      mapM_ (notice verbosity) (drop toDrop lns)+      let toDrop = if (len > n && n > 0) then (len - n) else 0+      mapM_ putStrLn (drop toDrop lns)  -- | Call an installer for an 'SourcePackage' but override the configure -- flags with the ones given by the 'ConfiguredPackage'. In particular the@@ -936,7 +1055,8 @@                                          -> PackageDescriptionOverride -> a)                          -> a installConfiguredPackage platform comp configFlags-  (ConfiguredPackage (SourcePackage _ gpkg source pkgoverride) flags stanzas deps)+  (ConfiguredPackage (SourcePackage _ gpkg source pkgoverride)+   flags stanzas deps)   installPkg = installPkg configFlags {     configConfigurationsFlags = flags,     configConstraints = map thisPackageVersion deps,@@ -1027,6 +1147,7 @@   -> InstallFlags   -> HaddockFlags   -> CompilerId+  -> Platform   -> PackageDescription   -> PackageDescriptionOverride   -> Maybe FilePath -- ^ Directory to change to before starting the installation.@@ -1035,7 +1156,7 @@ installUnpackedPackage verbosity buildLimit installLock numJobs                        scriptOptions miscOptions                        configFlags installConfigFlags haddockFlags-                       compid pkg pkgoverride workingDir useLogFile = do+                       compid platform pkg pkgoverride workingDir useLogFile = do    -- Override the .cabal file if necessary   case pkgoverride of@@ -1046,8 +1167,17 @@       info verbosity $         "Updating " ++ display (packageName pkgid) <.> "cabal"                     ++ " with the latest revision from the index."-      writeFileAtomic descFilePath (BS.unpack pkgtxt)+      writeFileAtomic descFilePath pkgtxt +  -- Make sure that we pass --libsubdir etc to 'setup configure' (necessary if+  -- the setup script was compiled against an old version of the Cabal lib).+  configFlags' <- addDefaultInstallDirs configFlags+  -- Filter out flags not supported by the old versions of the Cabal lib.+  let configureFlags :: Version -> ConfigFlags+      configureFlags  = filterConfigureFlags configFlags' {+        configVerbosity = toFlag verbosity'+      }+   -- Configure phase   onFailure ConfigureFailed $ withJobLimit buildLimit $ do     when (numJobs > 1) $ notice verbosity $@@ -1078,7 +1208,7 @@        -- Install phase         onFailure InstallFailed $ criticalSection installLock $-          withWin32SelfUpgrade verbosity configFlags compid pkg $ do+          withWin32SelfUpgrade verbosity configFlags compid platform pkg $ do             case rootCmd miscOptions of               (Just cmd) -> reexec cmd               Nothing    -> setup Cabal.installCommand installFlags@@ -1086,9 +1216,6 @@    where     pkgid            = packageId pkg-    configureFlags   = filterConfigureFlags configFlags {-      configVerbosity = toFlag verbosity'-    }     buildCommand'    = buildCommand defaultProgramConfiguration     buildFlags   _   = emptyBuildFlags {       buildDistPref  = configDistPref configFlags,@@ -1096,16 +1223,34 @@     }     shouldHaddock    = fromFlag (installDocumentation installConfigFlags)     haddockFlags' _   = haddockFlags {-      haddockVerbosity = toFlag verbosity'+      haddockVerbosity = toFlag verbosity',+      haddockDistPref  = configDistPref configFlags     }     testsEnabled = fromFlag (configTests configFlags)-    testFlags _ = Cabal.emptyTestFlags+    testFlags _ = Cabal.emptyTestFlags {+      Cabal.testDistPref = configDistPref configFlags+    }     installFlags _   = Cabal.emptyInstallFlags {       Cabal.installDistPref  = configDistPref configFlags,       Cabal.installVerbosity = toFlag verbosity'     }     verbosity' = maybe verbosity snd useLogFile +    addDefaultInstallDirs :: ConfigFlags -> IO ConfigFlags+    addDefaultInstallDirs configFlags' = do+      defInstallDirs <- InstallDirs.defaultInstallDirs flavor userInstall False+      return $ configFlags' {+          configInstallDirs = fmap Cabal.Flag .+                              InstallDirs.substituteInstallDirTemplates env $+                              InstallDirs.combineInstallDirs fromFlagOrDefault+                              defInstallDirs (configInstallDirs configFlags)+          }+        where+          CompilerId flavor _ = compid+          env         = initialPathTemplateEnv pkgid compid platform+          userInstall = fromFlagOrDefault defaultUserInstall+                        (configUserInstall configFlags')+     setup cmd flags  = do       Exception.bracket               (case useLogFile of@@ -1114,7 +1259,7 @@                  let logFileName = mkLogFileName (packageId pkg)                      logDir      = takeDirectory logFileName                  unless (null logDir) $ createDirectoryIfMissing True logDir-                 logFile <- openFile logFileName AppendMode+                 logFile <- openFile logFileName WriteMode                  return (Just logFile))               (\mHandle -> case mHandle of                            Just handle -> hClose handle@@ -1142,7 +1287,6 @@ -- helper onFailure :: (SomeException -> BuildFailure) -> IO BuildResult -> IO BuildResult onFailure result action =-#if MIN_VERSION_base(4,0,0)   action `catches`     [ Handler $ \ioe  -> handler (ioe  :: IOException)     , Handler $ \exit -> handler (exit :: ExitCode)@@ -1150,11 +1294,6 @@   where     handler :: Exception e => e -> IO BuildResult     handler = return . Left . result . toException-#else-  action-    `catchIO`   (return . Left . result . IOException)-    `catchExit` (return . Left . result . ExitException)-#endif   -- ------------------------------------------------------------@@ -1164,10 +1303,11 @@ withWin32SelfUpgrade :: Verbosity                      -> ConfigFlags                      -> CompilerId+                     -> Platform                      -> PackageDescription                      -> IO a -> IO a-withWin32SelfUpgrade _ _ _ _ action | buildOS /= Windows = action-withWin32SelfUpgrade verbosity configFlags compid pkg action = do+withWin32SelfUpgrade _ _ _ _ _ action | buildOS /= Windows = action+withWin32SelfUpgrade verbosity configFlags compid platform pkg action = do    defaultDirs <- InstallDirs.defaultInstallDirs                    compFlavor@@ -1195,7 +1335,8 @@         templateDirs   = InstallDirs.combineInstallDirs fromFlagOrDefault                            defaultDirs (configInstallDirs configFlags)         absoluteDirs   = InstallDirs.absoluteInstallDirs-                           pkgid compid InstallDirs.NoCopyDest templateDirs+                           pkgid compid InstallDirs.NoCopyDest+                           platform templateDirs         substTemplate  = InstallDirs.fromPathTemplate                        . InstallDirs.substPathTemplate env-          where env = InstallDirs.initialPathTemplateEnv pkgid compid+          where env = InstallDirs.initialPathTemplateEnv pkgid compid platform
Distribution/Client/InstallPlan.hs view
@@ -409,7 +409,7 @@ -- most one version of any package in the set. It only requires that of -- packages which have more than one other package depending on them. We could -- actually make the condition even more precise and say that different--- versions are ok so long as they are not both in the transative closure of+-- versions are ok so long as they are not both in the transitive closure of -- any other package (or equivalently that their inverse closures do not -- intersect). The point is we do not want to have any packages depending -- directly or indirectly on two different versions of the same package. The
Distribution/Client/InstallSymlink.hs view
@@ -1,9 +1,4 @@-{-# OPTIONS -cpp #-}--- OPTIONS required for ghc-6.4.x compat, and must appear first {-# LANGUAGE CPP #-}-{-# OPTIONS_GHC -cpp #-}-{-# OPTIONS_NHC98 -cpp #-}-{-# OPTIONS_JHC -fcpp  #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.InstallSymlink@@ -152,12 +147,12 @@                            defaultDirs (configInstallDirs configFlags)           absoluteDirs = InstallDirs.absoluteInstallDirs                            (packageId pkg) compilerId InstallDirs.NoCopyDest-                           templateDirs+                           platform templateDirs       canonicalizePath (InstallDirs.bindir absoluteDirs)      substTemplate pkgid = InstallDirs.fromPathTemplate                         . InstallDirs.substPathTemplate env-      where env = InstallDirs.initialPathTemplateEnv pkgid compilerId+      where env = InstallDirs.initialPathTemplateEnv pkgid compilerId platform      fromFlagTemplate = fromFlagOrDefault (InstallDirs.toPathTemplate "")     prefixTemplate   = fromFlagTemplate (configProgPrefix configFlags)@@ -234,6 +229,6 @@       bs = splitPath b       commonLen = length $ takeWhile id $ zipWith (==) as bs    in joinPath $ [ ".." | _  <- drop commonLen as ]-              ++ [  b'  | b' <- drop commonLen bs ]+              ++ drop commonLen bs  #endif
Distribution/Client/JobControl.hs view
@@ -27,8 +27,9 @@   ) where  import Control.Monad-import Control.Concurrent-import Control.Exception+import Control.Concurrent hiding (QSem, newQSem, waitQSem, signalQSem)+import Control.Exception (SomeException, bracket_, mask, throw, try)+import Distribution.Client.Compat.Semaphore  data JobControl m a = JobControl {        spawnJob    :: m a -> m (),@@ -51,7 +52,6 @@     collect = join . readChan  newParallelJobControl :: IO (JobControl IO a)-#if MIN_VERSION_base(4,3,0) newParallelJobControl = do     resultVar <- newEmptyMVar     return JobControl {@@ -69,9 +69,6 @@     collect :: MVar (Either SomeException a) -> IO a     collect resultVar =       takeMVar resultVar >>= either throw return-#else-newParallelJobControl = newSerialJobControl-#endif  data JobLimit = JobLimit QSem
Distribution/Client/List.hs view
@@ -138,6 +138,9 @@      -> InfoFlags      -> [UserTarget]      -> IO ()+info verbosity _ _ _ _ _ _ [] =+    notice verbosity "No packages requested. Nothing to do."+ info verbosity packageDBs repos comp conf      globalFlags _listFlags userTargets = do @@ -184,9 +187,8 @@                                  sourcePkgs  selectedSourcePkg'                                  showPkgVersion       where-        pref           = prefs name-        installedPkgs  = concatMap snd (InstalledPackageIndex.lookupPackageName installedPkgIndex name)-        sourcePkgs     =                         PackageIndex.lookupPackageName sourcePkgIndex name+        (pref, installedPkgs, sourcePkgs) =+          sourcePkgsInfo prefs name installedPkgIndex sourcePkgIndex          selectedInstalledPkgs = InstalledPackageIndex.lookupDependency installedPkgIndex                                     (Dependency name verConstraint)@@ -205,10 +207,22 @@                                  selectedPkg True       where         name          = packageName pkg-        pref          = prefs name-        installedPkgs = concatMap snd (InstalledPackageIndex.lookupPackageName installedPkgIndex name)-        sourcePkgs    =                         PackageIndex.lookupPackageName sourcePkgIndex name         selectedPkg   = Just pkg+        (pref, installedPkgs, sourcePkgs) =+          sourcePkgsInfo prefs name installedPkgIndex sourcePkgIndex++sourcePkgsInfo ::+  (PackageName -> VersionRange)+  -> PackageName+  -> InstalledPackageIndex.PackageIndex+  -> PackageIndex.PackageIndex SourcePackage+  -> (VersionRange, [Installed.InstalledPackageInfo], [SourcePackage])+sourcePkgsInfo prefs name installedPkgIndex sourcePkgIndex =+  (pref, installedPkgs, sourcePkgs)+  where+    pref          = prefs name+    installedPkgs = concatMap snd (InstalledPackageIndex.lookupPackageName installedPkgIndex name)+    sourcePkgs    =                         PackageIndex.lookupPackageName sourcePkgIndex name   -- | The info that we can display for each package. It is information per
Distribution/Client/PackageIndex.hs view
@@ -63,7 +63,7 @@ import Data.Array ((!)) import Data.List (groupBy, sortBy, nub, isInfixOf) import Data.Monoid (Monoid(..))-import Data.Maybe (isJust, isNothing, fromMaybe)+import Data.Maybe (isJust, isNothing, fromMaybe, catMaybes)  import Distribution.Package          ( PackageName(..), PackageIdentifier(..)@@ -90,7 +90,7 @@   deriving (Show, Read)  instance Package pkg => Monoid (PackageIndex pkg) where-  mempty  = PackageIndex (Map.empty)+  mempty  = PackageIndex Map.empty   mappend = merge   --save one mappend with empty in the common case:   mconcat [] = mempty@@ -334,9 +334,9 @@                          , isNothing (lookupPackageId index pkg') ]   , not (null missing) ] --- | Tries to take the transative closure of the package dependencies.+-- | Tries to take the transitive closure of the package dependencies. ----- If the transative closure is complete then it returns that subset of the+-- If the transitive closure is complete then it returns that subset of the -- index. Otherwise it returns the broken packages as in 'brokenPackages'. -- -- * Note that if the result is @Right []@ it is because at least one of@@ -360,7 +360,7 @@           where completed' = insert pkg completed                 pkgids'    = depends pkg ++ pkgids --- | Takes the transative closure of the packages reverse dependencies.+-- | Takes the transitive closure of the packages reverse dependencies. -- -- * The given 'PackageIdentifier's must be in the index. --@@ -466,9 +466,8 @@                     PackageIdentifier -> Maybe Graph.Vertex) dependencyGraph index = (graph, vertexToPkg, pkgIdToVertex)   where-    graph = Array.listArray bounds-              [ [ v | Just v <- map pkgIdToVertex (depends pkg) ]-              | pkg <- pkgs ]+    graph = Array.listArray bounds $+            map (catMaybes . map pkgIdToVertex . depends) pkgs     vertexToPkg vertex = pkgTable ! vertex     pkgIdToVertex = binarySearch 0 topBound
+ Distribution/Client/ParseUtils.hs view
@@ -0,0 +1,57 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.ParseUtils+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- Parsing utilities.+-----------------------------------------------------------------------------++module Distribution.Client.ParseUtils ( parseFields, ppFields, ppSection )+       where++import Distribution.ParseUtils+         ( FieldDescr(..), ParseResult(..), warning, lineNo )+import qualified Distribution.ParseUtils as ParseUtils+         ( Field(..) )++import Control.Monad    ( foldM )+import Text.PrettyPrint ( (<>), (<+>), ($$) )+import qualified Data.Map as Map+import qualified Text.PrettyPrint as Disp+         ( Doc, text, colon, vcat, empty, isEmpty, nest )++--FIXME: replace this with something better+parseFields :: [FieldDescr a] -> a -> [ParseUtils.Field] -> ParseResult a+parseFields fields = foldM setField+  where+    fieldMap = Map.fromList+      [ (name, f) | f@(FieldDescr name _ _) <- fields ]+    setField accum (ParseUtils.F line name value) =+      case Map.lookup name fieldMap of+        Just (FieldDescr _ _ set) -> set line value accum+        Nothing -> do+          warning $ "Unrecognized field " ++ name ++ " on line " ++ show line+          return accum+    setField accum f = do+      warning $ "Unrecognized stanza on line " ++ show (lineNo f)+      return accum++-- | This is a customised version of the functions from Distribution.ParseUtils+-- that also optionally print default values for empty fields as comments.+--+ppFields :: [FieldDescr a] -> (Maybe a) -> a -> Disp.Doc+ppFields fields def cur = Disp.vcat [ ppField name (fmap getter def) (getter cur)+                                    | FieldDescr name getter _ <- fields]++ppField :: String -> (Maybe Disp.Doc) -> Disp.Doc -> Disp.Doc+ppField name mdef cur+  | Disp.isEmpty cur = maybe Disp.empty+                       (\def -> Disp.text "--" <+> Disp.text name+                                <> Disp.colon <+> def) mdef+  | otherwise        = Disp.text name <> Disp.colon <+> cur++ppSection :: String -> String -> [FieldDescr a] -> (Maybe a) -> a -> Disp.Doc+ppSection name arg fields def cur =+     Disp.text name <+> Disp.text arg+  $$ Disp.nest 2 (ppFields fields def cur)
+ Distribution/Client/Run.hs view
@@ -0,0 +1,64 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Run+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- Implementation of the 'run' command.+-----------------------------------------------------------------------------++module Distribution.Client.Run ( run, splitRunArgs )+       where++import Distribution.Client.Utils             (tryCanonicalizePath)++import Distribution.PackageDescription       (Executable (..),+                                              PackageDescription (..))+import Distribution.Simple.Build.PathsModule (pkgPathEnvVar)+import Distribution.Simple.BuildPaths        (exeExtension)+import Distribution.Simple.LocalBuildInfo    (LocalBuildInfo (..))+import Distribution.Simple.Utils             (die, rawSystemExitWithEnv)+import Distribution.Verbosity                (Verbosity)++import Data.Functor                          ((<$>))+import Data.List                             (find)+import System.Directory                      (getCurrentDirectory)+import Distribution.Compat.Environment       (getEnvironment)+import System.FilePath                       ((<.>), (</>))+++-- | Return the executable to run and any extra arguments that should be+-- forwarded to it.+splitRunArgs :: LocalBuildInfo -> [String] -> IO (Executable, [String])+splitRunArgs lbi args =+  case exes of+    []    -> die "Couldn't find any executables."+    [exe] -> case args of+      []                        -> return (exe, [])+      (x:xs) | x == exeName exe -> return (exe, xs)+             | otherwise        -> return (exe, args)+    _     -> case args of+      []     -> die $ "This package contains multiple executables. "+                ++ "You must pass the executable name as the first argument "+                ++ "to 'cabal run'."+      (x:xs) -> case find (\exe -> exeName exe == x) exes of+        Nothing  -> die $ "No executable named '" ++ x ++ "'."+        Just exe -> return (exe, xs)+  where+    pkg_descr = localPkgDescr lbi+    exes      = executables pkg_descr+++-- | Run a given executable.+run :: Verbosity -> LocalBuildInfo -> Executable -> [String] -> IO ()+run verbosity lbi exe exeArgs = do+  curDir <- getCurrentDirectory+  let buildPref     = buildDir lbi+      pkg_descr     = localPkgDescr lbi+      dataDirEnvVar = (pkgPathEnvVar pkg_descr "datadir",+                       curDir </> dataDir pkg_descr)++  path <- tryCanonicalizePath $+          buildPref </> exeName exe </> (exeName exe <.> exeExtension)+  env  <- (dataDirEnvVar:) <$> getEnvironment+  rawSystemExitWithEnv verbosity path exeArgs env
+ Distribution/Client/Sandbox.hs view
@@ -0,0 +1,730 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Sandbox+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- UI for the sandboxing functionality.+-----------------------------------------------------------------------------++module Distribution.Client.Sandbox (+    sandboxInit,+    sandboxDelete,+    sandboxAddSource,+    sandboxAddSourceSnapshot,+    sandboxDeleteSource,+    sandboxListSources,+    sandboxHcPkg,+    dumpPackageEnvironment,+    withSandboxBinDirOnSearchPath,++    getSandboxConfigFilePath,+    loadConfigOrSandboxConfig,+    initPackageDBIfNeeded,+    maybeWithSandboxDirOnSearchPath,++    WereDepsReinstalled(..),+    reinstallAddSourceDeps,+    maybeReinstallAddSourceDeps,++    SandboxPackageInfo(..),+    maybeWithSandboxPackageInfo,++    tryGetIndexFilePath,+    sandboxBuildDir,+    getInstalledPackagesInSandbox,++    -- FIXME: move somewhere else+    configPackageDB', configCompilerAux'+  ) where++import Distribution.Client.Setup+  ( SandboxFlags(..), ConfigFlags(..), ConfigExFlags(..), InstallFlags(..)+  , GlobalFlags(..), defaultConfigExFlags, defaultInstallFlags+  , defaultSandboxLocation, globalRepos )+import Distribution.Client.Sandbox.Timestamp  ( listModifiedDeps+                                              , maybeAddCompilerTimestampRecord+                                              , withAddTimestamps+                                              , withRemoveTimestamps )+import Distribution.Client.Config             ( SavedConfig(..), loadConfig )+import Distribution.Client.Dependency         ( foldProgress )+import Distribution.Client.IndexUtils         ( BuildTreeRefType(..) )+import Distribution.Client.Install            ( InstallArgs,+                                                makeInstallContext,+                                                makeInstallPlan,+                                                processInstallPlan )+import Distribution.Client.Sandbox.PackageEnvironment+  ( PackageEnvironment(..), IncludeComments(..), PackageEnvironmentType(..)+  , createPackageEnvironmentFile, classifyPackageEnvironment+  , tryLoadSandboxPackageEnvironmentFile, loadUserConfig+  , commentPackageEnvironment, showPackageEnvironmentWithComments+  , sandboxPackageEnvironmentFile, userPackageEnvironmentFile )+import Distribution.Client.Sandbox.Types      ( SandboxPackageInfo(..)+                                              , UseSandbox(..) )+import Distribution.Client.Types              ( PackageLocation(..)+                                              , SourcePackage(..) )+import Distribution.Client.Utils              ( inDir, tryCanonicalizePath )+import Distribution.PackageDescription.Configuration+                                              ( flattenPackageDescription )+import Distribution.PackageDescription.Parse  ( readPackageDescription )+import Distribution.Simple.Compiler           ( Compiler(..), PackageDB(..)+                                              , PackageDBStack )+import Distribution.Simple.Configure          ( configCompilerAuxEx+                                              , interpretPackageDbFlags+                                              , getPackageDBContents )+import Distribution.Simple.PreProcess         ( knownSuffixHandlers )+import Distribution.Simple.Program            ( ProgramConfiguration )+import Distribution.Simple.Setup              ( Flag(..), HaddockFlags(..)+                                              , fromFlagOrDefault )+import Distribution.Simple.SrcDist            ( prepareTree )+import Distribution.Simple.Utils              ( die, debug, notice, warn+                                              , debugNoWrap, defaultPackageDesc+                                              , findPackageDesc+                                              , intercalate, topHandlerWith+                                              , createDirectoryIfMissingVerbose )+import Distribution.Package                   ( Package(..) )+import Distribution.System                    ( Platform )+import Distribution.Text                      ( display )+import Distribution.Verbosity                 ( Verbosity, lessVerbose )+import Distribution.Client.Compat.Environment ( lookupEnv, setEnv )+import Distribution.Client.Compat.FilePerms   ( setFileHidden )+import qualified Distribution.Client.Sandbox.Index as Index+import qualified Distribution.Simple.PackageIndex  as InstalledPackageIndex+import qualified Distribution.Simple.Register      as Register+import qualified Data.Map                          as M+import qualified Data.Set                          as S+import Control.Exception                      ( assert, bracket_ )+import Control.Monad                          ( forM, liftM2, unless, when )+import Data.Bits                              ( shiftL, shiftR, xor )+import Data.Char                              ( ord )+import Data.IORef                             ( newIORef, writeIORef, readIORef )+import Data.List                              ( delete, foldl' )+import Data.Maybe                             ( fromJust )+import Data.Monoid                            ( mempty, mappend )+import Data.Word                              ( Word32 )+import Numeric                                ( showHex )+import System.Directory                       ( createDirectory+                                              , doesDirectoryExist+                                              , doesFileExist+                                              , getCurrentDirectory+                                              , removeDirectoryRecursive+                                              , removeFile+                                              , renameDirectory )+import System.FilePath                        ( (</>), getSearchPath+                                              , searchPathSeparator+                                              , takeDirectory )+++--+-- * Constants+--++-- | The name of the sandbox subdirectory where we keep snapshots of add-source+-- dependencies.+snapshotDirectoryName :: FilePath+snapshotDirectoryName = "snapshots"++-- | Non-standard build dir that is used for building add-source deps instead of+-- "dist". Fixes surprising behaviour in some cases (see issue #1281).+sandboxBuildDir :: FilePath -> FilePath+sandboxBuildDir sandboxDir = "dist/dist-sandbox-" ++ showHex sandboxDirHash ""+  where+    sandboxDirHash = jenkins sandboxDir++    -- See http://en.wikipedia.org/wiki/Jenkins_hash_function+    jenkins :: String -> Word32+    jenkins str = loop_finish $ foldl' loop 0 str+      where+        loop :: Word32 -> Char -> Word32+        loop hash key_i' = hash'''+          where+            key_i   = toEnum . ord $ key_i'+            hash'   = hash + key_i+            hash''  = hash' + (shiftL hash' 10)+            hash''' = hash'' `xor` (shiftR hash'' 6)++        loop_finish :: Word32 -> Word32+        loop_finish hash = hash'''+          where+            hash'   = hash + (shiftL hash 3)+            hash''  = hash' `xor` (shiftR hash' 11)+            hash''' = hash'' + (shiftL hash'' 15)++--+-- * Basic sandbox functions.+--++-- | Return the path to the package environment directory - either the current+-- directory or the one that @--sandbox-config-file@ resides in.+getPkgEnvDir :: GlobalFlags -> IO FilePath+getPkgEnvDir globalFlags = do+  let sandboxConfigFileFlag = globalSandboxConfigFile globalFlags+  case sandboxConfigFileFlag of+    NoFlag    -> getCurrentDirectory+    Flag path -> tryCanonicalizePath . takeDirectory $ path++-- | Return the path to the sandbox config file - either the default or the one+-- specified with @--sandbox-config-file@.+getSandboxConfigFilePath :: GlobalFlags -> IO FilePath+getSandboxConfigFilePath globalFlags = do+  let sandboxConfigFileFlag = globalSandboxConfigFile globalFlags+  case sandboxConfigFileFlag of+    NoFlag -> do pkgEnvDir <- getCurrentDirectory+                 return (pkgEnvDir </> sandboxPackageEnvironmentFile)+    Flag path -> return path++-- | Load the @cabal.sandbox.config@ file (and possibly the optional+-- @cabal.config@). In addition to a @PackageEnvironment@, also return a+-- canonical path to the sandbox. Exit with error if the sandbox directory or+-- the package environment file do not exist.+tryLoadSandboxConfig :: Verbosity -> GlobalFlags+                        -> IO (FilePath, PackageEnvironment)+tryLoadSandboxConfig verbosity globalFlags = do+  path <- getSandboxConfigFilePath globalFlags+  tryLoadSandboxPackageEnvironmentFile verbosity path+    (globalConfigFile globalFlags)++-- | Return the name of the package index file for this package environment.+tryGetIndexFilePath :: SavedConfig -> IO FilePath+tryGetIndexFilePath config = tryGetIndexFilePath' (savedGlobalFlags config)++-- | The same as 'tryGetIndexFilePath', but takes 'GlobalFlags' instead of+-- 'SavedConfig'.+tryGetIndexFilePath' :: GlobalFlags -> IO FilePath+tryGetIndexFilePath' globalFlags = do+  let paths = globalLocalRepos globalFlags+  case paths of+    []  -> die $ "Distribution.Client.Sandbox.tryGetIndexFilePath: " +++           "no local repos found. " ++ checkConfiguration+    _   -> return $ (last paths) </> Index.defaultIndexFileName+  where+    checkConfiguration = "Please check your configuration ('"+                         ++ userPackageEnvironmentFile ++ "')."++-- | Try to extract a 'PackageDB' from 'ConfigFlags'. Gives a better error+-- message than just pattern-matching.+getSandboxPackageDB :: ConfigFlags -> IO PackageDB+getSandboxPackageDB configFlags = do+  case configPackageDBs configFlags of+    [Just sandboxDB@(SpecificPackageDB _)] -> return sandboxDB+    -- TODO: should we allow multiple package DBs (e.g. with 'inherit')?++    []                                     ->+      die $ "Sandbox package DB is not specified. " ++ sandboxConfigCorrupt+    [_]                                    ->+      die $ "Unexpected contents of the 'package-db' field. "+            ++ sandboxConfigCorrupt+    _                                      ->+      die $ "Too many package DBs provided. " ++ sandboxConfigCorrupt++  where+    sandboxConfigCorrupt = "Your 'cabal.sandbox.config' is probably corrupt."+++-- | Which packages are installed in the sandbox package DB?+getInstalledPackagesInSandbox :: Verbosity -> ConfigFlags+                                 -> Compiler -> ProgramConfiguration+                                 -> IO InstalledPackageIndex.PackageIndex+getInstalledPackagesInSandbox verbosity configFlags comp conf = do+    sandboxDB <- getSandboxPackageDB configFlags+    getPackageDBContents verbosity comp sandboxDB conf++-- | Temporarily add $SANDBOX_DIR/bin to $PATH.+withSandboxBinDirOnSearchPath :: FilePath -> IO a -> IO a+withSandboxBinDirOnSearchPath sandboxDir = bracket_ addBinDir rmBinDir+  where+    -- TODO: Instead of modifying the global process state, it'd be better to+    -- set the environment individually for each subprocess invocation. This+    -- will have to wait until the Shell monad is implemented; without it the+    -- required changes are too intrusive.+    addBinDir :: IO ()+    addBinDir = do+      mbOldPath <- lookupEnv "PATH"+      let newPath = maybe sandboxBin ((++) sandboxBin . (:) searchPathSeparator)+                    mbOldPath+      setEnv "PATH" newPath++    rmBinDir :: IO ()+    rmBinDir = do+      oldPath <- getSearchPath+      let newPath = intercalate [searchPathSeparator]+                    (delete sandboxBin oldPath)+      setEnv "PATH" newPath++    sandboxBin = sandboxDir </> "bin"++-- | Initialise a package DB for this compiler if it doesn't exist.+initPackageDBIfNeeded :: Verbosity -> ConfigFlags+                         -> Compiler -> ProgramConfiguration+                         -> IO ()+initPackageDBIfNeeded verbosity configFlags comp conf = do+  SpecificPackageDB dbPath <- getSandboxPackageDB configFlags+  packageDBExists <- doesDirectoryExist dbPath+  unless packageDBExists $+    Register.initPackageDB verbosity comp conf dbPath+  when packageDBExists $+    debug verbosity $ "The package database already exists: " ++ dbPath++-- | Entry point for the 'cabal dump-pkgenv' command.+dumpPackageEnvironment :: Verbosity -> SandboxFlags -> GlobalFlags -> IO ()+dumpPackageEnvironment verbosity _sandboxFlags globalFlags = do+  (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags+  commentPkgEnv        <- commentPackageEnvironment sandboxDir+  putStrLn . showPackageEnvironmentWithComments (Just commentPkgEnv) $ pkgEnv++-- | Entry point for the 'cabal sandbox-init' command.+sandboxInit :: Verbosity -> SandboxFlags  -> GlobalFlags -> IO ()+sandboxInit verbosity sandboxFlags globalFlags = do+  -- Warn if there's a 'cabal-dev' sandbox.+  isCabalDevSandbox <- liftM2 (&&) (doesDirectoryExist "cabal-dev")+                       (doesFileExist $ "cabal-dev" </> "cabal.config")+  when isCabalDevSandbox $+    warn verbosity $+    "You are apparently using a legacy (cabal-dev) sandbox. "+    ++ "Legacy sandboxes may interact badly with native Cabal sandboxes. "+    ++ "You may want to delete the 'cabal-dev' directory to prevent issues."++  -- Create the sandbox directory.+  let sandboxDir' = fromFlagOrDefault defaultSandboxLocation+                    (sandboxLocation sandboxFlags)+  createDirectoryIfMissingVerbose verbosity True sandboxDir'+  sandboxDir <- tryCanonicalizePath sandboxDir'+  setFileHidden sandboxDir++  -- Determine which compiler to use (using the value from ~/.cabal/config).+  userConfig <- loadConfig verbosity (globalConfigFile globalFlags) NoFlag+  (comp, platform, conf) <- configCompilerAuxEx (savedConfigureFlags userConfig)++  -- Create the package environment file.+  pkgEnvFile <- getSandboxConfigFilePath globalFlags+  createPackageEnvironmentFile verbosity sandboxDir pkgEnvFile+    NoComments comp platform+  (_sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags+  let config      = pkgEnvSavedConfig pkgEnv+      configFlags = savedConfigureFlags config++  -- Create the index file if it doesn't exist.+  indexFile <- tryGetIndexFilePath config+  indexFileExists <- doesFileExist indexFile+  if indexFileExists+    then notice verbosity $ "Using an existing sandbox located at " ++ sandboxDir+    else notice verbosity $ "Creating a new sandbox at " ++ sandboxDir+  Index.createEmpty verbosity indexFile++  -- Create the package DB for the default compiler.+  initPackageDBIfNeeded verbosity configFlags comp conf+  maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile+    (compilerId comp) platform++-- | Entry point for the 'cabal sandbox-delete' command.+sandboxDelete :: Verbosity -> SandboxFlags -> GlobalFlags -> IO ()+sandboxDelete verbosity _sandboxFlags globalFlags = do+  (useSandbox, _) <- loadConfigOrSandboxConfig verbosity globalFlags mempty+  case useSandbox of+    NoSandbox -> die "Not in a sandbox."+    UseSandbox sandboxDir -> do+      curDir     <- getCurrentDirectory+      pkgEnvFile <- getSandboxConfigFilePath globalFlags++      -- Remove the @cabal.sandbox.config@ file, unless it's in a non-standard+      -- location.+      let isNonDefaultConfigLocation =+            pkgEnvFile /= (curDir </> sandboxPackageEnvironmentFile)++      if isNonDefaultConfigLocation+        then warn verbosity $ "Sandbox config file is in non-default location: '"+                    ++ pkgEnvFile ++ "'.\n Please delete manually."+        else removeFile pkgEnvFile++      -- Remove the sandbox directory, unless we're using a shared sandbox.+      let isNonDefaultSandboxLocation =+            sandboxDir /= (curDir </> defaultSandboxLocation)++      when isNonDefaultSandboxLocation $+        die $ "Non-default sandbox location used: '" ++ sandboxDir+        ++ "'.\nAssuming a shared sandbox. Please delete '"+        ++ sandboxDir ++ "' manually."++      notice verbosity $ "Deleting the sandbox located at " ++ sandboxDir+      removeDirectoryRecursive sandboxDir++-- Common implementation of 'sandboxAddSource' and 'sandboxAddSourceSnapshot'.+doAddSource :: Verbosity -> [FilePath] -> FilePath -> PackageEnvironment+               -> BuildTreeRefType+               -> IO ()+doAddSource verbosity buildTreeRefs sandboxDir pkgEnv refType = do+  let savedConfig       = pkgEnvSavedConfig pkgEnv+  indexFile            <- tryGetIndexFilePath savedConfig++  -- If we're running 'sandbox add-source' for the first time for this compiler,+  -- we need to create an initial timestamp record.+  (comp, platform, _) <- configCompilerAuxEx . savedConfigureFlags $ savedConfig+  maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile+    (compilerId comp) platform++  withAddTimestamps sandboxDir $ do+    -- FIXME: path canonicalisation is done in addBuildTreeRefs, but we do it+    -- twice because of the timestamps file.+    buildTreeRefs' <- mapM tryCanonicalizePath buildTreeRefs+    Index.addBuildTreeRefs verbosity indexFile buildTreeRefs' refType+    return buildTreeRefs'++-- | Entry point for the 'cabal sandbox add-source' command.+sandboxAddSource :: Verbosity -> [FilePath] -> SandboxFlags -> GlobalFlags+                    -> IO ()+sandboxAddSource verbosity buildTreeRefs sandboxFlags globalFlags = do+  (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags++  if fromFlagOrDefault False (sandboxSnapshot sandboxFlags)+    then sandboxAddSourceSnapshot verbosity buildTreeRefs sandboxDir pkgEnv+    else doAddSource verbosity buildTreeRefs sandboxDir pkgEnv LinkRef++-- | Entry point for the 'cabal sandbox add-source --snapshot' command.+sandboxAddSourceSnapshot :: Verbosity -> [FilePath] -> FilePath+                            -> PackageEnvironment+                            -> IO ()+sandboxAddSourceSnapshot verbosity buildTreeRefs sandboxDir pkgEnv = do+  let snapshotDir = sandboxDir </> snapshotDirectoryName++  -- Use 'D.S.SrcDist.prepareTree' to copy each package's files to our private+  -- location.+  createDirectoryIfMissingVerbose verbosity True snapshotDir++  -- Collect the package descriptions first, so that if some path does not refer+  -- to a cabal package, we fail immediately.+  pkgs      <- forM buildTreeRefs $ \buildTreeRef ->+    inDir (Just buildTreeRef) $+    return . flattenPackageDescription+            =<< readPackageDescription verbosity+            =<< defaultPackageDesc     verbosity++  -- Copy the package sources to "snapshots/$PKGNAME-$VERSION-tmp". If+  -- 'prepareTree' throws an error at any point, the old snapshots will still be+  -- in consistent state.+  tmpDirs <- forM (zip buildTreeRefs pkgs) $ \(buildTreeRef, pkg) ->+    inDir (Just buildTreeRef) $ do+      let targetDir    = snapshotDir </> (display . packageId $ pkg)+          targetTmpDir = targetDir ++ "-tmp"+      dirExists <- doesDirectoryExist targetTmpDir+      when dirExists $+        removeDirectoryRecursive targetDir+      createDirectory targetTmpDir+      prepareTree verbosity pkg Nothing targetTmpDir knownSuffixHandlers+      return (targetTmpDir, targetDir)++  -- Now rename the "snapshots/$PKGNAME-$VERSION-tmp" dirs to+  -- "snapshots/$PKGNAME-$VERSION".+  snapshots <- forM tmpDirs $ \(targetTmpDir, targetDir) -> do+    dirExists <- doesDirectoryExist targetDir+    when dirExists $+      removeDirectoryRecursive targetDir+    renameDirectory targetTmpDir targetDir+    return targetDir++  -- Once the packages are copied, just 'add-source' them as usual.+  doAddSource verbosity snapshots sandboxDir pkgEnv SnapshotRef++-- | Entry point for the 'cabal sandbox delete-source' command.+sandboxDeleteSource :: Verbosity -> [FilePath] -> SandboxFlags -> GlobalFlags+                       -> IO ()+sandboxDeleteSource verbosity buildTreeRefs _sandboxFlags globalFlags = do+  (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags+  indexFile            <- tryGetIndexFilePath (pkgEnvSavedConfig pkgEnv)++  withRemoveTimestamps sandboxDir $ do+    Index.removeBuildTreeRefs verbosity indexFile buildTreeRefs++  notice verbosity $ "Note: 'sandbox delete-source' only unregisters the " +++    "source dependency, but does not remove the package " +++    "from the sandbox package DB.\n\n" +++    "Use 'sandbox hc-pkg -- unregister' to do that."++-- | Entry point for the 'cabal sandbox list-sources' command.+sandboxListSources :: Verbosity -> SandboxFlags -> GlobalFlags+                      -> IO ()+sandboxListSources verbosity _sandboxFlags globalFlags = do+  (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags+  indexFile            <- tryGetIndexFilePath (pkgEnvSavedConfig pkgEnv)++  refs <- Index.listBuildTreeRefs verbosity+          Index.ListIgnored Index.LinksAndSnapshots indexFile+  when (null refs) $+    notice verbosity $ "Index file '" ++ indexFile+    ++ "' has no references to local build trees."+  when (not . null $ refs) $ do+    notice verbosity $ "Source dependencies registered "+      ++ "in the current sandbox ('" ++ sandboxDir ++ "'):\n\n"+    mapM_ putStrLn refs+    notice verbosity $ "\nTo unregister source dependencies, "+                       ++ "use the 'sandbox delete-source' command."++-- | Invoke the @hc-pkg@ tool with provided arguments, restricted to the+-- sandbox.+sandboxHcPkg :: Verbosity -> SandboxFlags -> GlobalFlags -> [String] -> IO ()+sandboxHcPkg verbosity _sandboxFlags globalFlags extraArgs = do+  (_sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags+  let configFlags = savedConfigureFlags . pkgEnvSavedConfig $ pkgEnv+      dbStack     = configPackageDB' configFlags+  (comp, _platform, conf) <- configCompilerAux' configFlags++  Register.invokeHcPkg verbosity comp conf dbStack extraArgs++-- | Check which type of package environment we're in and return a+-- correctly-initialised @SavedConfig@ and a @UseSandbox@ value that indicates+-- whether we're working in a sandbox.+loadConfigOrSandboxConfig :: Verbosity+                             -> GlobalFlags  -- ^ For @--config-file@ and+                                             -- @--sandbox-config-file@.+                             -> Flag Bool    -- ^ Ignored if we're in a sandbox.+                             -> IO (UseSandbox, SavedConfig)+loadConfigOrSandboxConfig verbosity globalFlags userInstallFlag = do+  let configFileFlag        = globalConfigFile globalFlags+      sandboxConfigFileFlag = globalSandboxConfigFile globalFlags++  pkgEnvDir  <- getPkgEnvDir globalFlags+  pkgEnvType <- case sandboxConfigFileFlag of+    NoFlag -> classifyPackageEnvironment pkgEnvDir+    Flag _ -> return SandboxPackageEnvironment++  case pkgEnvType of+    -- A @cabal.sandbox.config@ file (and possibly @cabal.config@) is present.+    SandboxPackageEnvironment -> do+      (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags+                              -- ^ Prints an error message and exits on error.+      let config = pkgEnvSavedConfig pkgEnv+      return (UseSandbox sandboxDir, config)++    -- Only @cabal.config@ is present.+    UserPackageEnvironment    -> do+      config <- loadConfig verbosity configFileFlag userInstallFlag+      userConfig <- loadUserConfig verbosity pkgEnvDir+      return (NoSandbox, config `mappend` userConfig)++    -- Neither @cabal.sandbox.config@ nor @cabal.config@ are present.+    AmbientPackageEnvironment -> do+      config <- loadConfig verbosity configFileFlag userInstallFlag+      return (NoSandbox, config)++-- | If we're in a sandbox, call @withSandboxBinDirOnSearchPath@, otherwise do+-- nothing.+maybeWithSandboxDirOnSearchPath :: UseSandbox -> IO a -> IO a+maybeWithSandboxDirOnSearchPath NoSandbox               act = act+maybeWithSandboxDirOnSearchPath (UseSandbox sandboxDir) act =+  withSandboxBinDirOnSearchPath sandboxDir $ act++-- | Had reinstallAddSourceDeps actually reinstalled any dependencies?+data WereDepsReinstalled = ReinstalledSomeDeps | NoDepsReinstalled++-- | Reinstall those add-source dependencies that have been modified since+-- we've last installed them. Assumes that we're working inside a sandbox.+reinstallAddSourceDeps :: Verbosity+                          -> ConfigFlags  -> ConfigExFlags+                          -> InstallFlags -> GlobalFlags+                          -> FilePath+                          -> IO WereDepsReinstalled+reinstallAddSourceDeps verbosity configFlags' configExFlags+                       installFlags globalFlags sandboxDir = topHandler' $ do+  let sandboxDistPref     = sandboxBuildDir sandboxDir+      configFlags         = configFlags'+                            { configDistPref  = Flag sandboxDistPref }+      haddockFlags        = mempty+                            { haddockDistPref = Flag sandboxDistPref }+  (comp, platform, conf) <- configCompilerAux' configFlags+  retVal                 <- newIORef NoDepsReinstalled++  withSandboxPackageInfo verbosity configFlags globalFlags+                         comp platform conf sandboxDir $ \sandboxPkgInfo ->+    unless (null $ modifiedAddSourceDependencies sandboxPkgInfo) $ do++      let args :: InstallArgs+          args = ((configPackageDB' configFlags)+                 ,(globalRepos globalFlags)+                 ,comp, platform, conf+                 ,UseSandbox sandboxDir, Just sandboxPkgInfo+                 ,globalFlags, configFlags, configExFlags, installFlags+                 ,haddockFlags)++      -- This can actually be replaced by a call to 'install', but we use a+      -- lower-level API because of layer separation reasons. Additionally, we+      -- might want to use some lower-level features this in the future.+      withSandboxBinDirOnSearchPath sandboxDir $ do+        installContext <- makeInstallContext verbosity args Nothing+        installPlan    <- foldProgress logMsg die' return =<<+                          makeInstallPlan verbosity args installContext++        processInstallPlan verbosity args installContext installPlan+        writeIORef retVal ReinstalledSomeDeps++  readIORef retVal++    where+      die' message = die (message ++ installFailedInSandbox)+      -- TODO: use a better error message, remove duplication.+      installFailedInSandbox =+        "Note: when using a sandbox, all packages are required to have \+        consistent dependencies. \+        Try reinstalling/unregistering the offending packages or \+        recreating the sandbox."+      logMsg message rest = debugNoWrap verbosity message >> rest++      topHandler' = topHandlerWith $ \_ -> do+        warn verbosity "Couldn't reinstall some add-source dependencies."+        -- Here we can't know whether any deps have been reinstalled, so we have+        -- to be conservative.+        return ReinstalledSomeDeps++-- | Produce a 'SandboxPackageInfo' and feed it to the given action. Note that+-- we don't update the timestamp file here - this is done in+-- 'postInstallActions'.+withSandboxPackageInfo :: Verbosity -> ConfigFlags -> GlobalFlags+                          -> Compiler -> Platform -> ProgramConfiguration+                          -> FilePath+                          -> (SandboxPackageInfo -> IO ())+                          -> IO ()+withSandboxPackageInfo verbosity configFlags globalFlags+                       comp platform conf sandboxDir cont = do+  -- List all add-source deps.+  indexFile              <- tryGetIndexFilePath' globalFlags+  buildTreeRefs          <- Index.listBuildTreeRefs verbosity+                            Index.DontListIgnored Index.OnlyLinks indexFile+  let allAddSourceDepsSet = S.fromList buildTreeRefs++  -- List all packages installed in the sandbox.+  installedPkgIndex <- getInstalledPackagesInSandbox verbosity+                       configFlags comp conf++  -- Get the package descriptions for all add-source deps.+  depsCabalFiles <- mapM findPackageDesc buildTreeRefs+  depsPkgDescs   <- mapM (readPackageDescription verbosity) depsCabalFiles+  let depsMap           = M.fromList (zip buildTreeRefs depsPkgDescs)+      isInstalled pkgid = not . null+        . InstalledPackageIndex.lookupSourcePackageId installedPkgIndex $ pkgid+      installedDepsMap  = M.filter (isInstalled . packageId) depsMap++  -- Get the package ids of modified (and installed) add-source deps.+  modifiedAddSourceDeps <- listModifiedDeps verbosity sandboxDir+                           (compilerId comp) platform installedDepsMap+  -- 'fromJust' here is safe because 'modifiedAddSourceDeps' are guaranteed to+  -- be a subset of the keys of 'depsMap'.+  let modifiedDeps    = [ (modDepPath, fromJust $ M.lookup modDepPath depsMap)+                        | modDepPath <- modifiedAddSourceDeps ]+      modifiedDepsMap = M.fromList modifiedDeps++  assert (all (`S.member` allAddSourceDepsSet) modifiedAddSourceDeps) (return ())+  unless (null modifiedDeps) $+    notice verbosity $ "Some add-source dependencies have been modified. "+                       ++ "They will be reinstalled..."++  -- Get the package ids of the remaining add-source deps (some are possibly not+  -- installed).+  let otherDeps = M.assocs (depsMap `M.difference` modifiedDepsMap)++  -- Finally, assemble a 'SandboxPackageInfo'.+  cont $ SandboxPackageInfo (map toSourcePackage modifiedDeps)+    (map toSourcePackage otherDeps) installedPkgIndex allAddSourceDepsSet++  where+    toSourcePackage (path, pkgDesc) = SourcePackage+      (packageId pkgDesc) pkgDesc (LocalUnpackedPackage path) Nothing++-- | Same as 'withSandboxPackageInfo' if we're inside a sandbox and a no-op+-- otherwise.+maybeWithSandboxPackageInfo :: Verbosity -> ConfigFlags -> GlobalFlags+                               -> Compiler -> Platform -> ProgramConfiguration+                               -> UseSandbox+                               -> (Maybe SandboxPackageInfo -> IO ())+                               -> IO ()+maybeWithSandboxPackageInfo verbosity configFlags globalFlags+                            comp platform conf useSandbox cont =+  case useSandbox of+    NoSandbox             -> cont Nothing+    UseSandbox sandboxDir -> withSandboxPackageInfo verbosity+                             configFlags globalFlags+                             comp platform conf sandboxDir+                             (\spi -> cont (Just spi))++-- | Check if a sandbox is present and call @reinstallAddSourceDeps@ in that+-- case.+maybeReinstallAddSourceDeps :: Verbosity+                               -> Flag (Maybe Int) -- ^ The '-j' flag+                               -> ConfigFlags      -- ^ Saved configure flags+                                                   -- (from dist/setup-config)+                               -> GlobalFlags+                               -> IO (UseSandbox, WereDepsReinstalled)+maybeReinstallAddSourceDeps verbosity numJobsFlag configFlags' globalFlags' = do+  currentDir <- getCurrentDirectory+  pkgEnvType <- classifyPackageEnvironment currentDir+  case pkgEnvType of+    AmbientPackageEnvironment -> return (NoSandbox, NoDepsReinstalled)+    UserPackageEnvironment    -> return (NoSandbox, NoDepsReinstalled)+    SandboxPackageEnvironment -> do+      (sandboxDir, pkgEnv)    <- tryLoadSandboxConfig verbosity globalFlags'++      -- Actually reinstall the modified add-source deps.+      let config         = pkgEnvSavedConfig pkgEnv+          configFlags    = savedConfigureFlags config+                           `mappendSomeSavedFlags`+                           configFlags'+          configExFlags  = defaultConfigExFlags+                           `mappend` savedConfigureExFlags config+          installFlags'  = defaultInstallFlags+                           `mappend` savedInstallFlags config+          installFlags   = installFlags' {+            installNumJobs    = installNumJobs installFlags'+                                `mappend` numJobsFlag+            }+          globalFlags    = savedGlobalFlags config+          -- This makes it possible to override things like 'remote-repo-cache'+          -- from the command line. These options are hidden, and are only+          -- useful for debugging, so this should be fine.+                           `mappend` globalFlags'+      depsReinstalled <- reinstallAddSourceDeps verbosity+                         configFlags configExFlags installFlags globalFlags+                         sandboxDir+      return (UseSandbox sandboxDir, depsReinstalled)++  where++    -- NOTE: we can't simply do @sandboxConfigFlags `mappend` savedFlags@+    -- because we don't want to auto-enable things like 'library-profiling' for+    -- all add-source dependencies even if the user has passed+    -- '--enable-library-profiling' to 'cabal configure'. These options are+    -- supposed to be set in 'cabal.config'.+    mappendSomeSavedFlags :: ConfigFlags -> ConfigFlags -> ConfigFlags+    mappendSomeSavedFlags sandboxConfigFlags savedFlags =+      sandboxConfigFlags {+        configHcFlavor     = configHcFlavor sandboxConfigFlags+                             `mappend` configHcFlavor savedFlags,+        configHcPath       = configHcPath sandboxConfigFlags+                             `mappend` configHcPath savedFlags,+        configHcPkg        = configHcPkg sandboxConfigFlags+                             `mappend` configHcPkg savedFlags,+        configProgramPaths = configProgramPaths sandboxConfigFlags+                             `mappend` configProgramPaths savedFlags,+        configProgramArgs  = configProgramArgs sandboxConfigFlags+                             `mappend` configProgramArgs savedFlags+        -- NOTE: We don't touch the @configPackageDBs@ field because+        -- @sandboxConfigFlags@ contains the sandbox location which was set when+        -- creating @cabal.sandbox.config@.+        -- FIXME: Is this compatible with the 'inherit' feature?+        }++--+-- Utils (transitionary)+--+-- FIXME: configPackageDB' and configCompilerAux' don't really belong in this+-- module+--++configPackageDB' :: ConfigFlags -> PackageDBStack+configPackageDB' cfg =+    interpretPackageDbFlags userInstall (configPackageDBs cfg)+  where+    userInstall = fromFlagOrDefault True (configUserInstall cfg)++configCompilerAux' :: ConfigFlags+                   -> IO (Compiler, Platform, ProgramConfiguration)+configCompilerAux' configFlags =+  configCompilerAuxEx configFlags+    --FIXME: make configCompilerAux use a sensible verbosity+    { configVerbosity = fmap lessVerbose (configVerbosity configFlags) }
+ Distribution/Client/Sandbox/Index.hs view
@@ -0,0 +1,237 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Sandbox.Index+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- Querying and modifying local build tree references in the package index.+-----------------------------------------------------------------------------++module Distribution.Client.Sandbox.Index (+    createEmpty,+    addBuildTreeRefs,+    removeBuildTreeRefs,+    ListIgnoredBuildTreeRefs(..), RefTypesToList(..),+    listBuildTreeRefs,+    validateIndexPath,++    defaultIndexFileName+  ) where++import qualified Distribution.Client.Tar as Tar+import Distribution.Client.IndexUtils ( BuildTreeRefType(..)+                                      , refTypeFromTypeCode+                                      , typeCodeFromRefType+                                      , getSourcePackagesStrict )+import Distribution.Client.PackageIndex ( allPackages )+import Distribution.Client.Types ( Repo(..), LocalRepo(..)+                                 , SourcePackageDb(..)+                                 , SourcePackage(..), PackageLocation(..) )+import Distribution.Client.Utils ( byteStringToFilePath, filePathToByteString+                                 , makeAbsoluteToCwd, tryCanonicalizePath+                                 , canonicalizePathNoThrow )++import Distribution.Simple.Utils ( die, debug, findPackageDesc )+import Distribution.Verbosity    ( Verbosity )++import qualified Data.ByteString.Lazy as BS+import Control.Exception         ( evaluate )+import Control.Monad             ( liftM, unless )+import Data.List                 ( (\\), intersect, nub )+import Data.Maybe                ( catMaybes )+import System.Directory          ( createDirectoryIfMissing,+                                   doesDirectoryExist, doesFileExist,+                                   renameFile )+import System.FilePath           ( (</>), (<.>), takeDirectory, takeExtension )+import System.IO                 ( IOMode(..), SeekMode(..)+                                 , hSeek, withBinaryFile )++-- | A reference to a local build tree.+data BuildTreeRef = BuildTreeRef {+  buildTreeRefType :: !BuildTreeRefType,+  buildTreePath     :: !FilePath+  }++defaultIndexFileName :: FilePath+defaultIndexFileName = "00-index.tar"++-- | Given a path, ensure that it refers to a local build tree.+buildTreeRefFromPath :: BuildTreeRefType -> FilePath -> IO (Maybe BuildTreeRef)+buildTreeRefFromPath refType dir = do+  dirExists <- doesDirectoryExist dir+  unless dirExists $+    die $ "directory '" ++ dir ++ "' does not exist"+  _ <- findPackageDesc dir+  return . Just $ BuildTreeRef refType dir++-- | Given a tar archive entry, try to parse it as a local build tree reference.+readBuildTreeRef :: Tar.Entry -> Maybe BuildTreeRef+readBuildTreeRef entry = case Tar.entryContent entry of+  (Tar.OtherEntryType typeCode bs size)+    | (Tar.isBuildTreeRefTypeCode typeCode)+      && (size == BS.length bs) -> Just $! BuildTreeRef+                                   (refTypeFromTypeCode typeCode)+                                   (byteStringToFilePath bs)+    | otherwise                 -> Nothing+  _ -> Nothing++-- | Given a sequence of tar archive entries, extract all references to local+-- build trees.+readBuildTreeRefs :: Tar.Entries -> [BuildTreeRef]+readBuildTreeRefs =+  catMaybes+  . Tar.foldrEntries (\e r -> readBuildTreeRef e : r)+  [] error++-- | Given a path to a tar archive, extract all references to local build trees.+readBuildTreeRefsFromFile :: FilePath -> IO [BuildTreeRef]+readBuildTreeRefsFromFile = liftM (readBuildTreeRefs . Tar.read) . BS.readFile++-- | Given a local build tree ref, serialise it to a tar archive entry.+writeBuildTreeRef :: BuildTreeRef -> Tar.Entry+writeBuildTreeRef (BuildTreeRef refType path) = Tar.simpleEntry tarPath content+  where+    bs       = filePathToByteString path+    -- Provide a filename for tools that treat custom entries as ordinary files.+    tarPath' = "local-build-tree-reference"+    -- fromRight can't fail because the path is shorter than 255 characters.+    tarPath  = fromRight $ Tar.toTarPath True tarPath'+    content  = Tar.OtherEntryType (typeCodeFromRefType refType) bs (BS.length bs)++    -- TODO: Move this to D.C.Utils?+    fromRight (Left err) = error err+    fromRight (Right a)  = a++-- | Check that the provided path is either an existing directory, or a tar+-- archive in an existing directory.+validateIndexPath :: FilePath -> IO FilePath+validateIndexPath path' = do+   path <- makeAbsoluteToCwd path'+   if (== ".tar") . takeExtension $ path+     then return path+     else do dirExists <- doesDirectoryExist path+             unless dirExists $+               die $ "directory does not exist: '" ++ path ++ "'"+             return $ path </> defaultIndexFileName++-- | Create an empty index file.+createEmpty :: Verbosity -> FilePath -> IO ()+createEmpty verbosity path = do+  indexExists <- doesFileExist path+  if indexExists+    then debug verbosity $ "Package index already exists: " ++ path+    else do+    debug verbosity $ "Creating the index file '" ++ path ++ "'"+    createDirectoryIfMissing True (takeDirectory path)+    -- Equivalent to 'tar cvf empty.tar --files-from /dev/null'.+    let zeros = BS.replicate (512*20) 0+    BS.writeFile path zeros++-- | Add given local build tree references to the index.+addBuildTreeRefs :: Verbosity -> FilePath -> [FilePath] -> BuildTreeRefType+                    -> IO ()+addBuildTreeRefs _         _   []  _ =+  error "Distribution.Client.Sandbox.Index.addBuildTreeRefs: unexpected"+addBuildTreeRefs verbosity path l' refType = do+  checkIndexExists path+  l <- liftM nub . mapM tryCanonicalizePath $ l'+  treesInIndex <- fmap (map buildTreePath) (readBuildTreeRefsFromFile path)+  -- Add only those paths that aren't already in the index.+  treesToAdd <- mapM (buildTreeRefFromPath refType) (l \\ treesInIndex)+  let entries = map writeBuildTreeRef (catMaybes treesToAdd)+  unless (null entries) $ do+    offset <-+      fmap (Tar.foldrEntries (\e acc -> Tar.entrySizeInBytes e + acc) 0 error+            . Tar.read) $ BS.readFile path+    _ <- evaluate offset+    debug verbosity $ "Writing at offset: " ++ show offset+    withBinaryFile path ReadWriteMode $ \h -> do+      hSeek h AbsoluteSeek (fromIntegral offset)+      BS.hPut h (Tar.write entries)+      debug verbosity $ "Successfully appended to '" ++ path ++ "'"++-- | Remove given local build tree references from the index.+removeBuildTreeRefs :: Verbosity -> FilePath -> [FilePath] -> IO [FilePath]+removeBuildTreeRefs _         _   [] =+  error "Distribution.Client.Sandbox.Index.removeBuildTreeRefs: unexpected"+removeBuildTreeRefs verbosity path l' = do+  checkIndexExists path+  l <- mapM canonicalizePathNoThrow l'+  let tmpFile = path <.> "tmp"+  -- Performance note: on my system, it takes 'index --remove-source'+  -- approx. 3,5s to filter a 65M file. Real-life indices are expected to be+  -- much smaller.+  BS.writeFile tmpFile . Tar.writeEntries . Tar.filterEntries (p l) . Tar.read+    =<< BS.readFile path+  -- This invalidates the cache, so we don't have to update it explicitly.+  renameFile tmpFile path+  debug verbosity $ "Successfully renamed '" ++ tmpFile+    ++ "' to '" ++ path ++ "'"+  -- FIXME: return only the refs that vere actually removed.+  return l+    where+      p l entry = case readBuildTreeRef entry of+        Nothing                     -> True+        -- FIXME: removing snapshot deps is done with `delete-source+        -- .cabal-sandbox/snapshots/$SNAPSHOT_NAME`. Perhaps we also want to+        -- support removing snapshots by providing the original path.+        (Just (BuildTreeRef _ pth)) -> pth `notElem` l++-- | A build tree ref can become ignored if the user later adds a build tree ref+-- with the same package ID. We display ignored build tree refs when the user+-- runs 'cabal sandbox list-sources', but do not look at their timestamps in+-- 'reinstallAddSourceDeps'.+data ListIgnoredBuildTreeRefs = ListIgnored | DontListIgnored++-- | Which types of build tree refs should be listed?+data RefTypesToList = OnlySnapshots | OnlyLinks | LinksAndSnapshots++-- | List the local build trees that are referred to from the index.+listBuildTreeRefs :: Verbosity -> ListIgnoredBuildTreeRefs -> RefTypesToList+                     -> FilePath+                     -> IO [FilePath]+listBuildTreeRefs verbosity listIgnored refTypesToList path = do+  checkIndexExists path+  buildTreeRefs <-+    case listIgnored of+      DontListIgnored -> do+        paths <- listWithoutIgnored+        case refTypesToList of+          LinksAndSnapshots -> return paths+          _                 -> do+            allPathsFiltered <- fmap (map buildTreePath . filter predicate)+                                listWithIgnored+            _ <- evaluate (length allPathsFiltered)+            return (paths `intersect` allPathsFiltered)++      ListIgnored -> fmap (map buildTreePath . filter predicate) listWithIgnored++  _ <- evaluate (length buildTreeRefs)+  return buildTreeRefs++    where+      predicate :: BuildTreeRef -> Bool+      predicate = case refTypesToList of+        OnlySnapshots     -> (==) SnapshotRef . buildTreeRefType+        OnlyLinks         -> (==) LinkRef     . buildTreeRefType+        LinksAndSnapshots -> const True++      listWithIgnored :: IO [BuildTreeRef]+      listWithIgnored = readBuildTreeRefsFromFile $ path++      listWithoutIgnored :: IO [FilePath]+      listWithoutIgnored = do+        let repo = Repo { repoKind = Right LocalRepo+                        , repoLocalDir = takeDirectory path }+        pkgIndex <- fmap packageIndex+                    . getSourcePackagesStrict verbosity $ [repo]+        return [ pkgPath | (LocalUnpackedPackage pkgPath) <-+                    map packageSource . allPackages $ pkgIndex ]+++-- | Check that the package index file exists and exit with error if it does not.+checkIndexExists :: FilePath -> IO ()+checkIndexExists path = do+  indexExists <- doesFileExist path+  unless indexExists $+    die $ "index does not exist: '" ++ path ++ "'"
+ Distribution/Client/Sandbox/PackageEnvironment.hs view
@@ -0,0 +1,497 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Sandbox.PackageEnvironment+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- Utilities for working with the package environment file. Patterned after+-- Distribution.Client.Config.+-----------------------------------------------------------------------------++module Distribution.Client.Sandbox.PackageEnvironment (+    PackageEnvironment(..)+  , IncludeComments(..)+  , PackageEnvironmentType(..)+  , classifyPackageEnvironment+  , createPackageEnvironmentFile+  , tryLoadSandboxPackageEnvironmentFile+  , readPackageEnvironmentFile+  , showPackageEnvironment+  , showPackageEnvironmentWithComments+  , setPackageDB+  , loadUserConfig++  , basePackageEnvironment+  , initialPackageEnvironment+  , commentPackageEnvironment+  , sandboxPackageEnvironmentFile+  , userPackageEnvironmentFile+  ) where++import Distribution.Client.Config      ( SavedConfig(..), commentSavedConfig,+                                         loadConfig, configFieldDescriptions,+                                         installDirsFields, defaultCompiler )+import Distribution.Client.ParseUtils  ( parseFields, ppFields, ppSection )+import Distribution.Client.Setup       ( GlobalFlags(..), ConfigExFlags(..)+                                       , InstallFlags(..)+                                       , defaultSandboxLocation )+import Distribution.Simple.Compiler    ( Compiler, PackageDB(..)+                                       , compilerFlavor, showCompilerId )+import Distribution.Simple.InstallDirs ( InstallDirs(..), PathTemplate+                                       , defaultInstallDirs, combineInstallDirs+                                       , fromPathTemplate, toPathTemplate )+import Distribution.Simple.Setup       ( Flag(..), ConfigFlags(..),+                                         fromFlagOrDefault, toFlag )+import Distribution.Simple.Utils       ( die, info, notice, warn, lowercase )+import Distribution.ParseUtils         ( FieldDescr(..), ParseResult(..),+                                         commaListField,+                                         liftField, lineNo, locatedErrorMsg,+                                         parseFilePathQ, readFields,+                                         showPWarning, simpleField, syntaxError )+import Distribution.System             ( Platform )+import Distribution.Verbosity          ( Verbosity, normal )+import Control.Monad                   ( foldM, when, unless )+import Data.List                       ( partition )+import Data.Monoid                     ( Monoid(..) )+import Distribution.Compat.Exception   ( catchIO )+import System.Directory                ( doesDirectoryExist, doesFileExist,+                                         renameFile )+import System.FilePath                 ( (<.>), (</>), takeDirectory )+import System.IO.Error                 ( isDoesNotExistError )+import Text.PrettyPrint                ( ($+$) )++import qualified Text.PrettyPrint          as Disp+import qualified Distribution.Compat.ReadP as Parse+import qualified Distribution.ParseUtils   as ParseUtils ( Field(..) )+import qualified Distribution.Text         as Text+++--+-- * Configuration saved in the package environment file+--++-- TODO: would be nice to remove duplication between+-- D.C.Sandbox.PackageEnvironment and D.C.Config.+data PackageEnvironment = PackageEnvironment {+  -- The 'inherit' feature is not used ATM, but could be useful in the future+  -- for constructing nested sandboxes (see discussion in #1196).+  pkgEnvInherit       :: Flag FilePath,+  pkgEnvSavedConfig   :: SavedConfig+}++instance Monoid PackageEnvironment where+  mempty = PackageEnvironment {+    pkgEnvInherit       = mempty,+    pkgEnvSavedConfig   = mempty+    }++  mappend a b = PackageEnvironment {+    pkgEnvInherit       = combine pkgEnvInherit,+    pkgEnvSavedConfig   = combine pkgEnvSavedConfig+    }+    where+      combine f = f a `mappend` f b++-- | The automatically-created package environment file that should not be+-- touched by the user.+sandboxPackageEnvironmentFile :: FilePath+sandboxPackageEnvironmentFile = "cabal.sandbox.config"++-- | Optional package environment file that can be used to customize the default+-- settings. Created by the user.+userPackageEnvironmentFile :: FilePath+userPackageEnvironmentFile = "cabal.config"++-- | Type of the current package environment.+data PackageEnvironmentType =+  SandboxPackageEnvironment   -- ^ './cabal.sandbox.config'+  | UserPackageEnvironment    -- ^ './cabal.config'+  | AmbientPackageEnvironment -- ^ '~/.cabal/config'++-- | Is there a 'cabal.sandbox.config' or 'cabal.config' in this+-- directory?+classifyPackageEnvironment :: FilePath -> IO PackageEnvironmentType+classifyPackageEnvironment pkgEnvDir = do+  isSandbox <- configExists sandboxPackageEnvironmentFile+  isUser    <- configExists userPackageEnvironmentFile+  case (isSandbox, isUser) of+    (True,  _)     -> return SandboxPackageEnvironment+    (False, True)  -> return UserPackageEnvironment+    (False, False) -> return AmbientPackageEnvironment+  where+    configExists fname = doesFileExist (pkgEnvDir </> fname)++-- | Defaults common to 'initialPackageEnvironment' and+-- 'commentPackageEnvironment'.+commonPackageEnvironmentConfig :: FilePath -> SavedConfig+commonPackageEnvironmentConfig sandboxDir =+  mempty {+    savedConfigureFlags = mempty {+       -- TODO: Currently, we follow cabal-dev and set 'user-install: False' in+       -- the config file. In the future we may want to distinguish between+       -- global, sandbox and user install types.+       configUserInstall = toFlag False,+       configInstallDirs = installDirs+       },+    savedUserInstallDirs   = installDirs,+    savedGlobalInstallDirs = installDirs,+    savedGlobalFlags = mempty {+      globalLogsDir = toFlag $ sandboxDir </> "logs",+      -- Is this right? cabal-dev uses the global world file.+      globalWorldFile = toFlag $ sandboxDir </> "world"+      }+    }+  where+    installDirs = sandboxInstallDirs sandboxDir++-- | 'commonPackageEnvironmentConfig' wrapped inside a 'PackageEnvironment'.+commonPackageEnvironment :: FilePath -> PackageEnvironment+commonPackageEnvironment sandboxDir = mempty {+  pkgEnvSavedConfig = commonPackageEnvironmentConfig sandboxDir+  }++-- | Given a path to a sandbox, return the corresponding InstallDirs record.+sandboxInstallDirs :: FilePath -> InstallDirs (Flag PathTemplate)+sandboxInstallDirs sandboxDir = mempty {+  prefix = toFlag (toPathTemplate sandboxDir)+  }++-- | These are the absolute basic defaults, the fields that must be+-- initialised. When we load the package environment from the file we layer the+-- loaded values over these ones.+basePackageEnvironment :: PackageEnvironment+basePackageEnvironment =+    mempty {+      pkgEnvSavedConfig = mempty {+         savedConfigureFlags = mempty {+            configHcFlavor    = toFlag defaultCompiler,+            configVerbosity   = toFlag normal+            }+         }+      }++-- | Initial configuration that we write out to the package environment file if+-- it does not exist. When the package environment gets loaded this+-- configuration gets layered on top of 'basePackageEnvironment'.+initialPackageEnvironment :: FilePath -> Compiler -> Platform+                             -> IO PackageEnvironment+initialPackageEnvironment sandboxDir compiler platform = do+  defInstallDirs <- defaultInstallDirs (compilerFlavor compiler)+                    {- userInstall= -} False {- _hasLibs= -} False+  let initialConfig = commonPackageEnvironmentConfig sandboxDir+      installDirs   = combineInstallDirs (\d f -> Flag $ fromFlagOrDefault d f)+                      defInstallDirs (savedUserInstallDirs initialConfig)+  return $ mempty {+    pkgEnvSavedConfig = initialConfig {+       savedUserInstallDirs   = installDirs,+       savedGlobalInstallDirs = installDirs,+       savedGlobalFlags = (savedGlobalFlags initialConfig) {+          globalLocalRepos = [sandboxDir </> "packages"]+          },+       savedConfigureFlags = setPackageDB sandboxDir compiler platform+                             (savedConfigureFlags initialConfig),+       savedInstallFlags = (savedInstallFlags initialConfig) {+         installSummaryFile = [toPathTemplate (sandboxDir </>+                                               "logs" </> "build.log")]+         }+       }+    }++-- | Use the package DB location specific for this compiler.+setPackageDB :: FilePath -> Compiler -> Platform -> ConfigFlags -> ConfigFlags+setPackageDB sandboxDir compiler platform configFlags =+  configFlags {+    configPackageDBs = [Just (SpecificPackageDB $ sandboxDir+                              </> (Text.display platform ++ "-"+                                   ++ showCompilerId compiler+                                   ++ "-packages.conf.d"))]+    }++-- | Almost the same as 'savedConf `mappend` pkgEnv', but some settings are+-- overridden instead of mappend'ed.+overrideSandboxSettings :: PackageEnvironment -> PackageEnvironment ->+                           PackageEnvironment+overrideSandboxSettings pkgEnv0 pkgEnv =+  pkgEnv {+    pkgEnvSavedConfig = mappendedConf {+         savedConfigureFlags = (savedConfigureFlags mappendedConf) {+          configPackageDBs = configPackageDBs pkgEnvConfigureFlags+          }+       , savedInstallFlags = (savedInstallFlags mappendedConf) {+          installSummaryFile = installSummaryFile pkgEnvInstallFlags+          }+       },+    pkgEnvInherit = pkgEnvInherit pkgEnv0+    }+  where+    pkgEnvConf           = pkgEnvSavedConfig pkgEnv+    mappendedConf        = (pkgEnvSavedConfig pkgEnv0) `mappend` pkgEnvConf+    pkgEnvConfigureFlags = savedConfigureFlags pkgEnvConf+    pkgEnvInstallFlags   = savedInstallFlags pkgEnvConf++-- | Default values that get used if no value is given. Used here to include in+-- comments when we write out the initial package environment.+commentPackageEnvironment :: FilePath -> IO PackageEnvironment+commentPackageEnvironment sandboxDir = do+  commentConf  <- commentSavedConfig+  let baseConf =  commonPackageEnvironmentConfig sandboxDir+  return $ mempty {+    pkgEnvSavedConfig = commentConf `mappend` baseConf+    }++-- | If this package environment inherits from some other package environment,+-- return that package environment; otherwise return mempty.+inheritedPackageEnvironment :: Verbosity -> PackageEnvironment+                               -> IO PackageEnvironment+inheritedPackageEnvironment verbosity pkgEnv = do+  case (pkgEnvInherit pkgEnv) of+    NoFlag                -> return mempty+    confPathFlag@(Flag _) -> do+      conf <- loadConfig verbosity confPathFlag NoFlag+      return $ mempty { pkgEnvSavedConfig = conf }++-- | Load the user package environment if it exists (the optional "cabal.config"+-- file).+userPackageEnvironment :: Verbosity -> FilePath -> IO PackageEnvironment+userPackageEnvironment verbosity pkgEnvDir = do+  let path = pkgEnvDir </> userPackageEnvironmentFile+  minp <- readPackageEnvironmentFile mempty path+  case minp of+    Nothing -> return mempty+    Just (ParseOk warns parseResult) -> do+      when (not $ null warns) $ warn verbosity $+        unlines (map (showPWarning path) warns)+      return parseResult+    Just (ParseFailed err) -> do+      let (line, msg) = locatedErrorMsg err+      warn verbosity $ "Error parsing user package environment file " ++ path+        ++ maybe "" (\n -> ":" ++ show n) line ++ ":\n" ++ msg+      return mempty++-- | Same as @userPackageEnvironmentFile@, but returns a SavedConfig.+loadUserConfig :: Verbosity -> FilePath -> IO SavedConfig+loadUserConfig verbosity pkgEnvDir = fmap pkgEnvSavedConfig+                                     $ userPackageEnvironment verbosity pkgEnvDir++-- | Common error handling code used by 'tryLoadSandboxPackageEnvironment' and+-- 'updatePackageEnvironment'.+handleParseResult :: Verbosity -> FilePath+                     -> Maybe (ParseResult PackageEnvironment)+                     -> IO PackageEnvironment+handleParseResult verbosity path minp =+  case minp of+    Nothing -> die $+      "The package environment file '" ++ path ++ "' doesn't exist"+    Just (ParseOk warns parseResult) -> do+      when (not $ null warns) $ warn verbosity $+        unlines (map (showPWarning path) warns)+      return parseResult+    Just (ParseFailed err) -> do+      let (line, msg) = locatedErrorMsg err+      die $ "Error parsing package environment file " ++ path+        ++ maybe "" (\n -> ":" ++ show n) line ++ ":\n" ++ msg++-- | Try to load the given package environment file, exiting with error if it+-- doesn't exist. Also returns the path to the sandbox directory. The path+-- parameter should refer to an existing file.+tryLoadSandboxPackageEnvironmentFile :: Verbosity -> FilePath -> (Flag FilePath)+                                        -> IO (FilePath, PackageEnvironment)+tryLoadSandboxPackageEnvironmentFile verbosity pkgEnvFile configFileFlag = do+  let pkgEnvDir = takeDirectory pkgEnvFile+  minp   <- readPackageEnvironmentFile mempty pkgEnvFile+  pkgEnv <- handleParseResult verbosity pkgEnvFile minp++  -- Get the saved sandbox directory.+  -- TODO: Use substPathTemplate with compilerTemplateEnv ++ platformTemplateEnv.+  let sandboxDir = fromFlagOrDefault defaultSandboxLocation+                   . fmap fromPathTemplate . prefix . savedUserInstallDirs+                   . pkgEnvSavedConfig $ pkgEnv++  -- Do some sanity checks+  dirExists            <- doesDirectoryExist sandboxDir+  -- TODO: Also check for an initialised package DB?+  unless dirExists $+    die ("No sandbox exists at " ++ sandboxDir)+  info verbosity $ "Using a sandbox located at " ++ sandboxDir++  let base   = basePackageEnvironment+  let common = commonPackageEnvironment sandboxDir+  user      <- userPackageEnvironment verbosity pkgEnvDir+  inherited <- inheritedPackageEnvironment verbosity user++  -- Layer the package environment settings over settings from ~/.cabal/config.+  cabalConfig <- loadConfig verbosity configFileFlag NoFlag+  return (sandboxDir,+          updateInstallDirs $+          (base `mappend` (toPkgEnv cabalConfig) `mappend`+           common `mappend` inherited `mappend` user)+          `overrideSandboxSettings` pkgEnv)+    where+      toPkgEnv config = mempty { pkgEnvSavedConfig = config }++      updateInstallDirs pkgEnv =+        let config         = pkgEnvSavedConfig pkgEnv+            configureFlags = savedConfigureFlags config+            installDirs    = savedUserInstallDirs config+        in pkgEnv {+          pkgEnvSavedConfig = config {+             savedConfigureFlags = configureFlags {+                configInstallDirs = installDirs+                }+             }+          }++-- | Should the generated package environment file include comments?+data IncludeComments = IncludeComments | NoComments++-- | Create a new package environment file, replacing the existing one if it+-- exists. Note that the path parameters should point to existing directories.+createPackageEnvironmentFile :: Verbosity -> FilePath -> FilePath+                                -> IncludeComments+                                -> Compiler+                                -> Platform+                                -> IO ()+createPackageEnvironmentFile verbosity sandboxDir pkgEnvFile incComments+  compiler platform = do+  notice verbosity $ "Writing a default package environment file to "+    ++ pkgEnvFile++  commentPkgEnv <- commentPackageEnvironment sandboxDir+  initialPkgEnv <- initialPackageEnvironment sandboxDir compiler platform+  writePackageEnvironmentFile pkgEnvFile incComments commentPkgEnv initialPkgEnv++-- | Descriptions of all fields in the package environment file.+pkgEnvFieldDescrs :: [FieldDescr PackageEnvironment]+pkgEnvFieldDescrs = [+  simpleField "inherit"+    (fromFlagOrDefault Disp.empty . fmap Disp.text) (optional parseFilePathQ)+    pkgEnvInherit (\v pkgEnv -> pkgEnv { pkgEnvInherit = v })++    -- FIXME: Should we make these fields part of ~/.cabal/config ?+  , commaListField "constraints"+    Text.disp Text.parse+    (configExConstraints . savedConfigureExFlags . pkgEnvSavedConfig)+    (\v pkgEnv -> updateConfigureExFlags pkgEnv+                  (\flags -> flags { configExConstraints = v }))++  , commaListField "preferences"+    Text.disp Text.parse+    (configPreferences . savedConfigureExFlags . pkgEnvSavedConfig)+    (\v pkgEnv -> updateConfigureExFlags pkgEnv+                  (\flags -> flags { configPreferences = v }))+  ]+  ++ map toPkgEnv configFieldDescriptions'+  where+    optional = Parse.option mempty . fmap toFlag++    configFieldDescriptions' :: [FieldDescr SavedConfig]+    configFieldDescriptions' = filter+      (\(FieldDescr name _ _) -> name /= "preference" && name /= "constraint")+      configFieldDescriptions++    toPkgEnv :: FieldDescr SavedConfig -> FieldDescr PackageEnvironment+    toPkgEnv fieldDescr =+      liftField pkgEnvSavedConfig+      (\savedConfig pkgEnv -> pkgEnv { pkgEnvSavedConfig = savedConfig})+      fieldDescr++    updateConfigureExFlags :: PackageEnvironment+                              -> (ConfigExFlags -> ConfigExFlags)+                              -> PackageEnvironment+    updateConfigureExFlags pkgEnv f = pkgEnv {+      pkgEnvSavedConfig = (pkgEnvSavedConfig pkgEnv) {+         savedConfigureExFlags = f . savedConfigureExFlags . pkgEnvSavedConfig+                                 $ pkgEnv+         }+      }++-- | Read the package environment file.+readPackageEnvironmentFile :: PackageEnvironment -> FilePath+                              -> IO (Maybe (ParseResult PackageEnvironment))+readPackageEnvironmentFile initial file =+  handleNotExists $+  fmap (Just . parsePackageEnvironment initial) (readFile file)+  where+    handleNotExists action = catchIO action $ \ioe ->+      if isDoesNotExistError ioe+        then return Nothing+        else ioError ioe++-- | Parse the package environment file.+parsePackageEnvironment :: PackageEnvironment -> String+                           -> ParseResult PackageEnvironment+parsePackageEnvironment initial str = do+  fields <- readFields str+  let (knownSections, others) = partition isKnownSection fields+  pkgEnv <- parse others+  let config       = pkgEnvSavedConfig pkgEnv+      installDirs0 = savedUserInstallDirs config+  -- 'install-dirs' is the only section that we care about.+  installDirs <- foldM parseSection installDirs0 knownSections+  return pkgEnv {+    pkgEnvSavedConfig = config {+       savedUserInstallDirs   = installDirs,+       savedGlobalInstallDirs = installDirs+       }+    }++  where+    isKnownSection :: ParseUtils.Field -> Bool+    isKnownSection (ParseUtils.Section _ "install-dirs" _ _) = True+    isKnownSection _                                         = False++    parse :: [ParseUtils.Field] -> ParseResult PackageEnvironment+    parse = parseFields pkgEnvFieldDescrs initial++    parseSection :: InstallDirs (Flag PathTemplate)+                    -> ParseUtils.Field+                    -> ParseResult (InstallDirs (Flag PathTemplate))+    parseSection accum (ParseUtils.Section line "install-dirs" name fs)+      | name' == "" = do accum' <- parseFields installDirsFields accum fs+                         return accum'+      | otherwise   =+        syntaxError line $+        "Named 'install-dirs' section: '" ++ name+        ++ "'. Note that named 'install-dirs' sections are not allowed in the '"+        ++ userPackageEnvironmentFile ++ "' file."+      where name' = lowercase name+    parseSection _accum f =+      syntaxError (lineNo f)  "Unrecognized stanza."++-- | Write out the package environment file.+writePackageEnvironmentFile :: FilePath -> IncludeComments+                               -> PackageEnvironment -> PackageEnvironment+                               -> IO ()+writePackageEnvironmentFile path incComments comments pkgEnv = do+  let tmpPath = (path <.> "tmp")+  writeFile tmpPath $ explanation ++ pkgEnvStr ++ "\n"+  renameFile tmpPath path+  where+    pkgEnvStr = case incComments of+      IncludeComments -> showPackageEnvironmentWithComments+                         (Just comments) pkgEnv+      NoComments      -> showPackageEnvironment pkgEnv+    explanation = unlines+      ["-- This is a Cabal package environment file."+      ,"-- THIS FILE IS AUTO-GENERATED. DO NOT EDIT DIRECTLY."+      ,"-- Please create a 'cabal.config' file in the same directory"+      ,"-- if you want to change the default settings for this sandbox."+      ,"",""+      ]++-- | Pretty-print the package environment.+showPackageEnvironment :: PackageEnvironment -> String+showPackageEnvironment pkgEnv = showPackageEnvironmentWithComments Nothing pkgEnv++-- | Pretty-print the package environment with default values for empty fields+-- commented out (just like the default ~/.cabal/config).+showPackageEnvironmentWithComments :: (Maybe PackageEnvironment)+                                      -> PackageEnvironment+                                      -> String+showPackageEnvironmentWithComments mdefPkgEnv pkgEnv = Disp.render $+      ppFields pkgEnvFieldDescrs mdefPkgEnv pkgEnv+  $+$ Disp.text ""+  $+$ ppSection "install-dirs" "" installDirsFields+                (fmap installDirsSection mdefPkgEnv) (installDirsSection pkgEnv)+  where+    installDirsSection = savedUserInstallDirs . pkgEnvSavedConfig
+ Distribution/Client/Sandbox/Timestamp.hs view
@@ -0,0 +1,288 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Sandbox.Timestamp+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- Timestamp file handling (for add-source dependencies).+-----------------------------------------------------------------------------++module Distribution.Client.Sandbox.Timestamp (+  AddSourceTimestamp,+  withAddTimestamps,+  withRemoveTimestamps,+  withUpdateTimestamps,+  maybeAddCompilerTimestampRecord,+  isDepModified,+  listModifiedDeps,+  ) where++import Control.Monad                                 (filterM, forM, when)+import Data.Char                                     (isSpace)+import Data.List                                     (partition)+import System.Directory                              (renameFile)+import System.FilePath                               ((<.>), (</>))+import qualified Data.Map as M++import Distribution.Compiler                         (CompilerId)+import Distribution.Package                          (packageName)+import Distribution.PackageDescription.Configuration (flattenPackageDescription)+import Distribution.PackageDescription.Parse         (readPackageDescription)+import Distribution.Simple.Setup                     (Flag (..),+                                                      SDistFlags (..),+                                                      defaultSDistFlags,+                                                      sdistCommand)+import Distribution.Simple.Utils                     (debug, die,+                                                      findPackageDesc, warn)+import Distribution.System                           (Platform)+import Distribution.Text                             (display)+import Distribution.Verbosity                        (Verbosity, lessVerbose,+                                                      normal)+import Distribution.Version                          (Version (..),+                                                      orLaterVersion)++import Distribution.Client.Sandbox.Index+  (ListIgnoredBuildTreeRefs (DontListIgnored), RefTypesToList(OnlyLinks)+  ,listBuildTreeRefs)+import Distribution.Client.SetupWrapper              (SetupScriptOptions (..),+                                                      defaultSetupScriptOptions,+                                                      setupWrapper)+import Distribution.Client.Utils                     (inDir, removeExistingFile,+                                                      tryCanonicalizePath)++import Distribution.Compat.Exception                 (catchIO)+import Distribution.Client.Compat.Time               (EpochTime, getCurTime,+                                                      getModTime)+++-- | Timestamp of an add-source dependency.+type AddSourceTimestamp  = (FilePath, EpochTime)+-- | Timestamp file record - a string identifying the compiler & platform plus a+-- list of add-source timestamps.+type TimestampFileRecord = (String, [AddSourceTimestamp])++timestampRecordKey :: CompilerId -> Platform -> String+timestampRecordKey compId platform = display platform ++ "-" ++ display compId++-- | The 'add-source-timestamps' file keeps the timestamps of all add-source+-- dependencies. It is initially populated by 'sandbox add-source' and kept+-- current by 'reinstallAddSourceDeps' and 'configure -w'. The user can install+-- add-source deps manually with 'cabal install' after having edited them, so we+-- can err on the side of caution sometimes.+-- FIXME: We should keep this info in the index file, together with build tree+-- refs.+timestampFileName :: FilePath+timestampFileName = "add-source-timestamps"++-- | Read the timestamp file. Exits with error if the timestamp file is+-- corrupted. Returns an empty list if the file doesn't exist.+readTimestampFile :: FilePath -> IO [TimestampFileRecord]+readTimestampFile timestampFile = do+  timestampString <- readFile timestampFile `catchIO` \_ -> return "[]"+  case reads timestampString of+    [(timestamps, s)] | all isSpace s -> return timestamps+    _                                 ->+      die $ "The timestamps file is corrupted. "+      ++ "Please delete & recreate the sandbox."++-- | Write the timestamp file, atomically.+writeTimestampFile :: FilePath -> [TimestampFileRecord] -> IO ()+writeTimestampFile timestampFile timestamps = do+  writeFile  timestampTmpFile (show timestamps)+  renameFile timestampTmpFile timestampFile+  where+    timestampTmpFile = timestampFile <.> "tmp"++-- | Read, process and write the timestamp file in one go.+withTimestampFile :: FilePath+                     -> ([TimestampFileRecord] -> IO [TimestampFileRecord])+                     -> IO ()+withTimestampFile sandboxDir process = do+  let timestampFile = sandboxDir </> timestampFileName+  timestampRecords <- readTimestampFile timestampFile >>= process+  writeTimestampFile timestampFile timestampRecords++-- | Given a list of 'AddSourceTimestamp's, a list of paths to add-source deps+-- we've added and an initial timestamp, add an 'AddSourceTimestamp' to the list+-- for each path. If a timestamp for a given path already exists in the list,+-- update it.+addTimestamps :: EpochTime -> [AddSourceTimestamp] -> [FilePath]+                 -> [AddSourceTimestamp]+addTimestamps initial timestamps newPaths =+  [ (p, initial) | p <- newPaths ] ++ oldTimestamps+  where+    (oldTimestamps, _toBeUpdated) =+      partition (\(path, _) -> path `notElem` newPaths) timestamps++-- | Given a list of 'AddSourceTimestamp's, a list of paths to add-source deps+-- we've reinstalled and a new timestamp value, update the timestamp value for+-- the deps in the list. If there are new paths in the list, ignore them.+updateTimestamps :: [AddSourceTimestamp] -> [FilePath] -> EpochTime+                    -> [AddSourceTimestamp]+updateTimestamps timestamps pathsToUpdate newTimestamp =+  foldr updateTimestamp [] timestamps+  where+    updateTimestamp t@(path, _oldTimestamp) rest+      | path `elem` pathsToUpdate = (path, newTimestamp) : rest+      | otherwise                 = t : rest++-- | Given a list of 'TimestampFileRecord's and a list of paths to add-source+-- deps we've removed, remove those deps from the list.+removeTimestamps :: [AddSourceTimestamp] -> [FilePath] -> [AddSourceTimestamp]+removeTimestamps l pathsToRemove = foldr removeTimestamp [] l+  where+    removeTimestamp t@(path, _oldTimestamp) rest =+      if path `elem` pathsToRemove+      then rest+      else t : rest++-- | If a timestamp record for this compiler doesn't exist, add a new one.+maybeAddCompilerTimestampRecord :: Verbosity -> FilePath -> FilePath+                                   -> CompilerId -> Platform+                                   -> IO ()+maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile+                                compId platform = do+  buildTreeRefs <- listBuildTreeRefs verbosity DontListIgnored OnlyLinks+                                     indexFile+  withTimestampFile sandboxDir $ \timestampRecords -> do+    let key = timestampRecordKey compId platform+    case lookup key timestampRecords of+      Just _  -> return timestampRecords+      Nothing -> do now <- getCurTime+                    let timestamps = map (\p -> (p, now)) buildTreeRefs+                    return $ (key, timestamps):timestampRecords++-- | Given an IO action that returns a list of build tree refs, add those+-- build tree refs to the timestamps file (for all compilers).+withAddTimestamps :: FilePath -> IO [FilePath] -> IO ()+withAddTimestamps sandboxDir act = do+  let initialTimestamp = 0+  withActionOnAllTimestamps (addTimestamps initialTimestamp) sandboxDir act++-- | Given an IO action that returns a list of build tree refs, remove those+-- build tree refs from the timestamps file (for all compilers).+withRemoveTimestamps :: FilePath -> IO [FilePath] -> IO ()+withRemoveTimestamps = withActionOnAllTimestamps removeTimestamps++-- | Given an IO action that returns a list of build tree refs, update the+-- timestamps of the returned build tree refs to the current time (only for the+-- given compiler & platform).+withUpdateTimestamps :: FilePath -> CompilerId -> Platform+                        ->([AddSourceTimestamp] -> IO [FilePath])+                        -> IO ()+withUpdateTimestamps =+  withActionOnCompilerTimestamps updateTimestamps++-- | Helper for implementing 'withAddTimestamps' and+-- 'withRemoveTimestamps'. Runs a given action on the list of+-- 'AddSourceTimestamp's for all compilers, applies 'f' to the result and then+-- updates the timestamp file. The IO action is run only once.+withActionOnAllTimestamps :: ([AddSourceTimestamp] -> [FilePath]+                              -> [AddSourceTimestamp])+                             -> FilePath+                             -> IO [FilePath]+                             -> IO ()+withActionOnAllTimestamps f sandboxDir act =+  withTimestampFile sandboxDir $ \timestampRecords -> do+    paths <- act+    return [(key, f timestamps paths) | (key, timestamps) <- timestampRecords]++-- | Helper for implementing 'withUpdateTimestamps'. Runs a given action on the+-- list of 'AddSourceTimestamp's for this compiler, applies 'f' to the result+-- and then updates the timestamp file record. The IO action is run only once.+withActionOnCompilerTimestamps :: ([AddSourceTimestamp]+                                   -> [FilePath] -> EpochTime+                                   -> [AddSourceTimestamp])+                                  -> FilePath+                                  -> CompilerId+                                  -> Platform+                                  -> ([AddSourceTimestamp] -> IO [FilePath])+                                  -> IO ()+withActionOnCompilerTimestamps f sandboxDir compId platform act = do+  let needle = timestampRecordKey compId platform+  withTimestampFile sandboxDir $ \timestampRecords -> do+    timestampRecords' <- forM timestampRecords $ \r@(key, timestamps) ->+      if key == needle+      then do paths <- act timestamps+              now   <- getCurTime+              return (key, f timestamps paths now)+      else return r+    return timestampRecords'++-- | List all source files of a given add-source dependency. Exits with error if+-- something is wrong (e.g. there is no .cabal file in the given directory).+-- FIXME: This function is not thread-safe because of 'inDir'.+allPackageSourceFiles :: Verbosity -> FilePath -> IO [FilePath]+allPackageSourceFiles verbosity packageDir = inDir (Just packageDir) $ do+  pkg <- fmap (flattenPackageDescription)+         . readPackageDescription verbosity =<< findPackageDesc packageDir++  let file      = "cabal-sdist-list-sources"+      flags     = defaultSDistFlags {+        sDistVerbosity   = Flag $ if verbosity == normal+                                  then lessVerbose verbosity else verbosity,+        sDistListSources = Flag file+        }+      setupOpts = defaultSetupScriptOptions {+        -- 'sdist --list-sources' was introduced in Cabal 1.18.+        useCabalVersion = orLaterVersion $ Version [1,18,0] []+        }++      doListSources :: IO [FilePath]+      doListSources = do+        setupWrapper verbosity setupOpts (Just pkg) sdistCommand (const flags) []+        srcs <- fmap lines . readFile $ file+        mapM tryCanonicalizePath srcs++      onFailedListSources :: IO ()+      onFailedListSources = warn verbosity $+          "Could not list sources of the add-source dependency '"+          ++ display (packageName pkg) ++ "'. Skipping the timestamp check."++  -- Run setup sdist --list-sources=TMPFILE+  ret <- doListSources `catchIO` (\_ -> onFailedListSources >> return [])+  removeExistingFile file+  return ret++-- | Has this dependency been modified since we have last looked at it?+isDepModified :: Verbosity -> EpochTime -> AddSourceTimestamp -> IO Bool+isDepModified verbosity now (packageDir, timestamp) = do+  debug verbosity ("Checking whether the dependency is modified: " ++ packageDir)+  depSources <- allPackageSourceFiles verbosity packageDir+  go depSources++  where+    go []         = return False+    go (dep:rest) = do+      -- FIXME: What if the clock jumps backwards at any point? For now we only+      -- print a warning.+      modTime <- getModTime dep+      when (modTime > now) $+        warn verbosity $ "File '" ++ dep+                         ++ "' has a modification time that is in the future."+      if modTime >= timestamp+        then do+          debug verbosity ("Dependency has a modified source file: " ++ dep)+          return True+        else go rest++-- | List all modified dependencies.+listModifiedDeps :: Verbosity -> FilePath -> CompilerId -> Platform+                    -> M.Map FilePath a+                       -- ^ The set of all installed add-source deps.+                    -> IO [FilePath]+listModifiedDeps verbosity sandboxDir compId platform installedDepsMap = do+  timestampRecords <- readTimestampFile (sandboxDir </> timestampFileName)+  let needle        = timestampRecordKey compId platform+  timestamps       <- maybe noTimestampRecord return+                      (lookup needle timestampRecords)+  now <- getCurTime+  fmap (map fst) . filterM (isDepModified verbosity now)+    . filter (\ts -> fst ts `M.member` installedDepsMap)+    $ timestamps++  where+    noTimestampRecord = die $ "Сouldn't find a timestamp record for the given "+                        ++ "compiler/platform pair. "+                        ++ "Please report this on the Cabal bug tracker: "+                        ++ "https://github.com/haskell/cabal/issues/new ."
+ Distribution/Client/Sandbox/Types.hs view
@@ -0,0 +1,61 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Sandbox.Types+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- Helpers for writing code that works both inside and outside a sandbox.+-----------------------------------------------------------------------------++module Distribution.Client.Sandbox.Types (+  UseSandbox(..), isUseSandbox, whenUsingSandbox,+  SandboxPackageInfo(..)+  ) where++import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex+import Distribution.Client.Types (SourcePackage)++import Data.Monoid+import qualified Data.Set as S++-- | Are we using a sandbox?+data UseSandbox = UseSandbox FilePath | NoSandbox++instance Monoid UseSandbox where+  mempty = NoSandbox++  NoSandbox        `mappend` s                  = s+  u0@(UseSandbox _) `mappend` NoSandbox         = u0+  (UseSandbox   _)  `mappend` u1@(UseSandbox _) = u1++-- | Convert a @UseSandbox@ value to a boolean. Useful in conjunction with+-- @when@.+isUseSandbox :: UseSandbox -> Bool+isUseSandbox (UseSandbox _) = True+isUseSandbox NoSandbox      = False++-- | Execute an action only if we're in a sandbox, feeding to it the path to the+-- sandbox directory.+whenUsingSandbox :: UseSandbox -> (FilePath -> IO ()) -> IO ()+whenUsingSandbox NoSandbox               _   = return ()+whenUsingSandbox (UseSandbox sandboxDir) act = act sandboxDir++-- | Data about the packages installed in the sandbox that is passed from+-- 'reinstallAddSourceDeps' to the solver.+data SandboxPackageInfo = SandboxPackageInfo {+  modifiedAddSourceDependencies :: ![SourcePackage],+  -- ^ Modified add-source deps that we want to reinstall. These are guaranteed+  -- to be already installed in the sandbox.++  otherAddSourceDependencies    :: ![SourcePackage],+  -- ^ Remaining add-source deps. Some of these may be not installed in the+  -- sandbox.++  otherInstalledSandboxPackages :: !InstalledPackageIndex.PackageIndex,+  -- ^ All packages installed in the sandbox. Intersection with+  -- 'modifiedAddSourceDependencies' and/or 'otherAddSourceDependencies' can be+  -- non-empty.++  allAddSourceDependencies      :: !(S.Set FilePath)+  -- ^ A set of paths to all add-source dependencies, for convenience.+  }
Distribution/Client/Setup.hs view
@@ -15,18 +15,23 @@     , configureCommand, ConfigFlags(..), filterConfigureFlags     , configureExCommand, ConfigExFlags(..), defaultConfigExFlags                         , configureExOptions+    , buildCommand, BuildFlags(..), BuildExFlags(..), SkipAddSourceDepsCheck(..)+    , testCommand, benchmarkCommand     , installCommand, InstallFlags(..), installOptions, defaultInstallFlags     , listCommand, ListFlags(..)     , updateCommand     , upgradeCommand     , infoCommand, InfoFlags(..)     , fetchCommand, FetchFlags(..)+    , getCommand, unpackCommand, GetFlags(..)     , checkCommand     , uploadCommand, UploadFlags(..)     , reportCommand, ReportFlags(..)-    , unpackCommand, UnpackFlags(..)+    , runCommand     , initCommand, IT.InitFlags(..)     , sdistCommand, SDistFlags(..), SDistExFlags(..), ArchiveFormat(..)+    , win32SelfUpgradeCommand, Win32SelfUpgradeFlags(..)+    , sandboxCommand, defaultSandboxLocation, SandboxFlags(..)      , parsePackageArgs     --TODO: stop exporting these:@@ -49,18 +54,20 @@          ( defaultProgramConfiguration ) import Distribution.Simple.Command hiding (boolOpt) import qualified Distribution.Simple.Setup as Cabal-         ( configureCommand, sdistCommand, haddockCommand ) import Distribution.Simple.Setup-         ( ConfigFlags(..), SDistFlags(..), HaddockFlags(..) )-import Distribution.Simple.Setup-         ( Flag(..), toFlag, fromFlag, flagToMaybe, flagToList+         ( ConfigFlags(..), BuildFlags(..), TestFlags(..), BenchmarkFlags(..)+         , SDistFlags(..), HaddockFlags(..)+         , Flag(..), toFlag, fromFlag, flagToMaybe, flagToList          , optionVerbosity, boolOpt, trueArg, falseArg ) import Distribution.Simple.InstallDirs-         ( PathTemplate, toPathTemplate, fromPathTemplate )+         ( PathTemplate, InstallDirs(sysconfdir)+         , toPathTemplate, fromPathTemplate ) import Distribution.Version          ( Version(Version), anyVersion, thisVersion ) import Distribution.Package          ( PackageIdentifier, packageName, packageVersion, Dependency(..) )+import Distribution.PackageDescription+         ( RepoKind(..) ) import Distribution.Text          ( Text(..), display ) import Distribution.ReadE@@ -93,26 +100,28 @@  -- | Flags that apply at the top level, not to any sub-command. data GlobalFlags = GlobalFlags {-    globalVersion        :: Flag Bool,-    globalNumericVersion :: Flag Bool,-    globalConfigFile     :: Flag FilePath,-    globalRemoteRepos    :: [RemoteRepo],     -- ^ Available Hackage servers.-    globalCacheDir       :: Flag FilePath,-    globalLocalRepos     :: [FilePath],-    globalLogsDir        :: Flag FilePath,-    globalWorldFile      :: Flag FilePath+    globalVersion           :: Flag Bool,+    globalNumericVersion    :: Flag Bool,+    globalConfigFile        :: Flag FilePath,+    globalSandboxConfigFile :: Flag FilePath,+    globalRemoteRepos       :: [RemoteRepo],     -- ^ Available Hackage servers.+    globalCacheDir          :: Flag FilePath,+    globalLocalRepos        :: [FilePath],+    globalLogsDir           :: Flag FilePath,+    globalWorldFile         :: Flag FilePath   }  defaultGlobalFlags :: GlobalFlags defaultGlobalFlags  = GlobalFlags {-    globalVersion        = Flag False,-    globalNumericVersion = Flag False,-    globalConfigFile     = mempty,-    globalRemoteRepos    = [],-    globalCacheDir       = mempty,-    globalLocalRepos     = mempty,-    globalLogsDir        = mempty,-    globalWorldFile      = mempty+    globalVersion           = Flag False,+    globalNumericVersion    = Flag False,+    globalConfigFile        = mempty,+    globalSandboxConfigFile = mempty,+    globalRemoteRepos       = [],+    globalCacheDir          = mempty,+    globalLocalRepos        = mempty,+    globalLogsDir           = mempty,+    globalWorldFile         = mempty   }  globalCommand :: CommandUI GlobalFlags@@ -132,7 +141,7 @@       ++ "  " ++ pname ++ " update\n",     commandDefaultFlags = defaultGlobalFlags,     commandOptions      = \showOrParseArgs ->-      (case showOrParseArgs of ShowArgs -> take 2; ParseArgs -> id)+      (case showOrParseArgs of ShowArgs -> take 4; ParseArgs -> id)       [option ['V'] ["version"]          "Print version information"          globalVersion (\v flags -> flags { globalVersion = v })@@ -148,6 +157,12 @@          globalConfigFile (\v flags -> flags { globalConfigFile = v })          (reqArgFlag "FILE") +      ,option [] ["sandbox-config-file"]+         "Set an alternate location for the sandbox config file \+         (default: './cabal.sandbox.config')"+         globalConfigFile (\v flags -> flags { globalSandboxConfigFile = v })+         (reqArgFlag "FILE")+       ,option [] ["remote-repo"]          "The name and url for a remote repository"          globalRemoteRepos (\v flags -> flags { globalRemoteRepos = v })@@ -177,24 +192,26 @@  instance Monoid GlobalFlags where   mempty = GlobalFlags {-    globalVersion        = mempty,-    globalNumericVersion = mempty,-    globalConfigFile     = mempty,-    globalRemoteRepos    = mempty,-    globalCacheDir       = mempty,-    globalLocalRepos     = mempty,-    globalLogsDir        = mempty,-    globalWorldFile      = mempty+    globalVersion           = mempty,+    globalNumericVersion    = mempty,+    globalConfigFile        = mempty,+    globalSandboxConfigFile = mempty,+    globalRemoteRepos       = mempty,+    globalCacheDir          = mempty,+    globalLocalRepos        = mempty,+    globalLogsDir           = mempty,+    globalWorldFile         = mempty   }   mappend a b = GlobalFlags {-    globalVersion        = combine globalVersion,-    globalNumericVersion = combine globalNumericVersion,-    globalConfigFile     = combine globalConfigFile,-    globalRemoteRepos    = combine globalRemoteRepos,-    globalCacheDir       = combine globalCacheDir,-    globalLocalRepos     = combine globalLocalRepos,-    globalLogsDir        = combine globalLogsDir,-    globalWorldFile      = combine globalWorldFile+    globalVersion           = combine globalVersion,+    globalNumericVersion    = combine globalNumericVersion,+    globalConfigFile        = combine globalConfigFile,+    globalSandboxConfigFile = combine globalConfigFile,+    globalRemoteRepos       = combine globalRemoteRepos,+    globalCacheDir          = combine globalCacheDir,+    globalLocalRepos        = combine globalLocalRepos,+    globalLogsDir           = combine globalLogsDir,+    globalWorldFile         = combine globalWorldFile   }     where combine field = field a `mappend` field b @@ -224,10 +241,26 @@  filterConfigureFlags :: ConfigFlags -> Version -> ConfigFlags filterConfigureFlags flags cabalLibVersion-  | cabalLibVersion >= Version [1,3,10] [] = flags-    -- older Cabal does not grok the constraints flag:-  | otherwise = flags { configConstraints = [] }+  | cabalLibVersion >= Version [1,18,0] [] = flags+  | cabalLibVersion <  Version [1,3,10] [] = flags_1_3_10+  | cabalLibVersion <  Version [1,10,0] [] = flags_1_10_0+  | cabalLibVersion <  Version [1,14,0] [] = flags_1_14_0+  | cabalLibVersion <  Version [1,18,0] [] = flags_1_18_0 +  -- A no-op that silences the "pattern match is non-exhaustive" warning.+  | otherwise = flags+  where+    -- Cabal < 1.18.0 doesn't know about --extra-prog-path and --sysconfdir.+    flags_1_18_0 = flags        { configProgramPathExtra = []+                                , configInstallDirs = configInstallDirs_1_18_0}+    configInstallDirs_1_18_0 = (configInstallDirs flags) { sysconfdir = NoFlag }+    -- Cabal < 1.14.0 doesn't know about --disable-benchmarks.+    flags_1_14_0 = flags_1_18_0 { configBenchmarks  = NoFlag }+    -- Cabal < 1.10.0 doesn't know about --disable-tests.+    flags_1_10_0 = flags_1_14_0 { configTests       = NoFlag }+    -- Cabal < 1.3.10 does not grok the constraints flag.+    flags_1_3_10 = flags_1_10_0 { configConstraints = [] }+ -- ------------------------------------------------------------ -- * Config extra flags -- ------------------------------------------------------------@@ -299,6 +332,99 @@     where combine field = field a `mappend` field b  -- ------------------------------------------------------------+-- * Build flags+-- ------------------------------------------------------------++data SkipAddSourceDepsCheck =+  SkipAddSourceDepsCheck | DontSkipAddSourceDepsCheck+  deriving Eq++data BuildExFlags = BuildExFlags {+  buildNumJobs  :: Flag (Maybe Int),+  buildOnly     :: Flag SkipAddSourceDepsCheck+}++buildExOptions :: ShowOrParseArgs -> [OptionField BuildExFlags]+buildExOptions _showOrParseArgs =+  option "j" ["jobs"]+  "Run NUM jobs simultaneously (or '$ncpus' if no NUM is given)"+  buildNumJobs (\v flags -> flags { buildNumJobs = v })+  (optArg "NUM" (fmap Flag numJobsParser)+   (Flag Nothing)+   (map (Just . maybe "$ncpus" show) . flagToList))++  : option [] ["only"]+  "Don't reinstall add-source dependencies (sandbox-only)"+  buildOnly (\v flags -> flags { buildOnly = v })+  (noArg (Flag SkipAddSourceDepsCheck))++  : []++buildCommand :: CommandUI (BuildFlags, BuildExFlags)+buildCommand = parent {+    commandDefaultFlags = (commandDefaultFlags parent, mempty),+    commandOptions      =+      \showOrParseArgs -> liftOptions fst setFst+                          (commandOptions parent showOrParseArgs)+                          +++                          liftOptions snd setSnd (buildExOptions showOrParseArgs)+  }+  where+    setFst a (_,b) = (a,b)+    setSnd b (a,_) = (a,b)++    parent = Cabal.buildCommand defaultProgramConfiguration++instance Monoid BuildExFlags where+  mempty = BuildExFlags {+    buildNumJobs = mempty,+    buildOnly    = mempty+  }+  mappend a b = BuildExFlags {+    buildNumJobs = combine buildNumJobs,+    buildOnly    = combine buildOnly+  }+    where combine field = field a `mappend` field b++-- ------------------------------------------------------------+-- * Test command+-- ------------------------------------------------------------++testCommand :: CommandUI (TestFlags, BuildExFlags)+testCommand = parent {+  commandDefaultFlags = (commandDefaultFlags parent, mempty),+  commandOptions      =+    \showOrParseArgs -> liftOptions fst setFst+                        (commandOptions parent showOrParseArgs)+                        +++                        liftOptions snd setSnd (buildExOptions showOrParseArgs)+  }+  where+    setFst a (_,b) = (a,b)+    setSnd b (a,_) = (a,b)++    parent = Cabal.testCommand++-- ------------------------------------------------------------+-- * Bench command+-- ------------------------------------------------------------++benchmarkCommand :: CommandUI (BenchmarkFlags, BuildExFlags)+benchmarkCommand = parent {+  commandDefaultFlags = (commandDefaultFlags parent, mempty),+  commandOptions      =+    \showOrParseArgs -> liftOptions fst setFst+                        (commandOptions parent showOrParseArgs)+                        +++                        liftOptions snd setSnd (buildExOptions showOrParseArgs)+  }+  where+    setFst a (_,b) = (a,b)+    setSnd b (a,_) = (a,b)++    parent = Cabal.benchmarkCommand++-- ------------------------------------------------------------ -- * Fetch command -- ------------------------------------------------------------ @@ -375,9 +501,9 @@ updateCommand  :: CommandUI (Flag Verbosity) updateCommand = CommandUI {     commandName         = "update",-    commandSynopsis     = "Updates list of known packages",+    commandSynopsis     = "Updates list of known packages.",     commandDescription  = Nothing,-    commandUsage        = usagePackages "update",+    commandUsage        = usageFlags "update",     commandDefaultFlags = toFlag normal,     commandOptions      = \_ -> [optionVerbosity id const]   }@@ -387,7 +513,7 @@     commandName         = "upgrade",     commandSynopsis     = "(command disabled, use install instead)",     commandDescription  = Nothing,-    commandUsage        = usagePackages "upgrade",+    commandUsage        = usageFlagsOrPackages "upgrade",     commandDefaultFlags = (mempty, mempty, mempty, mempty),     commandOptions      = commandOptions installCommand   }@@ -406,13 +532,36 @@ checkCommand  :: CommandUI (Flag Verbosity) checkCommand = CommandUI {     commandName         = "check",-    commandSynopsis     = "Check the package for common mistakes",+    commandSynopsis     = "Check the package for common mistakes.",     commandDescription  = Nothing,     commandUsage        = \pname -> "Usage: " ++ pname ++ " check\n",     commandDefaultFlags = toFlag normal,     commandOptions      = \_ -> []   } +runCommand :: CommandUI (BuildFlags, BuildExFlags)+runCommand = CommandUI {+    commandName         = "run",+    commandSynopsis     = "Runs the compiled executable.",+    commandDescription  = Nothing,+    commandUsage        =+      \pname -> "Usage: " ++ pname+                ++ " run [FLAGS] [EXECUTABLE] [-- EXECUTABLE_FLAGS]\n\n"+                ++ "Flags for run:",+    commandDefaultFlags = mempty,+    commandOptions      =+      \showOrParseArgs -> liftOptions fst setFst+                          (Cabal.buildOptions progConf showOrParseArgs)+                          +++                          liftOptions snd setSnd+                          (buildExOptions showOrParseArgs)+  }+  where+    setFst a (_,b) = (a,b)+    setSnd b (a,_) = (a,b)++    progConf = defaultProgramConfiguration+ -- ------------------------------------------------------------ -- * Report flags -- ------------------------------------------------------------@@ -470,52 +619,74 @@     where combine field = field a `mappend` field b  -- --------------------------------------------------------------- * Unpack flags+-- * Get flags -- ------------------------------------------------------------ -data UnpackFlags = UnpackFlags {-      unpackDestDir :: Flag FilePath,-      unpackVerbosity :: Flag Verbosity,-      unpackPristine :: Flag Bool-    }+data GetFlags = GetFlags {+    getDestDir          :: Flag FilePath,+    getPristine         :: Flag Bool,+    getSourceRepository :: Flag (Maybe RepoKind),+    getVerbosity        :: Flag Verbosity+  } -defaultUnpackFlags :: UnpackFlags-defaultUnpackFlags = UnpackFlags {-    unpackDestDir = mempty,-    unpackVerbosity = toFlag normal,-    unpackPristine  = toFlag False+defaultGetFlags :: GetFlags+defaultGetFlags = GetFlags {+    getDestDir          = mempty,+    getPristine         = mempty,+    getSourceRepository = mempty,+    getVerbosity        = toFlag normal    } -unpackCommand :: CommandUI UnpackFlags-unpackCommand = CommandUI {-    commandName         = "unpack",-    commandSynopsis     = "Unpacks packages for user inspection.",-    commandDescription  = Nothing,-    commandUsage        = usagePackages "unpack",+getCommand :: CommandUI GetFlags+getCommand = CommandUI {+    commandName         = "get",+    commandSynopsis     = "Gets a package's source code.",+    commandDescription  = Just $ \_ ->+          "Creates a local copy of a package's source code. By default it gets "+       ++ "the source\ntarball and unpacks it in a local subdirectory. "+       ++ "Alternatively, with -s it will\nget the code from the source "+       ++ "repository specified by the package.\n",+    commandUsage        = usagePackages "get",     commandDefaultFlags = mempty,     commandOptions      = \_ -> [-        optionVerbosity unpackVerbosity (\v flags -> flags { unpackVerbosity = v })+        optionVerbosity getVerbosity (\v flags -> flags { getVerbosity = v })         ,option "d" ["destdir"]-         "where to unpack the packages, defaults to the current directory."-         unpackDestDir (\v flags -> flags { unpackDestDir = v })+         "Where to place the package source, defaults to the current directory."+         getDestDir (\v flags -> flags { getDestDir = v })          (reqArgFlag "PATH") +       ,option "s" ["source-repository"]+         "Copy the package's source repository (ie git clone, darcs get, etc as appropriate)."+         getSourceRepository (\v flags -> flags { getSourceRepository = v })+        (optArg "[head|this|...]" (readP_to_E (const "invalid source-repository")+                                              (fmap (toFlag . Just) parse))+                                  (Flag Nothing)+                                  (map (fmap show) . flagToList))+        , option [] ["pristine"]            ("Unpack the original pristine tarball, rather than updating the "            ++ ".cabal file with the latest revision from the package archive.")-           unpackPristine (\v flags -> flags { unpackPristine = v })+           getPristine (\v flags -> flags { getPristine = v })            trueArg        ]   } -instance Monoid UnpackFlags where-  mempty = defaultUnpackFlags-  mappend a b = UnpackFlags {-    unpackDestDir   = combine unpackDestDir,-    unpackVerbosity = combine unpackVerbosity,-    unpackPristine  = combine unpackPristine+-- 'cabal unpack' is a deprecated alias for 'cabal get'.+unpackCommand :: CommandUI GetFlags+unpackCommand = getCommand {+  commandName  = "unpack",+  commandUsage = usagePackages "unpack"   }++instance Monoid GetFlags where+  mempty = defaultGetFlags+  mappend a b = GetFlags {+    getDestDir          = combine getDestDir,+    getPristine         = combine getPristine,+    getSourceRepository = combine getSourceRepository,+    getVerbosity        = combine getVerbosity+  }     where combine field = field a `mappend` field b  -- ------------------------------------------------------------@@ -540,7 +711,7 @@     commandName         = "list",     commandSynopsis     = "List packages matching a search string.",     commandDescription  = Nothing,-    commandUsage        = usagePackages "list",+    commandUsage        = usageFlagsOrPackages "list",     commandDefaultFlags = defaultListFlags,     commandOptions      = \_ -> [         optionVerbosity listVerbosity (\v flags -> flags { listVerbosity = v })@@ -667,7 +838,7 @@ installCommand = CommandUI {   commandName         = "install",   commandSynopsis     = "Installs a list of packages.",-  commandUsage        = usagePackages "install",+  commandUsage        = usageFlagsOrPackages "install",   commandDescription  = Just $ \pname ->     let original = case commandDescription configureCommand of           Just desc -> desc pname ++ "\n"@@ -696,18 +867,19 @@     get3 (_,_,c,_) = c; set3 c (a,b,_,d) = (a,b,c,d)     get4 (_,_,_,d) = d; set4 d (a,b,c,_) = (a,b,c,d) -    haddockOptions showOrParseArgs-      = [ opt { optionName = "haddock-" ++ name,-                optionDescr = [ fmapOptFlags (\(_, lflags) -> ([], map ("haddock-" ++) lflags)) descr-                              | descr <- optionDescr opt] }-        | opt <- commandOptions Cabal.haddockCommand showOrParseArgs-        , let name = optionName opt-        , name `elem` ["hoogle", "html", "html-location",-                       "executables", "internal", "css",-                       "hyperlink-source", "hscolour-css",-                       "contents-location"]-        ]-+haddockOptions :: ShowOrParseArgs -> [OptionField HaddockFlags]+haddockOptions showOrParseArgs+  = [ opt { optionName = "haddock-" ++ name,+            optionDescr = [ fmapOptFlags (\(_, lflags) -> ([], map ("haddock-" ++) lflags)) descr+                          | descr <- optionDescr opt] }+    | opt <- commandOptions Cabal.haddockCommand showOrParseArgs+    , let name = optionName opt+    , name `elem` ["hoogle", "html", "html-location",+                   "executables", "internal", "css",+                   "hyperlink-source", "hscolour-css",+                   "contents-location"]+    ]+  where     fmapOptFlags :: (OptFlags -> OptFlags) -> OptDescr a -> OptDescr a     fmapOptFlags modify (ReqArg d f p r w)    = ReqArg d (modify f) p r w     fmapOptFlags modify (OptArg d f p r i w)  = OptArg d (modify f) p r i w@@ -764,6 +936,11 @@           installOnlyDeps (\v flags -> flags { installOnlyDeps = v })           (yesNoOpt showOrParseArgs) +      , option [] ["dependencies-only"]+          "A synonym for --only-dependencies"+          installOnlyDeps (\v flags -> flags { installOnlyDeps = v })+          (yesNoOpt showOrParseArgs)+       , option [] ["root-cmd"]           "Command used to gain root privileges, when installing with --global."           installRootCmd (\v flags -> flags { installRootCmd = v })@@ -799,22 +976,21 @@           (yesNoOpt showOrParseArgs)        , option "j" ["jobs"]-        "Run NUM jobs simultaneously."+        "Run NUM jobs simultaneously (or '$ncpus' if no NUM is given)."         installNumJobs (\v flags -> flags { installNumJobs = v })-        (optArg "NUM" (readP_to_E (\_ -> "jobs should be a number")-                                  (fmap (toFlag . Just)-                                        (Parse.readS_to_P reads)))+        (optArg "NUM" (fmap Flag numJobsParser)                       (Flag Nothing)-                      (map (fmap show) . flagToList))-      ] ++ case showOrParseArgs of      -- TODO: remove when "cabal install" avoids+                      (map (Just . maybe "$ncpus" show) . flagToList))+      ] ++ case showOrParseArgs of      -- TODO: remove when "cabal install"+                                        -- avoids           ParseArgs ->-            option [] ["only"]+            [ option [] ["only"]               "Only installs the package in the current directory."               installOnly (\v flags -> flags { installOnly = v })-              trueArg-             : []+              trueArg ]           _ -> [] + instance Monoid InstallFlags where   mempty = InstallFlags {     installDocumentation   = mempty,@@ -884,7 +1060,7 @@ uploadCommand :: CommandUI UploadFlags uploadCommand = CommandUI {     commandName         = "upload",-    commandSynopsis     = "Uploads source packages to Hackage",+    commandSynopsis     = "Uploads source packages to Hackage.",     commandDescription  = Just $ \_ ->          "You can store your Hackage login in the ~/.cabal/config file\n",     commandUsage        = \pname ->@@ -976,6 +1152,11 @@         IT.minimal (\v flags -> flags { IT.minimal = v })         trueArg +      , option [] ["overwrite"]+        "Overwrite any existing .cabal, LICENSE, or Setup.hs files without warning."+        IT.overwrite (\v flags -> flags { IT.overwrite = v })+        trueArg+       , option [] ["package-dir"]         "Root directory of the package (default = current directory)."         IT.packageDir (\v flags -> flags { IT.packageDir = v })@@ -1033,6 +1214,12 @@         (reqArg' "CATEGORY" (\s -> toFlag $ maybe (Left s) Right (readMaybe s))                             (flagToList . fmap (either id show))) +      , option ['x'] ["extra-source-file"]+        "Extra source file to be distributed with tarball."+        IT.extraSrc (\v flags -> flags { IT.extraSrc = v })+        (reqArg' "FILE" (Just . (:[]))+                        (fromMaybe []))+       , option [] ["is-library"]         "Build a library."         IT.packageType (\v flags -> flags { IT.packageType = v })@@ -1044,20 +1231,36 @@         (\v flags -> flags { IT.packageType = v })         (noArg (Flag IT.Executable)) +      , option [] ["language"]+        "Specify the default language."+        IT.language+        (\v flags -> flags { IT.language = v })+        (reqArg "LANGUAGE" (readP_to_E ("Cannot parse language: "++)+                                       (toFlag `fmap` parse))+                          (flagToList . fmap display))+       , option ['o'] ["expose-module"]         "Export a module from the package."         IT.exposedModules         (\v flags -> flags { IT.exposedModules = v })         (reqArg "MODULE" (readP_to_E ("Cannot parse module name: "++)                                      ((Just . (:[])) `fmap` parse))-                         (fromMaybe [] . fmap (fmap display)))+                         (maybe [] (fmap display))) +      , option [] ["extension"]+        "Use a LANGUAGE extension (in the other-extensions field)."+        IT.otherExts+        (\v flags -> flags { IT.otherExts = v })+        (reqArg "EXTENSION" (readP_to_E ("Cannot parse extension: "++)+                                        ((Just . (:[])) `fmap` parse))+                            (maybe [] (fmap display)))+       , option ['d'] ["dependency"]         "Package dependency."         IT.dependencies (\v flags -> flags { IT.dependencies = v })         (reqArg "PACKAGE" (readP_to_E ("Cannot parse dependency: "++)                                       ((Just . (:[])) `fmap` parse))-                          (fromMaybe [] . fmap (fmap display)))+                          (maybe [] (fmap display)))        , option [] ["source-dir"]         "Directory containing package source."@@ -1130,6 +1333,121 @@       combine field = field a `mappend` field b  -- ------------------------------------------------------------+-- * Win32SelfUpgrade flags+-- ------------------------------------------------------------++data Win32SelfUpgradeFlags = Win32SelfUpgradeFlags {+  win32SelfUpgradeVerbosity :: Flag Verbosity+}++defaultWin32SelfUpgradeFlags :: Win32SelfUpgradeFlags+defaultWin32SelfUpgradeFlags = Win32SelfUpgradeFlags {+  win32SelfUpgradeVerbosity = toFlag normal+}++win32SelfUpgradeCommand :: CommandUI Win32SelfUpgradeFlags+win32SelfUpgradeCommand = CommandUI {+  commandName         = "win32selfupgrade",+  commandSynopsis     = "Self-upgrade the executable on Windows",+  commandDescription  = Nothing,+  commandUsage        = \pname ->+    "Usage: " ++ pname ++ " win32selfupgrade PID PATH\n\n"+     ++ "Flags for win32selfupgrade:",+  commandDefaultFlags = defaultWin32SelfUpgradeFlags,+  commandOptions      = \_ ->+      [optionVerbosity win32SelfUpgradeVerbosity+       (\v flags -> flags { win32SelfUpgradeVerbosity = v})+      ]+}++instance Monoid Win32SelfUpgradeFlags where+  mempty = defaultWin32SelfUpgradeFlags+  mappend a b = Win32SelfUpgradeFlags {+    win32SelfUpgradeVerbosity = combine win32SelfUpgradeVerbosity+  }+    where combine field = field a `mappend` field b++-- ------------------------------------------------------------+-- * Sandbox-related flags+-- ------------------------------------------------------------++data SandboxFlags = SandboxFlags {+  sandboxVerbosity :: Flag Verbosity,+  sandboxSnapshot  :: Flag Bool, -- FIXME: this should be an 'add-source'-only+                                 -- flag.+  sandboxLocation  :: Flag FilePath+}++defaultSandboxLocation :: FilePath+defaultSandboxLocation = ".cabal-sandbox"++defaultSandboxFlags :: SandboxFlags+defaultSandboxFlags = SandboxFlags {+  sandboxVerbosity = toFlag normal,+  sandboxSnapshot  = toFlag False,+  sandboxLocation  = toFlag defaultSandboxLocation+  }++sandboxCommand :: CommandUI SandboxFlags+sandboxCommand = CommandUI {+  commandName         = "sandbox",+  commandSynopsis     = "Create/modify/delete a sandbox.",+  commandDescription  = Nothing,+  commandUsage        = \pname ->+       "Usage: " ++ pname ++ " sandbox init\n"+    ++ "   or: " ++ pname ++ " sandbox delete\n"+    ++ "   or: " ++ pname ++ " sandbox add-source  [PATHS]\n\n"+    ++ "   or: " ++ pname ++ " sandbox hc-pkg      -- [ARGS]\n"+    ++ "   or: " ++ pname ++ " sandbox list-sources\n\n"+    ++ "Flags for sandbox:",++  commandDefaultFlags = defaultSandboxFlags,+  commandOptions      = \_ ->+    [ optionVerbosity sandboxVerbosity+      (\v flags -> flags { sandboxVerbosity = v })++    , option [] ["snapshot"]+      "Take a snapshot instead of creating a link (only applies to 'add-source')"+      sandboxSnapshot (\v flags -> flags { sandboxSnapshot = v })+      trueArg++    , option [] ["sandbox"]+      "Sandbox location (default: './.cabal-sandbox')."+      sandboxLocation (\v flags -> flags { sandboxLocation = v })+      (reqArgFlag "DIR")+    ]+  }++instance Monoid SandboxFlags where+  mempty = SandboxFlags {+    sandboxVerbosity = mempty,+    sandboxSnapshot  = mempty,+    sandboxLocation  = mempty+    }+  mappend a b = SandboxFlags {+    sandboxVerbosity = combine sandboxVerbosity,+    sandboxSnapshot  = combine sandboxSnapshot,+    sandboxLocation  = combine sandboxLocation+    }+    where combine field = field a `mappend` field b++-- ------------------------------------------------------------+-- * Shared options utils+-- ------------------------------------------------------------++-- | Common parser for the @-j@ flag of @build@ and @install@.+numJobsParser :: ReadE (Maybe Int)+numJobsParser = ReadE $ \s ->+  case s of+    "$ncpus" -> Right Nothing+    _        -> case reads s of+      [(n, "")]+        | n < 1     -> Left "The number of jobs should be 1 or more."+        | n > 64    -> Left "You probably don't want that many jobs."+        | otherwise -> Right (Just n)+      _             -> Left "The jobs value should be a number or '$ncpus'"++-- ------------------------------------------------------------ -- * GetOpt Utils -- ------------------------------------------------------------ @@ -1141,7 +1459,7 @@             -> [OptionField a] -> [OptionField b] liftOptions get set = map (liftOption get set) -yesNoOpt :: ShowOrParseArgs -> MkOptDescr (b -> Flag Bool) (Flag Bool -> (b -> b)) b+yesNoOpt :: ShowOrParseArgs -> MkOptDescr (b -> Flag Bool) (Flag Bool -> b -> b) b yesNoOpt ShowArgs sf lf = trueArg sf lf yesNoOpt _        sf lf = boolOpt' flagToMaybe Flag (sf, lf) ([], map ("no-" ++) lf) sf lf @@ -1187,10 +1505,20 @@   ]  -usagePackages :: String -> String -> String-usagePackages name pname =+usageFlagsOrPackages :: String -> String -> String+usageFlagsOrPackages name pname =      "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n"   ++ "   or: " ++ pname ++ " " ++ name ++ " [PACKAGES]\n\n"+  ++ "Flags for " ++ name ++ ":"++usagePackages :: String -> String -> String+usagePackages name pname =+     "Usage: " ++ pname ++ " " ++ name ++ " [PACKAGES]\n\n"+  ++ "Flags for " ++ name ++ ":"++usageFlags :: String -> String -> String+usageFlags name pname =+  "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n\n"   ++ "Flags for " ++ name ++ ":"  --TODO: do we want to allow per-package flags?
Distribution/Client/SetupWrapper.hs view
@@ -26,8 +26,10 @@          ( Version(..), VersionRange, anyVersion          , intersectVersionRanges, orLaterVersion          , withinRange )+import Distribution.InstalledPackageInfo (installedPackageId, sourcePackageId) import Distribution.Package-         ( PackageIdentifier(..), PackageName(..), Package(..), packageName+         ( InstalledPackageId(..), PackageIdentifier(..),+           PackageName(..), Package(..), packageName          , packageVersion, Dependency(..) ) import Distribution.PackageDescription          ( GenericPackageDescription(packageDescription)@@ -36,19 +38,25 @@ import Distribution.PackageDescription.Parse          ( readPackageDescription ) import Distribution.Simple.Configure-         ( configCompiler )+         ( configCompilerEx )+import Distribution.Compiler ( buildCompilerId ) import Distribution.Simple.Compiler-         ( CompilerFlavor(GHC), Compiler, compilerVersion, showCompilerId+         ( CompilerFlavor(GHC), Compiler(compilerId)+         , compilerVersion          , PackageDB(..), PackageDBStack ) import Distribution.Simple.Program          ( ProgramConfiguration, emptyProgramConfiguration-         , getDbProgramOutput, runDbProgram, ghcProgram )+         , getProgramSearchPath, getDbProgramOutput, runDbProgram, ghcProgram )+import Distribution.Simple.Program.Find+         ( programSearchPathAsPATHVar )+import Distribution.Simple.Program.Run+         ( getEffectiveEnvironment ) import Distribution.Simple.BuildPaths          ( defaultDistPref, exeExtension ) import Distribution.Simple.Command          ( CommandUI(..), commandShowOptions )-import Distribution.Simple.GHC-         ( ghcVerbosityOptions )+import Distribution.Simple.Program.GHC+         ( GhcMode(..), GhcOptions(..), renderGhcOptions ) import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Simple.PackageIndex (PackageIndex) import Distribution.Client.Config@@ -57,12 +65,15 @@          ( getInstalledPackages ) import Distribution.Client.JobControl          ( Lock, criticalSection )+import Distribution.Simple.Setup+         ( Flag(..) ) import Distribution.Simple.Utils          ( die, debug, info, cabalVersion, findPackageDesc, comparing          , createDirectoryIfMissingVerbose, installExecutableFile-         , rewriteFile, intercalate )+         , moreRecentFile, rewriteFile, intercalate ) import Distribution.Client.Utils-         ( moreRecentFile, inDir )+         ( inDir, tryCanonicalizePath )+import Distribution.System ( Platform(..), buildPlatform ) import Distribution.Text          ( display ) import Distribution.Verbosity@@ -70,19 +81,21 @@ import Distribution.Compat.Exception          ( catchIO ) -import System.Directory  ( doesFileExist, canonicalizePath )+import System.Directory  ( doesFileExist ) import System.FilePath   ( (</>), (<.>) ) import System.IO         ( Handle, hPutStr ) import System.Exit       ( ExitCode(..), exitWith ) import System.Process    ( runProcess, waitForProcess ) import Control.Monad     ( when, unless )-import Data.List         ( maximumBy )+import Data.List         ( foldl1' ) import Data.Maybe        ( fromMaybe, isJust )+import Data.Monoid       ( mempty ) import Data.Char         ( isSpace )  data SetupScriptOptions = SetupScriptOptions {     useCabalVersion          :: VersionRange,     useCompiler              :: Maybe Compiler,+    usePlatform              :: Maybe Platform,     usePackageDB             :: PackageDBStack,     usePackageIndex          :: Maybe PackageIndex,     useProgramConfig         :: ProgramConfiguration,@@ -93,6 +106,16 @@      -- Used only when calling setupWrapper from parallel code to serialise     -- access to the setup cache; should be Nothing otherwise.+    --+    -- Note: setup exe cache+    ------------------------+    -- When we are installing in parallel, we always use the external setup+    -- method. Since compiling the setup script each time adds noticeable+    -- overhead, we use a shared setup script cache+    -- ('~/.cabal/setup-exe-cache'). For each (compiler, platform, Cabal+    -- version) combination the cache holds a compiled setup script+    -- executable. This only affects the Simple build type; for the Custom,+    -- Configure and Make build types we always compile the setup script anew.     setupCacheLock           :: Maybe Lock   } @@ -100,6 +123,7 @@ defaultSetupScriptOptions = SetupScriptOptions {     useCabalVersion          = anyVersion,     useCompiler              = Nothing,+    usePlatform              = Nothing,     usePackageDB             = [GlobalPackageDB, UserPackageDB],     usePackageIndex          = Nothing,     useProgramConfig         = emptyProgramConfiguration,@@ -193,9 +217,11 @@   setupHs <- updateSetupScript cabalLibVersion bt   debug verbosity $ "Using " ++ setupHs ++ " as setup script."   path <- case bt of+    -- TODO: Should we also cache the setup exe for the Make and Configure build+    -- types?     Simple -> getCachedSetupExecutable options' cabalLibVersion setupHs-    _      -> compileSetupExecutable options' cabalLibVersion setupHs-  invokeSetupScript path (mkargs cabalLibVersion)+    _      -> compileSetupExecutable options' cabalLibVersion setupHs False+  invokeSetupScript options' path (mkargs cabalLibVersion)    where   workingDir       = case fromMaybe "" (useWorkingDir options) of@@ -204,6 +230,14 @@   setupDir         = workingDir </> useDistPref options </> "setup"   setupVersionFile = setupDir </> "setup" <.> "version" +  maybeGetInstalledPackages :: SetupScriptOptions -> Compiler+                               -> ProgramConfiguration -> IO PackageIndex+  maybeGetInstalledPackages options' comp conf =+    case usePackageIndex options' of+      Just index -> return index+      Nothing    -> getInstalledPackages verbosity+                    comp (usePackageDB options') conf+   cabalLibVersionToUse :: IO (Version, SetupScriptOptions)   cabalLibVersionToUse = do     savedVersion <- savedCabalVersion@@ -211,7 +245,7 @@       Just version | version `withinRange` useCabalVersion options         -> return (version, options)       _ -> do (comp, conf, options') <- configureCompiler options-              version <- installedCabalVersion options comp conf+              version <- installedCabalVersion options' comp conf               writeFile setupVersionFile (show version ++ "\n")               return (version, options') @@ -226,19 +260,34 @@   installedCabalVersion _ _ _ | packageName pkg == PackageName "Cabal" =     return (packageVersion pkg)   installedCabalVersion options' comp conf = do-    index <- case usePackageIndex options' of-      Just index -> return index-      Nothing    -> getInstalledPackages verbosity-                      comp (usePackageDB options') conf--    let cabalDep = Dependency (PackageName "Cabal") (useCabalVersion options)+    index <- maybeGetInstalledPackages options' comp conf+    let cabalDep = Dependency (PackageName "Cabal") (useCabalVersion options')     case PackageIndex.lookupDependency index cabalDep of-      []   -> die $ "The package requires Cabal library version "+      []   -> die $ "The package '" ++ display (packageName pkg)+                 ++ "' requires Cabal library version "                  ++ display (useCabalVersion options)                  ++ " but no suitable version is installed."-      pkgs -> return $ bestVersion (map fst pkgs)+      pkgs -> return $ bestVersion id (map fst pkgs)++  bestVersion :: (a -> Version) -> [a] -> a+  bestVersion f = firstMaximumBy (comparing (preference . f))     where-      bestVersion          = maximumBy (comparing preference)+      -- Like maximumBy, but picks the first maximum element instead of the+      -- last. In general, we expect the preferred version to go first in the+      -- list. For the default case, this has the effect of choosing the version+      -- installed in the user package DB instead of the global one. See #1463.+      --+      -- Note: firstMaximumBy could be written as just+      -- `maximumBy cmp . reverse`, but the problem is that the behaviour of+      -- maximumBy is not fully specified in the case when there is not a single+      -- greatest element.+      firstMaximumBy :: (a -> a -> Ordering) -> [a] -> a+      firstMaximumBy _ []   =+        error "Distribution.Client.firstMaximumBy: empty list"+      firstMaximumBy cmp xs =  foldl1' maxBy xs+        where+          maxBy x y = case cmp x y of { GT -> x; EQ -> x; LT -> y; }+       preference version   = (sameVersion, sameMajorVersion                              ,stableVersion, latestVersion)         where@@ -250,14 +299,37 @@                                _       -> False           latestVersion    = version +  -- TODO: This function looks a lot like @installedCabalVersion@ - can the+  -- duplication be removed?+  installedCabalPkgId :: SetupScriptOptions -> Compiler -> ProgramConfiguration+                         -> Version -> IO (Maybe InstalledPackageId)+  installedCabalPkgId _ _ _ _ | packageName pkg == PackageName "Cabal" =+    return Nothing+  installedCabalPkgId options' compiler conf cabalLibVersion = do+    index <- maybeGetInstalledPackages options' compiler conf+    let cabalPkgid = PackageIdentifier (PackageName "Cabal") cabalLibVersion+    case PackageIndex.lookupSourcePackageId index cabalPkgid of+      []           -> die $ "The package '" ++ display (packageName pkg)+                      ++ "' requires Cabal library version "+                      ++ display (cabalLibVersion)+                      ++ " but no suitable version is installed."+      iPkgInfos   -> return . Just . installedPackageId+                     . bestVersion (pkgVersion . sourcePackageId) $ iPkgInfos+   configureCompiler :: SetupScriptOptions                     -> IO (Compiler, ProgramConfiguration, SetupScriptOptions)   configureCompiler options' = do     (comp, conf) <- case useCompiler options' of       Just comp -> return (comp, useProgramConfig options')-      Nothing   -> configCompiler (Just GHC) Nothing Nothing-                     (useProgramConfig options') verbosity-    return (comp, conf, options' { useCompiler = Just comp,+      Nothing   -> do (comp, _, conf) <-+                        configCompilerEx (Just GHC) Nothing Nothing+                        (useProgramConfig options') verbosity+                      return (comp, conf)+    -- Whenever we need to call configureCompiler, we also need to access the+    -- package index, so let's cache it here.+    index <- maybeGetInstalledPackages options' comp conf+    return (comp, conf, options' { useCompiler      = Just comp,+                                   usePackageIndex  = Just index,                                    useProgramConfig = conf })    -- | Decide which Setup.hs script to use, creating it if necessary.@@ -299,6 +371,7 @@     let setupCacheDir = cabalDir </> "setup-exe-cache"     let setupProgFile = setupCacheDir                         </> ("setup-" ++ cabalVersionString ++ "-"+                             ++ platformString ++ "-"                              ++ compilerVersionString)                         <.> exeExtension     setupProgFileExists <- doesFileExist setupProgFile@@ -313,39 +386,51 @@                "Found cached setup executable: " ++ setupProgFile           else do           debug verbosity $ "Setup executable not found in the cache."-          src <- compileSetupExecutable options' cabalLibVersion setupHsFile+          src <- compileSetupExecutable options' cabalLibVersion setupHsFile True           createDirectoryIfMissingVerbose verbosity True setupCacheDir           installExecutableFile verbosity src setupProgFile     return setupProgFile       where         cabalVersionString    = "Cabal-" ++ (display cabalLibVersion)-        compilerVersionString = fromMaybe "nonexisting-compiler"-                                (showCompilerId `fmap` useCompiler options')+        compilerVersionString = display $+                                fromMaybe buildCompilerId+                                (fmap compilerId . useCompiler $ options')+        platformString        = display $+                                fromMaybe buildPlatform (usePlatform options')         criticalSection'      = fromMaybe id                                 (fmap criticalSection $ setupCacheLock options')    -- | If the Setup.hs is out of date wrt the executable then recompile it.   -- Currently this is GHC only. It should really be generalised.   ---  compileSetupExecutable :: SetupScriptOptions -> Version -> FilePath+  compileSetupExecutable :: SetupScriptOptions -> Version -> FilePath -> Bool                          -> IO FilePath-  compileSetupExecutable options' cabalLibVersion setupHsFile = do+  compileSetupExecutable options' cabalLibVersion setupHsFile forceCompile = do     setupHsNewer      <- setupHsFile      `moreRecentFile` setupProgFile     cabalVersionNewer <- setupVersionFile `moreRecentFile` setupProgFile     let outOfDate = setupHsNewer || cabalVersionNewer-    when outOfDate $ do-      debug verbosity "Setup script is out of date, compiling..."-      (compiler, conf, _) <- configureCompiler options'-      --TODO: get Cabal's GHC module to export a GhcOptions type and render func-      let ghcCmdLine =-            ghcVerbosityOptions verbosity-            ++ ["--make", setupHsFile, "-o", setupProgFile-               ,"-odir", setupDir, "-hidir", setupDir-               ,"-i", "-i" ++ workingDir ]-            ++ ghcPackageDbOptions compiler (usePackageDB options')-            ++ if packageName pkg == PackageName "Cabal"-               then []-               else ["-package", display cabalPkgid]+    when (outOfDate || forceCompile) $ do+      debug verbosity "Setup executable needs to be updated, compiling..."+      (compiler, conf, options'') <- configureCompiler options'+      let cabalPkgid = PackageIdentifier (PackageName "Cabal") cabalLibVersion+      maybeCabalInstalledPkgId <- installedCabalPkgId options'' compiler conf+                                  cabalLibVersion+      let ghcOptions = mempty {+              ghcOptVerbosity       = Flag verbosity+            , ghcOptMode            = Flag GhcModeMake+            , ghcOptInputFiles      = [setupHsFile]+            , ghcOptOutputFile      = Flag setupProgFile+            , ghcOptObjDir          = Flag setupDir+            , ghcOptHiDir           = Flag setupDir+            , ghcOptSourcePathClear = Flag True+            , ghcOptSourcePath      = [workingDir]+            , ghcOptPackageDBs      = usePackageDB options''+            , ghcOptPackages        =+              maybe []+              (\cabalInstalledPkgId -> [(cabalInstalledPkgId, cabalPkgid)])+              maybeCabalInstalledPkgId+            }+      let ghcCmdLine = renderGhcOptions (compilerVersion compiler) ghcOptions       case useLoggingHandle options of         Nothing          -> runDbProgram verbosity ghcProgram conf ghcCmdLine @@ -356,29 +441,11 @@     return setupProgFile     where       setupProgFile = setupDir </> "setup" <.> exeExtension-      cabalPkgid    = PackageIdentifier (PackageName "Cabal") cabalLibVersion -      ghcPackageDbOptions :: Compiler -> PackageDBStack -> [String]-      ghcPackageDbOptions compiler dbstack = case dbstack of-        (GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs-        (GlobalPackageDB:dbs)               -> ("-no-user-" ++ packageDbFlag)-                                             : concatMap specific dbs-        _                                   -> ierror-        where-          specific (SpecificPackageDB db) = [ '-':packageDbFlag, db ]-          specific _ = ierror-          ierror     = error "internal error: unexpected package db stack"--          packageDbFlag-            | compilerVersion compiler < Version [7,5] []-            = "package-conf"-            | otherwise-            = "package-db"--  invokeSetupScript :: FilePath -> [String] -> IO ()-  invokeSetupScript path args = do+  invokeSetupScript :: SetupScriptOptions -> FilePath -> [String] -> IO ()+  invokeSetupScript options' path args = do     info verbosity $ unwords (path : args)-    case useLoggingHandle options of+    case useLoggingHandle options' of       Nothing        -> return ()       Just logHandle -> info verbosity $ "Redirecting build log to "                                       ++ show logHandle@@ -387,10 +454,14 @@     -- be turned into an absolute path. On some systems, runProcess will take     -- path as relative to the new working directory instead of the current     -- working directory.-    path' <- canonicalizePath path+    path' <- tryCanonicalizePath path +    searchpath <- programSearchPathAsPATHVar+                    (getProgramSearchPath (useProgramConfig options'))+    env        <- getEffectiveEnvironment [("PATH", Just searchpath)]+     process <- runProcess path' args-                 (useWorkingDir options) Nothing-                 Nothing (useLoggingHandle options) (useLoggingHandle options)+                 (useWorkingDir options') env+                 Nothing (useLoggingHandle options') (useLoggingHandle options')     exitCode <- waitForProcess process     unless (exitCode == ExitSuccess) $ exitWith exitCode
Distribution/Client/SrcDist.hs view
@@ -6,42 +6,34 @@   )  where  -import Distribution.Simple.SrcDist-         ( printPackageProblems, prepareTree, snapshotPackage )+import Distribution.Client.SetupWrapper+        ( SetupScriptOptions(..), defaultSetupScriptOptions, setupWrapper ) import Distribution.Client.Tar (createTarGzFile)  import Distribution.Package-         ( Package(..), packageVersion )+         ( Package(..) ) import Distribution.PackageDescription          ( PackageDescription )+import Distribution.PackageDescription.Configuration+         ( flattenPackageDescription ) import Distribution.PackageDescription.Parse          ( readPackageDescription ) import Distribution.Simple.Utils-         ( defaultPackageDesc, die, warn, notice, setupMessage-         , createDirectoryIfMissingVerbose, withTempDirectory-         , withUTF8FileContents, writeUTF8File )+         ( createDirectoryIfMissingVerbose, defaultPackageDesc+         , die, notice, withTempDirectory ) import Distribution.Client.Setup          ( SDistFlags(..), SDistExFlags(..), ArchiveFormat(..) ) import Distribution.Simple.Setup-         ( fromFlag, flagToMaybe )-import Distribution.Verbosity (Verbosity)-import Distribution.Simple.PreProcess (knownSuffixHandlers)+         ( Flag(..), sdistCommand, flagToList, fromFlag, fromFlagOrDefault ) import Distribution.Simple.BuildPaths ( srcPref)-import Distribution.Simple.Configure(maybeGetPersistBuildConfig)-import Distribution.PackageDescription.Configuration ( flattenPackageDescription ) import Distribution.Simple.Program (requireProgram, simpleProgram, programPath) import Distribution.Simple.Program.Db (emptyProgramDb)-import Distribution.Text-         ( display )-import Distribution.Version-         ( Version )+import Distribution.Text ( display )+import Distribution.Verbosity (Verbosity, lessVerbose, normal)+import Distribution.Version   (Version(..), orLaterVersion) -import System.Time (getClockTime, toCalendarTime) import System.FilePath ((</>), (<.>)) import Control.Monad (when, unless)-import Data.Maybe (isNothing)-import Data.Char (toLower)-import Data.List (isPrefixOf) import System.Directory (doesFileExist, removeFile, canonicalizePath) import System.Process (runProcess, waitForProcess) import System.Exit    (ExitCode(..))@@ -50,93 +42,79 @@ sdist :: SDistFlags -> SDistExFlags -> IO () sdist flags exflags = do   pkg <- return . flattenPackageDescription-     =<< readPackageDescription verbosity-     =<< defaultPackageDesc verbosity-  mb_lbi <- maybeGetPersistBuildConfig distPref--  -- do some QA-  printPackageProblems verbosity pkg+         =<< readPackageDescription verbosity+         =<< defaultPackageDesc verbosity+  let withDir = if not needMakeArchive then (\f -> f tmpTargetDir)+                else withTempDirectory verbosity tmpTargetDir "sdist."+  -- 'withTempDir' fails if we don't create 'tmpTargetDir'...+  when needMakeArchive $+    createDirectoryIfMissingVerbose verbosity True tmpTargetDir+  withDir $ \tmpDir -> do+    let outDir = if isOutDirectory then tmpDir else tmpDir </> tarBallName pkg+        flags' = (if not needMakeArchive then flags+                  else flags { sDistDirectory = Flag outDir })+                 { sDistVerbosity = Flag $ if   verbosity == normal+                                           then lessVerbose verbosity+                                           else verbosity }+    unless isListSources $+      createDirectoryIfMissingVerbose verbosity True outDir -  when (isNothing mb_lbi) $-    warn verbosity "Cannot run preprocessors. Run 'configure' command first."+    -- Run 'setup sdist --output-directory=tmpDir' (or+    -- '--list-source'/'--output-directory=someOtherDir') in case we were passed+    -- those options.+    setupWrapper verbosity setupOpts (Just pkg) sdistCommand (const flags') [] -  date <- toCalendarTime =<< getClockTime-  let pkg' | snapshot  = snapshotPackage date pkg-           | otherwise = pkg+    -- Unless we were given --list-sources or --output-directory ourselves,+    -- create an archive.+    when needMakeArchive $+      createArchive verbosity pkg tmpDir distPref -  case flagToMaybe (sDistDirectory flags) of-    Just targetDir -> do-      generateSourceDir targetDir pkg' mb_lbi-      notice verbosity $ "Source directory created: " ++ targetDir+    when isOutDirectory $+      notice verbosity $ "Source directory created: " ++ tmpTargetDir -    Nothing -> do-      createDirectoryIfMissingVerbose verbosity True tmpTargetDir-      withTempDirectory verbosity tmpTargetDir "sdist." $ \tmpDir -> do-        let targetDir = tmpDir </> tarBallName pkg'-        generateSourceDir targetDir pkg' mb_lbi-        targzFile <- createArchive verbosity format pkg' tmpDir targetPref-        notice verbosity $ "Source tarball created: " ++ targzFile+    when isListSources $+      notice verbosity $ "List of package sources written to file '"+                         ++ (fromFlag . sDistListSources $ flags) ++ "'"    where-    generateSourceDir targetDir pkg' mb_lbi = do--      setupMessage verbosity "Building source dist for" (packageId pkg')-      prepareTree verbosity pkg' mb_lbi distPref targetDir pps-      when snapshot $-        overwriteSnapshotPackageDesc verbosity pkg' targetDir+    flagEnabled f  = not . null . flagToList . f $ flags -    verbosity = fromFlag (sDistVerbosity flags)-    snapshot  = fromFlag (sDistSnapshot flags)-    format    = fromFlag (sDistFormat exflags)-    pps       = knownSuffixHandlers-    distPref     = fromFlag $ sDistDistPref flags-    targetPref   = distPref-    tmpTargetDir = srcPref distPref+    isListSources   = flagEnabled sDistListSources+    isOutDirectory  = flagEnabled sDistDirectory+    needMakeArchive = not (isListSources || isOutDirectory)+    verbosity       = fromFlag (sDistVerbosity flags)+    distPref        = fromFlag (sDistDistPref flags)+    tmpTargetDir    = fromFlagOrDefault (srcPref distPref) (sDistDirectory flags)+    setupOpts       = defaultSetupScriptOptions {+      -- The '--output-directory' sdist flag was introduced in Cabal 1.12, and+      -- '--list-sources' in 1.17.+      useCabalVersion = if isListSources+                        then orLaterVersion $ Version [1,17,0] []+                        else orLaterVersion $ Version [1,12,0] []+      }+    format        = fromFlag (sDistFormat exflags)+    createArchive = case format of+      TargzFormat -> createTarGzArchive+      ZipFormat   -> createZipArchive  tarBallName :: PackageDescription -> String tarBallName = display . packageId -overwriteSnapshotPackageDesc :: Verbosity          -- ^verbosity-                             -> PackageDescription -- ^info from the cabal file-                             -> FilePath           -- ^source tree-                             -> IO ()-overwriteSnapshotPackageDesc verbosity pkg targetDir = do-    -- We could just writePackageDescription targetDescFile pkg_descr,-    -- but that would lose comments and formatting.-    descFile <- defaultPackageDesc verbosity-    withUTF8FileContents descFile $-      writeUTF8File (targetDir </> descFile)-        . unlines . map (replaceVersion (packageVersion pkg)) . lines--  where-    replaceVersion :: Version -> String -> String-    replaceVersion version line-      | "version:" `isPrefixOf` map toLower line-                  = "version: " ++ display version-      | otherwise = line---- | Create an archive from a tree of source files.----createArchive :: Verbosity-              -> ArchiveFormat-              -> PackageDescription-              -> FilePath-              -> FilePath-              -> IO FilePath-createArchive _verbosity TargzFormat pkg tmpDir targetPref = do+-- | Create a tar.gz archive from a tree of source files.+createTarGzArchive :: Verbosity -> PackageDescription -> FilePath -> FilePath+                    -> IO ()+createTarGzArchive verbosity pkg tmpDir targetPref = do     createTarGzFile tarBallFilePath tmpDir (tarBallName pkg)-    return tarBallFilePath+    notice verbosity $ "Source tarball created: " ++ tarBallFilePath   where     tarBallFilePath = targetPref </> tarBallName pkg <.> "tar.gz" -createArchive verbosity ZipFormat pkg tmpDir targetPref = do-    createZipFile verbosity zipFilePath tmpDir (tarBallName pkg)-    return zipFilePath-  where-    zipFilePath = targetPref </> tarBallName pkg <.> "zip"--createZipFile :: Verbosity -> FilePath -> FilePath -> FilePath -> IO ()-createZipFile verbosity zipfile base dir = do+-- | Create a zip archive from a tree of source files.+createZipArchive :: Verbosity -> PackageDescription -> FilePath -> FilePath+                    -> IO ()+createZipArchive verbosity pkg tmpDir targetPref = do+    let dir       = tarBallName pkg+        zipfile   = targetPref </> dir <.> "zip"     (zipProg, _) <- requireProgram verbosity zipProgram emptyProgramDb      -- zip has an annoying habbit of updating the target rather than creating@@ -146,15 +124,19 @@     alreadyExists <- doesFileExist zipfile     when alreadyExists $ removeFile zipfile -    -- we call zip with a different CWD, so have to make the path absolute-    zipfileAbs <- canonicalizePath zipfile+    -- We call zip with a different CWD, so have to make the path+    -- absolute. Can't just use 'canonicalizePath zipfile' since this function+    -- requires its argument to refer to an existing file.+    zipfileAbs <- fmap (</> dir <.> "zip") . canonicalizePath $ targetPref      --TODO: use runProgramInvocation, but has to be able to set CWD-    hnd <- runProcess (programPath zipProg) ["-q", "-r", zipfileAbs, dir] (Just base)+    hnd <- runProcess (programPath zipProg) ["-q", "-r", zipfileAbs, dir]+                      (Just tmpDir)                       Nothing Nothing Nothing Nothing     exitCode <- waitForProcess hnd     unless (exitCode == ExitSuccess) $       die $ "Generating the zip file failed "          ++ "(zip returned exit code " ++ show exitCode ++ ")"+    notice verbosity $ "Source zip archive created: " ++ zipfile   where     zipProgram = simpleProgram "zip"
Distribution/Client/Tar.hs view
@@ -21,6 +21,7 @@   -- * Converting between internal and external representation   read,   write,+  writeEntries,    -- * Packing and unpacking files to\/from internal representation   pack,@@ -38,6 +39,11 @@   DevMinor,   TypeCode,   Format(..),+  buildTreeRefTypeCode,+  buildTreeSnapshotTypeCode,+  isBuildTreeRefTypeCode,+  entrySizeInBlocks,+  entrySizeInBytes,    -- * Constructing simple entry values   simpleEntry,@@ -79,15 +85,15 @@ import qualified System.FilePath.Windows as FilePath.Windows import qualified System.FilePath.Posix   as FilePath.Posix import System.Directory-         ( getDirectoryContents, doesDirectoryExist, getModificationTime+         ( getDirectoryContents, doesDirectoryExist          , getPermissions, createDirectoryIfMissing, copyFile ) import qualified System.Directory as Permissions          ( Permissions(executable) )-import Distribution.Compat.FilePerms+import Distribution.Client.Compat.FilePerms          ( setFileExecutable ) import System.Posix.Types          ( FileMode )-import Distribution.Compat.Time+import Distribution.Client.Compat.Time import System.IO          ( IOMode(ReadMode), openBinaryFile, hFileSize ) import System.IO.Unsafe (unsafeInterleaveIO)@@ -110,8 +116,9 @@                  -> FilePath -- ^ Expected subdir (to check for tarbombs)                  -> FilePath -- ^ Tarball                 -> IO ()-extractTarGzFile dir expected tar = do-  unpack dir . checkTarbomb expected . read . GZipUtils.maybeDecompress =<< BS.readFile tar+extractTarGzFile dir expected tar =+  unpack dir . checkTarbomb expected . read+  . GZipUtils.maybeDecompress =<< BS.readFile tar  -- -- * Entry type@@ -148,11 +155,41 @@     entryFormat :: !Format   } +-- | Type code for the local build tree reference entry type. We don't use the+-- symbolic link entry type because it allows only 100 ASCII characters for the+-- path.+buildTreeRefTypeCode :: TypeCode+buildTreeRefTypeCode = 'C'++-- | Type code for the local build tree snapshot entry type.+buildTreeSnapshotTypeCode :: TypeCode+buildTreeSnapshotTypeCode = 'S'++-- | Is this a type code for a build tree reference?+isBuildTreeRefTypeCode :: TypeCode -> Bool+isBuildTreeRefTypeCode typeCode+  | (typeCode == buildTreeRefTypeCode+     || typeCode == buildTreeSnapshotTypeCode) = True+  | otherwise                                  = False+ -- | Native 'FilePath' of the file or directory within the archive. -- entryPath :: Entry -> FilePath entryPath = fromTarPath . entryTarPath +-- | Return the size of an entry in bytes.+entrySizeInBytes :: Entry -> FileSize+entrySizeInBytes = (*512) . fromIntegral . entrySizeInBlocks++-- | Return the number of blocks in an entry.+entrySizeInBlocks :: Entry -> Int+entrySizeInBlocks entry = 1 + case entryContent entry of+  NormalFile     _   size -> bytesToBlocks size+  OtherEntryType _ _ size -> bytesToBlocks size+  _                       -> 0+  where+    bytesToBlocks s = 1 + ((fromIntegral s - 1) `div` 512)+ -- | The content of a tar archive entry, which depends on the type of entry. -- -- Portable archives should contain only 'NormalFile' and 'Directory'.@@ -340,7 +377,7 @@     Right (name, [])         -> Right (TarPath name "")     Right (name, first:rest) -> case packName prefixMax remainder of       Left err               -> Left err-      Right (_     , (_:_))  -> Left "File name too long (cannot split)"+      Right (_     , _ : _)  -> Left "File name too long (cannot split)"       Right (prefix, [])     -> Right (TarPath name prefix)       where         -- drop the '/' between the name and prefix:@@ -362,7 +399,7 @@                                      where n' = n + length c     packName' _      _ ok    cs  = (FilePath.Posix.joinPath ok, cs) --- | The tar format allows just 100 ASCII charcters for the 'SymbolicLink' and+-- | The tar format allows just 100 ASCII characters for the 'SymbolicLink' and -- 'HardLink' entry types. -- newtype LinkTarget = LinkTarget FilePath@@ -472,7 +509,7 @@       | not (FilePath.Native.isValid name)       = Just $ "Invalid file name in tar archive: " ++ show name -      | any (=="..") (FilePath.Native.splitDirectories name)+      | ".." `elem` FilePath.Native.splitDirectories name       = Just $ "Invalid file name in tar archive: " ++ show name        | otherwise = Nothing@@ -490,8 +527,10 @@ checkEntryTarbomb expectedTopDir entry =   case FilePath.Native.splitDirectories (entryPath entry) of     (topDir:_) | topDir == expectedTopDir -> Nothing-    _ -> Just $ "File in tar archive is not in the expected directory "-             ++ show expectedTopDir+    s -> Just $ "File in tar archive is not in the expected directory. "+             ++ "Expected: " ++ show expectedTopDir+             ++ " but got the following hierarchy: "+             ++ show s   --@@ -628,7 +667,8 @@ getChars off len = BS.Char8.unpack . getBytes off len  getString :: Int64 -> Int64 -> ByteString -> String-getString off len = BS.Char8.unpack . BS.Char8.takeWhile (/='\0') . getBytes off len+getString off len = BS.Char8.unpack . BS.Char8.takeWhile (/='\0')+                    . getBytes off len  data Partial a = Error String | Ok a @@ -654,6 +694,11 @@ write :: [Entry] -> ByteString write es = BS.concat $ map putEntry es ++ [BS.replicate (512*2) 0] +-- | Same as 'write', but for 'Entries'.+writeEntries :: Entries -> ByteString+writeEntries entries = BS.concat $ foldrEntries (\e res -> putEntry e : res)+                       [BS.replicate (512*2) 0] error entries+ putEntry :: Entry -> ByteString putEntry entry = case entryContent entry of   NormalFile       content size -> BS.concat [ header, content, padding size ]@@ -666,12 +711,15 @@  putHeader :: Entry -> ByteString putHeader entry =-     BS.Char8.pack $ take 148 block-  ++ putOct 7 checksum-  ++ ' ' : drop 156 block+     BS.concat [ BS.take 148 block+               , BS.Char8.pack $ putOct 7 checksum+               , BS.Char8.singleton ' '+               , BS.drop 156 block ]   where-    block    = putHeaderNoChkSum entry-    checksum = foldl' (\x y -> x + ord y) 0 block+    -- putHeaderNoChkSum returns a String, so we convert it to the final+    -- representation before calculating the checksum.+    block    = BS.Char8.pack . putHeaderNoChkSum $ entry+    checksum = BS.Char8.foldl' (\x y -> x + ord y) 0 block  putHeaderNoChkSum :: Entry -> String putHeaderNoChkSum Entry {
Distribution/Client/Targets.hs view
@@ -708,17 +708,22 @@  --FIXME: use Text instance for FlagName and FlagAssignment instance Text UserConstraint where-  disp (UserConstraintVersion   pkgname verrange) = disp pkgname <+> disp verrange-  disp (UserConstraintInstalled pkgname)          = disp pkgname <+> Disp.text "installed"-  disp (UserConstraintSource    pkgname)          = disp pkgname <+> Disp.text "source"-  disp (UserConstraintFlags     pkgname flags)    = disp pkgname <+> dispFlagAssignment flags+  disp (UserConstraintVersion   pkgname verrange) = disp pkgname+                                                    <+> disp verrange+  disp (UserConstraintInstalled pkgname)          = disp pkgname+                                                    <+> Disp.text "installed"+  disp (UserConstraintSource    pkgname)          = disp pkgname+                                                    <+> Disp.text "source"+  disp (UserConstraintFlags     pkgname flags)    = disp pkgname+                                                    <+> dispFlagAssignment flags     where       dispFlagAssignment = Disp.hsep . map dispFlagValue       dispFlagValue (f, True)   = Disp.char '+' <> dispFlagName f       dispFlagValue (f, False)  = Disp.char '-' <> dispFlagName f       dispFlagName (FlagName f) = Disp.text f -  disp (UserConstraintStanzas   pkgname stanzas)  = disp pkgname <+> dispStanzas stanzas+  disp (UserConstraintStanzas   pkgname stanzas)  = disp pkgname+                                                    <+> dispStanzas stanzas     where       dispStanzas = Disp.hsep . map dispStanza       dispStanza TestStanzas  = Disp.text "test"@@ -729,7 +734,7 @@       spaces = Parse.satisfy isSpace >> Parse.skipSpaces        parseConstraint pkgname =-            (parse >>= return . UserConstraintVersion pkgname)+            ((parse >>= return . UserConstraintVersion pkgname)         +++ (do spaces                 _ <- Parse.string "installed"                 return (UserConstraintInstalled pkgname))@@ -741,7 +746,7 @@                 return (UserConstraintStanzas pkgname [TestStanzas]))         +++ (do spaces                 _ <- Parse.string "bench"-                return (UserConstraintStanzas pkgname [BenchStanzas]))+                return (UserConstraintStanzas pkgname [BenchStanzas])))         <++ (parseFlagAssignment >>= (return . UserConstraintFlags pkgname))        parseFlagAssignment = Parse.many1 (spaces >> parseFlagValue)
Distribution/Client/Types.hs view
@@ -30,7 +30,7 @@ import Data.Map (Map) import Network.URI (URI) import Data.ByteString.Lazy (ByteString)-import Distribution.Compat.Exception+import Control.Exception          ( SomeException )  newtype Username = Username { unUsername :: String }
− Distribution/Client/Unpack.hs 
@@ -1,138 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.Unpack--- Copyright   :  (c) Andrea Vezzosi 2008---                    Duncan Coutts 2011--- License     :  BSD-like------ Maintainer  :  cabal-devel@haskell.org--- Stability   :  provisional--- Portability :  portable-------------------------------------------------------------------------------------module Distribution.Client.Unpack (--    -- * Commands-    unpack,--  ) where--import Distribution.Package-         ( PackageId, packageId, packageName )-import Distribution.Simple.Setup-         ( fromFlag, fromFlagOrDefault )-import Distribution.Simple.Utils-         ( notice, die, info, writeFileAtomic )-import Distribution.Verbosity-         ( Verbosity )-import Distribution.Text(display)--import Distribution.Client.Setup-         ( GlobalFlags(..), UnpackFlags(..) )-import Distribution.Client.Types-import Distribution.Client.Targets-import Distribution.Client.Dependency-import Distribution.Client.FetchUtils-import qualified Distribution.Client.Tar as Tar (extractTarGzFile)-import Distribution.Client.IndexUtils as IndexUtils-        ( getSourcePackages )--import System.Directory-         ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist )-import Control.Monad-         ( unless, when )-import Data.Monoid-         ( mempty )-import System.FilePath-         ( (</>), (<.>), addTrailingPathSeparator )-import qualified Data.ByteString.Lazy.Char8 as BS-         ( unpack )--unpack :: Verbosity-       -> [Repo]-       -> GlobalFlags-       -> UnpackFlags-       -> [UserTarget] -       -> IO ()-unpack verbosity _ _ _ [] =-    notice verbosity "No packages requested. Nothing to do."--unpack verbosity repos globalFlags unpackFlags userTargets = do-  mapM_ checkTarget userTargets--  sourcePkgDb   <- getSourcePackages verbosity repos--  pkgSpecifiers <- resolveUserTargets verbosity-                     (fromFlag $ globalWorldFile globalFlags)-                     (packageIndex sourcePkgDb)-                     userTargets--  pkgs <- either (die . unlines . map show) return $-            resolveWithoutDependencies-              (resolverParams sourcePkgDb pkgSpecifiers)--  unless (null prefix) $-         createDirectoryIfMissing True prefix--  flip mapM_ pkgs $ \pkg -> do-    location <- fetchPackage verbosity (packageSource pkg)-    let pkgid = packageId pkg-        descOverride | usePristine = Nothing-                     | otherwise   = packageDescrOverride pkg-    case location of-      LocalTarballPackage tarballPath ->-        unpackPackage verbosity prefix pkgid descOverride tarballPath--      RemoteTarballPackage _tarballURL tarballPath ->-        unpackPackage verbosity prefix pkgid descOverride tarballPath--      RepoTarballPackage _repo _pkgid tarballPath ->-        unpackPackage verbosity prefix pkgid descOverride tarballPath--      LocalUnpackedPackage _ ->-        error "Distribution.Client.Unpack.unpack: the impossible happened."--  where-    resolverParams sourcePkgDb pkgSpecifiers =-        --TODO: add commandline constraint and preference args for unpack--        standardInstallPolicy mempty sourcePkgDb pkgSpecifiers--    prefix = fromFlagOrDefault "" (unpackDestDir unpackFlags)-    usePristine = fromFlagOrDefault False (unpackPristine unpackFlags)--checkTarget :: UserTarget -> IO ()-checkTarget target = case target of-    UserTargetLocalDir       dir  -> die (notTarball dir)-    UserTargetLocalCabalFile file -> die (notTarball file)-    _                             -> return ()-  where-    notTarball t =-        "The 'unpack' command is for tarball packages. "-     ++ "The target '" ++ t ++ "' is not a tarball."--unpackPackage :: Verbosity -> FilePath -> PackageId-              -> PackageDescriptionOverride-              -> FilePath  -> IO ()-unpackPackage verbosity prefix pkgid descOverride pkgPath = do-    let pkgdirname = display pkgid-        pkgdir     = prefix </> pkgdirname-        pkgdir'    = addTrailingPathSeparator pkgdir-    existsDir  <- doesDirectoryExist pkgdir-    when existsDir $ die $-     "The directory \"" ++ pkgdir' ++ "\" already exists, not unpacking."-    existsFile  <- doesFileExist pkgdir-    when existsFile $ die $-     "A file \"" ++ pkgdir ++ "\" is in the way, not unpacking."-    notice verbosity $ "Unpacking to " ++ pkgdir'-    Tar.extractTarGzFile prefix pkgdirname pkgPath--    case descOverride of-      Nothing     -> return ()-      Just pkgtxt -> do-        let descFilePath = pkgdir </> display (packageName pkgid) <.> "cabal"-        info verbosity $-          "Updating " ++ descFilePath-                      ++ " with the latest revision from the index."-        writeFileAtomic descFilePath (BS.unpack pkgtxt)
Distribution/Client/Update.hs view
@@ -16,6 +16,8 @@  import Distribution.Client.Types          ( Repo(..), RemoteRepo(..), LocalRepo(..), SourcePackageDb(..) )+import Distribution.Client.HttpUtils+         ( DownloadResult(..) ) import Distribution.Client.FetchUtils          ( downloadIndex ) import qualified Distribution.Client.PackageIndex as PackageIndex@@ -29,21 +31,20 @@ import Distribution.Version          ( anyVersion, withinRange ) import Distribution.Simple.Utils-         ( warn, notice, writeFileAtomic )+         ( writeFileAtomic, warn, notice ) import Distribution.Verbosity          ( Verbosity )  import qualified Data.ByteString.Lazy       as BS-import qualified Data.ByteString.Lazy.Char8 as BS.Char8 import Distribution.Client.GZipUtils (maybeDecompress) import qualified Data.Map as Map import System.FilePath (dropExtension) import Data.Maybe      (fromMaybe)-import Control.Monad   (when)+import Control.Monad   (unless)  -- | 'update' downloads the package list from all known servers update :: Verbosity -> [Repo] -> IO ()-update verbosity [] = do+update verbosity [] =   warn verbosity $ "No remote package servers have been specified. Usually "                 ++ "you would have one specified in the config file." update verbosity repos = do@@ -56,11 +57,13 @@   Left remoteRepo -> do     notice verbosity $ "Downloading the latest package list from "                     ++ remoteRepoName remoteRepo-    indexPath <- downloadIndex verbosity remoteRepo (repoLocalDir repo)-    writeFileAtomic (dropExtension indexPath) . BS.Char8.unpack-                                              . maybeDecompress-                                            =<< BS.readFile indexPath-    updateRepoIndexCache verbosity repo+    downloadResult <- downloadIndex verbosity remoteRepo (repoLocalDir repo)+    case downloadResult of+      FileAlreadyInCache -> return ()+      FileDownloaded indexPath -> do+        writeFileAtomic (dropExtension indexPath) . maybeDecompress+                                                =<< BS.readFile indexPath+        updateRepoIndexCache verbosity repo  checkForSelfUpgrade :: Verbosity -> [Repo] -> IO () checkForSelfUpgrade verbosity repos = do@@ -76,8 +79,7 @@         , version > currentVersion         , version `withinRange` preferredVersionRange ] -  when (not (null laterPreferredVersions)) $+  unless (null laterPreferredVersions) $     notice verbosity $          "Note: there is a new version of cabal-install available.\n"       ++ "To upgrade, run: cabal install cabal-install"-
Distribution/Client/Utils.hs view
@@ -1,20 +1,41 @@-{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE ForeignFunctionInterface, CPP #-}  module Distribution.Client.Utils ( MergeResult(..)                                  , mergeBy, duplicates, duplicatesBy-                                 , moreRecentFile, inDir, numberOfProcessors )+                                 , inDir, numberOfProcessors+                                 , removeExistingFile+                                 , makeAbsoluteToCwd, filePathToByteString+                                 , byteStringToFilePath, tryCanonicalizePath+                                 , canonicalizePathNoThrow )        where +import Distribution.Compat.Exception ( catchIO )+import qualified Data.ByteString.Lazy as BS+import Control.Monad+         ( when )+import Data.Bits+         ( (.|.), shiftL, shiftR )+import Data.Char+         ( ord, chr ) import Data.List          ( sortBy, groupBy )+import Data.Word+         ( Word8, Word32) import Foreign.C.Types ( CInt(..) )-import System.Directory-         ( doesFileExist, getModificationTime-         , getCurrentDirectory, setCurrentDirectory )-import System.IO.Unsafe ( unsafePerformIO ) import qualified Control.Exception as Exception          ( finally )+import System.Directory+         ( canonicalizePath, doesFileExist, getCurrentDirectory+         , removeFile, setCurrentDirectory )+import System.FilePath+         ( (</>), isAbsolute )+import System.IO.Unsafe ( unsafePerformIO ) +#if defined(mingw32_HOST_OS)+import Control.Monad (liftM2, unless)+import System.Directory (doesDirectoryExist)+#endif+ -- | Generic merging utility. For sorted input lists this is a full outer join. -- -- * The result list never contains @(Nothing, Nothing)@.@@ -44,22 +65,16 @@     moreThanOne (_:_:_) = True     moreThanOne _       = False --- | Compare the modification times of two files to see if the first is newer--- than the second. The first file must exist but the second need not.--- The expected use case is when the second file is generated using the first.--- In this use case, if the result is True then the second file is out of date.----moreRecentFile :: FilePath -> FilePath -> IO Bool-moreRecentFile a b = do-  exists <- doesFileExist b-  if not exists-    then return True-    else do tb <- getModificationTime b-            ta <- getModificationTime a-            return (ta > tb)+-- | Like 'removeFile', but does not throw an exception when the file does not+-- exist.+removeExistingFile :: FilePath -> IO ()+removeExistingFile path = do+  exists <- doesFileExist path+  when exists $+    removeFile path  -- | Executes the action in the specified directory.-inDir :: Maybe FilePath -> IO () -> IO ()+inDir :: Maybe FilePath -> IO a -> IO a inDir Nothing m = m inDir (Just d) m = do   old <- getCurrentDirectory@@ -72,3 +87,65 @@ -- program, so unsafePerformIO is safe here. numberOfProcessors :: Int numberOfProcessors = fromEnum $ unsafePerformIO c_getNumberOfProcessors++-- | Given a relative path, make it absolute relative to the current+-- directory. Absolute paths are returned unmodified.+makeAbsoluteToCwd :: FilePath -> IO FilePath+makeAbsoluteToCwd path | isAbsolute path = return path+                       | otherwise       = do cwd <- getCurrentDirectory+                                              return $! cwd </> path++-- | Convert a 'FilePath' to a lazy 'ByteString'. Each 'Char' is+-- encoded as a little-endian 'Word32'.+filePathToByteString :: FilePath -> BS.ByteString+filePathToByteString p =+  BS.pack $ foldr conv [] codepts+  where+    codepts :: [Word32]+    codepts = map (fromIntegral . ord) p++    conv :: Word32 -> [Word8] -> [Word8]+    conv w32 rest = b0:b1:b2:b3:rest+      where+        b0 = fromIntegral $ w32+        b1 = fromIntegral $ w32 `shiftR` 8+        b2 = fromIntegral $ w32 `shiftR` 16+        b3 = fromIntegral $ w32 `shiftR` 24++-- | Reverse operation to 'filePathToByteString'.+byteStringToFilePath :: BS.ByteString -> FilePath+byteStringToFilePath bs | bslen `mod` 4 /= 0 = unexpected+                        | otherwise = go 0+  where+    unexpected = "Distribution.Client.Utils.byteStringToFilePath: unexpected"+    bslen = BS.length bs++    go i | i == bslen = []+         | otherwise = (chr . fromIntegral $ w32) : go (i+4)+      where+        w32 :: Word32+        w32 = b0 .|. (b1 `shiftL` 8) .|. (b2 `shiftL` 16) .|. (b3 `shiftL` 24)+        b0 = fromIntegral $ BS.index bs i+        b1 = fromIntegral $ BS.index bs (i + 1)+        b2 = fromIntegral $ BS.index bs (i + 2)+        b3 = fromIntegral $ BS.index bs (i + 3)++-- | Workaround for the inconsistent behaviour of 'canonicalizePath'. It throws+-- an error if the path refers to a non-existent file on *nix, but not on+-- Windows.+tryCanonicalizePath :: FilePath -> IO FilePath+tryCanonicalizePath path = do+  ret <- canonicalizePath path+#if defined(mingw32_HOST_OS)+  exists <- liftM2 (||) (doesFileExist ret) (doesDirectoryExist ret)+  unless exists $+    error $ ret ++ ": canonicalizePath: does not exist "+                ++ "(No such file or directory)"+#endif+  return ret++-- | A non-throwing wrapper for 'canonicalizePath'. If 'canonicalizePath' throws+-- an exception, returns the path argument unmodified.+canonicalizePathNoThrow :: FilePath -> IO FilePath+canonicalizePathNoThrow path = do+  canonicalizePath path `catchIO` (\_ -> return path)
Distribution/Client/Win32SelfUpgrade.hs view
@@ -1,6 +1,4 @@ {-# LANGUAGE CPP, ForeignFunctionInterface #-}-{-# OPTIONS_NHC98 -cpp #-}-{-# OPTIONS_JHC -fcpp -fffi #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.Win32SelfUpgrade@@ -122,7 +120,7 @@    let args = mkArgs (show ourPID) tmpPath   log $ "launching child " ++ unwords (dstPath : map show args)-  runProcess dstPath args Nothing Nothing Nothing Nothing Nothing+  _ <- runProcess dstPath args Nothing Nothing Nothing Nothing Nothing    log $ "waiting for the child to start up"   waitForSingleObject event (10*1000) -- wait at most 10 sec
Distribution/Client/World.hs view
@@ -102,7 +102,7 @@             all (`elem` pkgsNewWorld) pkgsOldWorld)       then do         info verbosity "Updating world file..."-        writeFileAtomic world $ unlines+        writeFileAtomic world . B.pack $ unlines             [ (display pkg) | pkg <- pkgsNewWorld]       else         info verbosity "World file is already up to date."
− Distribution/Compat/Exception.hs 
@@ -1,56 +0,0 @@-{-# LANGUAGE CPP #-}-{-# OPTIONS_GHC -cpp #-}-{-# OPTIONS_NHC98 -cpp #-}-{-# OPTIONS_JHC -fcpp #-}--- #hide-module Distribution.Compat.Exception (-  SomeException,-  onException,-  catchIO,-  handleIO,-  catchExit,-  throwIOIO-  ) where--import System.Exit-import qualified Control.Exception as Exception-#if MIN_VERSION_base(4,0,0)-import Control.Exception (SomeException)-#else-import Control.Exception (Exception)-type SomeException = Exception-#endif--onException :: IO a -> IO b -> IO a-#if MIN_VERSION_base(4,0,0)-onException = Exception.onException-#else-onException io what = io `Exception.catch` \e -> do what-                                                    Exception.throw e-#endif--throwIOIO :: Exception.IOException -> IO a-#if MIN_VERSION_base(4,0,0)-throwIOIO = Exception.throwIO-#else-throwIOIO = Exception.throwIO . Exception.IOException-#endif--catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a-#if MIN_VERSION_base(4,0,0)-catchIO = Exception.catch-#else-catchIO = Exception.catchJust Exception.ioErrors-#endif--handleIO :: (Exception.IOException -> IO a) -> IO a -> IO a-handleIO = flip catchIO--catchExit :: IO a -> (ExitCode -> IO a) -> IO a-#if MIN_VERSION_base(4,0,0)-catchExit = Exception.catch-#else-catchExit = Exception.catchJust exitExceptions-    where exitExceptions (Exception.ExitException ee) = Just ee-          exitExceptions _                            = Nothing-#endif
− Distribution/Compat/FilePerms.hs 
@@ -1,40 +0,0 @@-{-# LANGUAGE CPP #-}--- #hide-module Distribution.Compat.FilePerms (-  setFileOrdinary,-  setFileExecutable,-  ) where--#ifndef mingw32_HOST_OS-import System.Posix.Types-         ( FileMode )-import System.Posix.Internals-         ( c_chmod )-import Foreign.C-         ( withCString )-#if MIN_VERSION_base(4,0,0)-import Foreign.C-         ( throwErrnoPathIfMinus1_ )-#else-import Foreign.C-         ( throwErrnoIfMinus1_ )-#endif-#endif /* mingw32_HOST_OS */--setFileOrdinary,  setFileExecutable  :: FilePath -> IO ()-#ifndef mingw32_HOST_OS-setFileOrdinary   path = setFileMode path 0o644 -- file perms -rw-r--r---setFileExecutable path = setFileMode path 0o755 -- file perms -rwxr-xr-x--setFileMode :: FilePath -> FileMode -> IO ()-setFileMode name m =-  withCString name $ \s -> do-#if __GLASGOW_HASKELL__ >= 608-    throwErrnoPathIfMinus1_ "setFileMode" name (c_chmod s m)-#else-    throwErrnoIfMinus1_                   name (c_chmod s m)-#endif-#else-setFileOrdinary   _ = return ()-setFileExecutable _ = return ()-#endif
− Distribution/Compat/Time.hs 
@@ -1,37 +0,0 @@-{-# 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
Main.hs view
@@ -17,29 +17,36 @@          ( GlobalFlags(..), globalCommand, globalRepos          , ConfigFlags(..)          , ConfigExFlags(..), defaultConfigExFlags, configureExCommand+         , BuildFlags(..), BuildExFlags(..), SkipAddSourceDepsCheck(..)+         , buildCommand, testCommand, benchmarkCommand          , InstallFlags(..), defaultInstallFlags          , installCommand, upgradeCommand          , FetchFlags(..), fetchCommand+         , GetFlags(..), getCommand, unpackCommand          , checkCommand          , updateCommand          , ListFlags(..), listCommand          , InfoFlags(..), infoCommand          , UploadFlags(..), uploadCommand          , ReportFlags(..), reportCommand+         , runCommand          , InitFlags(initVerbosity), initCommand          , SDistFlags(..), SDistExFlags(..), sdistCommand+         , Win32SelfUpgradeFlags(..), win32SelfUpgradeCommand+         , SandboxFlags(..), sandboxCommand          , reportCommand-         , unpackCommand, UnpackFlags(..) )+         ) import Distribution.Simple.Setup-         ( BuildFlags(..), buildCommand-         , HaddockFlags(..), haddockCommand+         ( HaddockFlags(..), haddockCommand          , HscolourFlags(..), hscolourCommand+         , ReplFlags(..), replCommand          , CopyFlags(..), copyCommand          , RegisterFlags(..), registerCommand          , CleanFlags(..), cleanCommand-         , TestFlags(..), testCommand-         , BenchmarkFlags(..), benchmarkCommand-         , Flag(..), fromFlag, fromFlagOrDefault, flagToMaybe )+         , TestFlags(..), BenchmarkFlags(..)+         , Flag(..), fromFlag, fromFlagOrDefault, flagToMaybe, toFlag+         , configAbsolutePaths+         )  import Distribution.Client.SetupWrapper          ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions )@@ -47,51 +54,91 @@          ( SavedConfig(..), loadConfig, defaultConfigFile ) import Distribution.Client.Targets          ( readUserTargets )+import qualified Distribution.Client.List as List+         ( list, info ) -import Distribution.Client.List             (list, info)-import Distribution.Client.Install          (install, upgrade)-import Distribution.Client.Configure        (configure)-import Distribution.Client.Update           (update)-import Distribution.Client.Fetch            (fetch)-import Distribution.Client.Check as Check   (check)+import Distribution.Client.Install            (install)+import Distribution.Client.Configure          (configure)+import Distribution.Client.Update             (update)+import Distribution.Client.Fetch              (fetch)+import Distribution.Client.Check as Check     (check) --import Distribution.Client.Clean            (clean)-import Distribution.Client.Upload as Upload (upload, check, report)-import Distribution.Client.SrcDist          (sdist)-import Distribution.Client.Unpack           (unpack)-import Distribution.Client.Init             (initCabal)+import Distribution.Client.Upload as Upload   (upload, check, report)+import Distribution.Client.Run                (run, splitRunArgs)+import Distribution.Client.SrcDist            (sdist)+import Distribution.Client.Get                (get)+import Distribution.Client.Sandbox            (sandboxInit+                                              ,sandboxAddSource+                                              ,sandboxDelete+                                              ,sandboxDeleteSource+                                              ,sandboxListSources+                                              ,sandboxHcPkg+                                              ,dumpPackageEnvironment++                                              ,getSandboxConfigFilePath+                                              ,loadConfigOrSandboxConfig+                                              ,initPackageDBIfNeeded+                                              ,maybeWithSandboxDirOnSearchPath+                                              ,maybeWithSandboxPackageInfo+                                              ,WereDepsReinstalled(..)+                                              ,maybeReinstallAddSourceDeps+                                              ,tryGetIndexFilePath+                                              ,sandboxBuildDir++                                              ,configCompilerAux'+                                              ,configPackageDB')+import Distribution.Client.Sandbox.PackageEnvironment+                                              (setPackageDB+                                              ,userPackageEnvironmentFile)+import Distribution.Client.Sandbox.Timestamp  (maybeAddCompilerTimestampRecord)+import Distribution.Client.Sandbox.Types      (UseSandbox(..), whenUsingSandbox)+import Distribution.Client.Init               (initCabal) import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade -import Distribution.Simple.Compiler-         ( Compiler, PackageDBStack )-import Distribution.Simple.Program-         ( ProgramConfiguration, defaultProgramConfiguration )+import Distribution.PackageDescription+         ( Executable(..) ) import Distribution.Simple.Command+         ( CommandParse(..), CommandUI(..), Command+         , commandsRun, commandAddAction, hiddenCommand )+import Distribution.Simple.Compiler+         ( Compiler(..) ) import Distribution.Simple.Configure-         ( configCompilerAux, interpretPackageDbFlags )+         ( checkPersistBuildConfigOutdated, configCompilerAuxEx+         , ConfigStateFileErrorType(..), localBuildInfoFile+         , getPersistBuildConfig, tryGetPersistBuildConfig )+import qualified Distribution.Simple.LocalBuildInfo as LBI+import Distribution.Simple.Program (defaultProgramConfiguration)+import qualified Distribution.Simple.Setup as Cabal import Distribution.Simple.Utils-         ( cabalVersion, die, topHandler, intercalate )+         ( cabalVersion, die, notice, info, moreRecentFile, topHandler ) import Distribution.Text          ( display ) import Distribution.Verbosity as Verbosity-       ( Verbosity, normal, intToVerbosity, lessVerbose )+         ( Verbosity, normal )+import Distribution.Version+         ( Version(..), orLaterVersion ) import qualified Paths_cabal_install_bundle (version)  import System.Environment       (getArgs, getProgName) import System.Exit              (exitFailure) import System.FilePath          (splitExtension, takeExtension)+import System.IO                (BufferMode(LineBuffering),+                                 hSetBuffering, stdout) import System.Directory         (doesFileExist)-import Data.List                (intersperse)-import Data.Maybe               (fromMaybe)+import Data.List                (intercalate) import Data.Monoid              (Monoid(..))-import Control.Monad            (unless)+import Control.Monad            (when, unless)  -- | Entry point -- main :: IO ()-main = getArgs >>= mainWorker+main = do+  -- Enable line buffering so that we can get fast feedback even when piped.+  -- This is especially important for CI and build systems.+  hSetBuffering stdout LineBuffering+  getArgs >>= mainWorker  mainWorker :: [String] -> IO ()-mainWorker ("win32selfupgrade":args) = win32SelfUpgradeAction args mainWorker args = topHandler $   case commandsRun globalCommand commands args of     CommandHelp   help                 -> printGlobalHelp help@@ -116,8 +163,12 @@       putStr (help pname)       putStr $ "\nYou can edit the cabal configuration file to set defaults:\n"             ++ "  " ++ configFile ++ "\n"+      exists <- doesFileExist configFile+      when (not exists) $+          putStrLn $ "This file will be generated with sensible "+                  ++ "defaults if you run 'cabal update'."     printOptionsList = putStr . unlines-    printErrors errs = die $ concat (intersperse "\n" errs)+    printErrors errs = die $ intercalate "\n" errs     printNumericVersion = putStrLn $ display Paths_cabal_install_bundle.version     printVersion        = putStrLn $ "cabal-install version "                                   ++ display Paths_cabal_install_bundle.version@@ -131,15 +182,20 @@       ,listCommand            `commandAddAction` listAction       ,infoCommand            `commandAddAction` infoAction       ,fetchCommand           `commandAddAction` fetchAction-      ,unpackCommand          `commandAddAction` unpackAction+      ,getCommand             `commandAddAction` getAction+      ,hiddenCommand $+       unpackCommand          `commandAddAction` unpackAction       ,checkCommand           `commandAddAction` checkAction       ,sdistCommand           `commandAddAction` sdistAction       ,uploadCommand          `commandAddAction` uploadAction       ,reportCommand          `commandAddAction` reportAction+      ,runCommand             `commandAddAction` runAction       ,initCommand            `commandAddAction` initAction       ,configureExCommand     `commandAddAction` configureAction-      ,wrapperAction (buildCommand defaultProgramConfiguration)-                     buildVerbosity    buildDistPref+      ,buildCommand           `commandAddAction` buildAction+      ,replCommand defaultProgramConfiguration+                              `commandAddAction` replAction+      ,sandboxCommand         `commandAddAction` sandboxAction       ,wrapperAction copyCommand                      copyVerbosity     copyDistPref       ,wrapperAction haddockCommand@@ -150,11 +206,12 @@                      hscolourVerbosity hscolourDistPref       ,wrapperAction registerCommand                      regVerbosity      regDistPref-      ,wrapperAction testCommand-                     testVerbosity     testDistPref-      ,wrapperAction benchmarkCommand-                     benchmarkVerbosity     benchmarkDistPref-      ,upgradeCommand         `commandAddAction` upgradeAction+      ,testCommand            `commandAddAction` testAction+      ,benchmarkCommand       `commandAddAction` benchmarkAction+      ,hiddenCommand $+       upgradeCommand         `commandAddAction` upgradeAction+      ,hiddenCommand $+       win32SelfUpgradeCommand`commandAddAction` win32SelfUpgradeAction       ]  wrapperAction :: Monoid flags@@ -178,16 +235,319 @@                 -> [String] -> GlobalFlags -> IO () configureAction (configFlags, configExFlags) extraArgs globalFlags = do   let verbosity = fromFlagOrDefault normal (configVerbosity configFlags)-  config <- loadConfig verbosity (globalConfigFile globalFlags)-                                 (configUserInstall configFlags)++  (useSandbox, config) <- loadConfigOrSandboxConfig verbosity+                          globalFlags (configUserInstall configFlags)   let configFlags'   = savedConfigureFlags   config `mappend` configFlags       configExFlags' = savedConfigureExFlags config `mappend` configExFlags       globalFlags'   = savedGlobalFlags      config `mappend` globalFlags-  (comp, conf) <- configCompilerAux configFlags'-  configure verbosity-            (configPackageDB' configFlags') (globalRepos globalFlags')-            comp conf configFlags' configExFlags' extraArgs+  (comp, platform, conf) <- configCompilerAuxEx configFlags' +  -- If we're working inside a sandbox and the user has set the -w option, we+  -- may need to create a sandbox-local package DB for this compiler and add a+  -- timestamp record for this compiler to the timestamp file.+  let configFlags''  = case useSandbox of+        NoSandbox               -> configFlags'+        (UseSandbox sandboxDir) -> setPackageDB sandboxDir+                                   comp platform configFlags'++  whenUsingSandbox useSandbox $ \sandboxDir -> do+    initPackageDBIfNeeded verbosity configFlags'' comp conf++    indexFile     <- tryGetIndexFilePath config+    maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile+      (compilerId comp) platform++  maybeWithSandboxDirOnSearchPath useSandbox $+    configure verbosity+              (configPackageDB' configFlags'')+              (globalRepos globalFlags')+              comp platform conf configFlags'' configExFlags' extraArgs++buildAction :: (BuildFlags, BuildExFlags) -> [String] -> GlobalFlags -> IO ()+buildAction (buildFlags, buildExFlags) extraArgs globalFlags = do+  let distPref    = fromFlagOrDefault (useDistPref defaultSetupScriptOptions)+                    (buildDistPref buildFlags)+      verbosity   = fromFlagOrDefault normal (buildVerbosity buildFlags)+      noAddSource = fromFlagOrDefault DontSkipAddSourceDepsCheck+                    (buildOnly buildExFlags)++  -- Calls 'configureAction' to do the real work, so nothing special has to be+  -- done to support sandboxes.+  useSandbox <- reconfigure verbosity distPref+                mempty [] globalFlags noAddSource (buildNumJobs buildExFlags)+                (const Nothing)++  maybeWithSandboxDirOnSearchPath useSandbox $+    build verbosity distPref buildFlags extraArgs+++-- | Actually do the work of building the package. This is separate from+-- 'buildAction' so that 'testAction' and 'benchmarkAction' do not invoke+-- 'reconfigure' twice.+build :: Verbosity -> FilePath -> BuildFlags -> [String] -> IO ()+build verbosity distPref buildFlags extraArgs =+  setupWrapper verbosity setupOptions Nothing+               (Cabal.buildCommand progConf) (const buildFlags') extraArgs+  where+    progConf     = defaultProgramConfiguration+    setupOptions = defaultSetupScriptOptions { useDistPref = distPref }+    buildFlags'  = buildFlags+      { buildVerbosity = toFlag verbosity+      , buildDistPref = toFlag distPref+      }++replAction :: ReplFlags -> [String] -> GlobalFlags -> IO ()+replAction replFlags extraArgs globalFlags = do+  let distPref    = fromFlagOrDefault (useDistPref defaultSetupScriptOptions)+                    (replDistPref replFlags)+      verbosity   = fromFlagOrDefault normal (replVerbosity replFlags)+      noAddSource = case replReload replFlags of+                      Flag True -> SkipAddSourceDepsCheck+                      _         -> DontSkipAddSourceDepsCheck++  -- Calls 'configureAction' to do the real work, so nothing special has to be+  -- done to support sandboxes.+  useSandbox <- reconfigure verbosity distPref+                mempty [] globalFlags noAddSource NoFlag+                (const Nothing)++  maybeWithSandboxDirOnSearchPath useSandbox $+    let progConf     = defaultProgramConfiguration+        setupOptions = defaultSetupScriptOptions+          { useCabalVersion = orLaterVersion $ Version [1,18,0] []+          , useDistPref     = distPref+          }+        replFlags'   = replFlags+          { replVerbosity = toFlag verbosity+          , replDistPref  = toFlag distPref+          }+    in setupWrapper verbosity setupOptions Nothing+         (Cabal.replCommand progConf) (const replFlags') extraArgs+++-- | Re-configure the package in the current directory if needed. Deciding+-- when to reconfigure and with which options is convoluted:+--+-- If we are reconfiguring, we must always run @configure@ with the+-- verbosity option we are given; however, that a previous configuration+-- uses a different verbosity setting is not reason enough to reconfigure.+--+-- The package should be configured to use the same \"dist\" prefix as+-- given to the @build@ command, otherwise the build will probably+-- fail. Not only does this determine the \"dist\" prefix setting if we+-- need to reconfigure anyway, but an existing configuration should be+-- invalidated if its \"dist\" prefix differs.+--+-- If the package has never been configured (i.e., there is no+-- LocalBuildInfo), we must configure first, using the default options.+--+-- If the package has been configured, there will be a 'LocalBuildInfo'.+-- If there no package description file, we assume that the+-- 'PackageDescription' is up to date, though the configuration may need+-- to be updated for other reasons (see above). If there is a package+-- description file, and it has been modified since the 'LocalBuildInfo'+-- was generated, then we need to reconfigure.+--+-- The caller of this function may also have specific requirements+-- regarding the flags the last configuration used. For example,+-- 'testAction' requires that the package be configured with test suites+-- enabled. The caller may pass the required settings to this function+-- along with a function to check the validity of the saved 'ConfigFlags';+-- these required settings will be checked first upon determining that+-- a previous configuration exists.+reconfigure :: Verbosity    -- ^ Verbosity setting+            -> FilePath     -- ^ \"dist\" prefix+            -> ConfigFlags  -- ^ Additional config flags to set. These flags+                            -- will be 'mappend'ed to the last used or+                            -- default 'ConfigFlags' as appropriate, so+                            -- this value should be 'mempty' with only the+                            -- required flags set. The required verbosity+                            -- and \"dist\" prefix flags will be set+                            -- automatically because they are always+                            -- required; therefore, it is not necessary to+                            -- set them here.+            -> [String]     -- ^ Extra arguments+            -> GlobalFlags  -- ^ Global flags+            -> SkipAddSourceDepsCheck+                            -- ^ Should we skip the timestamp check for modified+                            -- add-source dependencies?+            -> Flag (Maybe Int)+                            -- ^ -j flag for reinstalling add-source deps.+            -> (ConfigFlags -> Maybe String)+                            -- ^ Check that the required flags are set in+                            -- the last used 'ConfigFlags'. If the required+                            -- flags are not set, provide a message to the+                            -- user explaining the reason for+                            -- reconfiguration. Because the correct \"dist\"+                            -- prefix setting is always required, it is checked+                            -- automatically; this function need not check+                            -- for it.+            -> IO UseSandbox+reconfigure verbosity distPref     addConfigFlags extraArgs globalFlags+            skipAddSourceDepsCheck numJobsFlag    checkFlags = do+  eLbi <- tryGetPersistBuildConfig distPref+  case eLbi of+    Left (err, errCode) -> onNoBuildConfig err errCode+    Right lbi           -> onBuildConfig lbi++  where++    -- We couldn't load the saved package config file.+    --+    -- If we're in a sandbox: add-source deps don't have to be reinstalled+    -- (since we don't know the compiler & platform).+    onNoBuildConfig :: String -> ConfigStateFileErrorType -> IO UseSandbox+    onNoBuildConfig err errCode = do+      let msg = case errCode of+            ConfigStateFileMissing    -> "Package has never been configured."+            ConfigStateFileCantParse  -> "Saved package config file seems "+                                         ++ "to be corrupt."+            ConfigStateFileBadVersion -> err+      case errCode of+        ConfigStateFileBadVersion -> info verbosity msg+        _                         -> do+          notice verbosity+            $ msg ++ " Configuring with default flags." ++ configureManually+          configureAction (defaultFlags, defaultConfigExFlags)+            extraArgs globalFlags+      (useSandbox, _) <- loadConfigOrSandboxConfig verbosity globalFlags mempty+      return useSandbox++    -- Package has been configured, but the configuration may be out of+    -- date or required flags may not be set.+    --+    -- If we're in a sandbox: reinstall the modified add-source deps and+    -- force reconfigure if we did.+    onBuildConfig :: LBI.LocalBuildInfo -> IO UseSandbox+    onBuildConfig lbi = do+      let configFlags = LBI.configFlags lbi+          flags       = mconcat [configFlags, addConfigFlags, distVerbFlags]++      -- Was the sandbox created after the package was already configured? We+      -- may need to skip reinstallation of add-source deps and force+      -- reconfigure.+      let buildConfig       = localBuildInfoFile distPref+      sandboxConfig        <- getSandboxConfigFilePath globalFlags+      isSandboxConfigNewer <-+        sandboxConfig `existsAndIsMoreRecentThan` buildConfig++      let skipAddSourceDepsCheck'+            | isSandboxConfigNewer = SkipAddSourceDepsCheck+            | otherwise            = skipAddSourceDepsCheck++      (useSandbox, depsReinstalled) <-+        case skipAddSourceDepsCheck' of+        DontSkipAddSourceDepsCheck     ->+          maybeReinstallAddSourceDeps verbosity numJobsFlag flags globalFlags+        SkipAddSourceDepsCheck -> do+          (useSandbox, _) <- loadConfigOrSandboxConfig verbosity+                             globalFlags mempty+          return (useSandbox, NoDepsReinstalled)++      -- Is the @cabal.config@ file newer than @dist/setup.config@? Then we need+      -- to force reconfigure. Note that it's possible to use @cabal.config@+      -- even without sandboxes.+      isUserPackageEnvironmentFileNewer <-+        userPackageEnvironmentFile `existsAndIsMoreRecentThan` buildConfig++      -- Determine whether we need to reconfigure and which message to show to+      -- the user if that is the case.+      mMsg <- determineMessageToShow lbi configFlags depsReinstalled+                                     isSandboxConfigNewer+                                     isUserPackageEnvironmentFileNewer+      case mMsg of++        -- No message for the user indicates that reconfiguration+        -- is not required.+        Nothing -> return useSandbox++        -- Show the message and reconfigure.+        Just msg -> do+          notice verbosity msg+          configureAction (flags, defaultConfigExFlags)+            extraArgs globalFlags+          return useSandbox++    -- True if the first file exists and is more recent than the second file.+    existsAndIsMoreRecentThan :: FilePath -> FilePath -> IO Bool+    existsAndIsMoreRecentThan a b = do+      exists <- doesFileExist a+      if not exists+        then return False+        else a `moreRecentFile` b++    -- Determine what message, if any, to display to the user if reconfiguration+    -- is required.+    determineMessageToShow :: LBI.LocalBuildInfo -> ConfigFlags+                            -> WereDepsReinstalled -> Bool -> Bool+                            -> IO (Maybe String)+    determineMessageToShow _   _           _               True  _     =+      -- The sandbox was created after the package was already configured.+      return $! Just $! sandboxConfigNewerMessage++    determineMessageToShow _   _           _               False True  =+      -- The user package environment file was modified.+      return $! Just $! userPackageEnvironmentFileModifiedMessage++    determineMessageToShow lbi configFlags depsReinstalled False False = do+      let savedDistPref = fromFlagOrDefault+                          (useDistPref defaultSetupScriptOptions)+                          (configDistPref configFlags)+      case depsReinstalled of+        ReinstalledSomeDeps ->+          -- Some add-source deps were reinstalled.+          return $! Just $! reinstalledDepsMessage+        NoDepsReinstalled ->+          case checkFlags configFlags of+            -- Flag required by the caller is not set.+            Just msg -> return $! Just $! msg ++ configureManually++            Nothing+              -- Required "dist" prefix is not set.+              | savedDistPref /= distPref ->+                return $! Just distPrefMessage++              -- All required flags are set, but the configuration+              -- may be outdated.+              | otherwise -> case LBI.pkgDescrFile lbi of+                Nothing -> return Nothing+                Just pdFile -> do+                  outdated <- checkPersistBuildConfigOutdated+                              distPref pdFile+                  return $! if outdated+                            then Just $! outdatedMessage pdFile+                            else Nothing++    defaultFlags = mappend addConfigFlags distVerbFlags+    distVerbFlags = mempty+        { configVerbosity = toFlag verbosity+        , configDistPref  = toFlag distPref+        }+    reconfiguringMostRecent = " Re-configuring with most recently used options."+    configureManually       = " If this fails, please run configure manually."+    sandboxConfigNewerMessage =+        "The sandbox was created after the package was already configured."+        ++ reconfiguringMostRecent+        ++ configureManually+    userPackageEnvironmentFileModifiedMessage =+        "The user package environment file ('"+        ++ userPackageEnvironmentFile ++ "') was modified."+        ++ reconfiguringMostRecent+        ++ configureManually+    distPrefMessage =+        "Package previously configured with different \"dist\" prefix."+        ++ reconfiguringMostRecent+        ++ configureManually+    outdatedMessage pdFile =+        pdFile ++ " has been changed."+        ++ reconfiguringMostRecent+        ++ configureManually+    reinstalledDepsMessage =+        "Some add-source dependencies have been reinstalled."+        ++ reconfiguringMostRecent+        ++ configureManually+ installAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)               -> [String] -> GlobalFlags -> IO () installAction (configFlags, _, installFlags, _) _ _globalFlags@@ -199,29 +559,126 @@ installAction (configFlags, configExFlags, installFlags, haddockFlags)               extraArgs globalFlags = do   let verbosity = fromFlagOrDefault normal (configVerbosity configFlags)+  (useSandbox, config) <- loadConfigOrSandboxConfig verbosity+                          globalFlags (configUserInstall configFlags)   targets <- readUserTargets verbosity extraArgs-  config <- loadConfig verbosity (globalConfigFile globalFlags)-                                 (configUserInstall configFlags)-  let configFlags'   = savedConfigureFlags   config `mappend` configFlags-      configExFlags' = defaultConfigExFlags         `mappend`-                       savedConfigureExFlags config `mappend` configExFlags-      installFlags'  = defaultInstallFlags          `mappend`-                       savedInstallFlags     config `mappend` installFlags-      globalFlags'   = savedGlobalFlags      config `mappend` globalFlags-  (comp, conf) <- configCompilerAux' configFlags'-  install verbosity-          (configPackageDB' configFlags') (globalRepos globalFlags')-          comp conf globalFlags' configFlags' configExFlags' installFlags' haddockFlags-          targets +  -- TODO: It'd be nice if 'cabal install' picked up the '-w' flag passed to+  -- 'configure' when run inside a sandbox.  Right now, running+  --+  -- $ cabal sandbox init && cabal configure -w /path/to/ghc+  --   && cabal build && cabal install+  --+  -- performs the compilation twice unless you also pass -w to 'install'.+  -- However, this is the same behaviour that 'cabal install' has in the normal+  -- mode of operation, so we stick to it for consistency.++  let sandboxDistPref = case useSandbox of+        NoSandbox             -> NoFlag+        UseSandbox sandboxDir -> Flag $ sandboxBuildDir sandboxDir+      configFlags'    = savedConfigureFlags   config `mappend` configFlags+      configExFlags'  = defaultConfigExFlags         `mappend`+                        savedConfigureExFlags config `mappend` configExFlags+      installFlags'   = defaultInstallFlags          `mappend`+                        savedInstallFlags     config `mappend` installFlags+      globalFlags'    = savedGlobalFlags      config `mappend` globalFlags+  (comp, platform, conf) <- configCompilerAux' configFlags'++  -- If we're working inside a sandbox and the user has set the -w option, we+  -- may need to create a sandbox-local package DB for this compiler and add a+  -- timestamp record for this compiler to the timestamp file.+  configFlags'' <- case useSandbox of+        NoSandbox               -> configAbsolutePaths $ configFlags'+        (UseSandbox sandboxDir) ->+          return $ (setPackageDB sandboxDir comp platform configFlags') {+            configDistPref = sandboxDistPref+            }++  whenUsingSandbox useSandbox $ \sandboxDir -> do+    initPackageDBIfNeeded verbosity configFlags'' comp conf++    indexFile     <- tryGetIndexFilePath config+    maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile+      (compilerId comp) platform++  -- FIXME: Passing 'SandboxPackageInfo' to install unconditionally here means+  -- that 'cabal install some-package' inside a sandbox will sometimes reinstall+  -- modified add-source deps, even if they are not among the dependencies of+  -- 'some-package'. This can also prevent packages that depend on older+  -- versions of add-source'd packages from building (see #1362).+  maybeWithSandboxPackageInfo verbosity configFlags'' globalFlags'+                              comp platform conf useSandbox $ \mSandboxPkgInfo ->+                              maybeWithSandboxDirOnSearchPath useSandbox $+      install verbosity+              (configPackageDB' configFlags'')+              (globalRepos globalFlags')+              comp platform conf+              useSandbox mSandboxPkgInfo+              globalFlags' configFlags'' configExFlags'+              installFlags' haddockFlags+              targets++testAction :: (TestFlags, BuildExFlags) -> [String] -> GlobalFlags -> IO ()+testAction (testFlags, buildExFlags) extraArgs globalFlags = do+  let verbosity      = fromFlagOrDefault normal (testVerbosity testFlags)+      distPref       = fromFlagOrDefault (useDistPref defaultSetupScriptOptions)+                       (testDistPref testFlags)+      setupOptions   = defaultSetupScriptOptions { useDistPref = distPref }+      addConfigFlags = mempty { configTests = toFlag True }+      checkFlags flags+        | fromFlagOrDefault False (configTests flags) = Nothing+        | otherwise  = Just "Re-configuring with test suites enabled."+      noAddSource    = fromFlagOrDefault DontSkipAddSourceDepsCheck+                       (buildOnly buildExFlags)++  -- reconfigure also checks if we're in a sandbox and reinstalls add-source+  -- deps if needed.+  useSandbox <- reconfigure verbosity distPref addConfigFlags []+                globalFlags noAddSource (buildNumJobs buildExFlags) checkFlags++  maybeWithSandboxDirOnSearchPath useSandbox $+    build verbosity distPref mempty extraArgs++  maybeWithSandboxDirOnSearchPath useSandbox $+    setupWrapper verbosity setupOptions Nothing+      Cabal.testCommand (const testFlags) extraArgs++benchmarkAction :: (BenchmarkFlags, BuildExFlags) -> [String] -> GlobalFlags+                   -> IO ()+benchmarkAction (benchmarkFlags, buildExFlags) extraArgs globalFlags = do+  let verbosity      = fromFlagOrDefault normal+                       (benchmarkVerbosity benchmarkFlags)+      distPref       = fromFlagOrDefault (useDistPref defaultSetupScriptOptions)+                       (benchmarkDistPref benchmarkFlags)+      setupOptions   = defaultSetupScriptOptions { useDistPref = distPref }+      addConfigFlags = mempty { configBenchmarks = toFlag True }+      checkFlags flags+        | fromFlagOrDefault False (configBenchmarks flags) = Nothing+        | otherwise = Just "Re-configuring with benchmarks enabled."+      noAddSource   = fromFlagOrDefault DontSkipAddSourceDepsCheck+                      (buildOnly buildExFlags)++  -- reconfigure also checks if we're in a sandbox and reinstalls add-source+  -- deps if needed.+  useSandbox <- reconfigure verbosity distPref addConfigFlags []+                globalFlags noAddSource (buildNumJobs buildExFlags)+                checkFlags++  maybeWithSandboxDirOnSearchPath useSandbox $+    build verbosity distPref mempty extraArgs++  maybeWithSandboxDirOnSearchPath useSandbox $+    setupWrapper verbosity setupOptions Nothing+      Cabal.benchmarkCommand (const benchmarkFlags) extraArgs+ listAction :: ListFlags -> [String] -> GlobalFlags -> IO () listAction listFlags extraArgs globalFlags = do   let verbosity = fromFlag (listVerbosity listFlags)-  config <- loadConfig verbosity (globalConfigFile globalFlags) mempty+  (_, config) <- loadConfigOrSandboxConfig verbosity globalFlags mempty   let configFlags  = savedConfigureFlags config       globalFlags' = savedGlobalFlags    config `mappend` globalFlags-  (comp, conf) <- configCompilerAux' configFlags-  list verbosity+  (comp, _, conf) <- configCompilerAux' configFlags+  List.list verbosity        (configPackageDB' configFlags)        (globalRepos globalFlags')        comp@@ -233,11 +690,11 @@ infoAction infoFlags extraArgs globalFlags = do   let verbosity = fromFlag (infoVerbosity infoFlags)   targets <- readUserTargets verbosity extraArgs-  config <- loadConfig verbosity (globalConfigFile globalFlags) mempty+  (_, config) <- loadConfigOrSandboxConfig verbosity globalFlags mempty   let configFlags  = savedConfigureFlags config       globalFlags' = savedGlobalFlags    config `mappend` globalFlags-  (comp, conf) <- configCompilerAux configFlags-  info verbosity+  (comp, _, conf) <- configCompilerAuxEx configFlags+  List.info verbosity        (configPackageDB' configFlags)        (globalRepos globalFlags')        comp@@ -248,7 +705,7 @@  updateAction :: Flag Verbosity -> [String] -> GlobalFlags -> IO () updateAction verbosityFlag extraArgs globalFlags = do-  unless (null extraArgs) $ do+  unless (null extraArgs) $     die $ "'update' doesn't take any extra arguments: " ++ unwords extraArgs   let verbosity = fromFlag verbosityFlag   config <- loadConfig verbosity (globalConfigFile globalFlags) mempty@@ -257,22 +714,18 @@  upgradeAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)               -> [String] -> GlobalFlags -> IO ()-upgradeAction (configFlags, configExFlags, installFlags, haddockFlags)-              extraArgs globalFlags = do-  let verbosity = fromFlagOrDefault normal (configVerbosity configFlags)-  targets <- readUserTargets verbosity extraArgs-  config <- loadConfig verbosity (globalConfigFile globalFlags)-                                 (configUserInstall configFlags)-  let configFlags'   = savedConfigureFlags   config `mappend` configFlags-      configExFlags' = savedConfigureExFlags config `mappend` configExFlags-      installFlags'  = defaultInstallFlags          `mappend`-                       savedInstallFlags     config `mappend` installFlags-      globalFlags'   = savedGlobalFlags      config `mappend` globalFlags-  (comp, conf) <- configCompilerAux' configFlags'-  upgrade verbosity-          (configPackageDB' configFlags') (globalRepos globalFlags')-          comp conf globalFlags' configFlags' configExFlags' installFlags' haddockFlags-          targets+upgradeAction _ _ _ = die $+    "Use the 'cabal install' command instead of 'cabal upgrade'.\n"+ ++ "You can install the latest version of a package using 'cabal install'. "+ ++ "The 'cabal upgrade' command has been removed because people found it "+ ++ "confusing and it often led to broken packages.\n"+ ++ "If you want the old upgrade behaviour then use the install command "+ ++ "with the --upgrade-dependencies flag (but check first with --dry-run "+ ++ "to see what would happen). This will try to pick the latest versions "+ ++ "of all dependencies, rather than the usual behaviour of trying to pick "+ ++ "installed versions of all dependencies. If you do use "+ ++ "--upgrade-dependencies, it is recommended that you do not upgrade core "+ ++ "packages (e.g. by using appropriate --constraint= flags)."  fetchAction :: FetchFlags -> [String] -> GlobalFlags -> IO () fetchAction fetchFlags extraArgs globalFlags = do@@ -281,10 +734,11 @@   config <- loadConfig verbosity (globalConfigFile globalFlags) mempty   let configFlags  = savedConfigureFlags config       globalFlags' = savedGlobalFlags config `mappend` globalFlags-  (comp, conf) <- configCompilerAux' configFlags+  (comp, platform, conf) <- configCompilerAux' configFlags   fetch verbosity-        (configPackageDB' configFlags) (globalRepos globalFlags')-        comp conf globalFlags' fetchFlags+        (configPackageDB' configFlags)+        (globalRepos globalFlags')+        comp platform conf globalFlags' fetchFlags         targets  uploadAction :: UploadFlags -> [String] -> GlobalFlags -> IO ()@@ -321,7 +775,7 @@  checkAction :: Flag Verbosity -> [String] -> GlobalFlags -> IO () checkAction verbosityFlag extraArgs _globalFlags = do-  unless (null extraArgs) $ do+  unless (null extraArgs) $     die $ "'check' doesn't take any extra arguments: " ++ unwords extraArgs   allOk <- Check.check (fromFlag verbosityFlag)   unless allOk exitFailure@@ -329,13 +783,13 @@  sdistAction :: (SDistFlags, SDistExFlags) -> [String] -> GlobalFlags -> IO () sdistAction (sdistFlags, sdistExFlags) extraArgs _globalFlags = do-  unless (null extraArgs) $ do+  unless (null extraArgs) $     die $ "'sdist' doesn't take any extra arguments: " ++ unwords extraArgs   sdist sdistFlags sdistExFlags  reportAction :: ReportFlags -> [String] -> GlobalFlags -> IO () reportAction reportFlags extraArgs globalFlags = do-  unless (null extraArgs) $ do+  unless (null extraArgs) $     die $ "'report' doesn't take any extra arguments: " ++ unwords extraArgs    let verbosity = fromFlag (reportVerbosity reportFlags)@@ -347,55 +801,97 @@     (flagToMaybe $ reportUsername reportFlags')     (flagToMaybe $ reportPassword reportFlags') -unpackAction :: UnpackFlags -> [String] -> GlobalFlags -> IO ()-unpackAction unpackFlags extraArgs globalFlags = do-  let verbosity = fromFlag (unpackVerbosity unpackFlags)+runAction :: (BuildFlags, BuildExFlags) -> [String] -> GlobalFlags -> IO ()+runAction (buildFlags, buildExFlags) extraArgs globalFlags = do+  let verbosity   = fromFlagOrDefault normal (buildVerbosity buildFlags)+      distPref    = fromFlagOrDefault (useDistPref defaultSetupScriptOptions)+                    (buildDistPref buildFlags)+      noAddSource = fromFlagOrDefault DontSkipAddSourceDepsCheck+                    (buildOnly buildExFlags)++  -- reconfigure also checks if we're in a sandbox and reinstalls add-source+  -- deps if needed.+  useSandbox <- reconfigure verbosity distPref mempty []+                globalFlags noAddSource (buildNumJobs buildExFlags)+                (const Nothing)++  lbi <- getPersistBuildConfig distPref+  (exe, exeArgs) <- splitRunArgs lbi extraArgs++  maybeWithSandboxDirOnSearchPath useSandbox $+    build verbosity distPref mempty ["exe:" ++ exeName exe]++  maybeWithSandboxDirOnSearchPath useSandbox $+    run verbosity lbi exe exeArgs++getAction :: GetFlags -> [String] -> GlobalFlags -> IO ()+getAction getFlags extraArgs globalFlags = do+  let verbosity = fromFlag (getVerbosity getFlags)   targets <- readUserTargets verbosity extraArgs   config <- loadConfig verbosity (globalConfigFile globalFlags) mempty   let globalFlags' = savedGlobalFlags config `mappend` globalFlags-  unpack verbosity-         (globalRepos (savedGlobalFlags config))-         globalFlags'-         unpackFlags-         targets+  get verbosity+    (globalRepos (savedGlobalFlags config))+    globalFlags'+    getFlags+    targets +unpackAction :: GetFlags -> [String] -> GlobalFlags -> IO ()+unpackAction getFlags extraArgs globalFlags = do+  getAction getFlags extraArgs globalFlags+ initAction :: InitFlags -> [String] -> GlobalFlags -> IO () initAction initFlags _extraArgs globalFlags = do   let verbosity = fromFlag (initVerbosity initFlags)   config <- loadConfig verbosity (globalConfigFile globalFlags) mempty   let configFlags  = savedConfigureFlags config-  (comp, conf) <- configCompilerAux' configFlags+  (comp, _, conf) <- configCompilerAux' configFlags   initCabal verbosity             (configPackageDB' configFlags)             comp             conf             initFlags --- | See 'Distribution.Client.Install.withWin32SelfUpgrade' for details.----win32SelfUpgradeAction :: [String] -> IO ()-win32SelfUpgradeAction (pid:path:rest) =-  Win32SelfUpgrade.deleteOldExeFile verbosity (read pid) path-  where-    verbosity = case rest of-      (['-','-','v','e','r','b','o','s','e','=',n]:_) | n `elem` ['0'..'9']-         -> fromMaybe Verbosity.normal (Verbosity.intToVerbosity (read [n]))-      _  ->           Verbosity.normal-win32SelfUpgradeAction _ = return ()+sandboxAction :: SandboxFlags -> [String] -> GlobalFlags -> IO ()+sandboxAction sandboxFlags extraArgs globalFlags = do+  let verbosity = fromFlag (sandboxVerbosity sandboxFlags)+  case extraArgs of+    -- Basic sandbox commands.+    ["init"] -> sandboxInit verbosity sandboxFlags globalFlags+    ["delete"] -> sandboxDelete verbosity sandboxFlags globalFlags+    ("add-source":extra) -> do+        when (noExtraArgs extra) $+          die "The 'sandbox add-source' command expects at least one argument"+        sandboxAddSource verbosity extra sandboxFlags globalFlags ------ Utils (transitionary)---+    -- More advanced commands.+    ("hc-pkg":extra) -> do+        when (noExtraArgs extra) $+            die $ "The 'sandbox hc-pkg' command expects at least one argument"+        sandboxHcPkg verbosity sandboxFlags globalFlags extra+    ["buildopts"] -> die "Not implemented!" -configPackageDB' :: ConfigFlags -> PackageDBStack-configPackageDB' cfg =-    interpretPackageDbFlags userInstall (configPackageDBs cfg)+    -- Hidden commands.+    ("delete-source":extra) -> do+        when (noExtraArgs extra) $+          die "The 'sandbox delete-source' command expects \+              \at least one argument"+        sandboxDeleteSource verbosity extra sandboxFlags globalFlags+    ["list-sources"] -> sandboxListSources verbosity sandboxFlags globalFlags+    ["dump-pkgenv"]  -> dumpPackageEnvironment verbosity sandboxFlags globalFlags++    -- Error handling.+    [] -> die $ "Please specify a subcommand (see 'help sandbox')"+    _  -> die $ "Unknown 'sandbox' subcommand: " ++ unwords extraArgs+   where-    userInstall = fromFlagOrDefault True (configUserInstall cfg)+    noExtraArgs = (<1) . length -configCompilerAux' :: ConfigFlags-                   -> IO (Compiler, ProgramConfiguration)-configCompilerAux' configFlags =-  configCompilerAux configFlags-    --FIXME: make configCompilerAux use a sensible verbosity-    { configVerbosity = fmap lessVerbose (configVerbosity configFlags) }+-- | See 'Distribution.Client.Install.withWin32SelfUpgrade' for details.+--+win32SelfUpgradeAction :: Win32SelfUpgradeFlags -> [String] -> GlobalFlags+                          -> IO ()+win32SelfUpgradeAction selfUpgradeFlags (pid:path:_extraArgs) _globalFlags = do+  let verbosity = fromFlag (win32SelfUpgradeVerbosity selfUpgradeFlags)+  Win32SelfUpgrade.deleteOldExeFile verbosity (read pid) path+win32SelfUpgradeAction _ _ _ = return ()
cabal-install-bundle.cabal view
@@ -1,5 +1,5 @@ Name:               cabal-install-bundle-Version:            0.16.0.2.1+Version:            1.18.0.2 Synopsis:           The (bundled) command-line interface for Cabal and Hackage. Description:        This is cabal-install with bundled dependencies. Easier to bootstrap. License:            BSD3@@ -76,6 +76,14 @@         Control.Monad.Trans.Writer         Control.Monad.Trans.Writer.Lazy         Control.Monad.Trans.Writer.Strict+        Control.Concurrent.STM+        Control.Concurrent.STM.TBQueue+        Control.Concurrent.STM.TQueue+        Control.Concurrent.STM.TArray+        Control.Concurrent.STM.TVar+        Control.Concurrent.STM.TChan+        Control.Concurrent.STM.TMVar+        Control.Monad.STM         Data.Functor.Compose         Data.Functor.Constant         Data.Functor.Identity@@ -166,6 +174,7 @@         Distribution.Client.Dependency.Modular.Version         Distribution.Client.Fetch         Distribution.Client.FetchUtils+        Distribution.Client.Get         Distribution.Client.GZipUtils         Distribution.Client.Haddock         Distribution.Client.HttpUtils@@ -181,21 +190,28 @@         Distribution.Client.List         Distribution.Client.PackageIndex         Distribution.Client.PackageUtils+        Distribution.Client.ParseUtils+        Distribution.Client.Run+        Distribution.Client.Sandbox+        Distribution.Client.Sandbox.Index+        Distribution.Client.Sandbox.PackageEnvironment+        Distribution.Client.Sandbox.Timestamp+        Distribution.Client.Sandbox.Types         Distribution.Client.Setup         Distribution.Client.SetupWrapper         Distribution.Client.SrcDist         Distribution.Client.Tar         Distribution.Client.Targets         Distribution.Client.Types-        Distribution.Client.Unpack         Distribution.Client.Update         Distribution.Client.Upload         Distribution.Client.Utils         Distribution.Client.World         Distribution.Client.Win32SelfUpgrade-        Distribution.Compat.Exception-        Distribution.Compat.FilePerms-        Distribution.Compat.Time+        Distribution.Client.Compat.Environment+        Distribution.Client.Compat.FilePerms+        Distribution.Client.Compat.Semaphore+        Distribution.Client.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