Merge branch 'master' into buffering

Author: DanBurton

.travis.yml

@@ -41,8 +41,9 @@ script:
 
  - cabal copy
  - cd test/integration
- - stack setup
- - stack test
+ # Takes too long for now
+ # - stack setup
+ # - stack test
  - cd ../..
 
 # Check that the resulting source distribution can be built & installed.

ChangeLog.md

@@ -1,7 +1,13 @@
-## Unreleased
+## 0.1.0.0
 
 * Fall back to cabal dependency solver when a snapshot can't be found
 * Basic implementation of `stack new` [#137](https://github.com/commercialhaskell/stack/issues/137)
+* `stack solver` command [#364](https://github.com/commercialhaskell/stack/issues/364)
+* `stack path` command [#95](https://github.com/commercialhaskell/stack/issues/95)
+* Haddocks [#143](https://github.com/commercialhaskell/stack/issues/143):
+    * Build for dependencies
+    * Use relative links
+    * Generate module contents and index for all packages in project
 
 ## 0.0.3
 

README.md

@@ -56,8 +56,7 @@ A full description of the architecture
   please see
   [the FAQ](https://github.com/commercialhaskell/stack/wiki/FAQ).
 * For general questions, comments, feedback and support please write
-  to
-  [the Commercial Haskell mailing list](https://groups.google.com/d/forum/commercialhaskell).
+  to [the stack mailing list](https://groups.google.com/d/forum/haskell-stack).
 * For bugs, issues, or requests please
   [open an issue](https://github.com/commercialhaskell/stack/issues/new).
 

src/Data/Aeson/Extended.hs

@@ -15,9 +15,9 @@ import Data.Text (unpack, Text)
 import Data.Monoid ((<>))
 
 (.:) :: FromJSON a => Object -> Text -> Parser a
-(.:) o p = modifyFailure (("failed to parse field " <> unpack p <> ": ") <>) (o A..: p)
+(.:) o p = modifyFailure (("failed to parse field '" <> unpack p <> "': ") <>) (o A..: p)
 {-# INLINE (.:) #-}
 
 (.:?) :: FromJSON a => Object -> Text -> Parser (Maybe a)
-(.:?) o p = modifyFailure (("failed to parse field " <> unpack p <> ": ") <>) (o A..:? p)
+(.:?) o p = modifyFailure (("failed to parse field '" <> unpack p <> "': ") <>) (o A..:? p)
 {-# INLINE (.:?) #-}

src/Data/Attoparsec/Args.hs

@@ -0,0 +1,30 @@
+-- | Parsing argument-like things.
+
+module Data.Attoparsec.Args (EscapingMode(..), argsParser) where
+
+import           Control.Applicative
+import           Data.Attoparsec.Text ((<?>))
+import qualified Data.Attoparsec.Text as P
+import           Data.Attoparsec.Types (Parser)
+import           Data.Text (Text)
+
+-- | Mode for parsing escape characters.
+data EscapingMode
+    = Escaping
+    | NoEscaping
+    deriving (Show,Eq,Enum)
+
+-- | A basic argument parser. It supports space-separated text, and
+-- string quotation with identity escaping: \x -> x.
+argsParser :: EscapingMode -> Parser Text [String]
+argsParser mode = many (P.skipSpace *> (quoted <|> unquoted)) <*
+                  P.skipSpace <* (P.endOfInput <?> "unterminated string")
+  where
+    unquoted = P.many1 naked
+    quoted = P.char '"' *> string <* P.char '"'
+    string = many (case mode of
+                     Escaping -> escaped <|> nonquote
+                     NoEscaping -> nonquote)
+    escaped = P.char '\\' *> P.anyChar
+    nonquote = P.satisfy (not . (=='"'))
+    naked = P.satisfy (not . flip elem ("\" " :: String))

src/Data/Binary/VersionTagged.hs

@@ -1,46 +1,48 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 -- | Tag a Binary instance with the stack version number to ensure we're
 -- reading a compatible format.
 module Data.Binary.VersionTagged
     ( taggedDecodeOrLoad
     , taggedEncodeFile
+    , BinarySchema (..)
     ) where
 
 import Control.Monad.IO.Class (MonadIO, liftIO)
 import Data.Binary (Binary (..), encodeFile, decodeFileOrFail, putWord8, getWord8)
 import Control.Exception.Enclosed (tryIO)
-import qualified Paths_stack
-import Stack.Types.Version (Version, fromCabalVersion)
 import System.FilePath (takeDirectory)
 import System.Directory (createDirectoryIfMissing)
 import qualified Data.ByteString as S
 import Data.ByteString (ByteString)
 import Control.Monad (forM_, when)
-
-tag :: Version
-tag = fromCabalVersion Paths_stack.version
+import Data.Proxy
 
 magic :: ByteString
-magic = "STACK"
+magic = "stack"
+
+-- | A @Binary@ instance that also has a schema version
+class Binary a => BinarySchema a where
+    binarySchema :: Proxy a -> Int
 
 newtype WithTag a = WithTag a
-instance Binary a => Binary (WithTag a) where
+instance forall a. BinarySchema a => Binary (WithTag a) where
     get = do
         forM_ (S.unpack magic) $ \w -> do
             w' <- getWord8
             when (w /= w')
                 $ fail "Mismatched magic string, forcing a recompute"
         tag' <- get
-        if tag == tag'
+        if binarySchema (Proxy :: Proxy a) == tag'
             then fmap WithTag get
             else fail "Mismatched tags, forcing a recompute"
     put (WithTag x) = do
         mapM_ putWord8 $ S.unpack magic
-        put tag
+        put (binarySchema (Proxy :: Proxy a))
         put x
 
 -- | Write to the given file, with a version tag.
-taggedEncodeFile :: (Binary a, MonadIO m)
+taggedEncodeFile :: (BinarySchema a, MonadIO m)
                  => FilePath
                  -> a
                  -> m ()
@@ -51,7 +53,7 @@ taggedEncodeFile fp x = liftIO $ do
 -- | Read from the given file. If the read fails, run the given action and
 -- write that back to the file. Always starts the file off with the version
 -- tag.
-taggedDecodeOrLoad :: (Binary a, MonadIO m)
+taggedDecodeOrLoad :: (BinarySchema a, MonadIO m)
                    => FilePath
                    -> m a
                    -> m a

src/Network/HTTP/Download/Verified.hs

@@ -72,29 +72,35 @@ type LengthCheck = Int
 -- | An exception regarding verification of a download.
 data VerifiedDownloadException
     = WrongContentLength
+          Request
           Int -- expected
           ByteString -- actual (as listed in the header)
     | WrongStreamLength
+          Request
           Int -- expected
           Int -- actual
     | WrongDigest
+          Request
           String -- algorithm
           CheckHexDigest -- expected
           String -- actual (shown)
   deriving (Typeable)
 instance Show VerifiedDownloadException where
-    show (WrongContentLength expected actual) =
+    show (WrongContentLength req expected actual) =
         "Download expectation failure: ContentLength header\n"
         ++ "Expected: " ++ show expected ++ "\n"
-        ++ "Actual:   " ++ displayByteString actual
-    show (WrongStreamLength expected actual) =
+        ++ "Actual:   " ++ displayByteString actual ++ "\n"
+        ++ "For: " ++ show (getUri req)
+    show (WrongStreamLength req expected actual) =
         "Download expectation failure: download size\n"
         ++ "Expected: " ++ show expected ++ "\n"
-        ++ "Actual:   " ++ show actual
-    show (WrongDigest algo expected actual) =
+        ++ "Actual:   " ++ show actual ++ "\n"
+        ++ "For: " ++ show (getUri req)
+    show (WrongDigest req algo expected actual) =
         "Download expectation failure: content hash (" ++ algo ++  ")\n"
         ++ "Expected: " ++ displayCheckHexDigest expected ++ "\n"
-        ++ "Actual:   " ++ actual
+        ++ "Actual:   " ++ actual ++ "\n"
+        ++ "For: " ++ show (getUri req)
 
 instance Exception VerifiedDownloadException
 
@@ -125,9 +131,10 @@ displayCheckHexDigest (CheckHexDigestHeader h) =
 --
 -- Throws WrongDigest (VerifiedDownloadException)
 sinkCheckHash :: MonadThrow m
-    => HashCheck
+    => Request
+    -> HashCheck
     -> Consumer ByteString m ()
-sinkCheckHash HashCheck{..} = do
+sinkCheckHash req HashCheck{..} = do
     digest <- sinkHashUsing hashCheckAlgorithm
     let actualDigestString = show digest
     let actualDigestHexByteString = digestToHexByteString digest
@@ -142,23 +149,24 @@ sinkCheckHash HashCheck{..} = do
             || b == actualDigestHexByteString
 
     when (not passedCheck) $
-        throwM $ WrongDigest (show hashCheckAlgorithm) hashCheckHexDigest actualDigestString
+        throwM $ WrongDigest req (show hashCheckAlgorithm) hashCheckHexDigest actualDigestString
 
 assertLengthSink :: MonadThrow m
-    => LengthCheck
+    => Request
+    -> LengthCheck
     -> ZipSink ByteString m ()
-assertLengthSink expectedStreamLength = ZipSink $ do
+assertLengthSink req expectedStreamLength = ZipSink $ do
   Sum actualStreamLength <- CL.foldMap (Sum . ByteString.length)
   when (actualStreamLength /= expectedStreamLength) $
-    throwM $ WrongStreamLength expectedStreamLength actualStreamLength
+    throwM $ WrongStreamLength req expectedStreamLength actualStreamLength
 
 -- | A more explicitly type-guided sinkHash.
 sinkHashUsing :: (Monad m, HashAlgorithm a) => a -> Consumer ByteString m (Digest a)
 sinkHashUsing _ = sinkHash
 
 -- | Turns a list of hash checks into a ZipSink that checks all of them.
-hashChecksToZipSink :: MonadThrow m => [HashCheck] -> ZipSink ByteString m ()
-hashChecksToZipSink = traverse_ (ZipSink . sinkCheckHash)
+hashChecksToZipSink :: MonadThrow m => Request -> [HashCheck] -> ZipSink ByteString m ()
+hashChecksToZipSink req = traverse_ (ZipSink . sinkCheckHash req)
 
 -- | Copied and extended version of Network.HTTP.Download.download.
 --
@@ -215,7 +223,7 @@ verifiedDownload DownloadRequest{..} destpath progressSink = do
 
     checkExpectations = bracket (openFile fp ReadMode) hClose $ \h -> do
         whenJust drLengthCheck $ checkFileSizeExpectations h
-        sourceHandle h $$ getZipSink (hashChecksToZipSink drHashChecks)
+        sourceHandle h $$ getZipSink (hashChecksToZipSink drRequest drHashChecks)
 
     -- doesn't move the handle
     checkFileSizeExpectations h expectedFileSize = do
@@ -231,7 +239,7 @@ verifiedDownload DownloadRequest{..} destpath progressSink = do
             Just lengthBS -> do
               let lengthStr = displayByteString lengthBS
               when (lengthStr /= show expectedContentLength) $
-                throwM $ WrongContentLength expectedContentLength lengthBS
+                throwM $ WrongContentLength drRequest expectedContentLength lengthBS
             _ -> return ()
 
     go h res = do
@@ -250,7 +258,7 @@ verifiedDownload DownloadRequest{..} destpath progressSink = do
         responseBody res
             $= maybe (awaitForever yield) CB.isolate drLengthCheck
             $$ getZipSink
-                ( hashChecksToZipSink hashChecks
-                  *> maybe (pure ()) assertLengthSink drLengthCheck
+                ( hashChecksToZipSink drRequest hashChecks
+                  *> maybe (pure ()) (assertLengthSink drRequest) drLengthCheck
                   *> ZipSink (sinkHandle h)
                   *> ZipSink progressSink)

src/Options/Applicative/Args.hs

@@ -5,15 +5,11 @@
 module Options.Applicative.Args
     (argsArgument
     ,argsOption
-    ,parseArgsFromString
-    ,argsParser)
+    ,parseArgsFromString)
     where
 
-import           Control.Applicative
-import           Data.Attoparsec.Text ((<?>))
+import           Data.Attoparsec.Args
 import qualified Data.Attoparsec.Text as P
-import           Data.Attoparsec.Types (Parser)
-import           Data.Text (Text)
 import qualified Data.Text as T
 import qualified Options.Applicative as O
 
@@ -33,17 +29,4 @@ argsOption =
 
 -- | Parse from a string.
 parseArgsFromString :: String -> Either String [String]
-parseArgsFromString = P.parseOnly argsParser . T.pack
-
--- | A basic argument parser. It supports space-separated text, and
--- string quotation with identity escaping: \x -> x.
-argsParser :: Parser Text [String]
-argsParser = many (P.skipSpace *> (quoted <|> unquoted)) <*
-             P.skipSpace <* (P.endOfInput <?> "unterminated string")
-  where
-    unquoted = P.many1 naked
-    quoted = P.char '"' *> string <* P.char '"'
-    string = many (escaped <|> nonquote)
-    escaped = P.char '\\' *> P.anyChar
-    nonquote = P.satisfy (not . (=='"'))
-    naked = P.satisfy (not . flip elem ("\" " :: String))
+parseArgsFromString = P.parseOnly (argsParser Escaping) . T.pack

src/Options/Applicative/Builder/Extra.hs

@@ -2,8 +2,10 @@
 
 module Options.Applicative.Builder.Extra
   (boolFlags
+  ,boolFlagsNoDefault
   ,maybeBoolFlags
   ,enableDisableFlags
+  ,enableDisableFlagsNoDefault
   ,extraHelpOption
   ,execExtraHelp)
   where
@@ -17,13 +19,23 @@ import System.FilePath (takeBaseName)
 boolFlags :: Bool -> String -> String -> Mod FlagFields Bool -> Parser Bool
 boolFlags defaultValue = enableDisableFlags defaultValue True False
 
+-- | Enable/disable flags for a @Bool@, without a default case (to allow chaining @<|>@s).
+boolFlagsNoDefault :: String -> String -> Mod FlagFields Bool -> Parser Bool
+boolFlagsNoDefault = enableDisableFlagsNoDefault True False
+
 -- | Enable/disable flags for a @(Maybe Bool)@.
 maybeBoolFlags :: String -> String -> Mod FlagFields (Maybe Bool) -> Parser (Maybe Bool)
 maybeBoolFlags = enableDisableFlags Nothing (Just True) (Just False)
 
 -- | Enable/disable flags for any type.
 enableDisableFlags :: a -> a -> a -> String -> String -> Mod FlagFields a -> Parser a
 enableDisableFlags defaultValue enabledValue disabledValue name helpSuffix mods =
+  enableDisableFlagsNoDefault enabledValue disabledValue name helpSuffix mods <|>
+  pure defaultValue
+
+-- | Enable/disable flags for any type, without a default (to allow chaining @<|>@s)
+enableDisableFlagsNoDefault :: a -> a -> String -> String -> Mod FlagFields a -> Parser a
+enableDisableFlagsNoDefault enabledValue disabledValue name helpSuffix mods =
   flag' enabledValue
         (long name <>
          help ("Enable " ++ helpSuffix) <>
@@ -41,8 +53,7 @@ enableDisableFlags defaultValue enabledValue disabledValue name helpSuffix mods
         (internal <>
          long ("disable-" ++ name) <>
          help ("Disable " ++ helpSuffix) <>
-         mods) <|>
-  pure defaultValue
+         mods)
 
 -- | Show an extra help option (e.g. @--docker-help@ shows help for all @--docker*@ args).
 -- To actually show have that help appear, use 'execExtraHelp' before executing the main parser.

src/Path/IO.hs

@@ -14,7 +14,8 @@ module Path.IO
   ,removeTree
   ,removeTreeIfExists
   ,fileExists
-  ,dirExists)
+  ,dirExists
+  ,copyDirectoryRecursive)
   where
 
 import           Control.Exception hiding (catch)
@@ -150,3 +151,24 @@ fileExists =
 dirExists :: MonadIO m => Path b Dir -> m Bool
 dirExists =
     liftIO . doesFileExist . toFilePath
+
+-- | Copy a directory recursively.  This just uses 'copyFile', so it is not smart about symbolic
+-- links or other special files.
+copyDirectoryRecursive :: (MonadIO m,MonadThrow m)
+                       => Path Abs Dir -- ^ Source directory
+                       -> Path Abs Dir -- ^ Destination directory
+                       -> m ()
+copyDirectoryRecursive srcDir destDir =
+    do liftIO (createDirectoryIfMissing False (toFilePath destDir))
+       (srcSubDirs,srcFiles) <- listDirectory srcDir
+       forM_ srcFiles
+             (\srcFile ->
+                case stripDir srcDir srcFile of
+                  Nothing -> return ()
+                  Just relFile -> liftIO (copyFile (toFilePath srcFile)
+                                                   (toFilePath (destDir </> relFile))))
+       forM_ srcSubDirs
+             (\srcSubDir ->
+                case stripDir srcDir srcSubDir of
+                  Nothing -> return ()
+                  Just relSubDir -> copyDirectoryRecursive srcSubDir (destDir </> relSubDir))