diff --git a/ChangeLog.md b/ChangeLog.md
--- a/ChangeLog.md
+++ b/ChangeLog.md
@@ -1,3 +1,52 @@
+## 0.1.3.0
+
+Major changes:
+
+* Detect when a module is compiled but not listed in the cabal file ([#32](https://github.com/commercialhaskell/stack/issues/32))
+ * A warning is displayed for any modules that should be added to `other-modules` in the .cabal file
+ * These modules are taken into account when determining whether a package needs to be built
+* Respect TemplateHaskell addDependentFile dependency changes ([#105](https://github.com/commercialhaskell/stack/issues/105))
+ * TH dependent files are taken into account when determining whether a package needs to be built.
+* Overhauled target parsing, added `--test` and `--bench` options [#651](https://github.com/commercialhaskell/stack/issues/651)
+ * For details, see [Build commands Wiki page](https://github.com/commercialhaskell/stack/wiki/Build-command)
+
+Other enhancements:
+
+* Set the `HASKELL_DIST_DIR` environment variable [#524](https://github.com/commercialhaskell/stack/pull/524)
+* Track build status of tests and benchmarks [#525](https://github.com/commercialhaskell/stack/issues/525)
+* `--no-run-tests` [#517](https://github.com/commercialhaskell/stack/pull/517)
+* Targets outside of root dir don't build [#366](https://github.com/commercialhaskell/stack/issues/366)
+* Upper limit on number of flag combinations to test [#543](https://github.com/commercialhaskell/stack/issues/543)
+* Fuzzy matching support to give better error messages for close version numbers [#504](https://github.com/commercialhaskell/stack/issues/504)
+* `--local-bin-path` global option. Use to change where binaries get placed on a `--copy-bins` [#342](https://github.com/commercialhaskell/stack/issues/342)
+* Custom snapshots [#111](https://github.com/commercialhaskell/stack/issues/111)
+* --force-dirty flag: Force treating all local packages as having dirty files (useful for cases where stack can't detect a file change)
+* GHC error messages: display file paths as absolute instead of relative for better editor integration
+* Add the `--copy-bins` option [#569](https://github.com/commercialhaskell/stack/issues/569)
+* Give warnings on unexpected config keys [#48](https://github.com/commercialhaskell/stack/issues/48)
+* Remove Docker `pass-host` option
+* Don't require cabal-install to upload [#313](https://github.com/commercialhaskell/stack/issues/313)
+* Generate indexes for all deps and all installed snapshot packages [#143](https://github.com/commercialhaskell/stack/issues/143)
+* Provide `--resolver global` option [#645](https://github.com/commercialhaskell/stack/issues/645)
+ * Also supports `--resolver nightly`, `--resolver lts`, and `--resolver lts-X`
+* Make `stack build --flag` error when flag or package is unknown [#617](https://github.com/commercialhaskell/stack/issues/617)
+* Preserve file permissions when unpacking sources [#666](https://github.com/commercialhaskell/stack/pull/666)
+* `stack build` etc work outside of a project
+* `list-dependencies` command [#638](https://github.com/commercialhaskell/stack/issues/638)
+* `--upgrade-cabal` option to `stack setup` [#174](https://github.com/commercialhaskell/stack/issues/174)
+* `--exec` option [#651](https://github.com/commercialhaskell/stack/issues/651)
+* `--only-dependencies` implemented correctly [#387](https://github.com/commercialhaskell/stack/issues/387)
+
+Bug fixes:
+
+* Extensions from the `other-extensions` field no longer enabled by default [#449](https://github.com/commercialhaskell/stack/issues/449)
+* Fix: haddock forces rebuild of empty packages [#452](https://github.com/commercialhaskell/stack/issues/452)
+* Don't copy over executables excluded by component selection [#605](https://github.com/commercialhaskell/stack/issues/605)
+* Fix: stack fails on Windows with git package in stack.yaml and no git binary on path [#712](https://github.com/commercialhaskell/stack/issues/712)
+* Fixed GHCi issue: Specifying explicit package versions (#678)
+* Fixed GHCi issue: Specifying -odir and -hidir as .stack-work/odir (#529)
+* Fixed GHCi issue: Specifying A instead of A.ext for modules (#498)
+
## 0.1.2.0
* Add `--prune` flag to `stack dot` [#487](https://github.com/commercialhaskell/stack/issues/487)
diff --git a/README.md b/README.md
--- a/README.md
+++ b/README.md
@@ -1,7 +1,7 @@
## The Haskell Tool Stack
[](https://travis-ci.org/commercialhaskell/stack)
-
+[](https://github.com/commercialhaskell/stack/releases)
`stack` is a cross-platform program for developing Haskell
projects. It is aimed at Haskellers both new and experienced.
@@ -23,6 +23,9 @@
* [Windows](https://github.com/commercialhaskell/stack/wiki/Downloads#windows)
* [OS X](https://github.com/commercialhaskell/stack/wiki/Downloads#os-x)
* [Ubuntu](https://github.com/commercialhaskell/stack/wiki/Downloads#ubuntu)
+* [Debian](https://github.com/commercialhaskell/stack/wiki/Downloads#debian)
+* [CentOS / Red Hat / Amazon Linux](https://github.com/commercialhaskell/stack/wiki/Downloads#centos--red-hat)
+* [Fedora](https://github.com/commercialhaskell/stack/wiki/Downloads#fedora)
* [Arch Linux](https://github.com/commercialhaskell/stack/wiki/Downloads#arch-linux)
* [Linux (general)](https://github.com/commercialhaskell/stack/wiki/Downloads#linux)
@@ -63,6 +66,8 @@
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).
+* When using Stack Overflow, please use [the haskell-stack
+ tag](http://stackoverflow.com/questions/tagged/haskell-stack).
#### Why stack?
diff --git a/new-template/LICENSE b/new-template/LICENSE
deleted file mode 100644
--- a/new-template/LICENSE
+++ /dev/null
@@ -1,30 +0,0 @@
-Copyright (c) 2015
-
-All rights reserved.
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are met:
-
- * Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
-
- * Redistributions in binary form must reproduce the above
- copyright notice, this list of conditions and the following
- disclaimer in the documentation and/or other materials provided
- with the distribution.
-
- * Neither the name of Your name here nor the names of other
- contributors may be used to endorse or promote products derived
- from this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/new-template/Setup.hs b/new-template/Setup.hs
deleted file mode 100644
--- a/new-template/Setup.hs
+++ /dev/null
@@ -1,2 +0,0 @@
-import Distribution.Simple
-main = defaultMain
diff --git a/new-template/app/Main.hs b/new-template/app/Main.hs
deleted file mode 100644
--- a/new-template/app/Main.hs
+++ /dev/null
@@ -1,6 +0,0 @@
-module Main where
-
-import Lib
-
-main :: IO ()
-main = someFunc
diff --git a/new-template/new-template.cabal b/new-template/new-template.cabal
deleted file mode 100644
--- a/new-template/new-template.cabal
+++ /dev/null
@@ -1,41 +0,0 @@
-name: new-template
-version: 0.1.0.0
-synopsis: Initial project template from stack
-description: Please see README.md
-homepage: http://github.com/name/project
-license: BSD3
-license-file: LICENSE
-author: Your name here
-maintainer: your.address@example.com
--- copyright:
-category: Web
-build-type: Simple
--- extra-source-files:
-cabal-version: >=1.10
-
-library
- hs-source-dirs: src
- exposed-modules: Lib
- build-depends: base >= 4.7 && < 5
- default-language: Haskell2010
-
-executable new-template-exe
- hs-source-dirs: app
- main-is: Main.hs
- ghc-options: -threaded -rtsopts -with-rtsopts=-N
- build-depends: base
- , new-template
- default-language: Haskell2010
-
-test-suite new-template-test
- type: exitcode-stdio-1.0
- hs-source-dirs: test
- main-is: Spec.hs
- build-depends: base
- , new-template
- ghc-options: -threaded -rtsopts -with-rtsopts=-N
- default-language: Haskell2010
-
-source-repository head
- type: git
- location: https://github.com/name/project
diff --git a/new-template/src/Lib.hs b/new-template/src/Lib.hs
deleted file mode 100644
--- a/new-template/src/Lib.hs
+++ /dev/null
@@ -1,6 +0,0 @@
-module Lib
- ( someFunc
- ) where
-
-someFunc :: IO ()
-someFunc = putStrLn "someFunc"
diff --git a/new-template/test/Spec.hs b/new-template/test/Spec.hs
deleted file mode 100644
--- a/new-template/test/Spec.hs
+++ /dev/null
@@ -1,2 +0,0 @@
-main :: IO ()
-main = putStrLn "Test suite not yet implemented"
diff --git a/src/Data/Aeson/Extended.hs b/src/Data/Aeson/Extended.hs
--- a/src/Data/Aeson/Extended.hs
+++ b/src/Data/Aeson/Extended.hs
@@ -1,23 +1,151 @@
--- | The purpose of this module is to provide better failure messages
--- When parsing a key of an object, this makes sure the key itself will show up
+{-# LANGUAGE OverloadedStrings, RecordWildCards, TemplateHaskell, TupleSections #-}
+
+-- | Extensions to Aeson parsing of objects.
module Data.Aeson.Extended (
module Export
+ -- * Extended failure messages
, (.:)
, (.:?)
+ -- * JSON Parser that emits warnings
+ , WarningParser
+ , JSONWarning (..)
+ , withObjectWarnings
+ , (..:)
+ , (..:?)
+ , (..!=)
+ , jsonSubWarnings
+ , jsonSubWarningsT
+ , jsonSubWarningsMT
+ , logJSONWarnings
) where
+import Control.Monad.Logger (MonadLogger, logWarn)
+import Control.Monad.Trans (lift)
+import Control.Monad.Trans.Writer.Strict (WriterT, mapWriterT, runWriterT, tell)
import Data.Aeson as Export hiding ((.:), (.:?))
import qualified Data.Aeson as A
-
import Data.Aeson.Types hiding ((.:), (.:?))
-
+import qualified Data.HashMap.Strict as HashMap
+import Data.Monoid (Monoid (..), (<>))
+import Data.Set (Set)
+import qualified Data.Set as Set
import Data.Text (unpack, Text)
-import Data.Monoid ((<>))
+import qualified Data.Text as T
+import Data.Traversable (Traversable)
+import qualified Data.Traversable as Traversable
+-- | Extends @.:@ warning to include field name.
(.:) :: FromJSON a => Object -> Text -> Parser a
(.:) o p = modifyFailure (("failed to parse field '" <> unpack p <> "': ") <>) (o A..: p)
{-# INLINE (.:) #-}
+-- | Extends @.:?@ warning to include field name.
(.:?) :: FromJSON a => Object -> Text -> Parser (Maybe a)
(.:?) o p = modifyFailure (("failed to parse field '" <> unpack p <> "': ") <>) (o A..:? p)
{-# INLINE (.:?) #-}
+
+-- | 'WarningParser' version of @.:@.
+(..:)
+ :: FromJSON a
+ => Object -> Text -> WarningParser a
+o ..: k = tellField k >> lift (o .: k)
+
+-- | 'WarningParser' version of @.:?@.
+(..:?)
+ :: FromJSON a
+ => Object -> Text -> WarningParser (Maybe a)
+o ..:? k = tellField k >> lift (o .:? k)
+
+-- | 'WarningParser' version of @.!=@.
+(..!=) :: WarningParser (Maybe a) -> a -> WarningParser a
+wp ..!= d =
+ flip mapWriterT wp $
+ \p ->
+ do a <- fmap snd p
+ fmap (, a) (fmap fst p .!= d)
+
+-- | Tell warning parser about about an expected field.
+tellField :: Text -> WarningParser ()
+tellField key = tell (mempty { wpmExpectedFields = Set.singleton key})
+
+-- | 'MonadParser' version of 'withObject'.
+withObjectWarnings :: String
+ -> (Object -> WarningParser a)
+ -> Value
+ -> Parser (a, [JSONWarning])
+withObjectWarnings expected f =
+ withObject expected $
+ \obj ->
+ do (a,w) <- runWriterT (f obj)
+ let unrecognizedFields =
+ Set.toList
+ (Set.difference
+ (Set.fromList (HashMap.keys obj))
+ (wpmExpectedFields w))
+ return
+ ( a
+ , wpmWarnings w ++
+ case unrecognizedFields of
+ [] -> []
+ _ -> [JSONUnrecognizedFields expected unrecognizedFields])
+
+-- | Log JSON warnings.
+logJSONWarnings
+ :: MonadLogger m
+ => FilePath -> [JSONWarning] -> m ()
+logJSONWarnings fp =
+ mapM_ (\w -> $logWarn ("Warning: " <> T.pack fp <> ": " <> T.pack (show w)))
+
+-- | Handle warnings in a sub-object.
+jsonSubWarnings :: WarningParser (a, [JSONWarning]) -> WarningParser a
+jsonSubWarnings f = do
+ (result,warnings) <- f
+ tell
+ (mempty
+ { wpmWarnings = warnings
+ })
+ return result
+
+-- | Handle warnings in a @Traversable@ of sub-objects.
+jsonSubWarningsT
+ :: Traversable t
+ => WarningParser (t (a, [JSONWarning])) -> WarningParser (t a)
+jsonSubWarningsT f =
+ Traversable.mapM (jsonSubWarnings . return) =<< f
+
+-- | Handle warnings in a @Maybe Traversable@ of sub-objects.
+jsonSubWarningsMT
+ :: (Traversable t)
+ => WarningParser (Maybe (t (a, [JSONWarning])))
+ -> WarningParser (Maybe (t a))
+jsonSubWarningsMT f = do
+ ml <- f
+ case ml of
+ Nothing -> return Nothing
+ Just l -> fmap Just (jsonSubWarningsT (return l))
+
+-- | JSON parser that warns about unexpected fields in objects.
+type WarningParser a = WriterT WarningParserMonoid Parser a
+
+-- | Monoid used by 'MonadParser' to track expected fields and warnings.
+data WarningParserMonoid = WarningParserMonoid
+ { wpmExpectedFields :: !(Set Text)
+ , wpmWarnings :: [JSONWarning]
+ }
+instance Monoid WarningParserMonoid where
+ mempty = WarningParserMonoid Set.empty []
+ mappend a b =
+ WarningParserMonoid
+ { wpmExpectedFields = Set.union
+ (wpmExpectedFields a)
+ (wpmExpectedFields b)
+ , wpmWarnings = wpmWarnings a ++ wpmWarnings b
+ }
+
+-- | Warning output from 'WarningParser'.
+data JSONWarning = JSONUnrecognizedFields String [Text]
+instance Show JSONWarning where
+ show (JSONUnrecognizedFields obj [field]) =
+ "Unrecognized field in " <> obj <> ": " <> T.unpack field
+ show (JSONUnrecognizedFields obj fields) =
+ "Unrecognized fields in " <> obj <> ": " <> T.unpack (T.intercalate ", " fields)
diff --git a/src/Data/Binary/VersionTagged.hs b/src/Data/Binary/VersionTagged.hs
--- a/src/Data/Binary/VersionTagged.hs
+++ b/src/Data/Binary/VersionTagged.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | Tag a Binary instance with the stack version number to ensure we're
@@ -5,12 +7,22 @@
module Data.Binary.VersionTagged
( taggedDecodeOrLoad
, taggedEncodeFile
+ , Binary (..)
, BinarySchema (..)
+ , decodeFileOrFailDeep
+ , encodeFile
+ , NFData (..)
+ , genericRnf
) where
+import Control.DeepSeq.Generics (NFData (..), genericRnf)
+import Control.Exception (Exception)
+import Control.Monad.Catch (MonadThrow (..))
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Binary (Binary (..), encodeFile, decodeFileOrFail, putWord8, getWord8)
-import Control.Exception.Enclosed (tryIO)
+import Data.Binary.Get (ByteOffset)
+import Data.Typeable (Typeable)
+import Control.Exception.Enclosed (tryAnyDeep)
import System.FilePath (takeDirectory)
import System.Directory (createDirectoryIfMissing)
import qualified Data.ByteString as S
@@ -22,10 +34,11 @@
magic = "stack"
-- | A @Binary@ instance that also has a schema version
-class Binary a => BinarySchema a where
+class (Binary a, NFData a) => BinarySchema a where
binarySchema :: Proxy a -> Int
newtype WithTag a = WithTag a
+ deriving NFData
instance forall a. BinarySchema a => Binary (WithTag a) where
get = do
forM_ (S.unpack magic) $ \w -> do
@@ -58,10 +71,35 @@
-> m a
-> m a
taggedDecodeOrLoad fp mx = do
- eres <- liftIO $ tryIO $ decodeFileOrFail fp
+ eres <- decodeFileOrFailDeep fp
case eres of
- Right (Right (WithTag x)) -> return x
- _ -> do
+ Left _ -> do
x <- mx
taggedEncodeFile fp x
return x
+ Right (WithTag x) -> return x
+
+-- | Ensure that there are no lurking exceptions deep inside the parsed
+-- value... because that happens unfortunately. See
+-- https://github.com/commercialhaskell/stack/issues/554
+decodeFileOrFailDeep :: (Binary a, NFData a, MonadIO m, MonadThrow n)
+ => FilePath
+ -> m (n a)
+decodeFileOrFailDeep fp = liftIO $ fmap (either throwM return) $ tryAnyDeep $ do
+ eres <- decodeFileOrFail fp
+ case eres of
+ Left (offset, str) -> throwM $ DecodeFileFailure fp offset str
+ Right x -> return x
+
+data DecodeFileFailure = DecodeFileFailure FilePath ByteOffset String
+ deriving Typeable
+instance Show DecodeFileFailure where
+ show (DecodeFileFailure fp offset str) = concat
+ [ "Decoding of "
+ , fp
+ , " failed at offset "
+ , show offset
+ , ": "
+ , str
+ ]
+instance Exception DecodeFileFailure
diff --git a/src/Network/HTTP/Download.hs b/src/Network/HTTP/Download.hs
--- a/src/Network/HTTP/Download.hs
+++ b/src/Network/HTTP/Download.hs
@@ -4,7 +4,9 @@
module Network.HTTP.Download
( verifiedDownload
, DownloadRequest(..)
+ , drRetryPolicyDefault
, HashCheck(..)
+ , DownloadException(..)
, CheckHexDigest(..)
, LengthCheck
, VerifiedDownloadException(..)
@@ -69,8 +71,9 @@
{ drRequest = req
, drHashChecks = []
, drLengthCheck = Nothing
+ , drRetryPolicy = drRetryPolicyDefault
}
- let progressHook = return ()
+ let progressHook _ = return ()
verifiedDownload downloadReq destpath progressHook
-- | Same as 'download', but will download a file a second time if it is already present.
diff --git a/src/Network/HTTP/Download/Verified.hs b/src/Network/HTTP/Download/Verified.hs
--- a/src/Network/HTTP/Download/Verified.hs
+++ b/src/Network/HTTP/Download/Verified.hs
@@ -9,6 +9,7 @@
module Network.HTTP.Download.Verified
( verifiedDownload
, DownloadRequest(..)
+ , drRetryPolicyDefault
, HashCheck(..)
, CheckHexDigest(..)
, LengthCheck
@@ -27,10 +28,12 @@
import Control.Monad.Catch
import Control.Monad.IO.Class
import Control.Monad.Reader
+import Control.Retry (recovering,limitRetries,RetryPolicy,constantDelay)
import Control.Applicative
import Crypto.Hash
import Crypto.Hash.Conduit (sinkHash)
import Data.ByteString (ByteString)
+import Data.ByteString.Char8 (readInteger)
import Data.Conduit
import Data.Conduit.Binary (sourceHandle, sinkHandle)
import Data.Foldable (traverse_,for_)
@@ -50,9 +53,14 @@
{ drRequest :: Request
, drHashChecks :: [HashCheck]
, drLengthCheck :: Maybe LengthCheck
+ , drRetryPolicy :: RetryPolicy
}
- deriving Show
+-- | Default to retrying thrice with a short constant delay.
+drRetryPolicyDefault :: RetryPolicy
+drRetryPolicyDefault = limitRetries 3 <> constantDelay onehundredMilliseconds
+ where onehundredMilliseconds = 100000
+
data HashCheck = forall a. (Show a, HashAlgorithm a) => HashCheck
{ hashCheckAlgorithm :: a
, hashCheckHexDigest :: CheckHexDigest
@@ -178,22 +186,28 @@
-- * Verifies md5 if response includes content-md5 header
-- * Verifies the expected hashes
--
--- Throws VerifiedDownloadException, and whatever else "download" throws.
+-- Throws VerifiedDownloadException.
+-- Throws IOExceptions related to file system operations.
+-- Throws HttpException.
verifiedDownload :: (MonadReader env m, HasHttpManager env, MonadIO m)
=> DownloadRequest
-> Path Abs File -- ^ destination
- -> Sink ByteString (ReaderT env IO) () -- ^ custom hook to observe progress
+ -> (Maybe Integer -> Sink ByteString (ReaderT env IO) ()) -- ^ custom hook to observe progress
-> m Bool -- ^ Whether a download was performed
verifiedDownload DownloadRequest{..} destpath progressSink = do
let req = drRequest
env <- ask
liftIO $ whenM' getShouldDownload $ do
createDirectoryIfMissing True dir
- withBinaryFile fptmp WriteMode $ \h ->
- flip runReaderT env $
- withResponse req (go h)
+ withBinaryFile fptmp WriteMode $ \h -> do
+ recovering drRetryPolicy [const $ Handler alwaysRetryHttp] $
+ flip runReaderT env $
+ withResponse req (go h)
renameFile fptmp fp
where
+ alwaysRetryHttp :: Monad m => HttpException -> m Bool
+ alwaysRetryHttp _ = return True
+
whenM' mp m = do
p <- mp
if p then m >> return True else return False
@@ -240,6 +254,10 @@
go h res = do
let headers = responseHeaders res
+ mcontentLength = do
+ hLength <- List.lookup hContentLength headers
+ (i,_) <- readInteger hLength
+ return i
for_ drLengthCheck $ checkContentLengthHeader headers
let hashChecks = (case List.lookup hContentMD5 headers of
Just md5BS ->
@@ -257,4 +275,4 @@
( hashChecksToZipSink drRequest hashChecks
*> maybe (pure ()) (assertLengthSink drRequest) drLengthCheck
*> ZipSink (sinkHandle h)
- *> ZipSink progressSink)
+ *> ZipSink (progressSink mcontentLength))
diff --git a/src/Options/Applicative/Args.hs b/src/Options/Applicative/Args.hs
--- a/src/Options/Applicative/Args.hs
+++ b/src/Options/Applicative/Args.hs
@@ -5,6 +5,7 @@
module Options.Applicative.Args
(argsArgument
,argsOption
+ ,cmdOption
,parseArgsFromString)
where
@@ -26,6 +27,16 @@
O.option
(do string <- O.str
either O.readerError return (parseArgsFromString string))
+
+-- | An option which accepts a command and a list of arguments e.g. @--exec "echo hello world"@
+cmdOption :: O.Mod O.OptionFields (String, [String]) -> O.Parser (String, [String])
+cmdOption =
+ O.option
+ (do string <- O.str
+ xs <- either O.readerError return (parseArgsFromString string)
+ case xs of
+ [] -> O.readerError "Must provide a command"
+ x:xs' -> return (x, xs'))
-- | Parse from a string.
parseArgsFromString :: String -> Either String [String]
diff --git a/src/Options/Applicative/Builder/Extra.hs b/src/Options/Applicative/Builder/Extra.hs
--- a/src/Options/Applicative/Builder/Extra.hs
+++ b/src/Options/Applicative/Builder/Extra.hs
@@ -36,6 +36,10 @@
-- | 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 =
+ last <$> some (enableDisableFlagsNoDefault' enabledValue disabledValue name helpSuffix mods)
+
+enableDisableFlagsNoDefault' :: a -> a -> String -> String -> Mod FlagFields a -> Parser a
+enableDisableFlagsNoDefault' enabledValue disabledValue name helpSuffix mods =
flag' enabledValue
(long name <>
help ("Enable " ++ helpSuffix) <>
diff --git a/src/Path/IO.hs b/src/Path/IO.hs
--- a/src/Path/IO.hs
+++ b/src/Path/IO.hs
@@ -4,23 +4,33 @@
module Path.IO
(getWorkingDir
+ ,parseRelAsAbsDir
+ ,parseRelAsAbsFile
,listDirectory
,resolveDir
,resolveFile
,resolveDirMaybe
,resolveFileMaybe
,ResolveException(..)
+ ,removeFile
,removeFileIfExists
,removeTree
,removeTreeIfExists
- ,fileExists
+ ,renameFile
,renameFileIfExists
+ ,renameDir
,renameDirIfExists
+ ,moveFile
,moveFileIfExists
+ ,moveDir
,moveDirIfExists
+ ,fileExists
,dirExists
+ ,copyFile
+ ,copyFileIfExists
,copyDirectoryRecursive
- ,createTree)
+ ,createTree
+ ,dropRoot)
where
import Control.Exception hiding (catch)
@@ -31,7 +41,8 @@
import Data.Maybe
import Data.Typeable
import Path
-import System.Directory
+import Path.Internal (Path(..))
+import qualified System.Directory as D
import qualified System.FilePath as FP
import System.IO.Error
@@ -47,8 +58,18 @@
-- | Get the current working directory.
getWorkingDir :: (MonadIO m) => m (Path Abs Dir)
-getWorkingDir = liftIO (canonicalizePath "." >>= parseAbsDir)
+getWorkingDir = liftIO (D.canonicalizePath "." >>= parseAbsDir)
+-- | Parse a directory path. If it's relative, then the absolute version
+-- is yielded, based off the working directory.
+parseRelAsAbsDir :: (MonadThrow m, MonadIO m) => FilePath -> m (Path Abs Dir)
+parseRelAsAbsDir fp = parseAbsDir =<< liftIO (D.canonicalizePath fp)
+
+-- | Parse a file path. If it's relative, then the absolute version is
+-- yielded, based off the working directory.
+parseRelAsAbsFile :: (MonadThrow m, MonadIO m) => FilePath -> m (Path Abs File)
+parseRelAsAbsFile fp = parseAbsFile =<< liftIO (D.canonicalizePath fp)
+
-- | Appends a stringly-typed relative path to an absolute path, and then
-- canonicalizes it.
resolveDir :: (MonadIO m, MonadThrow m) => Path Abs Dir -> FilePath -> m (Path Abs Dir)
@@ -84,7 +105,7 @@
exists <- liftIO $ check fp
if exists
then do
- canonic <- liftIO $ canonicalizePath fp
+ canonic <- liftIO $ D.canonicalizePath fp
liftM Just (parse canonic)
else return Nothing
@@ -93,23 +114,23 @@
-- be canonicalized, 'Nothing' is returned).
resolveDirMaybe :: (MonadIO m,MonadThrow m)
=> Path Abs Dir -> FilePath -> m (Maybe (Path Abs Dir))
-resolveDirMaybe = resolveCheckParse doesDirectoryExist parseAbsDir
+resolveDirMaybe = resolveCheckParse D.doesDirectoryExist parseAbsDir
-- | Appends a stringly-typed relative path to an absolute path, and then
-- canonicalizes it. If the path doesn't exist (and therefore cannot
-- be canonicalized, 'Nothing' is returned).
resolveFileMaybe :: (MonadIO m,MonadThrow m)
=> Path Abs Dir -> FilePath -> m (Maybe (Path Abs File))
-resolveFileMaybe = resolveCheckParse doesFileExist parseAbsFile
+resolveFileMaybe = resolveCheckParse D.doesFileExist parseAbsFile
-- | List objects in a directory, excluding "@.@" and "@..@". Entries are not sorted.
listDirectory :: (MonadIO m,MonadThrow m) => Path Abs Dir -> m ([Path Abs Dir],[Path Abs File])
listDirectory dir =
- do entriesFP <- liftIO (getDirectoryContents dirFP)
+ do entriesFP <- liftIO (D.getDirectoryContents dirFP)
maybeEntries <-
forM (map (dirFP ++) entriesFP)
(\entryFP ->
- do isDir <- liftIO (doesDirectoryExist entryFP)
+ do isDir <- liftIO (D.doesDirectoryExist entryFP)
if isDir
then case parseAbsDir entryFP of
Nothing -> return Nothing
@@ -124,98 +145,79 @@
return (lefts entries,rights entries)
where dirFP = toFilePath dir
--- | Remove the given file. Optimistically assumes it exists. If it
--- doesn't, doesn't complain.
+-- | Remove a file. Bails out if it doesn't exist.
+removeFile :: MonadIO m => Path b File -> m ()
+removeFile = liftIO . D.removeFile . toFilePath
+
+-- | Remove a file. Optimistically assumes it exists. If it doesn't,
+-- doesn't complain.
removeFileIfExists :: MonadIO m => Path b File -> m ()
-removeFileIfExists fp =
- liftIO (catch
- (removeFile
- (toFilePath fp))
- (\e ->
- if isDoesNotExistError e
- then return ()
- else throwIO e))
+removeFileIfExists = ignoreDoesNotExist . removeFile
--- | Move the given file. Optimistically assumes it exists. If it
--- doesn't, doesn't complain.
-renameFileIfExists :: MonadIO m => Path b File -> Path b File -> m ()
-renameFileIfExists from to =
- liftIO
- (catch
- (renameFile (toFilePath from)
- (toFilePath to))
- (\e ->
- if isDoesNotExistError e
- then return ()
- else throwIO e))
+-- | Rename a file. Bails out if it doesn't exist.
+renameFile :: MonadIO m => Path b1 File -> Path b2 File -> m ()
+renameFile from to = liftIO (D.renameFile (toFilePath from) (toFilePath to))
--- | Rename the directory. Optimistically assumes it exists. If it
+-- | Rename a file. Optimistically assumes it exists. If it doesn't,
+-- doesn't complain.
+renameFileIfExists :: MonadIO m => Path b1 File -> Path b2 File -> m ()
+renameFileIfExists from to = ignoreDoesNotExist (renameFile from to)
+
+renameDir :: MonadIO m => Path b1 Dir -> Path b2 Dir -> m ()
+renameDir from to = liftIO (D.renameDirectory (toFilePath from) (toFilePath to))
+
+-- | Rename a directory. Optimistically assumes it exists. If it
-- doesn't, doesn't complain.
-renameDirIfExists :: MonadIO m => Path b Dir -> Path b Dir -> m ()
-renameDirIfExists from to =
- liftIO
- (catch
- (renameDirectory (toFilePath from)
- (toFilePath to))
- (\e ->
- if isDoesNotExistError e
- then return ()
- else throwIO e))
+renameDirIfExists :: MonadIO m => Path b1 Dir -> Path b2 Dir -> m ()
+renameDirIfExists from to = ignoreDoesNotExist (renameDir from to)
-- | Make a directory tree, creating parents if needed.
createTree :: MonadIO m => Path b Dir -> m ()
-createTree = liftIO . createDirectoryIfMissing True . toFilePath
+createTree = liftIO . D.createDirectoryIfMissing True . toFilePath
--- | Move the given file. Optimistically assumes it exists. If it
--- doesn't, doesn't complain.
-moveFileIfExists :: MonadIO m => Path b File -> Path b Dir -> m ()
-moveFileIfExists from to =
- liftIO
- (catch
- (renameFile (toFilePath from)
- (toFilePath (to filename from)))
- (\e ->
- if isDoesNotExistError e
- then return ()
- else throwIO e))
+-- | Move a file. Bails out if it doesn't exist.
+moveFile :: MonadIO m => Path b1 File -> Path b2 Dir -> m ()
+moveFile from to = renameFile from (to filename from)
--- | Move the given dir. Optimistically assumes it exists. If it
--- doesn't, doesn't complain.
-moveDirIfExists :: MonadIO m => Path b Dir -> Path b Dir -> m ()
-moveDirIfExists from to =
- liftIO
- (catch
- (renameDirectory
- (toFilePath from)
- (toFilePath (to dirname from)))
- (\e ->
- if isDoesNotExistError e
- then return ()
- else throwIO e))
+-- | Move a file. Optimistically assumes it exists. If it doesn't,
+-- doesn't complain.
+moveFileIfExists :: MonadIO m => Path b1 File -> Path b2 Dir -> m ()
+moveFileIfExists from to = ignoreDoesNotExist (moveFile from to)
--- | Remove the given tree. Bails out if the directory doesn't exist.
+-- | Move a dir. Bails out if it doesn't exist.
+moveDir :: MonadIO m => Path b1 Dir -> Path b2 Dir -> m ()
+moveDir from to = renameDir from (to dirname from)
+
+-- | Move a dir. Optimistically assumes it exists. If it doesn't,
+-- doesn't complain.
+moveDirIfExists :: MonadIO m => Path b1 Dir -> Path b2 Dir -> m ()
+moveDirIfExists from to = ignoreDoesNotExist (moveDir from to)
+
+-- | Remove a tree. Bails out if it doesn't exist.
removeTree :: MonadIO m => Path b Dir -> m ()
-removeTree =
- liftIO . removeDirectoryRecursive . toFilePath
+removeTree = liftIO . D.removeDirectoryRecursive . toFilePath
-- | Remove tree, don't complain about non-existent directories.
removeTreeIfExists :: MonadIO m => Path b Dir -> m ()
-removeTreeIfExists fp = do
- liftIO (catch (removeTree fp)
- (\e -> if isDoesNotExistError e
- then return ()
- else throwIO e))
+removeTreeIfExists = ignoreDoesNotExist . removeTree
--- | Does the given file exist?
+-- | Does the file exist?
fileExists :: MonadIO m => Path b File -> m Bool
-fileExists =
- liftIO . doesFileExist . toFilePath
+fileExists = liftIO . D.doesFileExist . toFilePath
--- | Does the given directory exist?
+-- | Does the directory exist?
dirExists :: MonadIO m => Path b Dir -> m Bool
-dirExists =
- liftIO . doesDirectoryExist . toFilePath
+dirExists = liftIO . D.doesDirectoryExist . toFilePath
+-- | Copies a file to another path. Bails out if it doesn't exist.
+copyFile :: MonadIO m => Path b1 File -> Path b2 File -> m ()
+copyFile from to = liftIO (D.copyFile (toFilePath from) (toFilePath to))
+
+-- | Copies a file to another path. Optimistically assumes it exists. If
+-- it doesn't, doesn't complain.
+copyFileIfExists :: MonadIO m => Path b1 File -> Path b2 File -> m ()
+copyFileIfExists from to = ignoreDoesNotExist (copyFile from to)
+
-- | 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)
@@ -223,16 +225,26 @@
-> Path Abs Dir -- ^ Destination directory
-> m ()
copyDirectoryRecursive srcDir destDir =
- do liftIO (createDirectoryIfMissing False (toFilePath destDir))
+ do liftIO (D.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))))
+ Just relFile -> copyFile srcFile (destDir relFile))
forM_ srcSubDirs
(\srcSubDir ->
case stripDir srcDir srcSubDir of
Nothing -> return ()
Just relSubDir -> copyDirectoryRecursive srcSubDir (destDir relSubDir))
+
+
+-- | Drop the root (either @\/@ on POSIX or @C:\\@, @D:\\@, etc. on
+-- Windows).
+dropRoot :: Path Abs t -> Path Rel t
+dropRoot (Path l) = Path (FP.dropDrive l)
+
+-- Utility function for a common pattern of ignoring does-not-exist errors.
+ignoreDoesNotExist :: MonadIO m => IO () -> m ()
+ignoreDoesNotExist f =
+ liftIO $ catch f $ \e -> unless (isDoesNotExistError e) (throwIO e)
diff --git a/src/Stack/Build.hs b/src/Stack/Build.hs
--- a/src/Stack/Build.hs
+++ b/src/Stack/Build.hs
@@ -15,7 +15,8 @@
module Stack.Build
(build
,clean
- ,withLoadPackage)
+ ,withLoadPackage
+ ,mkBaseConfigOpts)
where
import Control.Monad
@@ -25,8 +26,8 @@
import Control.Monad.Reader (MonadReader, asks)
import Control.Monad.Trans.Resource
import Data.Function
-import Data.Map.Strict (Map)
import qualified Data.Map as Map
+import Data.Map.Strict (Map)
import Data.Set (Set)
import qualified Data.Set as Set
import Network.HTTP.Client.Conduit (HasHttpManager)
@@ -38,22 +39,28 @@
import Stack.Build.Haddock
import Stack.Build.Installed
import Stack.Build.Source
-import Stack.Build.Types
+import Stack.Types.Build
import Stack.Constants
import Stack.Fetch as Fetch
import Stack.GhcPkg
import Stack.Package
import Stack.Types
import Stack.Types.Internal
+import System.FileLock (FileLock, unlockFile)
type M env m = (MonadIO m,MonadReader env m,HasHttpManager env,HasBuildConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,MonadMask m,HasLogLevel env,HasEnvConfig env,HasTerminal env)
--- | Build
+-- | Build.
+--
+-- If a buildLock is passed there is an important contract here. That lock must
+-- protect the snapshot, and it must be safe to unlock it if there are no further
+-- modifications to the snapshot to be performed by this build.
build :: M env m
=> (Set (Path Abs File) -> IO ()) -- ^ callback after discovering all local files
+ -> Maybe FileLock
-> BuildOpts
-> m ()
-build setLocalFiles bopts = do
+build setLocalFiles mbuildLk bopts = do
menv <- getMinimalEnvOverride
(mbp, locals, extraToBuild, sourceMap) <- loadSourceMap bopts
@@ -76,15 +83,33 @@
plan <- withLoadPackage menv $ \loadPackage ->
constructPlan mbp baseConfigOpts locals extraToBuild locallyRegistered loadPackage sourceMap installedMap
+ -- If our work to do is all local, let someone else have a turn with the snapshot.
+ -- They won't damage what's already in there.
+ case (mbuildLk, allLocal plan) of
+ -- NOTE: This policy is too conservative. In the future we should be able to
+ -- schedule unlocking as an Action that happens after all non-local actions are
+ -- complete.
+ (Just lk,True) -> do $logDebug "All installs are local; releasing snapshot lock early."
+ liftIO $ unlockFile lk
+ _ -> return ()
+
when (boptsPreFetch bopts) $
preFetch plan
if boptsDryrun bopts
- then printPlan (boptsFinalAction bopts) plan
+ then printPlan plan
else executePlan menv bopts baseConfigOpts locals sourceMap plan
where
profiling = boptsLibProfile bopts || boptsExeProfile bopts
+-- | If all the tasks are local, they don't mutate anything outside of our local directory.
+allLocal :: Plan -> Bool
+allLocal =
+ all (== Local) .
+ map taskLocation .
+ Map.elems .
+ planTasks
+
-- | Get the @BaseConfigOpts@ necessary for constructing configure options
mkBaseConfigOpts :: (MonadIO m, MonadReader env m, HasEnvConfig env, MonadThrow m)
=> BuildOpts -> m BaseConfigOpts
@@ -132,7 +157,7 @@
-- | Reset the build (remove Shake database and .gen files).
clean :: (M env m) => m ()
clean = do
- bconfig <- asks getBuildConfig
+ econfig <- asks getEnvConfig
forM_
- (Map.keys (bcPackages bconfig))
+ (Map.keys (envConfigPackages econfig))
(distDirFromDir >=> removeTreeIfExists)
diff --git a/src/Stack/Build/Cache.hs b/src/Stack/Build/Cache.hs
--- a/src/Stack/Build/Cache.hs
+++ b/src/Stack/Build/Cache.hs
@@ -20,29 +20,28 @@
, setTestSuccess
, unsetTestSuccess
, checkTestSuccess
+ , setTestBuilt
+ , unsetTestBuilt
+ , checkTestBuilt
+ , setBenchBuilt
+ , unsetBenchBuilt
+ , checkBenchBuilt
) where
-import Control.Exception.Enclosed (catchIO, handleIO, tryIO)
-import Control.Monad.Catch (MonadThrow, catch, throwM)
+import Control.Exception.Enclosed (handleIO)
+import Control.Monad.Catch (MonadThrow)
import Control.Monad.IO.Class
import Control.Monad.Logger (MonadLogger)
import Control.Monad.Reader
-import Data.Binary (Binary)
-import qualified Data.Binary as Binary
-import qualified Data.ByteString as S
-import qualified Data.ByteString.Lazy as L
+import Data.Binary.VersionTagged
import Data.Map (Map)
import Data.Maybe (fromMaybe, mapMaybe)
import GHC.Generics (Generic)
import Path
import Path.IO
-import Stack.Build.Types
+import Stack.Types.Build
import Stack.Constants
import Stack.Types
-import System.Directory (createDirectoryIfMissing,
- getDirectoryContents,
- removeFile)
-import System.IO.Error (isDoesNotExistError)
-- | Directory containing files to mark an executable as installed
exeInstalledDir :: (MonadReader env m, HasEnvConfig env, MonadThrow m)
@@ -55,15 +54,15 @@
=> InstallLocation -> m [PackageIdentifier]
getInstalledExes loc = do
dir <- exeInstalledDir loc
- files <- liftIO $ handleIO (const $ return []) $ getDirectoryContents $ toFilePath dir
- return $ mapMaybe parsePackageIdentifierFromString files
+ (_, files) <- liftIO $ handleIO (const $ return ([], [])) $ listDirectory dir
+ return $ mapMaybe (parsePackageIdentifierFromString . toFilePath . filename) files
-- | Mark the given executable as installed
markExeInstalled :: (MonadReader env m, HasEnvConfig env, MonadIO m, MonadThrow m)
=> InstallLocation -> PackageIdentifier -> m ()
markExeInstalled loc ident = do
dir <- exeInstalledDir loc
- liftIO $ createDirectoryIfMissing True $ toFilePath dir
+ createTree dir
ident' <- parseRelFile $ packageIdentifierString ident
let fp = toFilePath $ dir ident'
-- TODO consideration for the future: list all of the executables
@@ -77,8 +76,7 @@
markExeNotInstalled loc ident = do
dir <- exeInstalledDir loc
ident' <- parseRelFile $ packageIdentifierString ident
- let fp = toFilePath $ dir ident'
- liftIO $ catchIO (removeFile fp) (\_ -> return ())
+ removeFileIfExists (dir ident')
-- | Stored on disk to know whether the flags have changed or any
-- files have changed.
@@ -88,6 +86,8 @@
}
deriving (Generic)
instance Binary BuildCache
+instance NFData BuildCache where
+ rnf = genericRnf
-- | Try to read the dirtiness cache for the given package directory.
tryGetBuildCache :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m, HasEnvConfig env)
@@ -105,21 +105,11 @@
tryGetCabalMod = tryGetCache configCabalMod
-- | Try to load a cache.
-tryGetCache :: (MonadIO m, Binary a, MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m, HasEnvConfig env)
+tryGetCache :: (MonadIO m, Binary a, NFData a)
=> (Path Abs Dir -> m (Path Abs File))
-> Path Abs Dir
-> m (Maybe a)
-tryGetCache get' dir = do
- fp <- get' dir
- liftIO
- (catch
- (fmap (decodeMaybe . L.fromStrict) (S.readFile (toFilePath fp)))
- (\e -> if isDoesNotExistError e
- then return Nothing
- else throwM e))
- where decodeMaybe =
- either (const Nothing) (Just . thd) . Binary.decodeOrFail
- where thd (_,_,x) = x
+tryGetCache get' dir = get' dir >>= decodeFileOrFailDeep . toFilePath
-- | Write the dirtiness cache for this package's files.
writeBuildCache :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m, HasEnvConfig env)
@@ -158,17 +148,14 @@
removeFileIfExists cfp
-- | Write to a cache.
-writeCache :: (Binary a, MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env, HasEnvConfig env)
+writeCache :: (Binary a, MonadIO m)
=> Path Abs Dir
-> (Path Abs Dir -> m (Path Abs File))
-> a
-> m ()
writeCache dir get' content = do
fp <- get' dir
- liftIO
- (L.writeFile
- (toFilePath fp)
- (Binary.encode content))
+ liftIO $ encodeFile (toFilePath fp) content
flagCacheFile :: (MonadIO m, MonadThrow m, MonadReader env m, HasEnvConfig env)
=> Installed
@@ -185,12 +172,8 @@
tryGetFlagCache :: (MonadIO m, MonadThrow m, MonadReader env m, HasEnvConfig env)
=> Installed
-> m (Maybe ConfigCache)
-tryGetFlagCache gid = do
- file <- flagCacheFile gid
- eres <- liftIO $ tryIO $ Binary.decodeFileOrFail $ toFilePath file
- case eres of
- Right (Right x) -> return $ Just x
- _ -> return Nothing
+tryGetFlagCache gid =
+ flagCacheFile gid >>= decodeFileOrFailDeep . toFilePath
writeFlagCache :: (MonadIO m, MonadReader env m, HasEnvConfig env, MonadThrow m)
=> Installed
@@ -199,9 +182,8 @@
writeFlagCache gid cache = do
file <- flagCacheFile gid
liftIO $ do
- createDirectoryIfMissing True $ toFilePath $ parent file
-
- Binary.encodeFile (toFilePath file) cache
+ createTree (parent file)
+ encodeFile (toFilePath file) cache
-- | Mark a test suite as having succeeded
setTestSuccess :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env, HasEnvConfig env)
@@ -231,3 +213,61 @@
liftM
(fromMaybe False)
(tryGetCache testSuccessFile dir)
+
+-- | Mark a test suite as having built
+setTestBuilt :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env, HasEnvConfig env)
+ => Path Abs Dir
+ -> m ()
+setTestBuilt dir =
+ writeCache
+ dir
+ testBuiltFile
+ True
+
+-- | Mark a test suite as not having built
+unsetTestBuilt :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env, HasEnvConfig env)
+ => Path Abs Dir
+ -> m ()
+unsetTestBuilt dir =
+ writeCache
+ dir
+ testBuiltFile
+ False
+
+-- | Check if the test suite already built
+checkTestBuilt :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env, HasEnvConfig env)
+ => Path Abs Dir
+ -> m Bool
+checkTestBuilt dir =
+ liftM
+ (fromMaybe False)
+ (tryGetCache testBuiltFile dir)
+
+-- | Mark a bench suite as having built
+setBenchBuilt :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env, HasEnvConfig env)
+ => Path Abs Dir
+ -> m ()
+setBenchBuilt dir =
+ writeCache
+ dir
+ benchBuiltFile
+ True
+
+-- | Mark a bench suite as not having built
+unsetBenchBuilt :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env, HasEnvConfig env)
+ => Path Abs Dir
+ -> m ()
+unsetBenchBuilt dir =
+ writeCache
+ dir
+ benchBuiltFile
+ False
+
+-- | Check if the bench suite already built
+checkBenchBuilt :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env, HasEnvConfig env)
+ => Path Abs Dir
+ -> m Bool
+checkBenchBuilt dir =
+ liftM
+ (fromMaybe False)
+ (tryGetCache benchBuiltFile dir)
diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs
--- a/src/Stack/Build/ConstructPlan.hs
+++ b/src/Stack/Build/ConstructPlan.hs
@@ -31,15 +31,14 @@
import Data.Text.Encoding (encodeUtf8, decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)
import Distribution.Package (Dependency (..))
-import Distribution.Version (anyVersion,
- intersectVersionRanges)
+import Distribution.Version (anyVersion)
import Network.HTTP.Client.Conduit (HasHttpManager)
import Prelude hiding (FilePath, pi, writeFile)
import Stack.Build.Cache
import Stack.Build.Haddock
import Stack.Build.Installed
import Stack.Build.Source
-import Stack.Build.Types
+import Stack.Types.Build
import Stack.BuildPlan
import Stack.Package
@@ -75,12 +74,22 @@
| ADRFound InstallLocation Version Installed
deriving Show
+data W = W
+ { wFinals :: !(Map PackageName (Either ConstructPlanException (Task, LocalPackageTB)))
+ , wInstall :: !(Map Text InstallLocation)
+ -- ^ executable to be installed, and location where the binary is placed
+ , wDirty :: !(Map PackageName Text)
+ -- ^ why a local package is considered dirty
+ , wDeps :: !(Set PackageName)
+ -- ^ Packages which count as dependencies
+ }
+instance Monoid W where
+ mempty = W mempty mempty mempty mempty
+ mappend (W a b c d) (W w x y z) = W (mappend a w) (mappend b x) (mappend c y) (mappend d z)
+
type M = RWST
Ctx
- ( Map PackageName (Either ConstructPlanException Task) -- finals
- , Map Text InstallLocation -- executable to be installed, and location where the binary is placed
- , Map PackageName Text -- why a local package is considered dirty
- )
+ W
(Map PackageName (Either ConstructPlanException AddDepRes))
IO
@@ -122,14 +131,25 @@
let latest = Map.fromListWith max $ map toTuple $ Map.keys caches
econfig <- asks getEnvConfig
- let onWanted =
- case boptsFinalAction $ bcoBuildOpts baseConfigOpts0 of
- DoNothing -> void . addDep . packageName . lpPackage
- _ -> addFinal
+ let onWanted lp = do
+ {-
+ - Arguably this is the right thing to do. However, forcing the
+ - library to rebuild causes the cabal_macros.h file to change,
+ - which makes GHC rebuild everything...
+
+ case lpExeComponents lp of
+ Nothing -> return ()
+ Just _ -> void $ addDep $ packageName $ lpPackage lp
+ -}
+
+ case lpTestBench lp of
+ Just tb -> addFinal lp tb
+ -- See comment above
+ Nothing -> void $ addDep False $ packageName $ lpPackage lp
let inner = do
mapM_ onWanted $ filter lpWanted locals
- mapM_ addDep $ Set.toList extraToBuild0
- ((), m, (efinals, installExes, dirtyReason)) <- liftIO $ runRWST inner (ctx econfig latest) M.empty
+ mapM_ (addDep False) $ Set.toList extraToBuild0
+ ((), m, W efinals installExes dirtyReason deps) <- liftIO $ runRWST inner (ctx econfig latest) M.empty
let toEither (_, Left e) = Left e
toEither (k, Right v) = Right (k, v)
(errlibs, adrs) = partitionEithers $ map toEither $ M.toList m
@@ -140,11 +160,12 @@
let toTask (_, ADRFound _ _ _) = Nothing
toTask (name, ADRToInstall task) = Just (name, task)
tasks = M.fromList $ mapMaybe toTask adrs
- maybeStripLocals
- | boptsOnlySnapshot $ bcoBuildOpts baseConfigOpts0 =
- stripLocals
- | otherwise = id
- return $ maybeStripLocals Plan
+ takeSubset =
+ case boptsBuildSubset $ bcoBuildOpts baseConfigOpts0 of
+ BSAll -> id
+ BSOnlySnapshot -> stripLocals
+ BSOnlyDependencies -> stripNonDeps deps
+ return $ takeSubset Plan
{ planTasks = tasks
, planFinals = M.fromList finals
, planUnregisterLocal = mkUnregisterLocal tasks dirtyReason locallyRegistered
@@ -193,14 +214,14 @@
ident = ghcPkgIdPackageIdentifier gid
name = packageIdentifierName ident
-addFinal :: LocalPackage -> M ()
-addFinal lp = do
- depsRes <- addPackageDeps package
+addFinal :: LocalPackage -> LocalPackageTB -> M ()
+addFinal lp lptb = do
+ depsRes <- addPackageDeps False package
res <- case depsRes of
Left e -> return $ Left e
Right (missing, present, _minLoc) -> do
ctx <- ask
- return $ Right Task
+ return $ Right (Task
{ taskProvides = PackageIdentifier
(packageName package)
(packageVersion package)
@@ -215,32 +236,38 @@
package
, taskPresent = present
, taskType = TTLocal lp
- }
- tell (Map.singleton (packageName package) res, mempty, mempty)
+ }, lptb)
+ tell mempty { wFinals = Map.singleton (packageName package) res }
where
- package = lpPackageFinal lp
+ package = lptbPackage lptb
-addDep :: PackageName -> M (Either ConstructPlanException AddDepRes)
-addDep name = do
+addDep :: Bool -- ^ is this being used by a dependency?
+ -> PackageName -> M (Either ConstructPlanException AddDepRes)
+addDep treatAsDep' name = do
+ ctx <- ask
+ let treatAsDep = treatAsDep' || name `Set.notMember` wanted ctx
+ when treatAsDep $ markAsDep name
m <- get
case Map.lookup name m of
Just res -> return res
Nothing -> do
- res <- addDep' name
+ res <- addDep' treatAsDep name
modify $ Map.insert name res
return res
-addDep' :: PackageName -> M (Either ConstructPlanException AddDepRes)
-addDep' name = do
+addDep' :: Bool -- ^ is this being used by a dependency?
+ -> PackageName -> M (Either ConstructPlanException AddDepRes)
+addDep' treatAsDep name = do
ctx <- ask
if name `elem` callStack ctx
then return $ Left $ DependencyCycleDetected $ name : callStack ctx
else local
(\ctx' -> ctx' { callStack = name : callStack ctx' }) $ do
- (addDep'' name)
+ (addDep'' treatAsDep name)
-addDep'' :: PackageName -> M (Either ConstructPlanException AddDepRes)
-addDep'' name = do
+addDep'' :: Bool -- ^ is this being used by a dependency?
+ -> PackageName -> M (Either ConstructPlanException AddDepRes)
+addDep'' treatAsDep name = do
ctx <- ask
case Map.lookup name $ combinedMap ctx of
-- TODO look up in the package index and see if there's a
@@ -251,12 +278,12 @@
return $ Right $ ADRFound loc version installed
Just (PIOnlySource ps) -> do
tellExecutables name ps
- installPackage name ps
+ installPackage treatAsDep name ps
Just (PIBoth ps installed) -> do
tellExecutables name ps
- needInstall <- checkNeedInstall name ps installed (wanted ctx)
+ needInstall <- checkNeedInstall treatAsDep name ps installed (wanted ctx)
if needInstall
- then installPackage name ps
+ then installPackage treatAsDep name ps
else return $ Right $ ADRFound (piiLocation ps) (piiVersion ps) installed
tellExecutables :: PackageName -> PackageSource -> M () -- TODO merge this with addFinal above?
@@ -274,19 +301,39 @@
tellExecutablesPackage loc p
tellExecutablesPackage :: InstallLocation -> Package -> M ()
-tellExecutablesPackage loc p =
- tell (Map.empty, m, Map.empty)
+tellExecutablesPackage loc p = do
+ cm <- asks combinedMap
+ -- Determine which components are enabled so we know which ones to copy
+ let myComps =
+ case Map.lookup (packageName p) cm of
+ Nothing -> assert False Set.empty
+ Just (PIOnlyInstalled _ _ _) -> Set.empty
+ Just (PIOnlySource ps) -> goSource ps
+ Just (PIBoth ps _) -> goSource ps
+
+ goSource (PSLocal lp) = fromMaybe Set.empty $ lpExeComponents lp
+ goSource (PSUpstream _ _ _) = Set.empty
+
+ tell mempty { wInstall = m myComps }
where
- m = Map.fromList $ map (, loc) $ Set.toList $ packageExes p
+ m myComps = Map.fromList $ map (, loc) $ Set.toList
+ $ filterComps myComps $ packageExes p
+ filterComps myComps x
+ | Set.null myComps = x
+ | otherwise = Set.intersection x $ Set.map toExe myComps
+
+ toExe x = fromMaybe x $ T.stripPrefix "exe:" x
+
-- TODO There are a lot of duplicated computations below. I've kept that for
-- simplicity right now
-installPackage :: PackageName -> PackageSource -> M (Either ConstructPlanException AddDepRes)
-installPackage name ps = do
+installPackage :: Bool -- ^ is this being used by a dependency?
+ -> PackageName -> PackageSource -> M (Either ConstructPlanException AddDepRes)
+installPackage treatAsDep name ps = do
ctx <- ask
package <- psPackage name ps
- depsRes <- addPackageDeps package
+ depsRes <- addPackageDeps treatAsDep package
case depsRes of
Left e -> return $ Left e
Right (missing, present, minLoc) -> do
@@ -313,29 +360,31 @@
PSUpstream _ loc _ -> TTUpstream package $ loc <> minLoc
}
-checkNeedInstall :: PackageName -> PackageSource -> Installed -> Set PackageName -> M Bool
-checkNeedInstall name ps installed wanted = assert (piiLocation ps == Local) $ do
+checkNeedInstall :: Bool
+ -> PackageName -> PackageSource -> Installed -> Set PackageName -> M Bool
+checkNeedInstall treatAsDep name ps installed wanted = assert (piiLocation ps == Local) $ do
package <- psPackage name ps
- depsRes <- addPackageDeps package
+ depsRes <- addPackageDeps treatAsDep package
case depsRes of
Left _e -> return True -- installPackage will find the error again
Right (missing, present, _loc)
| Set.null missing -> checkDirtiness ps installed package present wanted
| otherwise -> do
- tell (Map.empty, Map.empty, Map.singleton name $
+ tell mempty { wDirty = Map.singleton name $
let t = T.intercalate ", " $ map (T.pack . packageNameString . packageIdentifierName) (Set.toList missing)
in T.append "missing dependencies: " $
if T.length t < 100
then t
- else T.take 97 t <> "...")
+ else T.take 97 t <> "..." }
return True
-addPackageDeps :: Package -> M (Either ConstructPlanException (Set PackageIdentifier, Set GhcPkgId, InstallLocation))
-addPackageDeps package = do
+addPackageDeps :: Bool -- ^ is this being used by a dependency?
+ -> Package -> M (Either ConstructPlanException (Set PackageIdentifier, Set GhcPkgId, InstallLocation))
+addPackageDeps treatAsDep package = do
ctx <- ask
deps' <- packageDepsWithTools package
deps <- forM (Map.toList deps') $ \(depname, range) -> do
- eres <- addDep depname
+ eres <- addDep treatAsDep depname
let mlatest = Map.lookup depname $ latestVersions ctx
case eres of
Left e ->
@@ -385,7 +434,7 @@
, configCacheDeps = present
, configCacheComponents =
case ps of
- PSLocal lp -> Set.map encodeUtf8 $ lpComponents lp
+ PSLocal lp -> Set.map renderComponent $ lpComponents lp
PSUpstream _ _ _ -> Set.empty
, configCacheHaddock =
shouldHaddockPackage buildOpts wanted (packageName package) ||
@@ -402,7 +451,7 @@
case mreason of
Nothing -> return False
Just reason -> do
- tell (Map.empty, Map.empty, Map.singleton (packageName package) reason)
+ tell mempty { wDirty = Map.singleton (packageName package) reason }
return True
describeConfigDiff :: ConfigCache -> ConfigCache -> Text
@@ -476,9 +525,14 @@
TTUpstream _ Local -> False
TTUpstream _ Snap -> True
-taskLocation :: Task -> InstallLocation
-taskLocation =
- go . taskType
+stripNonDeps :: Set PackageName -> Plan -> Plan
+stripNonDeps deps plan = plan
+ { planTasks = Map.filter checkTask $ planTasks plan
+ , planFinals = Map.empty
+ , planInstallExes = Map.empty -- TODO maybe don't disable this?
+ }
where
- go (TTLocal _) = Local
- go (TTUpstream _ loc) = loc
+ checkTask task = packageIdentifierName (taskProvides task) `Set.member` deps
+
+markAsDep :: PackageName -> M ()
+markAsDep name = tell mempty { wDeps = Set.singleton name }
diff --git a/src/Stack/Build/Coverage.hs b/src/Stack/Build/Coverage.hs
new file mode 100644
--- /dev/null
+++ b/src/Stack/Build/Coverage.hs
@@ -0,0 +1,147 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+-- | Generate HPC (Haskell Program Coverage) reports
+module Stack.Build.Coverage
+ ( generateHpcReport
+ , generateHpcMarkupIndex
+ ) where
+
+import Control.Applicative ((<$>))
+import Control.Exception.Lifted
+import Control.Monad (liftM)
+import Control.Monad.Catch (MonadCatch)
+import Control.Monad.IO.Class
+import Control.Monad.Logger
+import Control.Monad.Reader (MonadReader, asks)
+import Control.Monad.Trans.Resource
+import qualified Data.ByteString.Char8 as S8
+import Data.Foldable (forM_)
+import Data.Function
+import Data.List
+import qualified Data.Map.Strict as Map
+import Data.Maybe
+import Data.Monoid ((<>))
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
+import qualified Data.Text.IO as T
+import qualified Data.Text.Lazy as LT
+import Data.Traversable (forM)
+import Path
+import Path.IO
+import Prelude hiding (FilePath, writeFile)
+import Stack.Constants
+import Stack.Types
+import System.Process.Read
+import Text.Hastache (htmlEscape)
+
+-- | Generates the HTML coverage report and shows a textual coverage
+-- summary.
+generateHpcReport :: (MonadIO m,MonadReader env m,HasConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,HasEnvConfig env)
+ => Path Abs Dir -> Text -> Text -> Text -> m ()
+generateHpcReport pkgDir pkgName pkgId testName = do
+ let whichTest = pkgName <> "'s test-suite \"" <> testName <> "\""
+ -- Compute destination directory.
+ installDir <- installationRootLocal
+ testNamePath <- parseRelDir (T.unpack testName)
+ pkgIdPath <- parseRelDir (T.unpack pkgId)
+ let destDir = installDir hpcDirSuffix pkgIdPath testNamePath
+ -- Directories for .mix files.
+ hpcDir <- hpcDirFromDir pkgDir
+ hpcRelDir <- ( dotHpc) <$> hpcRelativeDir
+ -- Compute arguments used for both "hpc markup" and "hpc report".
+ pkgDirs <- Map.keys . envConfigPackages <$> asks getEnvConfig
+ let args =
+ -- Use index files from all packages (allows cross-package
+ -- coverage results).
+ concatMap (\x -> ["--srcdir", toFilePath x]) pkgDirs ++
+ -- Look for index files in the correct dir (relative to
+ -- each pkgdir).
+ ["--hpcdir", toFilePath hpcRelDir, "--reset-hpcdirs"
+ -- Restrict to just the current library code (see #634 -
+ -- this will likely be customizable in the future)
+ ,"--include", T.unpack (pkgId <> ":")]
+ -- If a .tix file exists, generate an HPC report for it.
+ tixFile <- parseRelFile (T.unpack testName ++ ".tix")
+ let tixFileAbs = hpcDir tixFile
+ tixFileExists <- fileExists tixFileAbs
+ if not tixFileExists
+ then $logError $ T.concat
+ [ "Didn't find .tix coverage file for "
+ , whichTest
+ , " - expected to find it at "
+ , T.pack (toFilePath tixFileAbs)
+ , "."
+ ]
+ else (`onException` $logError ("Error occurred while producing coverage report for " <> whichTest)) $ do
+ menv <- getMinimalEnvOverride
+ $logInfo $ "Generating HTML coverage report for " <> whichTest
+ _ <- readProcessStdout (Just hpcDir) menv "hpc"
+ ("markup" : toFilePath tixFileAbs : ("--destdir=" ++ toFilePath destDir) : args)
+ output <- readProcessStdout (Just hpcDir) menv "hpc"
+ ("report" : toFilePath tixFileAbs : args)
+ -- Print output, stripping @\r@ characters because
+ -- Windows.
+ forM_ (S8.lines output) ($logInfo . T.decodeUtf8 . S8.filter (not . (=='\r')))
+ $logInfo
+ ("The HTML coverage report for " <> whichTest <> " is available at " <>
+ T.pack (toFilePath (destDir $(mkRelFile "hpc_index.html"))))
+
+generateHpcMarkupIndex :: (MonadIO m,MonadReader env m,MonadLogger m,MonadCatch m,HasEnvConfig env)
+ => m ()
+generateHpcMarkupIndex = do
+ installDir <- installationRootLocal
+ let markupDir = installDir hpcDirSuffix
+ outputFile = markupDir $(mkRelFile "index.html")
+ (dirs, _) <- listDirectory markupDir
+ rows <- liftM (catMaybes . concat) $ forM dirs $ \dir -> do
+ (subdirs, _) <- listDirectory dir
+ forM subdirs $ \subdir -> do
+ let indexPath = subdir $(mkRelFile "hpc_index.html")
+ exists <- fileExists indexPath
+ if not exists then return Nothing else do
+ relPath <- stripDir markupDir indexPath
+ let package = dirname dir
+ testsuite = dirname subdir
+ return $ Just $ T.concat
+ [ "| "
+ , pathToHtml package
+ , " | "
+ , pathToHtml testsuite
+ , " |
"
+ ]
+ liftIO $ T.writeFile (toFilePath outputFile) $ T.concat $
+ [ ""
+ -- Part of the css from HPC's output HTML
+ , ""
+ , ""
+ , ""
+ ] ++
+ (if null rows
+ then
+ [ "No hpc_index.html files found in \""
+ , pathToHtml markupDir
+ , "\"."
+ ]
+ else
+ [ ""
+ , "NOTE: This is merely a listing of the html files found in the coverage reports directory. Some of these reports may be old.
"
+ , "| Package | TestSuite |
|---|
"
+ ] ++
+ rows ++
+ ["
"]) ++
+ [""]
+ $logInfo $ "\nAn index of the generated HTML coverage reports is available at " <>
+ T.pack (toFilePath outputFile)
+
+pathToHtml :: Path b t -> Text
+pathToHtml = T.dropWhileEnd (=='/') . LT.toStrict . htmlEscape . LT.pack . toFilePath
diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs
--- a/src/Stack/Build/Execute.hs
+++ b/src/Stack/Build/Execute.hs
@@ -4,59 +4,66 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
--- Perform a build
+-- | Perform a build
module Stack.Build.Execute
( printPlan
, preFetch
, executePlan
- -- TESTING
- , compareTestsComponents
+ -- * Running Setup.hs
+ , ExecuteEnv
+ , withExecuteEnv
+ , withSingleContext
) where
-import Control.Applicative ((<$>), (<*>))
-import Control.Concurrent.Lifted (fork)
+import Control.Applicative ((<$>))
import Control.Concurrent.Execute
+import Control.Concurrent.Lifted (fork)
import Control.Concurrent.MVar.Lifted
import Control.Concurrent.STM
+import Control.Exception.Enclosed (tryIO)
import Control.Exception.Lifted
-import Control.Monad
+import Control.Monad (liftM, when, unless, void, join, guard)
import Control.Monad.Catch (MonadCatch, MonadMask)
import Control.Monad.IO.Class
import Control.Monad.Logger
import Control.Monad.Reader (MonadReader, asks)
import Control.Monad.Trans.Control (liftBaseWith)
import Control.Monad.Trans.Resource
-import Control.Monad.Writer
import qualified Data.ByteString as S
+import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as S8
import Data.Conduit
import qualified Data.Conduit.Binary as CB
import qualified Data.Conduit.List as CL
+import Data.Foldable (forM_)
import Data.Function
import Data.List
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe
+import Data.Monoid ((<>))
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Streaming.Process hiding (callProcess, env)
import qualified Data.Streaming.Process as Process
+import Data.Traversable (forM)
import Data.Text (Text)
import qualified Data.Text as T
-import qualified Data.Text.Encoding as T
import Data.Text.Encoding (encodeUtf8)
+import Data.Word8 (_colon)
import Distribution.System (OS (Windows),
Platform (Platform))
-import Language.Haskell.TH (Loc(..))
+import Language.Haskell.TH as TH (location)
import Network.HTTP.Client.Conduit (HasHttpManager)
import Path
import Path.IO
import Prelude hiding (FilePath, writeFile)
import Stack.Build.Cache
+import Stack.Build.Coverage
import Stack.Build.Haddock
import Stack.Build.Installed
import Stack.Build.Source
-import Stack.Build.Types
+import Stack.Types.Build
import Stack.Fetch as Fetch
import Stack.GhcPkg
import Stack.Package
@@ -64,8 +71,7 @@
import Stack.Types
import Stack.Types.StackT
import Stack.Types.Internal
-import System.Directory hiding (findExecutable,
- findFiles)
+import qualified System.Directory as D
import System.Environment (getExecutablePath)
import System.Exit (ExitCode (ExitSuccess))
import qualified System.FilePath as FP
@@ -73,6 +79,7 @@
import System.IO.Temp (withSystemTempDirectory)
import System.Process.Internals (createProcess_)
import System.Process.Read
+import System.Process.Run
import System.Process.Log (showProcessArgDebug)
type M env m = (MonadIO m,MonadReader env m,HasHttpManager env,HasBuildConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,MonadMask m,HasLogLevel env,HasEnvConfig env,HasTerminal env)
@@ -97,12 +104,11 @@
(packageVersion package)
printPlan :: M env m
- => FinalAction
- -> Plan
+ => Plan
-> m ()
-printPlan finalAction plan = do
+printPlan plan = do
case Map.toList $ planUnregisterLocal plan of
- [] -> $logInfo "Nothing to unregister"
+ [] -> $logInfo "No packages would be unregistered."
xs -> do
$logInfo "Would unregister locally:"
forM_ xs $ \(gid, reason) -> $logInfo $ T.concat
@@ -115,31 +121,29 @@
$logInfo ""
case Map.elems $ planTasks plan of
- [] -> $logInfo "Nothing to build"
+ [] -> $logInfo "Nothing to build."
xs -> do
$logInfo "Would build:"
mapM_ ($logInfo . displayTask) xs
- let mfinalLabel =
- case finalAction of
- DoNothing -> Nothing
- DoBenchmarks -> Just "benchmark"
- DoTests _ -> Just "test"
- case mfinalLabel of
- Nothing -> return ()
- Just finalLabel -> do
- $logInfo ""
+ let hasTests = not . Set.null . lptbTests
+ hasBenches = not . Set.null . lptbBenches
+ tests = Map.elems $ fmap fst $ Map.filter (hasTests . snd) $ planFinals plan
+ benches = Map.elems $ fmap fst $ Map.filter (hasBenches . snd) $ planFinals plan
- case Map.toList $ planFinals plan of
- [] -> $logInfo $ "Nothing to " <> finalLabel
- xs -> do
- $logInfo $ "Would " <> finalLabel <> ":"
- forM_ xs $ \(name, _) -> $logInfo $ T.pack $ packageNameString name
+ unless (null tests) $ do
+ $logInfo ""
+ $logInfo "Would test:"
+ mapM_ ($logInfo . displayTask) tests
+ unless (null benches) $ do
+ $logInfo ""
+ $logInfo "Would benchmark:"
+ mapM_ ($logInfo . displayTask) benches
$logInfo ""
case Map.toList $ planInstallExes plan of
- [] -> $logInfo "No executables to be installed"
+ [] -> $logInfo "No executables to be installed."
xs -> do
$logInfo "Would install executables:"
forM_ xs $ \(name, loc) -> $logInfo $ T.concat
@@ -189,16 +193,15 @@
, eeGlobalDB :: !(Path Abs Dir)
}
--- | Perform the actual plan
-executePlan :: M env m
- => EnvOverride
- -> BuildOpts
- -> BaseConfigOpts
- -> [LocalPackage]
- -> SourceMap
- -> Plan
- -> m ()
-executePlan menv bopts baseConfigOpts locals sourceMap plan = do
+withExecuteEnv :: M env m
+ => EnvOverride
+ -> BuildOpts
+ -> BaseConfigOpts
+ -> [LocalPackage]
+ -> SourceMap
+ -> (ExecuteEnv -> m a)
+ -> m a
+withExecuteEnv menv bopts baseConfigOpts locals sourceMap inner = do
withSystemTempDirectory stackProgName $ \tmpdir -> do
tmpdir' <- parseAbsDir tmpdir
configLock <- newMVar ()
@@ -208,7 +211,7 @@
liftIO $ writeFile (toFilePath setupHs) "import Distribution.Simple\nmain = defaultMain"
cabalPkgVer <- asks (envConfigCabalVersion . getEnvConfig)
globalDB <- getGlobalDB menv
- executePlan' plan ExecuteEnv
+ inner ExecuteEnv
{ eeEnvOverride = menv
, eeBuildOpts = bopts
-- Uncertain as to why we cannot run configures in parallel. This appears
@@ -229,13 +232,25 @@
, eeGlobalDB = globalDB
}
+-- | Perform the actual plan
+executePlan :: M env m
+ => EnvOverride
+ -> BuildOpts
+ -> BaseConfigOpts
+ -> [LocalPackage]
+ -> SourceMap
+ -> Plan
+ -> m ()
+executePlan menv bopts baseConfigOpts locals sourceMap plan = do
+ withExecuteEnv menv bopts baseConfigOpts locals sourceMap (executePlan' plan)
+
unless (Map.null $ planInstallExes plan) $ do
snapBin <- ( bindirSuffix) `liftM` installationRootDeps
localBin <- ( bindirSuffix) `liftM` installationRootLocal
destDir <- asks $ configLocalBin . getConfig
- let destDir' = toFilePath destDir
- liftIO $ createDirectoryIfMissing True destDir'
+ createTree destDir
+ let destDir' = toFilePath destDir
when (not $ any (FP.equalFilePath destDir') (envSearchPath menv)) $
$logWarn $ T.concat
[ "Installation path "
@@ -278,25 +293,29 @@
liftIO $ case platform of
Platform _ Windows | FP.equalFilePath destFile currExe ->
windowsRenameCopy (toFilePath file) destFile
- _ -> copyFile (toFilePath file) destFile
+ _ -> D.copyFile (toFilePath file) destFile
return $ Just (destDir', [T.append name (T.pack ext)])
let destToInstalled = Map.fromListWith (++) (catMaybes installed)
unless (Map.null destToInstalled) $ $logInfo ""
forM_ (Map.toList destToInstalled) $ \(dest, executables) -> do
$logInfo $ T.concat
- [ "Installed executables to "
+ [ "Copied executables to "
, T.pack dest
, ":"]
forM_ executables $ \exe -> $logInfo $ T.append "- " exe
+ forM_ (boptsExec bopts) $ \(cmd, args) -> do
+ $logProcessRun cmd args
+ callProcess Nothing menv cmd args
+
-- | Windows can't write over the current executable. Instead, we rename the
-- current executable to something else and then do the copy.
windowsRenameCopy :: FilePath -> FilePath -> IO ()
windowsRenameCopy src dest = do
- copyFile src new
- renameFile dest old
- renameFile new dest
+ D.copyFile src new
+ D.renameFile dest old
+ D.renameFile new dest
where
new = dest ++ ".new"
old = dest ++ ".old"
@@ -337,14 +356,14 @@
let keepGoing =
case boptsKeepGoing eeBuildOpts of
Just kg -> kg
- Nothing ->
- case boptsFinalAction eeBuildOpts of
- DoNothing -> False
- _ -> True
+ Nothing -> boptsTests eeBuildOpts || boptsBenchmarks eeBuildOpts
concurrentFinal =
- case boptsFinalAction eeBuildOpts of
- DoTests _ -> concurrentTests
- _ -> True
+ -- TODO it probably makes more sense to use a lock for test suites
+ -- and just have the execution blocked. Turning off all concurrency
+ -- on finals based on the --test option doesn't fit in well.
+ if boptsTests eeBuildOpts
+ then concurrentTests
+ else True
terminal <- asks getTerminal
errs <- liftIO $ runActions threads keepGoing concurrentFinal actions $ \doneVar -> do
let total = length actions
@@ -363,13 +382,16 @@
then loop 0
else return ()
unless (null errs) $ throwM $ ExecutionFailure errs
- when (boptsHaddock eeBuildOpts && not (null actions))
- (generateHaddockIndex eeEnvOverride eeBaseConfigOpts eeLocals)
+ when (boptsHaddock eeBuildOpts) $ do
+ generateLocalHaddockIndex eeEnvOverride eeBaseConfigOpts eeLocals
+ generateDepsHaddockIndex eeEnvOverride eeBaseConfigOpts eeLocals
+ generateSnapHaddockIndex eeEnvOverride eeBaseConfigOpts eeGlobalDB
+ when (toCoverage $ boptsTestOpts eeBuildOpts) generateHpcMarkupIndex
toActions :: M env m
=> (m () -> IO ())
-> ExecuteEnv
- -> (Maybe Task, Maybe Task) -- build and final
+ -> (Maybe Task, Maybe (Task, LocalPackageTB)) -- build and final
-> [Action]
toActions runInBase ee (mbuild, mfinal) =
abuild ++ afinal
@@ -386,37 +408,29 @@
}
]
afinal =
- case (,) <$> mfinal <*> mfunc of
- Just (task@Task {..}, (func, checkTask)) | checkTask task ->
+ case mfinal of
+ Nothing -> []
+ Just (task@Task {..}, lptb) ->
[ Action
{ actionId = ActionId taskProvides ATFinal
, actionDeps = addBuild taskProvides $
(Set.map (\ident -> ActionId ident ATBuild) (tcoMissing taskConfigOpts))
- , actionDo = \ac -> runInBase $ func ac ee task
+ , actionDo = \ac -> runInBase $ do
+ unless (Set.null $ lptbTests lptb) $ do
+ singleTest topts lptb ac ee task
+ unless (Set.null $ lptbBenches lptb) $ do
+ singleBench beopts lptb ac ee task
}
]
- _ -> []
where
addBuild ident =
case mbuild of
Nothing -> id
Just _ -> Set.insert $ ActionId ident ATBuild
- mfunc =
- case boptsFinalAction $ eeBuildOpts ee of
- DoNothing -> Nothing
- DoTests rerunTests -> Just (singleTest rerunTests, checkTest)
- DoBenchmarks -> Just (singleBench, checkBench)
-
- checkTest task =
- case taskType task of
- TTLocal lp -> not $ Set.null $ packageTests $ lpPackage lp
- _ -> assert False False
-
- checkBench task =
- case taskType task of
- TTLocal lp -> not $ Set.null $ packageBenchmarks $ lpPackage lp
- _ -> assert False False
+ bopts = eeBuildOpts ee
+ topts = boptsTestOpts bopts
+ beopts = boptsBenchmarkOpts bopts
-- | Ensure that the configuration for the package matches what is given
ensureConfig :: M env m
@@ -434,7 +448,7 @@
mOldConfigCache <- tryGetConfigCache pkgDir
mOldCabalMod <- tryGetCabalMod pkgDir
- newCabalMod <- liftIO (fmap modTime (getModificationTime (toFilePath cabalfp)))
+ newCabalMod <- liftIO (fmap modTime (D.getModificationTime (toFilePath cabalfp)))
idMap <- liftIO $ readTVarIO eeGhcPkgIds
let getMissing ident =
@@ -451,7 +465,7 @@
, configCacheDeps = allDeps
, configCacheComponents =
case taskType of
- TTLocal lp -> Set.map encodeUtf8 $ lpComponents lp
+ TTLocal lp -> Set.map renderComponent $ lpComponents lp
TTUpstream _ _ -> Set.empty
, configCacheHaddock =
shouldHaddockPackage eeBuildOpts eeWanted (packageIdentifierName taskProvides)
@@ -472,6 +486,7 @@
=> ActionContext
-> ExecuteEnv
-> Task
+ -> Maybe String
-> ( Package
-> Path Abs File
-> Path Abs Dir
@@ -481,7 +496,7 @@
-> Maybe (Path Abs File, Handle)
-> m a)
-> m a
-withSingleContext ActionContext {..} ExecuteEnv {..} task@Task {..} inner0 =
+withSingleContext ActionContext {..} ExecuteEnv {..} task@Task {..} msuffix inner0 =
withPackage $ \package cabalfp pkgDir ->
withLogFile package $ \mlogFile ->
withCabal package pkgDir mlogFile $ \cabal ->
@@ -520,8 +535,8 @@
withLogFile package inner
| console = inner Nothing
| otherwise = do
- logPath <- buildLogPath package -- TODO give a difference suffix for test, bench, etc?
- liftIO $ createDirectoryIfMissing True $ toFilePath $ parent logPath
+ logPath <- buildLogPath package msuffix
+ createTree (parent logPath)
let fp = toFilePath logPath
bracket
(liftIO $ openBinaryFile fp WriteMode)
@@ -537,14 +552,13 @@
}
exeName <- liftIO $ join $ findExecutable menv "runhaskell"
distRelativeDir' <- distRelativeDir
- msetuphs <-
+ setuphs <-
-- Avoid broken Setup.hs files causing problems for simple build
-- types, see:
-- https://github.com/commercialhaskell/stack/issues/370
if packageSimpleType package
- then return Nothing
+ then return eeSetupHs
else liftIO $ getSetupHs pkgDir
- let setuphs = fromMaybe eeSetupHs msetuphs
inner $ \stripTHLoading args -> do
let fullArgs =
("-package=" ++
@@ -578,7 +592,13 @@
cp = cp0
{ cwd = Just $ toFilePath pkgDir
, Process.env = envHelper menv
- , std_in = CreatePipe
+ -- Ideally we'd create a new pipe here and then close it
+ -- below to avoid the child process from taking from our
+ -- stdin. However, if we do this, the child process won't
+ -- be able to get the codepage on Windows that we want.
+ -- See:
+ -- https://github.com/commercialhaskell/stack/issues/738
+ -- , std_in = CreatePipe
, std_out =
case mlogFile of
Nothing -> CreatePipe
@@ -591,10 +611,12 @@
$logProcessRun (toFilePath exeName) fullArgs
-- Use createProcess_ to avoid the log file being closed afterwards
- (Just inH, moutH, merrH, ph) <- liftIO $ createProcess_ "singleBuild" cp
- liftIO $ hClose inH
- maybePrintBuildOutput stripTHLoading LevelInfo mlogFile moutH
- maybePrintBuildOutput stripTHLoading LevelWarn mlogFile merrH
+ (Nothing, moutH, merrH, ph) <- liftIO $ createProcess_ "singleBuild" cp
+
+ let makeAbsolute = stripTHLoading -- If users want control, we should add a config option for this
+
+ maybePrintBuildOutput stripTHLoading makeAbsolute LevelInfo mlogFile moutH
+ maybePrintBuildOutput False makeAbsolute LevelWarn mlogFile merrH
ec <- liftIO $ waitForProcess ph
case ec of
ExitSuccess -> return ()
@@ -613,12 +635,12 @@
(fmap fst mlogFile)
bs
- maybePrintBuildOutput stripTHLoading level mlogFile mh =
+ maybePrintBuildOutput stripTHLoading makeAbsolute level mlogFile mh =
case mh of
Just h ->
case mlogFile of
Just{} -> return ()
- Nothing -> printBuildOutput stripTHLoading level h
+ Nothing -> printBuildOutput stripTHLoading makeAbsolute level h
Nothing -> return ()
singleBuild :: M env m
@@ -627,7 +649,7 @@
-> Task
-> m ()
singleBuild ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} =
- withSingleContext ac ee task $ \package cabalfp pkgDir cabal announce console _mlogFile -> do
+ withSingleContext ac ee task Nothing $ \package cabalfp pkgDir cabal announce console _mlogFile -> do
(cache, _neededConfig) <- ensureConfig pkgDir ee task (announce "configure") cabal cabalfp []
markExeNotInstalled (taskLocation task) taskProvides
@@ -637,10 +659,15 @@
announce "build"
config <- asks getConfig
+ extraOpts <- extraBuildOptions
cabal (console && configHideTHLoading config) $
- case taskType of
- TTLocal lp -> "build" : map T.unpack (Set.toList $ lpComponents lp)
- TTUpstream _ _ -> ["build"]
+ (case taskType of
+ TTLocal lp -> "build"
+ -- Cabal... There doesn't seem to be a way to call out the library component...
+ -- : "lib"
+ : map (T.unpack . T.append "exe:")
+ (maybe [] Set.toList $ lpExeComponents lp)
+ TTUpstream _ _ -> ["build"]) ++ extraOpts
let doHaddock = shouldHaddockPackage eeBuildOpts eeWanted (packageName package) &&
-- Works around haddock failing on bytestring-builder since it has no modules
@@ -648,7 +675,10 @@
packageHasExposedModules package
when doHaddock $ do
announce "haddock"
- hscolourExists <- doesExecutableExist eeEnvOverride "hscolour"
+ hscolourExists <- doesExecutableExist eeEnvOverride "HsColour"
+ unless hscolourExists $ $logWarn
+ ("Warning: haddock not generating hyperlinked sources because 'HsColour' not\n" <>
+ "found on PATH (use 'stack build hscolour --copy-bins' to install).")
cabal False (concat [["haddock", "--html", "--hoogle", "--html-location=../$pkg-$version/"]
,["--hyperlink-source" | hscolourExists]])
@@ -676,63 +706,72 @@
liftIO $ atomically $ modifyTVar eeGhcPkgIds $ Map.insert taskProvides mpkgid'
when (doHaddock && shouldHaddockDeps eeBuildOpts) $
- copyDepHaddocks
- eeEnvOverride
- eeBaseConfigOpts
- (pkgDbs ++ [eeGlobalDB])
- (PackageIdentifier (packageName package) (packageVersion package))
- Set.empty
+ withMVar eeInstallLock $ \() ->
+ copyDepHaddocks
+ eeEnvOverride
+ eeBaseConfigOpts
+ (pkgDbs ++ [eeGlobalDB])
+ (PackageIdentifier (packageName package) (packageVersion package))
+ Set.empty
singleTest :: M env m
- => Bool -- ^ rerun tests?
+ => TestOpts
+ -> LocalPackageTB
-> ActionContext
-> ExecuteEnv
-> Task
-> m ()
-singleTest rerunTests ac ee task =
- withSingleContext ac ee task $ \package cabalfp pkgDir cabal announce console mlogFile -> do
+singleTest topts lptb ac ee task =
+ withSingleContext ac ee task (Just "test") $ \package cabalfp pkgDir cabal announce console mlogFile -> do
(_cache, neededConfig) <- ensureConfig pkgDir ee task (announce "configure (test)") cabal cabalfp ["--enable-tests"]
config <- asks getConfig
+ testBuilt <- checkTestBuilt pkgDir
+
let needBuild = neededConfig ||
(case taskType task of
TTLocal lp -> lpDirtyFiles lp
- _ -> assert False True)
- needHpc = boptsCoverage (eeBuildOpts ee)
+ _ -> assert False True) ||
+ not testBuilt
- componentsRaw =
- case taskType task of
- TTLocal lp -> Set.toList $ lpComponents lp
- TTUpstream _ _ -> assert False []
- testsToRun = compareTestsComponents componentsRaw $ Set.toList $ packageTests package
+ needHpc = toCoverage topts
+
+ testsToRun = Set.toList $ lptbTests lptb
components = map (T.unpack . T.append "test:") testsToRun
when needBuild $ do
announce "build (test)"
+ unsetTestBuilt pkgDir
unsetTestSuccess pkgDir
case taskType task of
TTLocal lp -> writeBuildCache pkgDir $ lpNewBuildCache lp
TTUpstream _ _ -> assert False $ return ()
- cabal (console && configHideTHLoading config) $ "build" : components
+ extraOpts <- extraBuildOptions
+ cabal (console && configHideTHLoading config) $
+ "build" : (components ++ extraOpts)
+ setTestBuilt pkgDir
toRun <-
- if rerunTests
- then return True
- else do
- success <- checkTestSuccess pkgDir
- if success
- then do
- unless (null testsToRun) $ announce "skipping already passed test"
- return False
- else return True
+ if toDisableRun topts
+ then do
+ announce "Test running disabled by --no-run-tests flag."
+ return False
+ else if toRerunTests topts
+ then return True
+ else do
+ success <- checkTestSuccess pkgDir
+ if success
+ then do
+ unless (null testsToRun) $ announce "skipping already passed test"
+ return False
+ else return True
when toRun $ do
bconfig <- asks getBuildConfig
buildDir <- distDirFromDir pkgDir
hpcDir <- hpcDirFromDir pkgDir
when needHpc (createTree hpcDir)
- let dotHpcDir = pkgDir dotHpc
- exeExtension =
+ let exeExtension =
case configPlatform $ getConfig bconfig of
Platform _ Windows -> ".exe"
_ -> ""
@@ -757,11 +796,10 @@
$logWarn ("Removing HPC file " <> T.pack (toFilePath nameTix))
removeFileIfExists nameTix
- let args = boptsTestArgs (eeBuildOpts ee)
- argsDisplay =
- case args of
- [] -> ""
- _ -> ", args: " <> T.intercalate " " (map showProcessArgDebug args)
+ let args = toAdditionalArgs topts
+ argsDisplay = case args of
+ [] -> ""
+ _ -> ", args: " <> T.intercalate " " (map showProcessArgDebug args)
announce $ "test (suite: " <> testName <> argsDisplay <> ")"
let cp = (proc (toFilePath exeName) args)
{ cwd = Just $ toFilePath pkgDir
@@ -793,20 +831,15 @@
[ "Test suite "
, testName
, " executable not found for "
- , T.pack $ packageNameString $ packageName package
+ , packageNameText $ packageName package
]
return $ Map.singleton testName Nothing
- when needHpc $ do
- createTree (hpcDir dotHpc)
- exists <- dirExists dotHpcDir
- when exists $ do
- copyDirectoryRecursive dotHpcDir (hpcDir dotHpc)
- removeTree dotHpcDir
- (_,files) <- listDirectory hpcDir
- let tixes =
- filter (isSuffixOf ".tix" . toFilePath . filename) files
- generateHpcReport pkgDir hpcDir (hpcDir dotHpc) tixes
+ when needHpc $ forM_ testsToRun $ \testName -> do
+ let pkgName = packageNameText (packageName package)
+ pkgId = packageIdentifierText (packageIdentifier package)
+ generateHpcReport pkgDir pkgName pkgId testName
+
bs <- liftIO $
case mlogFile of
Nothing -> return ""
@@ -822,79 +855,54 @@
setTestSuccess pkgDir
--- | Determine the tests to be run based on the list of components.
-compareTestsComponents :: [Text] -- ^ components
- -> [Text] -- ^ all test names
- -> [Text] -- ^ tests to be run
-compareTestsComponents [] tests = tests -- no components -- all tests
-compareTestsComponents comps tests2 =
- Set.toList $ Set.intersection tests1 $ Set.fromList tests2
- where
- tests1 = Set.unions $ map toSet comps
-
- toSet x =
- case T.break (== ':') x of
- (y, "") -> assert (x == y) (Set.singleton x)
- ("test", y) -> Set.singleton $ T.drop 1 y
- _ -> Set.empty
-
--- | Generate the HTML report and
-generateHpcReport
- :: M env m
- => Path Abs Dir -> Path Abs Dir -> Path Abs Dir -> [Path Abs File] -> m ()
-generateHpcReport _ _ _ [] = return ()
-generateHpcReport pkgDir hpcDir dotHpcDir tixes = do
- menv <- getMinimalEnvOverride
- $logInfo "Generating HPC HTML ..."
- subdir <- stripDir pkgDir dotHpcDir
- _ <- readProcessStdout (Just hpcDir) menv "hpc" ("markup" : args subdir)
- output <-
- readProcessStdout (Just hpcDir) menv "hpc" ("report" : args subdir)
- forM_ (S8.lines output) ($logInfo . T.decodeUtf8)
- $logInfo
- ("The HTML report is available at " <>
- T.pack (toFilePath (hpcDir $(mkRelFile "hpc_index.html"))))
- where
- args subdir =
- concat
- [ map (toFilePath . filename) tixes
- , ["--srcdir", toFilePath pkgDir]
- , ["--hpcdir", toFilePath subdir]
- , ["--reset-hpcdirs"]]
-
singleBench :: M env m
- => ActionContext
+ => BenchmarkOpts
+ -> LocalPackageTB
+ -> ActionContext
-> ExecuteEnv
-> Task
-> m ()
-singleBench ac ee task =
- withSingleContext ac ee task $ \_package cabalfp pkgDir cabal announce console _mlogFile -> do
+singleBench beopts _lptb ac ee task =
+ withSingleContext ac ee task (Just "bench") $ \_package cabalfp pkgDir cabal announce console _mlogFile -> do
(_cache, neededConfig) <- ensureConfig pkgDir ee task (announce "configure (benchmarks)") cabal cabalfp ["--enable-benchmarks"]
+ benchBuilt <- checkBenchBuilt pkgDir
+
let needBuild = neededConfig ||
(case taskType task of
TTLocal lp -> lpDirtyFiles lp
- _ -> assert False True)
+ _ -> assert False True) ||
+ not benchBuilt
when needBuild $ do
announce "build (benchmarks)"
+ unsetBenchBuilt pkgDir
case taskType task of
TTLocal lp -> writeBuildCache pkgDir $ lpNewBuildCache lp
TTUpstream _ _ -> assert False $ return ()
config <- asks getConfig
- cabal (console && configHideTHLoading config) ["build"]
-
+ extraOpts <- extraBuildOptions
+ cabal (console && configHideTHLoading config) ("build" : extraOpts)
+ setBenchBuilt pkgDir
+ let args = maybe []
+ ((:[]) . ("--benchmark-options=" <>))
+ (beoAdditionalArgs beopts)
announce "benchmarks"
- cabal False ["bench"]
+ cabal False ("bench" : args)
-- | Grab all output from the given @Handle@ and print it to stdout, stripping
-- Template Haskell "Loading package" lines. Does work in a separate thread.
printBuildOutput :: (MonadIO m, MonadBaseControl IO m, MonadLogger m)
- => Bool -> LogLevel -> Handle -> m ()
-printBuildOutput excludeTHLoading level outH = void $ fork $
+ => Bool -- ^ exclude TH loading?
+ -> Bool -- ^ convert paths to absolute?
+ -> LogLevel
+ -> Handle -> m ()
+printBuildOutput excludeTHLoading makeAbsolute level outH = void $ fork $
CB.sourceHandle outH
$$ CB.lines
+ =$ CL.map stripCarriageReturn
=$ CL.filter (not . isTHLoading)
- =$ CL.mapM_ (monadLoggerLog (Loc "" "" "" (0,0) (0,0)) "" level)
+ =$ CL.mapM toAbsolutePath
+ =$ CL.mapM_ (monadLoggerLog $(TH.location >>= liftLoc) "" level)
where
-- | Is this line a Template Haskell "Loading package" line
-- ByteString
@@ -904,25 +912,56 @@
"Loading package " `S8.isPrefixOf` bs &&
("done." `S8.isSuffixOf` bs || "done.\r" `S8.isSuffixOf` bs)
-taskLocation :: Task -> InstallLocation
-taskLocation task =
- case taskType task of
- TTLocal _ -> Local
- TTUpstream _ loc -> loc
+ -- | Convert GHC error lines with file paths to have absolute file paths
+ toAbsolutePath bs | not makeAbsolute = return bs
+ toAbsolutePath bs = do
+ let (x, y) = S.break (== _colon) bs
+ mabs <-
+ if isValidSuffix y
+ then do
+ efp <- liftIO $ tryIO $ D.canonicalizePath $ S8.unpack x
+ case efp of
+ Left _ -> return Nothing
+ Right fp -> return $ Just $ S8.pack fp
+ else return Nothing
+ case mabs of
+ Nothing -> return bs
+ Just fp -> return $ fp `S.append` y
--- | Ensure Setup.hs exists in the given directory. Returns an action
--- to remove it later.
+ -- | Match the line:column format at the end of lines
+ isValidSuffix bs0 = maybe False (const True) $ do
+ guard $ not $ S.null bs0
+ guard $ S.head bs0 == _colon
+ (_, bs1) <- S8.readInt $ S.drop 1 bs0
+
+ guard $ not $ S.null bs1
+ guard $ S.head bs1 == _colon
+ (_, bs2) <- S8.readInt $ S.drop 1 bs1
+
+ guard $ bs2 == ":"
+
+ -- | Strip @\r@ characters from the byte vector. Used because Windows.
+ stripCarriageReturn :: ByteString -> ByteString
+ stripCarriageReturn = S8.filter (not . (=='\r'))
+
+-- | Find the Setup.hs or Setup.lhs in the given directory. If none exists,
+-- throw an exception.
getSetupHs :: Path Abs Dir -- ^ project directory
- -> IO (Maybe (Path Abs File))
+ -> IO (Path Abs File)
getSetupHs dir = do
exists1 <- fileExists fp1
if exists1
- then return $ Just fp1
+ then return fp1
else do
exists2 <- fileExists fp2
if exists2
- then return $ Just fp2
- else return Nothing
+ then return fp2
+ else throwM $ NoSetupHsFound dir
where
fp1 = dir $(mkRelFile "Setup.hs")
fp2 = dir $(mkRelFile "Setup.lhs")
+
+extraBuildOptions :: M env m => m [String]
+extraBuildOptions = do
+ hpcIndexDir <- toFilePath . ( dotHpc) <$> hpcRelativeDir
+ return ["--ghc-options", "-hpcdir " ++ hpcIndexDir ++ " -ddump-hi -ddump-to-file"]
diff --git a/src/Stack/Build/Haddock.hs b/src/Stack/Build/Haddock.hs
--- a/src/Stack/Build/Haddock.hs
+++ b/src/Stack/Build/Haddock.hs
@@ -8,11 +8,14 @@
-- | Generate haddocks
module Stack.Build.Haddock
( copyDepHaddocks
- , generateHaddockIndex
+ , generateLocalHaddockIndex
+ , generateDepsHaddockIndex
+ , generateSnapHaddockIndex
, shouldHaddockPackage
, shouldHaddockDeps
) where
+import Control.Exception (tryJust)
import Control.Monad
import Control.Monad.Catch (MonadCatch)
import Control.Monad.IO.Class
@@ -24,17 +27,19 @@
import Data.Maybe
import Data.Set (Set)
import qualified Data.Set as Set
+import Data.Text (Text)
import qualified Data.Text as T
import Path
import Path.IO
-import Prelude hiding (FilePath, writeFile)
-import Stack.Build.Types
+import Prelude
+import Safe (maximumMay)
+import Stack.Types.Build
import Stack.GhcPkg
import Stack.Package
import Stack.Types
-import System.Directory hiding (findExecutable,
- findFiles)
+import System.Directory (getModificationTime)
import qualified System.FilePath as FP
+import System.IO.Error (isDoesNotExistError)
import System.Process.Read
-- | Determine whether we should haddock for a package.
@@ -76,8 +81,8 @@
Just depOrigDir -> do
let extraDestDirs' =
-- Parent test ensures we don't try to copy docs to global locations
- if (bcoSnapInstallRoot bco) `isParentOf` pkgHtmlDir ||
- (bcoLocalInstallRoot bco) `isParentOf` pkgHtmlDir
+ if bcoSnapInstallRoot bco `isParentOf` pkgHtmlDir ||
+ bcoLocalInstallRoot bco `isParentOf` pkgHtmlDir
then Set.insert (parent pkgHtmlDir) extraDestDirs
else extraDestDirs
copyWhenNeeded extraDestDirs' depId depOrigDir
@@ -106,44 +111,124 @@
origMod <- liftIO $ getModificationTime (toFilePath depOrigIndex)
return (copyMod <= origMod)
doCopy depOrigDir depCopyDir = do
- depCopyDirExists <- dirExists depCopyDir
- liftIO $ do
- when depCopyDirExists $
- removeDirectoryRecursive (toFilePath depCopyDir)
- createDirectoryIfMissing True (toFilePath depCopyDir)
+ removeTreeIfExists depCopyDir
+ createTree depCopyDir
copyDirectoryRecursive depOrigDir depCopyDir
-- | Generate Haddock index and contents for local packages.
-generateHaddockIndex :: (MonadIO m, MonadCatch m, MonadThrow m, MonadLogger m, MonadBaseControl IO m)
- => EnvOverride
- -> BaseConfigOpts
- -> [LocalPackage]
- -> m ()
-generateHaddockIndex envOverride bco locals = do
- $logInfo ("Generating Haddock index in\n" <>
- T.pack (toFilePath (haddockIndexFile docDir)))
- interfaceArgs <- mapM (\LocalPackage {lpPackage = Package {..}} ->
- toInterfaceOpt (PackageIdentifier packageName packageVersion))
- locals
- readProcessNull
- (Just docDir)
+generateLocalHaddockIndex
+ :: (MonadIO m, MonadCatch m, MonadThrow m, MonadLogger m, MonadBaseControl IO m)
+ => EnvOverride -> BaseConfigOpts -> [LocalPackage] -> m ()
+generateLocalHaddockIndex envOverride bco locals = do
+ let packageIDs =
+ map
+ (\LocalPackage{lpPackage = Package{..}} ->
+ PackageIdentifier packageName packageVersion)
+ locals
+ generateHaddockIndex
+ "local packages"
envOverride
- "haddock"
- (["--gen-contents", "--gen-index"] ++ concat interfaceArgs)
+ packageIDs
+ "."
+ (localDocDir bco)
+
+-- | Generate Haddock index and contents for local packages and their dependencies.
+generateDepsHaddockIndex
+ :: (MonadIO m, MonadCatch m, MonadThrow m, MonadLogger m, MonadBaseControl IO m)
+ => EnvOverride -> BaseConfigOpts -> [LocalPackage] -> m ()
+generateDepsHaddockIndex envOverride bco locals = do
+ depSets <-
+ mapM
+ (\LocalPackage{lpPackage = Package{..}} ->
+ findTransitiveGhcPkgDepends
+ envOverride
+ [bcoSnapDB bco, bcoLocalDB bco]
+ (PackageIdentifier packageName packageVersion))
+ locals
+ generateHaddockIndex
+ "local packages and dependencies"
+ envOverride
+ (Set.toList (Set.unions depSets))
+ ".."
+ (localDocDir bco $(mkRelDir "all"))
+
+-- | Generate Haddock index and contents for all snapshot packages.
+generateSnapHaddockIndex
+ :: (MonadIO m, MonadCatch m, MonadThrow m, MonadLogger m, MonadBaseControl IO m)
+ => EnvOverride -> BaseConfigOpts -> Path Abs Dir -> m ()
+generateSnapHaddockIndex envOverride bco globalDB = do
+ pkgIds <- listGhcPkgDbs envOverride [globalDB, bcoSnapDB bco]
+ generateHaddockIndex
+ "snapshot packages"
+ envOverride
+ pkgIds
+ "."
+ (snapDocDir bco)
+
+-- | Generate Haddock index and contents for specified packages.
+generateHaddockIndex
+ :: (MonadIO m, MonadCatch m, MonadThrow m, MonadLogger m, MonadBaseControl IO m)
+ => Text
+ -> EnvOverride
+ -> [PackageIdentifier]
+ -> FilePath
+ -> Path Abs Dir
+ -> m ()
+generateHaddockIndex descr envOverride packageIDs docRelDir destDir = do
+ createTree destDir
+ interfaceOpts <- liftIO $ fmap catMaybes (mapM toInterfaceOpt packageIDs)
+ case maximumMay (map snd interfaceOpts) of
+ Nothing -> return ()
+ Just maxInterfaceModTime -> do
+ eindexModTime <-
+ liftIO $
+ tryJust (guard . isDoesNotExistError) $
+ getModificationTime (toFilePath (haddockIndexFile destDir))
+ let needUpdate =
+ case eindexModTime of
+ Left _ -> True
+ Right indexModTime ->
+ indexModTime < maxInterfaceModTime
+ when
+ needUpdate $
+ do $logInfo
+ ("Updating Haddock index for " <> descr <> " in\n" <>
+ T.pack (toFilePath (haddockIndexFile destDir)))
+ readProcessNull
+ (Just destDir)
+ envOverride
+ "haddock"
+ (["--gen-contents", "--gen-index"] ++ concatMap fst interfaceOpts)
where
- docDir = bcoLocalInstallRoot bco docdirSuffix
toInterfaceOpt pid@(PackageIdentifier name _) = do
- interfaceRelFile <- parseRelFile (packageIdentifierString pid FP.
- packageNameString name FP.<.>
- "haddock")
- interfaceExists <- fileExists (docDir interfaceRelFile)
- return $ if interfaceExists
- then [ "-i"
- , concat
- [ packageIdentifierString pid
- , ","
- , toFilePath interfaceRelFile ] ]
- else []
+ let interfaceRelFile =
+ docRelDir FP. packageIdentifierString pid FP.
+ packageNameString name FP.<.>
+ "haddock"
+ interfaceAbsFile = toFilePath destDir FP. interfaceRelFile
+ einterfaceModTime <-
+ tryJust (guard . isDoesNotExistError) $
+ getModificationTime interfaceAbsFile
+ return $
+ case einterfaceModTime of
+ Left _ -> Nothing
+ Right interfaceModTime ->
+ Just
+ ( [ "-i"
+ , concat
+ [ docRelDir FP. packageIdentifierString pid
+ , ","
+ , interfaceRelFile]]
+ , interfaceModTime)
+-- | Path of haddock index file.
haddockIndexFile :: Path Abs Dir -> Path Abs File
-haddockIndexFile docDir = docDir $(mkRelFile "index.html")
+haddockIndexFile destDir = destDir $(mkRelFile "index.html")
+
+-- | Path of local packages documentation directory.
+localDocDir :: BaseConfigOpts -> Path Abs Dir
+localDocDir bco = bcoLocalInstallRoot bco docDirSuffix
+
+-- | Path of snapshot packages documentation directory.
+snapDocDir :: BaseConfigOpts -> Path Abs Dir
+snapDocDir bco = bcoSnapInstallRoot bco docDirSuffix
diff --git a/src/Stack/Build/Installed.hs b/src/Stack/Build/Installed.hs
--- a/src/Stack/Build/Installed.hs
+++ b/src/Stack/Build/Installed.hs
@@ -32,7 +32,7 @@
import Path
import Prelude hiding (FilePath, writeFile)
import Stack.Build.Cache
-import Stack.Build.Types
+import Stack.Types.Build
import Stack.Constants
import Stack.GhcPkg
import Stack.PackageDump
diff --git a/src/Stack/Build/Source.hs b/src/Stack/Build/Source.hs
--- a/src/Stack/Build/Source.hs
+++ b/src/Stack/Build/Source.hs
@@ -10,67 +10,57 @@
, SourceMap
, PackageSource (..)
, localFlags
- , loadLocals
+ , getLocalPackageViews
+ , loadLocalPackage
) where
-import Network.HTTP.Client.Conduit (HasHttpManager)
-import Control.Applicative ((<|>), (<$>), (<*>))
-import Control.Exception (catch)
+import Control.Applicative ((<$>), (<*>))
+import Control.Arrow ((&&&))
+import Control.Exception (assert, catch)
import Control.Monad
-import Control.Monad.Catch (MonadCatch)
+import Control.Monad.Catch (MonadCatch)
import Control.Monad.IO.Class
import Control.Monad.Logger
-import Control.Monad.Reader (MonadReader, asks)
+import Control.Monad.Reader (MonadReader, asks)
import Control.Monad.Trans.Resource
-import Crypto.Hash (Digest, SHA256)
-import Crypto.Hash.Conduit (sinkHash)
-import Data.Byteable (toBytes)
-import qualified Data.ByteString as S
-import Data.Conduit (($$), ZipSink (..))
-import qualified Data.Conduit.Binary as CB
-import qualified Data.Conduit.List as CL
+import Crypto.Hash (Digest, SHA256)
+import Crypto.Hash.Conduit (sinkHash)
+import qualified Data.ByteString as S
+import Data.Byteable (toBytes)
+import Data.Conduit (($$), ZipSink (..))
+import qualified Data.Conduit.Binary as CB
+import qualified Data.Conduit.List as CL
import Data.Either
-import qualified Data.Foldable as F
import Data.Function
-import qualified Data.HashSet as HashSet
+import qualified Data.HashSet as HashSet
import Data.List
-import qualified Data.Map as Map
-import Data.Map.Strict (Map)
+import qualified Data.Map as Map
+import Data.Map.Strict (Map)
import Data.Maybe
-import Data.Monoid ((<>), Any (..), mconcat)
-import Data.Set (Set)
-import qualified Data.Set as Set
-import Data.Text (Text)
-import qualified Data.Text as T
+import Data.Monoid ((<>), Any (..), mconcat)
+import Data.Set (Set)
+import qualified Data.Set as Set
+import Data.Text (Text)
+import qualified Data.Text as T
+import Distribution.Package (pkgName, pkgVersion)
+import Distribution.PackageDescription (GenericPackageDescription, package, packageDescription)
+import qualified Distribution.PackageDescription as C
+import Network.HTTP.Client.Conduit (HasHttpManager)
import Path
-import Prelude hiding (writeFile)
+import Path.IO
+import Prelude
import Stack.Build.Cache
-import Stack.Build.Types
-import Stack.BuildPlan (loadMiniBuildPlan,
- shadowMiniBuildPlan)
-import Stack.Constants (wiredInPackages)
+import Stack.Build.Target
+import Stack.Types.Build
+import Stack.BuildPlan (loadMiniBuildPlan, shadowMiniBuildPlan,
+ parseCustomMiniBuildPlan)
+import Stack.Constants (wiredInPackages)
import Stack.Package
import Stack.PackageIndex
import Stack.Types
-import System.Directory hiding (findExecutable, findFiles)
-import System.IO (withBinaryFile, IOMode (ReadMode))
-import System.IO.Error (isDoesNotExistError)
-
-type SourceMap = Map PackageName PackageSource
-
--- | Where the package's source is located: local directory or package index
-data PackageSource
- = PSLocal LocalPackage
- | PSUpstream Version InstallLocation (Map FlagName Bool)
- -- ^ Upstream packages could be installed in either local or snapshot
- -- databases; this is what 'InstallLocation' specifies.
- deriving Show
-instance PackageInstallInfo PackageSource where
- piiVersion (PSLocal lp) = packageVersion $ lpPackage lp
- piiVersion (PSUpstream v _ _) = v
-
- piiLocation (PSLocal _) = Local
- piiLocation (PSUpstream _ loc _) = loc
+import System.Directory
+import System.IO (withBinaryFile, IOMode (ReadMode))
+import System.IO.Error (isDoesNotExistError)
loadSourceMap :: (MonadIO m, MonadCatch m, MonadReader env m, HasBuildConfig env, MonadBaseControl IO m, HasHttpManager env, MonadLogger m, HasEnvConfig env)
=> BuildOpts
@@ -89,30 +79,51 @@
{ mbpGhcVersion = fromMajorVersion ghc
, mbpPackages = Map.empty
}
+ ResolverCustom _ url -> do
+ stackYamlFP <- asks $ bcStackYaml . getBuildConfig
+ parseCustomMiniBuildPlan stackYamlFP url
+ rawLocals <- getLocalPackageViews
+ workingDir <- getWorkingDir
+ (cliExtraDeps, targets) <-
+ parseTargets
+ (bcImplicitGlobal bconfig)
+ (boptsTests bopts)
+ (boptsBenchmarks bopts)
+ (mpiVersion <$> mbpPackages mbp0)
+ (bcExtraDeps bconfig)
+ (fst <$> rawLocals)
+ workingDir
+ (boptsTargets bopts)
+
menv <- getMinimalEnvOverride
caches <- getPackageCaches menv
- let latestVersion = Map.fromList $ map toTuple $ Map.keys caches
- (locals, extraNames, extraIdents) <- loadLocals bopts latestVersion
+ let latestVersion = Map.fromListWith max $ map toTuple $ Map.keys caches
+ -- Extend extra-deps to encompass targets requested on the command line
+ -- that are not in the snapshot.
+ extraDeps0 <- extendExtraDeps
+ (bcExtraDeps bconfig)
+ cliExtraDeps
+ (Map.keysSet $ Map.filter (== STUnknown) targets)
+ latestVersion
+
+ locals <- mapM (loadLocalPackage bopts targets) $ Map.toList rawLocals
+ checkFlagsUsed bopts locals
+
let
-- loadLocals returns PackageName (foo) and PackageIdentifier (bar-1.2.3) targets separately;
-- here we combine them into nonLocalTargets. This is one of the
-- return values of this function.
nonLocalTargets :: Set PackageName
- nonLocalTargets = extraNames <> Set.map packageIdentifierName extraIdents
-
- -- Extend extra-deps to encompass targets requested on the command line
- -- that are not in the snapshot.
- extraDeps0 = extendExtraDeps
- (bcExtraDeps bconfig)
- mbp0
- latestVersion
- extraNames
- extraIdents
+ nonLocalTargets =
+ Map.keysSet $ Map.filter (not . isLocal) targets
+ where
+ isLocal (STLocal _) = True
+ isLocal STUnknown = False
+ isLocal STNonLocal = False
- let shadowed = Set.fromList (map (packageName . lpPackage) locals)
- <> Map.keysSet extraDeps0
+ shadowed = Map.keysSet rawLocals <> Map.keysSet extraDeps0
(mbp, extraDeps1) = shadowMiniBuildPlan mbp0 shadowed
-- Add the extra deps from the stack.yaml file to the deps grabbed from
@@ -135,152 +146,151 @@
(PSUpstream (mpiVersion mpi) Snap (mpiFlags mpi))
] `Map.difference` Map.fromList (map (, ()) (HashSet.toList wiredInPackages))
- let unknown = Set.difference nonLocalTargets $ Map.keysSet sourceMap
- unless (Set.null unknown) $ do
- let toEither name =
- case Map.lookup name latestVersion of
- Nothing -> Left name
- Just version -> Right (name, version)
- eithers = map toEither $ Set.toList unknown
- (unknown', notInIndex) = partitionEithers eithers
- throwM $ UnknownTargets
- (Set.fromList unknown')
- (Map.fromList notInIndex)
- (bcStackYaml bconfig)
-
return (mbp, locals, nonLocalTargets, sourceMap)
--- | 'loadLocals' combines two pieces of information:
---
--- 1. Targets, i.e. arguments passed to stack such as @foo@ and @bar@ in the @stack foo bar@ invocation
---
--- 2. Local packages listed in @stack.yaml@
---
--- It returns:
---
--- 1. For every local package, a 'LocalPackage' structure
---
--- 2. If a target does not correspond to a local package but is a valid
--- 'PackageName' or 'PackageIdentifier', it is returned as such.
---
--- NOTE: as the function is written right now, it may "drop" targets if
--- they correspond to existing directories not listed in stack.yaml. This
--- may be a bug.
-loadLocals :: forall m env .
- (MonadReader env m, HasBuildConfig env, MonadIO m, MonadLogger m, MonadThrow m, MonadCatch m,HasEnvConfig env)
- => BuildOpts
- -> Map PackageName Version
- -> m ([LocalPackage], Set PackageName, Set PackageIdentifier)
-loadLocals bopts latestVersion = do
- targets <- mapM parseTarget $
- case boptsTargets bopts of
- [] -> ["."]
- x -> x
-
- -- Group targets by their kind
- (dirs, names, idents) <-
- case partitionEithers targets of
- ([], targets') -> return $ partitionTargetSpecs targets'
- (bad, _) -> throwM $ Couldn'tParseTargets bad
-
+-- | Parse out the local package views for the current project
+getLocalPackageViews :: (MonadThrow m, MonadIO m, MonadReader env m, HasEnvConfig env)
+ => m (Map PackageName (LocalPackageView, GenericPackageDescription))
+getLocalPackageViews = do
econfig <- asks getEnvConfig
- bconfig <- asks getBuildConfig
- -- Iterate over local packages declared in stack.yaml and turn them
- -- into LocalPackage structures. The targets affect whether these
- -- packages will be marked as wanted.
- lps <- forM (Map.toList $ bcPackages bconfig) $ \(dir, validWanted) -> do
+ -- TODO ensure that there are no overlapping package names
+ liftM Map.fromList $ forM (Map.toList $ envConfigPackages econfig) $ \(dir, validWanted) -> do
cabalfp <- getCabalFileName dir
+ gpkg <- readPackageUnresolved cabalfp
+ let cabalID = package $ packageDescription gpkg
name <- parsePackageNameFromFilePath cabalfp
- let wanted = validWanted && isWanted dirs names dir name
- config = PackageConfig
- { packageConfigEnableTests = False
- , packageConfigEnableBenchmarks = False
- , packageConfigFlags = localFlags (boptsFlags bopts) bconfig name
- , packageConfigGhcVersion = envConfigGhcVersion econfig
- , packageConfigPlatform = configPlatform $ getConfig bconfig
- }
- configFinal = config
- { packageConfigEnableTests =
- case boptsFinalAction bopts of
- DoTests _ -> wanted
- _ -> False
- , packageConfigEnableBenchmarks = wanted && boptsFinalAction bopts == DoBenchmarks
+ when (fromCabalPackageName (pkgName $ cabalID) /= name)
+ $ throwM $ MismatchedCabalName cabalfp name
+ let lpv = LocalPackageView
+ { lpvVersion = fromCabalVersion $ pkgVersion cabalID
+ , lpvRoot = dir
+ , lpvCabalFP = cabalfp
+ , lpvExtraDep = not validWanted
+ , lpvComponents = getNamedComponents gpkg
}
- pkg <- readPackage config cabalfp
- pkgFinal <- readPackage configFinal cabalfp
- when (packageName pkg /= name) $ throwM
- $ MismatchedCabalName cabalfp (packageName pkg)
- mbuildCache <- tryGetBuildCache dir
- files <- getPackageFiles (packageFiles pkg) AllFiles cabalfp
- (isDirty, newBuildCache) <- checkBuildCache
- (fromMaybe Map.empty mbuildCache)
- (map toFilePath $ Set.toList files)
- return LocalPackage
- { lpPackage = pkg
- , lpPackageFinal = pkgFinal
- , lpWanted = wanted
- , lpFiles = files
- , lpDirtyFiles = isDirty
- , lpNewBuildCache = newBuildCache
- , lpCabalFile = cabalfp
- , lpDir = dir
- , lpComponents = fromMaybe Set.empty $ Map.lookup name names
+ return (name, (lpv, gpkg))
+ where
+ getNamedComponents gpkg = Set.fromList $ concat
+ [ maybe [] (const [CLib]) (C.condLibrary gpkg)
+ , go CExe C.condExecutables
+ , go CTest C.condTestSuites
+ , go CBench C.condBenchmarks
+ ]
+ where
+ go wrapper f = map (wrapper . T.pack . fst) $ f gpkg
+
+splitComponents :: [NamedComponent]
+ -> (Set Text, Set Text, Set Text)
+splitComponents =
+ go id id id
+ where
+ go a b c [] = (Set.fromList $ a [], Set.fromList $ b [], Set.fromList $ c [])
+ go a b c (CLib:xs) = go a b c xs
+ go a b c (CExe x:xs) = go (a . (x:)) b c xs
+ go a b c (CTest x:xs) = go a (b . (x:)) c xs
+ go a b c (CBench x:xs) = go a b (c . (x:)) xs
+
+-- | Upgrade the initial local package info to a full-blown @LocalPackage@
+-- based on the selected components
+loadLocalPackage
+ :: forall m env.
+ (MonadReader env m, HasEnvConfig env, MonadCatch m, MonadLogger m, MonadIO m)
+ => BuildOpts
+ -> Map PackageName SimpleTarget
+ -> (PackageName, (LocalPackageView, GenericPackageDescription))
+ -> m LocalPackage
+loadLocalPackage bopts targets (name, (lpv, gpkg)) = do
+ bconfig <- asks getBuildConfig
+ econfig <- asks getEnvConfig
+
+ let mtarget = Map.lookup name targets
+ components =
+ case mtarget of
+ Just (STLocal comps) -> comps
+ Just STNonLocal -> assert False Set.empty
+ Just STUnknown -> assert False Set.empty
+ Nothing -> Set.empty
+ (exes, tests, benches) = splitComponents $ Set.toList components
+ config = PackageConfig
+ { packageConfigEnableTests = False
+ , packageConfigEnableBenchmarks = False
+ , packageConfigFlags = localFlags (boptsFlags bopts) bconfig name
+ , packageConfigGhcVersion = envConfigGhcVersion econfig
+ , packageConfigPlatform = configPlatform $ getConfig bconfig
}
+ btconfig = config
+ { packageConfigEnableTests = not $ Set.null tests
+ , packageConfigEnableBenchmarks = not $ Set.null benches
+ }
+ pkg = resolvePackage config gpkg
+ btpkg
+ | Set.null tests && Set.null benches = Nothing
+ | otherwise = Just $ LocalPackageTB
+ { lptbPackage = resolvePackage btconfig gpkg
+ , lptbTests = tests
+ , lptbBenches = benches
+ }
+ mbuildCache <- tryGetBuildCache $ lpvRoot lpv
+ files <- getPackageFiles (packageFiles pkg) (lpvCabalFP lpv)
+ (isDirty, newBuildCache) <- checkBuildCache
+ (fromMaybe Map.empty mbuildCache)
+ (map toFilePath $ Set.toList files)
- let known = Set.fromList $ map (packageName . lpPackage) lps
- unknown = Set.difference (Map.keysSet names) known
+ return LocalPackage
+ { lpPackage = pkg
+ , lpExeComponents =
+ case mtarget of
+ Nothing -> Nothing
+ Just _ -> Just exes
+ , lpTestBench = btpkg
+ , lpFiles = files
+ , lpDirtyFiles = isDirty || boptsForceDirty bopts
+ , lpNewBuildCache = newBuildCache
+ , lpCabalFile = lpvCabalFP lpv
+ , lpDir = lpvRoot lpv
+ , lpComponents = components
+ }
- return (lps, unknown, idents)
- where
- -- Attempt to parse a TargetSpec based on its textual form and on
- -- whether it is a name of an existing directory.
- --
- -- If a TargetSpec is not recognized, return it verbatim as Left.
- parseTarget :: Text -> m (Either Text TargetSpec)
- parseTarget t = do
- let s = T.unpack t
- isDir <- liftIO $ doesDirectoryExist s
- if isDir
- then liftM (Right . TSDir) $ liftIO (canonicalizePath s) >>= parseAbsDir
- else return
- $ maybe (Left t) Right
- $ (flip TSName Set.empty <$> parsePackageNameFromString s)
- <|> (TSIdent <$> parsePackageIdentifierFromString s)
- <|> (do
- t' <- T.stripSuffix ":latest" t
- name <- parsePackageNameFromString $ T.unpack t'
- version <- Map.lookup name latestVersion
- Just $ TSIdent $ PackageIdentifier name version)
- <|> (do
- let (name', rest) = T.break (== ':') t
- component <- T.stripPrefix ":" rest
- name <- parsePackageNameFromString $ T.unpack name'
- Just $ TSName name $ Set.singleton component)
- isWanted dirs names dir name =
- name `Map.member` names ||
- any (`isParentOf` dir) dirs ||
- any (== dir) dirs
+-- | Ensure that the flags specified in the stack.yaml file and on the command
+-- line are used.
+checkFlagsUsed :: (MonadThrow m, MonadReader env m, HasBuildConfig env)
+ => BuildOpts
+ -> [LocalPackage]
+ -> m ()
+checkFlagsUsed bopts lps = do
+ bconfig <- asks getBuildConfig
-data TargetSpec
- = TSName PackageName (Set Text)
- | TSIdent PackageIdentifier
- | TSDir (Path Abs Dir)
+ -- Check if flags specified in stack.yaml and the command line are
+ -- used, see https://github.com/commercialhaskell/stack/issues/617
+ let flags = map (, FSCommandLine) [(k, v) | (Just k, v) <- Map.toList $ boptsFlags bopts]
+ ++ map (, FSStackYaml) (Map.toList $ bcFlags bconfig)
-partitionTargetSpecs :: [TargetSpec] -> ([Path Abs Dir], Map PackageName (Set Text), Set PackageIdentifier)
-partitionTargetSpecs =
- loop id Map.empty Set.empty
- where
- loop dirs names idents ts0 =
- case ts0 of
- [] -> (dirs [], names, idents)
- TSName name comps:ts -> loop
- dirs
- (Map.insertWith Set.union name comps names)
- idents
- ts
- TSIdent ident:ts -> loop dirs names (Set.insert ident idents) ts
- TSDir dir:ts -> loop (dirs . (dir:)) names idents ts
+ localNameMap = Map.fromList $ map (packageName . lpPackage &&& lpPackage) lps
+ checkFlagUsed ((name, userFlags), source) =
+ case Map.lookup name localNameMap of
+ -- Package is not available locally
+ Nothing ->
+ case Map.lookup name $ bcExtraDeps bconfig of
+ -- Also not in extra-deps, it's an error
+ Nothing -> Just $ UFNoPackage source name
+ -- We don't check for flag presence for extra deps
+ Just _ -> Nothing
+ -- Package exists locally, let's check if the flags are defined
+ Just pkg ->
+ let unused = Set.difference (Map.keysSet userFlags) (packageDefinedFlags pkg)
+ in if Set.null unused
+ -- All flags are defined, nothing to do
+ then Nothing
+ -- Error about the undefined flags
+ else Just $ UFFlagsNotDefined source pkg unused
+ unusedFlags = mapMaybe checkFlagUsed flags
+
+ unless (null unusedFlags)
+ $ throwM
+ $ InvalidFlagSpecification
+ $ Set.fromList unusedFlags
+
-- | All flags for a local package
localFlags :: (Map (Maybe PackageName) (Map FlagName Bool))
-> BuildConfig
@@ -294,36 +304,34 @@
-- | Add in necessary packages to extra dependencies
--
--- See https://github.com/commercialhaskell/stack/issues/272 for the requirements of this function
-extendExtraDeps :: Map PackageName Version -- ^ original extra deps
- -> MiniBuildPlan
+-- Originally part of https://github.com/commercialhaskell/stack/issues/272,
+-- this was then superseded by
+-- https://github.com/commercialhaskell/stack/issues/651
+extendExtraDeps :: (MonadThrow m, MonadReader env m, HasBuildConfig env)
+ => Map PackageName Version -- ^ original extra deps
+ -> Map PackageName Version -- ^ package identifiers from the command line
+ -> Set PackageName -- ^ all packages added on the command line
-> Map PackageName Version -- ^ latest versions in indices
- -> Set PackageName -- ^ extra package names desired
- -> Set PackageIdentifier -- ^ extra package identifiers desired
- -> Map PackageName Version -- ^ new extradeps
-extendExtraDeps extraDeps0 mbp latestVersion extraNames extraIdents =
- F.foldl' addIdent
- (F.foldl' addName extraDeps0 extraNames)
- extraIdents
+ -> m (Map PackageName Version) -- ^ new extradeps
+extendExtraDeps extraDeps0 cliExtraDeps unknowns latestVersion
+ | null errs = return $ Map.unions $ extraDeps1 : unknowns'
+ | otherwise = do
+ bconfig <- asks getBuildConfig
+ throwM $ UnknownTargets
+ (Set.fromList errs)
+ Map.empty -- TODO check the cliExtraDeps for presence in index
+ (bcStackYaml bconfig)
where
- snapshot = fmap mpiVersion $ mbpPackages mbp
+ extraDeps1 = Map.union extraDeps0 cliExtraDeps
- addName m name =
- case Map.lookup name m <|> Map.lookup name snapshot of
- -- alright exists in snapshot or extra-deps
- Just _ -> m
+ (errs, unknowns') = partitionEithers $ map addUnknown $ Set.toList unknowns
+ addUnknown pn =
+ case Map.lookup pn extraDeps1 of
+ Just _ -> Right Map.empty
Nothing ->
- case Map.lookup name latestVersion of
- -- use the latest version in the index
- Just v -> Map.insert name v m
- -- does not exist, will be reported as an error
- Nothing -> m
-
- addIdent m (PackageIdentifier name version) =
- case Map.lookup name snapshot of
- -- the version matches what's in the snapshot, so just use the snapshot version
- Just version' | version == version' -> m
- _ -> Map.insert name version m
+ case Map.lookup pn latestVersion of
+ Just v -> Right $ Map.singleton pn v
+ Nothing -> Left pn
-- | Compare the current filesystem state to the cached information, and
-- determine (1) if the files are dirty, and (2) the new cache values.
diff --git a/src/Stack/Build/Target.hs b/src/Stack/Build/Target.hs
new file mode 100644
--- /dev/null
+++ b/src/Stack/Build/Target.hs
@@ -0,0 +1,319 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE ViewPatterns #-}
+-- | Parsing command line targets
+module Stack.Build.Target
+ ( -- * Types
+ ComponentName
+ , UnresolvedComponent (..)
+ , RawTarget (..)
+ , LocalPackageView (..)
+ , SimpleTarget (..)
+ -- * Parsers
+ , parseRawTarget
+ , parseTargets
+ ) where
+
+import Control.Applicative
+import Control.Arrow (second)
+import Control.Monad.Catch (MonadThrow, throwM)
+import Control.Monad.IO.Class
+import Data.Either (partitionEithers)
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Maybe (mapMaybe)
+import Data.Monoid (mconcat)
+import Data.Set (Set)
+import qualified Data.Set as Set
+import Data.Text (Text)
+import qualified Data.Text as T
+import Path
+import Path.IO
+import Stack.Types
+
+-- | The name of a component, which applies to executables, test suites, and benchmarks
+type ComponentName = Text
+
+newtype RawInput = RawInput { unRawInput :: Text }
+
+-- | Either a fully resolved component, or a component name that could be
+-- either an executable, test, or benchmark
+data UnresolvedComponent
+ = ResolvedComponent !NamedComponent
+ | UnresolvedComponent !ComponentName
+ deriving (Show, Eq, Ord)
+
+-- | Raw command line input, without checking against any databases or list of
+-- locals. Does not deal with directories
+data RawTarget (a :: RawTargetType) where
+ RTPackageComponent :: !PackageName -> !UnresolvedComponent -> RawTarget a
+ RTComponent :: !ComponentName -> RawTarget a
+ RTPackage :: !PackageName -> RawTarget a
+ RTPackageIdentifier :: !PackageIdentifier -> RawTarget HasIdents
+
+deriving instance Show (RawTarget a)
+deriving instance Eq (RawTarget a)
+deriving instance Ord (RawTarget a)
+
+data RawTargetType = HasIdents | NoIdents
+
+-- | If this function returns @Nothing@, the input should be treated as a
+-- directory.
+parseRawTarget :: Text -> Maybe (RawTarget HasIdents)
+parseRawTarget t =
+ (RTPackageIdentifier <$> parsePackageIdentifierFromString s)
+ <|> (RTPackage <$> parsePackageNameFromString s)
+ <|> (RTComponent <$> T.stripPrefix ":" t)
+ <|> parsePackageComponent
+ where
+ s = T.unpack t
+
+ parsePackageComponent =
+ case T.splitOn ":" t of
+ [pname, "lib"]
+ | Just pname' <- parsePackageNameFromString (T.unpack pname) ->
+ Just $ RTPackageComponent pname' $ ResolvedComponent CLib
+ [pname, cname]
+ | Just pname' <- parsePackageNameFromString (T.unpack pname) ->
+ Just $ RTPackageComponent pname' $ UnresolvedComponent cname
+ [pname, typ, cname]
+ | Just pname' <- parsePackageNameFromString (T.unpack pname)
+ , Just wrapper <- parseCompType typ ->
+ Just $ RTPackageComponent pname' $ ResolvedComponent $ wrapper cname
+ _ -> Nothing
+
+ parseCompType t' =
+ case t' of
+ "exe" -> Just CExe
+ "test" -> Just CTest
+ "bench" -> Just CBench
+ _ -> Nothing
+
+-- | A view of a local package needed for resolving components
+data LocalPackageView = LocalPackageView
+ { lpvVersion :: !Version
+ , lpvRoot :: !(Path Abs Dir)
+ , lpvCabalFP :: !(Path Abs File)
+ , lpvComponents :: !(Set NamedComponent)
+ , lpvExtraDep :: !Bool
+ }
+
+-- | Same as @parseRawTarget@, but also takes directories into account.
+parseRawTargetDirs :: (MonadIO m, MonadThrow m)
+ => Path Abs Dir -- ^ current directory
+ -> Map PackageName LocalPackageView
+ -> Text
+ -> m (Either Text [(RawInput, RawTarget HasIdents)])
+parseRawTargetDirs root locals t =
+ case parseRawTarget t of
+ Just rt -> return $ Right [(ri, rt)]
+ Nothing -> do
+ mdir <- resolveDirMaybe root $ T.unpack t
+ case mdir of
+ Nothing -> return $ Left $ "Directory not found: " `T.append` t
+ Just dir ->
+ case mapMaybe (childOf dir) $ Map.toList locals of
+ [] -> return $ Left $
+ "No local directories found as children of " `T.append`
+ t
+ names -> return $ Right $ map ((ri, ) . RTPackage) names
+ where
+ ri = RawInput t
+
+ childOf dir (name, lpv) =
+ if (dir == lpvRoot lpv || isParentOf dir (lpvRoot lpv)) && not (lpvExtraDep lpv)
+ then Just name
+ else Nothing
+
+data TargetType
+ = TTUnknown
+ | TTNonLocal
+ | TTLocalComp !NamedComponent
+ | TTLocalAllComps !(Set NamedComponent)
+
+data SimpleTarget
+ = STUnknown
+ | STNonLocal
+ | STLocal !(Set NamedComponent)
+ deriving (Show, Eq, Ord)
+
+resolveIdents :: Map PackageName Version -- ^ snapshot
+ -> Map PackageName Version -- ^ extra deps
+ -> Map PackageName LocalPackageView
+ -> (RawInput, RawTarget HasIdents)
+ -> Either Text ((RawInput, RawTarget NoIdents), Map PackageName Version)
+resolveIdents _ _ _ (ri, RTPackageComponent x y) = Right ((ri, RTPackageComponent x y), Map.empty)
+resolveIdents _ _ _ (ri, RTComponent x) = Right ((ri, RTComponent x), Map.empty)
+resolveIdents _ _ _ (ri, RTPackage x) = Right $ ((ri, RTPackage x), Map.empty)
+resolveIdents snap extras locals (ri, RTPackageIdentifier (PackageIdentifier name version)) =
+ case mfound of
+ Just (foundPlace, foundVersion) | foundVersion /= version -> Left $ T.pack $ concat
+ [ "Specified target version "
+ , versionString version
+ , " for package "
+ , packageNameString name
+ , " does not match "
+ , foundPlace
+ , " version "
+ , versionString foundVersion
+ ]
+ _ -> Right
+ ( (ri, RTPackage name)
+ , case mfound of
+ -- Add to extra deps since we didn't have it already
+ Nothing -> Map.singleton name version
+ -- Already had it, don't add to extra deps
+ Just _ -> Map.empty
+ )
+ where
+ mfound = mlocal <|> mextra <|> msnap
+
+ mlocal = (("local", ) . lpvVersion) <$> Map.lookup name locals
+ mextra = ("extra-deps", ) <$> Map.lookup name extras
+ msnap = ("snapshot", ) <$> Map.lookup name snap
+
+resolveRawTarget :: Map PackageName Version -- ^ snapshot
+ -> Map PackageName Version -- ^ extra deps
+ -> Map PackageName LocalPackageView
+ -> (RawInput, RawTarget NoIdents)
+ -> Either Text (PackageName, (RawInput, TargetType))
+resolveRawTarget snap extras locals (ri, rt) =
+ go rt
+ where
+ go (RTPackageComponent name ucomp) =
+ case Map.lookup name locals of
+ Nothing -> Left $ T.pack $ "Unknown local package: " ++ packageNameString name
+ Just lpv ->
+ case ucomp of
+ ResolvedComponent comp
+ | comp `Set.member` lpvComponents lpv ->
+ Right (name, (ri, TTLocalComp comp))
+ | otherwise -> Left $ T.pack $ concat
+ [ "Component "
+ , show comp
+ , " does not exist in package "
+ , packageNameString name
+ ]
+ UnresolvedComponent comp ->
+ case filter (isCompNamed comp) $ Set.toList $ lpvComponents lpv of
+ [] -> Left $ T.concat
+ [ "Component "
+ , comp
+ , " does not exist in package "
+ , T.pack $ packageNameString name
+ ]
+ [x] -> Right (name, (ri, TTLocalComp x))
+ matches -> Left $ T.concat
+ [ "Ambiguous component name "
+ , comp
+ , " for package "
+ , T.pack $ packageNameString name
+ , ": "
+ , T.pack $ show matches
+ ]
+ go (RTComponent cname) =
+ let allPairs = concatMap
+ (\(name, lpv) -> map (name,) $ Set.toList $ lpvComponents lpv)
+ (Map.toList locals)
+ in case filter (isCompNamed cname . snd) allPairs of
+ [] -> Left $ "Could not find a component named " `T.append` cname
+ [(name, comp)] ->
+ Right (name, (ri, TTLocalComp comp))
+ matches -> Left $ T.concat
+ [ "Ambiugous component name "
+ , cname
+ , ", matches: "
+ , T.pack $ show matches
+ ]
+
+ go (RTPackage name) =
+ case Map.lookup name locals of
+ Just lpv -> Right (name, (ri, TTLocalAllComps $ lpvComponents lpv))
+ Nothing ->
+ case Map.lookup name extras of
+ Just _ -> Right (name, (ri, TTNonLocal))
+ Nothing ->
+ case Map.lookup name snap of
+ Just _ -> Right (name, (ri, TTNonLocal))
+ Nothing -> Right (name, (ri, TTUnknown))
+
+isCompNamed :: Text -> NamedComponent -> Bool
+isCompNamed _ CLib = False
+isCompNamed t1 (CExe t2) = t1 == t2
+isCompNamed t1 (CTest t2) = t1 == t2
+isCompNamed t1 (CBench t2) = t1 == t2
+
+simplifyTargets :: Bool -- ^ include tests
+ -> Bool -- ^ include benchmarks
+ -> [(PackageName, (RawInput, TargetType))]
+ -> ([Text], Map PackageName SimpleTarget)
+simplifyTargets includeTests includeBenches =
+ mconcat . map go . Map.toList . Map.fromListWith (++) . fmap (second return)
+ where
+ go :: (PackageName, [(RawInput, TargetType)])
+ -> ([Text], Map PackageName SimpleTarget)
+ go (_, []) = error "Stack.Build.Target.simplifyTargets: the impossible happened"
+ go (name, [(_, tt)]) = ([], Map.singleton name $
+ case tt of
+ TTUnknown -> STUnknown
+ TTNonLocal -> STNonLocal
+ TTLocalComp comp -> STLocal $ Set.singleton comp
+ TTLocalAllComps comps -> STLocal $ Set.filter keepComp comps
+ )
+ go (name, pairs) =
+ case partitionEithers $ map (getLocalComp . snd) pairs of
+ ([], comps) -> ([], Map.singleton name $ STLocal $ Set.fromList comps)
+ _ ->
+ let err = T.pack $ concat
+ [ "Overlapping targets provided for package "
+ , packageNameString name
+ , ": "
+ , show $ map (unRawInput . fst) pairs
+ ]
+ in ([err], Map.empty)
+
+ keepComp CLib = True
+ keepComp (CExe _) = True
+ keepComp (CTest _) = includeTests
+ keepComp (CBench _) = includeBenches
+
+ getLocalComp (TTLocalComp comp) = Right comp
+ getLocalComp _ = Left ()
+
+parseTargets :: (MonadThrow m, MonadIO m)
+ => Bool -- ^ using implicit global?
+ -> Bool -- ^ include tests
+ -> Bool -- ^ include benchmarks
+ -> Map PackageName Version -- ^ snapshot
+ -> Map PackageName Version -- ^ extra deps
+ -> Map PackageName LocalPackageView
+ -> Path Abs Dir -- ^ current directory
+ -> [Text] -- ^ command line targets
+ -> m (Map PackageName Version, Map PackageName SimpleTarget)
+parseTargets implicitGlobal includeTests includeBenches snap extras locals currDir textTargets' = do
+ let textTargets =
+ if null textTargets'
+ then map (T.pack . packageNameString) $ Map.keys $ Map.filter (not . lpvExtraDep) locals
+ else textTargets'
+ erawTargets <- mapM (parseRawTargetDirs currDir locals) textTargets
+
+ let (errs1, rawTargets) = partitionEithers erawTargets
+ (errs2, unzip -> (rawTargets', newExtras)) = partitionEithers $
+ map (resolveIdents snap extras locals) $ concat rawTargets
+ (errs3, targetTypes) = partitionEithers $
+ map (resolveRawTarget snap extras locals) rawTargets'
+ (errs4, targets) = simplifyTargets includeTests includeBenches targetTypes
+ errs = concat [errs1, errs2, errs3, errs4]
+
+ if null errs
+ then if Map.null targets
+ then throwM $ TargetParseException
+ $ if implicitGlobal
+ then ["The specified targets matched no packages.\nPerhaps you need to run 'stack init'?"]
+ else ["The specified targets matched no packages"]
+ else return (Map.unions newExtras, targets)
+ else throwM $ TargetParseException errs
diff --git a/src/Stack/Build/Types.hs b/src/Stack/Build/Types.hs
deleted file mode 100644
--- a/src/Stack/Build/Types.hs
+++ /dev/null
@@ -1,544 +0,0 @@
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE ViewPatterns #-}
-
--- | All data types.
-
-module Stack.Build.Types
- (StackBuildException(..)
- ,InstallLocation(..)
- ,ModTime
- ,modTime
- ,Installed(..)
- ,PackageInstallInfo(..)
- ,Task(..)
- ,LocalPackage(..)
- ,BaseConfigOpts(..)
- ,Plan(..)
- ,FinalAction(..)
- ,BuildOpts(..)
- ,defaultBuildOpts
- ,TaskType(..)
- ,TaskConfigOpts(..)
- ,ConfigCache(..)
- ,ConstructPlanException(..)
- ,configureOpts
- ,BadDependency(..)
- ,wantedLocalPackages
- ,FileCacheInfo (..))
- where
-
-import Control.DeepSeq
-import Control.Exception
-
-import Data.Binary (Binary(..))
-import qualified Data.ByteString as S
-import Data.Char (isSpace)
-import Data.Data
-import Data.Hashable
-import Data.List (dropWhileEnd, nub, intercalate)
-import qualified Data.Map as Map
-import Data.Map.Strict (Map)
-import Data.Maybe
-import Data.Monoid
-import Data.Set (Set)
-import qualified Data.Set as Set
-import Data.Text (Text)
-import qualified Data.Text as T
-import Data.Text.Encoding (decodeUtf8With)
-import Data.Text.Encoding.Error (lenientDecode)
-import Data.Time.Calendar
-import Data.Time.Clock
-import Data.Word (Word64)
-import Distribution.System (Arch)
-import Distribution.Text (display)
-import GHC.Generics
-import Path (Path, Abs, File, Dir, mkRelDir, toFilePath, parseRelDir, ())
-import Prelude
-import Stack.Package
-import Stack.Types
-import System.Exit (ExitCode)
-import System.FilePath (dropTrailingPathSeparator, pathSeparator)
-
-----------------------------------------------
--- Exceptions
-data StackBuildException
- = Couldn'tFindPkgId PackageName
- | GHCVersionMismatch (Maybe (Version, Arch)) (Version, Arch) (Maybe (Path Abs File))
- -- ^ Path to the stack.yaml file
- | Couldn'tParseTargets [Text]
- | UnknownTargets
- (Set PackageName) -- no known version
- (Map PackageName Version) -- not in snapshot, here's the most recent version in the index
- (Path Abs File) -- stack.yaml
- | TestSuiteFailure PackageIdentifier (Map Text (Maybe ExitCode)) (Maybe (Path Abs File)) S.ByteString
- | ConstructPlanExceptions
- [ConstructPlanException]
- (Path Abs File) -- stack.yaml
- | CabalExitedUnsuccessfully
- ExitCode
- PackageIdentifier
- (Path Abs File) -- cabal Executable
- [String] -- cabal arguments
- (Maybe (Path Abs File)) -- logfiles location
- S.ByteString -- log contents
- | ExecutionFailure [SomeException]
- deriving Typeable
-
-instance Show StackBuildException where
- show (Couldn'tFindPkgId name) =
- ("After installing " <> packageNameString name <>
- ", the package id couldn't be found " <> "(via ghc-pkg describe " <>
- packageNameString name <> "). This shouldn't happen, " <>
- "please report as a bug")
- show (GHCVersionMismatch mactual (expected, earch) mstack) = concat
- [ case mactual of
- Nothing -> "No GHC found, expected version "
- Just (actual, arch) -> concat
- [ "GHC version mismatched, found "
- , versionString actual
- , " ("
- , display arch
- , ")"
- , ", but expected version "
- ]
- , versionString expected
- , " ("
- , display earch
- , ") (based on "
- , case mstack of
- Nothing -> "command line arguments"
- Just stack -> "resolver setting in " ++ toFilePath stack
- , "). Try running stack setup"
- ]
- show (Couldn'tParseTargets targets) = unlines
- $ "The following targets could not be parsed as package names or directories:"
- : map T.unpack targets
- show (UnknownTargets noKnown notInSnapshot stackYaml) =
- unlines $ noKnown' ++ notInSnapshot'
- where
- noKnown'
- | Set.null noKnown = []
- | otherwise = return $
- "The following target packages were not found: " ++
- intercalate ", " (map packageNameString $ Set.toList noKnown)
- notInSnapshot'
- | Map.null notInSnapshot = []
- | otherwise =
- "The following packages are not in your snapshot, but exist"
- : "in your package index. Recommended action: add them to your"
- : ("extra-deps in " ++ toFilePath stackYaml)
- : "(Note: these are the most recent versions,"
- : "but there's no guarantee that they'll build together)."
- : ""
- : map
- (\(name, version) -> "- " ++ packageIdentifierString
- (PackageIdentifier name version))
- (Map.toList notInSnapshot)
- show (TestSuiteFailure ident codes mlogFile bs) = unlines $ concat
- [ ["Test suite failure for package " ++ packageIdentifierString ident]
- , flip map (Map.toList codes) $ \(name, mcode) -> concat
- [ " "
- , T.unpack name
- , ": "
- , case mcode of
- Nothing -> " executable not found"
- Just ec -> " exited with: " ++ show ec
- ]
- , return $ case mlogFile of
- Nothing -> "Logs printed to console"
- -- TODO Should we load up the full error output and print it here?
- Just logFile -> "Full log available at " ++ toFilePath logFile
- , if S.null bs
- then []
- else ["", "", doubleIndent $ T.unpack $ decodeUtf8With lenientDecode bs]
- ]
- where
- indent = dropWhileEnd isSpace . unlines . fmap (\line -> " " ++ line) . lines
- doubleIndent = indent . indent
- show (ConstructPlanExceptions exceptions stackYaml) =
- "While constructing the BuildPlan the following exceptions were encountered:" ++
- appendExceptions exceptions' ++
- if Map.null extras then "" else (unlines
- $ ("\n\nRecommended action: try adding the following to your extra-deps in "
- ++ toFilePath stackYaml)
- : map (\(name, version) -> concat
- [ "- "
- , packageNameString name
- , "-"
- , versionString version
- ]) (Map.toList extras)
- ++ ["", "You may also want to try the 'stack solver' command"]
- )
- where
- exceptions' = removeDuplicates exceptions
- appendExceptions = foldr (\e -> (++) ("\n\n--" ++ show e)) ""
- removeDuplicates = nub
- extras = Map.unions $ map getExtras exceptions'
-
- getExtras (DependencyCycleDetected _) = Map.empty
- getExtras (UnknownPackage _) = Map.empty
- getExtras (DependencyPlanFailures _ m) =
- Map.unions $ map go $ Map.toList m
- where
- go (name, (_range, Just version, NotInBuildPlan)) =
- Map.singleton name version
- go _ = Map.empty
- -- Supressing duplicate output
- show (CabalExitedUnsuccessfully exitCode taskProvides' execName fullArgs logFiles bs) =
- let fullCmd = (dropQuotes (show execName) ++ " " ++ (unwords fullArgs))
- logLocations = maybe "" (\fp -> "\n Logs have been written to: " ++ show fp) logFiles
- in "\n-- While building package " ++ dropQuotes (show taskProvides') ++ " using:\n" ++
- " " ++ fullCmd ++ "\n" ++
- " Process exited with code: " ++ show exitCode ++
- logLocations ++
- (if S.null bs
- then ""
- else "\n\n" ++ doubleIndent (T.unpack $ decodeUtf8With lenientDecode bs))
- where
- -- appendLines = foldr (\pName-> (++) ("\n" ++ show pName)) ""
- indent = dropWhileEnd isSpace . unlines . fmap (\line -> " " ++ line) . lines
- dropQuotes = filter ('\"' /=)
- doubleIndent = indent . indent
- show (ExecutionFailure es) = intercalate "\n\n" $ map show es
-
-instance Exception StackBuildException
-
-data ConstructPlanException
- = DependencyCycleDetected [PackageName]
- | DependencyPlanFailures PackageIdentifier (Map PackageName (VersionRange, LatestVersion, BadDependency))
- | UnknownPackage PackageName -- TODO perhaps this constructor will be removed, and BadDependency will handle it all
- -- ^ Recommend adding to extra-deps, give a helpful version number?
- deriving (Typeable, Eq)
-
--- | For display purposes only, Nothing if package not found
-type LatestVersion = Maybe Version
-
--- | Reason why a dependency was not used
-data BadDependency
- = NotInBuildPlan
- | Couldn'tResolveItsDependencies
- | DependencyMismatch Version
- deriving (Typeable, Eq)
-
-instance Show ConstructPlanException where
- show e =
- let details = case e of
- (DependencyCycleDetected pNames) ->
- "While checking call stack,\n" ++
- " dependency cycle detected in packages:" ++ indent (appendLines pNames)
- (DependencyPlanFailures pIdent (Map.toList -> pDeps)) ->
- "Failure when adding dependencies:" ++ doubleIndent (appendDeps pDeps) ++ "\n" ++
- " needed for package: " ++ packageIdentifierString pIdent
- (UnknownPackage pName) ->
- "While attempting to add dependency,\n" ++
- " Could not find package " ++ show pName ++ " in known packages"
- in indent details
- where
- appendLines = foldr (\pName-> (++) ("\n" ++ show pName)) ""
- indent = dropWhileEnd isSpace . unlines . fmap (\line -> " " ++ line) . lines
- doubleIndent = indent . indent
- appendDeps = foldr (\dep-> (++) ("\n" ++ showDep dep)) ""
- showDep (name, (range, mlatest, badDep)) = concat
- [ show name
- , ": needed ("
- , display range
- , ")"
- , case mlatest of
- Nothing -> ""
- Just latest -> ", latest is " ++ versionString latest
- , ", but "
- , case badDep of
- NotInBuildPlan -> "not present in build plan"
- Couldn'tResolveItsDependencies -> "couldn't resolve its dependencies"
- DependencyMismatch version -> versionString version ++ " found"
- ]
- {- TODO Perhaps change the showDep function to look more like this:
- dropQuotes = filter ((/=) '\"')
- (VersionOutsideRange pName pIdentifier versionRange) ->
- "Exception: Stack.Build.VersionOutsideRange\n" ++
- " While adding dependency for package " ++ show pName ++ ",\n" ++
- " " ++ dropQuotes (show pIdentifier) ++ " was found to be outside its allowed version range.\n" ++
- " Allowed version range is " ++ display versionRange ++ ",\n" ++
- " should you correct the version range for " ++ dropQuotes (show pIdentifier) ++ ", found in [extra-deps] in the project's stack.yaml?"
- -}
-
-
-----------------------------------------------
-
--- | Configuration for building.
-data BuildOpts =
- BuildOpts {boptsTargets :: ![Text]
- ,boptsLibProfile :: !Bool
- ,boptsExeProfile :: !Bool
- ,boptsEnableOptimizations :: !(Maybe Bool)
- ,boptsHaddock :: !Bool
- -- ^ Build haddocks?
- ,boptsHaddockDeps :: !(Maybe Bool)
- -- ^ Build haddocks for dependencies?
- ,boptsFinalAction :: !FinalAction
- ,boptsDryrun :: !Bool
- ,boptsGhcOptions :: ![Text]
- ,boptsFlags :: !(Map (Maybe PackageName) (Map FlagName Bool))
- ,boptsInstallExes :: !Bool
- -- ^ Install executables to user path after building?
- ,boptsPreFetch :: !Bool
- -- ^ Fetch all packages immediately
- ,boptsTestArgs :: ![String]
- -- ^ Arguments to pass to the test suites if we're running them.
- ,boptsOnlySnapshot :: !Bool
- -- ^ Only install packages in the snapshot database, skipping
- -- packages intended for the local database.
- ,boptsCoverage :: !Bool
- -- ^ Enable code coverage report generation for test
- -- suites.
- ,boptsFileWatch :: !Bool
- -- ^ Watch files for changes and automatically rebuild
- ,boptsKeepGoing :: !(Maybe Bool)
- -- ^ Keep building/running after failure
- }
- deriving (Show)
-
-defaultBuildOpts :: BuildOpts
-defaultBuildOpts = BuildOpts
- { boptsTargets = []
- , boptsLibProfile = False
- , boptsExeProfile = False
- , boptsEnableOptimizations = Nothing
- , boptsHaddock = False
- , boptsHaddockDeps = Nothing
- , boptsFinalAction = DoNothing
- , boptsDryrun = False
- , boptsGhcOptions = []
- , boptsFlags = Map.empty
- , boptsInstallExes = False
- , boptsPreFetch = False
- , boptsTestArgs = []
- , boptsOnlySnapshot = False
- , boptsCoverage = False
- , boptsFileWatch = False
- , boptsKeepGoing = Nothing
- }
-
--- | Run a Setup.hs action after building a package, before installing.
-data FinalAction
- = DoTests
- Bool -- rerun tests which already passed?
- | DoBenchmarks
- | DoNothing
- deriving (Eq,Show)
-
--- | Package dependency oracle.
-newtype PkgDepsOracle =
- PkgDeps PackageName
- deriving (Show,Typeable,Eq,Hashable,Binary,NFData)
-
--- | A location to install a package into, either snapshot or local
-data InstallLocation = Snap | Local
- deriving (Show, Eq)
-instance Monoid InstallLocation where
- mempty = Snap
- mappend Local _ = Local
- mappend _ Local = Local
- mappend Snap Snap = Snap
-
--- | Datatype which tells how which version of a package to install and where
--- to install it into
-class PackageInstallInfo a where
- piiVersion :: a -> Version
- piiLocation :: a -> InstallLocation
-
--- | Information on a locally available package of source code
-data LocalPackage = LocalPackage
- { lpPackage :: !Package -- ^ The @Package@ info itself, after resolution with package flags, not including any final actions
- , lpPackageFinal :: !Package -- ^ Same as lpPackage, but with any test suites or benchmarks enabled as necessary
- , lpWanted :: !Bool -- ^ Is this package a \"wanted\" target based on command line input
- , lpDir :: !(Path Abs Dir) -- ^ Directory of the package.
- , lpCabalFile :: !(Path Abs File) -- ^ The .cabal file
- , lpDirtyFiles :: !Bool -- ^ are there files that have changed since the last build?
- , lpNewBuildCache :: !(Map FilePath FileCacheInfo) -- ^ current state of the files
- , lpFiles :: !(Set (Path Abs File)) -- ^ all files used by this package
- , lpComponents :: !(Set Text) -- ^ components to build, passed directly to Setup.hs build
- }
- deriving Show
-
--- | Stored on disk to know whether the flags have changed or any
--- files have changed.
-data ConfigCache = ConfigCache
- { configCacheOpts :: ![S.ByteString]
- -- ^ All options used for this package.
- , configCacheDeps :: !(Set GhcPkgId)
- -- ^ The GhcPkgIds of all of the dependencies. Since Cabal doesn't take
- -- the complete GhcPkgId (only a PackageIdentifier) in the configure
- -- options, just using the previous value is insufficient to know if
- -- dependencies have changed.
- , configCacheComponents :: !(Set S.ByteString)
- -- ^ The components to be built. It's a bit of a hack to include this in
- -- here, as it's not a configure option (just a build option), but this
- -- is a convenient way to force compilation when the components change.
- , configCacheHaddock :: !Bool
- -- ^ Are haddocks to be built?
- }
- deriving (Generic,Eq,Show)
-instance Binary ConfigCache
-
--- | A task to perform when building
-data Task = Task
- { taskProvides :: !PackageIdentifier -- ^ the package/version to be built
- , taskType :: !TaskType -- ^ the task type, telling us how to build this
- , taskConfigOpts :: !TaskConfigOpts
- , taskPresent :: !(Set GhcPkgId) -- ^ GhcPkgIds of already-installed dependencies
- }
- deriving Show
-
--- | Given the IDs of any missing packages, produce the configure options
-data TaskConfigOpts = TaskConfigOpts
- { tcoMissing :: !(Set PackageIdentifier)
- -- ^ Dependencies for which we don't yet have an GhcPkgId
- , tcoOpts :: !(Set GhcPkgId -> [Text])
- -- ^ Produce the list of options given the missing @GhcPkgId@s
- }
-instance Show TaskConfigOpts where
- show (TaskConfigOpts missing f) = concat
- [ "Missing: "
- , show missing
- , ". Without those: "
- , show $ f Set.empty
- ]
-
--- | The type of a task, either building local code or something from the
--- package index (upstream)
-data TaskType = TTLocal LocalPackage
- | TTUpstream Package InstallLocation
- deriving Show
-
--- | A complete plan of what needs to be built and how to do it
-data Plan = Plan
- { planTasks :: !(Map PackageName Task)
- , planFinals :: !(Map PackageName Task)
- -- ^ Final actions to be taken (test, benchmark, etc)
- , planUnregisterLocal :: !(Map GhcPkgId Text)
- -- ^ Text is reason we're unregistering, for display only
- , planInstallExes :: !(Map Text InstallLocation)
- -- ^ Executables that should be installed after successful building
- }
- deriving Show
-
--- | Basic information used to calculate what the configure options are
-data BaseConfigOpts = BaseConfigOpts
- { bcoSnapDB :: !(Path Abs Dir)
- , bcoLocalDB :: !(Path Abs Dir)
- , bcoSnapInstallRoot :: !(Path Abs Dir)
- , bcoLocalInstallRoot :: !(Path Abs Dir)
- , bcoBuildOpts :: !BuildOpts
- }
-
--- | Render a @BaseConfigOpts@ to an actual list of options
-configureOpts :: EnvConfig
- -> BaseConfigOpts
- -> Set GhcPkgId -- ^ dependencies
- -> Bool -- ^ wanted?
- -> InstallLocation
- -> Package
- -> [Text]
-configureOpts econfig bco deps wanted loc package = map T.pack $ concat
- [ ["--user", "--package-db=clear", "--package-db=global"]
- , map (("--package-db=" ++) . toFilePath) $ case loc of
- Snap -> [bcoSnapDB bco]
- Local -> [bcoSnapDB bco, bcoLocalDB bco]
- , depOptions
- , [ "--libdir=" ++ toFilePathNoTrailingSlash (installRoot $(mkRelDir "lib"))
- , "--bindir=" ++ toFilePathNoTrailingSlash (installRoot bindirSuffix)
- , "--datadir=" ++ toFilePathNoTrailingSlash (installRoot $(mkRelDir "share"))
- , "--docdir=" ++ toFilePathNoTrailingSlash docDir
- , "--htmldir=" ++ toFilePathNoTrailingSlash docDir
- , "--haddockdir=" ++ toFilePathNoTrailingSlash docDir]
- , ["--enable-library-profiling" | boptsLibProfile bopts || boptsExeProfile bopts]
- , ["--enable-executable-profiling" | boptsExeProfile bopts]
- , map (\(name,enabled) ->
- "-f" <>
- (if enabled
- then ""
- else "-") <>
- flagNameString name)
- (Map.toList (packageFlags package))
- -- FIXME Chris: where does this come from now? , ["--ghc-options=-O2" | gconfigOptimize gconfig]
- , if wanted
- then concatMap (\x -> ["--ghc-options", T.unpack x]) (boptsGhcOptions bopts)
- else []
- , map (("--extra-include-dirs=" ++) . T.unpack) (Set.toList (configExtraIncludeDirs config))
- , map (("--extra-lib-dirs=" ++) . T.unpack) (Set.toList (configExtraLibDirs config))
- ]
- where
- config = getConfig econfig
- bopts = bcoBuildOpts bco
- toFilePathNoTrailingSlash = dropTrailingPathSeparator . toFilePath
- docDir =
- case pkgVerDir of
- Nothing -> installRoot docdirSuffix
- Just dir -> installRoot docdirSuffix dir
- installRoot =
- case loc of
- Snap -> bcoSnapInstallRoot bco
- Local -> bcoLocalInstallRoot bco
- pkgVerDir =
- parseRelDir (packageIdentifierString (PackageIdentifier (packageName package)
- (packageVersion package)) ++
- [pathSeparator])
-
- depOptions = map toDepOption $ Set.toList deps
- where
- toDepOption =
- if envConfigCabalVersion econfig >= $(mkVersion "1.22")
- then toDepOption1_22
- else toDepOption1_18
-
- toDepOption1_22 gid = concat
- [ "--dependency="
- , packageNameString $ packageIdentifierName $ ghcPkgIdPackageIdentifier gid
- , "="
- , ghcPkgIdString gid
- ]
-
- toDepOption1_18 gid = concat
- [ "--constraint="
- , packageNameString name
- , "=="
- , versionString version
- ]
- where
- PackageIdentifier name version = ghcPkgIdPackageIdentifier gid
-
--- | Get set of wanted package names from locals.
-wantedLocalPackages :: [LocalPackage] -> Set PackageName
-wantedLocalPackages = Set.fromList . map (packageName . lpPackage) . filter lpWanted
-
--- | Used for storage and comparison.
-newtype ModTime = ModTime (Integer,Rational)
- deriving (Ord,Show,Generic,Eq)
-instance Binary ModTime
-
--- | One-way conversion to serialized time.
-modTime :: UTCTime -> ModTime
-modTime x =
- ModTime
- ( toModifiedJulianDay
- (utctDay x)
- , toRational
- (utctDayTime x))
-
-data Installed = Library GhcPkgId | Executable PackageIdentifier
- deriving (Show, Eq, Ord)
-
-data FileCacheInfo = FileCacheInfo
- { fciModTime :: !ModTime
- , fciSize :: !Word64
- , fciHash :: !S.ByteString
- }
- deriving (Generic, Show)
-instance Binary FileCacheInfo
diff --git a/src/Stack/BuildPlan.hs b/src/Stack/BuildPlan.hs
--- a/src/Stack/BuildPlan.hs
+++ b/src/Stack/BuildPlan.hs
@@ -22,6 +22,7 @@
, ToolMap
, getToolMap
, shadowMiniBuildPlan
+ , parseCustomMiniBuildPlan
) where
import Control.Applicative
@@ -34,9 +35,12 @@
import Control.Monad.State.Strict (State, execState, get, modify,
put)
import Control.Monad.Trans.Control (MonadBaseControl)
-import Data.Aeson.Extended (FromJSON (..), withObject, withText, (.:))
+import qualified Crypto.Hash.SHA256 as SHA256
+import Data.Aeson.Extended (FromJSON (..), withObject, withText, (.:), (.:?), (.!=))
import Data.Binary.VersionTagged (taggedDecodeOrLoad)
import Data.ByteString (ByteString)
+import qualified Data.ByteString.Base16 as B16
+import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import Data.Either (partitionEithers)
import qualified Data.Foldable as F
@@ -46,15 +50,16 @@
import Data.List (intercalate)
import Data.Map (Map)
import qualified Data.Map as Map
-import Data.Maybe (mapMaybe)
+import Data.Maybe (fromMaybe, mapMaybe)
import Data.Monoid ((<>), Monoid (..))
import Data.Set (Set)
import qualified Data.Set as Set
import qualified Data.Text as T
+import Data.Text.Encoding (encodeUtf8)
import Data.Time (Day)
import qualified Data.Traversable as Tr
import Data.Typeable (Typeable)
-import Data.Yaml (decodeFileEither)
+import Data.Yaml (decodeEither', decodeFileEither)
import Distribution.PackageDescription (GenericPackageDescription,
flagDefault, flagManual,
flagName, genPackageFlags,
@@ -67,6 +72,7 @@
import Network.HTTP.Types (Status(..))
import Network.HTTP.Client (checkStatus)
import Path
+import Path.IO
import Prelude -- Fix AMP warning
import Stack.Constants
import Stack.Fetch
@@ -75,8 +81,8 @@
import Stack.PackageIndex
import Stack.Types
import Stack.Types.StackT
-import System.Directory (createDirectoryIfMissing)
-import System.FilePath (takeDirectory)
+import System.Directory (canonicalizePath)
+import qualified System.FilePath as FP
data BuildPlanException
= UnknownPackages
@@ -202,8 +208,11 @@
}
toMiniBuildPlan :: (MonadIO m, MonadLogger m, MonadReader env m, HasHttpManager env, MonadThrow m, HasConfig env, MonadBaseControl IO m, MonadCatch m)
- => BuildPlan -> m MiniBuildPlan
-toMiniBuildPlan bp = do
+ => Version -- ^ GHC version
+ -> Map PackageName Version -- ^ cores
+ -> Map PackageName (Version, Map FlagName Bool) -- ^ non-core packages
+ -> m MiniBuildPlan
+toMiniBuildPlan ghcVersion corePackages packages = do
$logInfo "Caching build plan"
-- Determine the dependencies of all of the packages in the build plan. We
@@ -212,9 +221,9 @@
-- remove those from the list of dependencies, since there's no way we'll
-- ever reinstall them anyway.
(cores, missingCores) <- addDeps True ghcVersion
- $ fmap (, Map.empty) (siCorePackages $ bpSystemInfo bp)
+ $ fmap (, Map.empty) corePackages
- (extras, missing) <- addDeps False ghcVersion $ fmap goPP $ bpPackages bp
+ (extras, missing) <- addDeps False ghcVersion packages
assert (Set.null missing) $ return MiniBuildPlan
{ mbpGhcVersion = ghcVersion
@@ -225,7 +234,6 @@
]
}
where
- ghcVersion = siGhcVersion $ bpSystemInfo bp
goCore (PackageIdentifier name version) = (name, MiniPackageInfo
{ mpiVersion = version
, mpiFlags = Map.empty
@@ -235,11 +243,6 @@
, mpiHasLibrary = True
})
- goPP pp =
- ( ppVersion pp
- , pcFlagOverrides $ ppConstraints pp
- )
-
removeMissingDeps cores mpi = mpi
{ mpiPackageDeps = Set.intersection cores (mpiPackageDeps mpi)
}
@@ -432,8 +435,17 @@
loadMiniBuildPlan name = do
path <- configMiniBuildPlanCache name
let fp = toFilePath path
- taggedDecodeOrLoad fp $ liftM buildPlanFixes $
- loadBuildPlan name >>= toMiniBuildPlan
+ taggedDecodeOrLoad fp $ liftM buildPlanFixes $ do
+ bp <- loadBuildPlan name
+ toMiniBuildPlan
+ (siGhcVersion $ bpSystemInfo bp)
+ (siCorePackages $ bpSystemInfo bp)
+ (fmap goPP $ bpPackages bp)
+ where
+ goPP pp =
+ ( ppVersion pp
+ , pcFlagOverrides $ ppConstraints pp
+ )
-- | Some hard-coded fixes for build plans, hopefully to be irrelevant over
-- time.
@@ -467,7 +479,7 @@
Right bp -> return bp
Left e -> do
$logDebug $ "Decoding build plan from file failed: " <> T.pack (show e)
- liftIO $ createDirectoryIfMissing True $ takeDirectory $ toFilePath fp
+ createTree (parent fp)
req <- parseUrl $ T.unpack url
$logSticky $ "Downloading " <> renderSnapName name <> " build plan ..."
$logDebug $ "Downloading build plan from: " <> url
@@ -522,7 +534,11 @@
flagName' = fromCabalFlagName . flagName
- flagOptions = map Map.fromList $ mapM getOptions $ genPackageFlags gpd
+ -- Avoid exponential complexity in flag combinations making us sad pandas.
+ -- See: https://github.com/commercialhaskell/stack/issues/543
+ maxFlagOptions = 128
+
+ flagOptions = take maxFlagOptions $ map Map.fromList $ mapM getOptions $ genPackageFlags gpd
getOptions f
| flagManual f = [(flagName' f, flagDefault f)]
| flagDefault f =
@@ -664,3 +680,62 @@
Just True -> Left
Just False -> Right
Nothing -> assert False Right
+
+parseCustomMiniBuildPlan :: (MonadIO m, MonadCatch m, MonadLogger m, MonadReader env m, HasHttpManager env, HasConfig env, MonadBaseControl IO m)
+ => Path Abs File -- ^ stack.yaml file location
+ -> T.Text -> m MiniBuildPlan
+parseCustomMiniBuildPlan stackYamlFP url0 = do
+ yamlFP <- getYamlFP url0
+
+ yamlBS <- liftIO $ S.readFile $ toFilePath yamlFP
+ let yamlHash = S8.unpack $ B16.encode $ SHA256.hash yamlBS
+ binaryFilename <- parseRelFile $ yamlHash ++ ".bin"
+ customPlanDir <- getCustomPlanDir
+ let binaryFP = customPlanDir $(mkRelDir "bin") binaryFilename
+
+ taggedDecodeOrLoad (toFilePath binaryFP) $ do
+ cs <- either throwM return $ decodeEither' yamlBS
+ let addFlags :: PackageIdentifier -> (PackageName, (Version, Map FlagName Bool))
+ addFlags (PackageIdentifier name ver) =
+ (name, (ver, fromMaybe Map.empty $ Map.lookup name $ csFlags cs))
+ toMiniBuildPlan
+ (csGhcVersion cs)
+ Map.empty
+ (Map.fromList $ map addFlags $ Set.toList $ csPackages cs)
+ where
+ getCustomPlanDir = do
+ root <- asks $ configStackRoot . getConfig
+ return $ root $(mkRelDir "custom-plan")
+
+ -- Get the path to the YAML file
+ getYamlFP url =
+ case parseUrl $ T.unpack url of
+ Just req -> getYamlFPFromReq url req
+ Nothing -> getYamlFPFromFile url
+
+ getYamlFPFromReq url req = do
+ let hashStr = S8.unpack $ B16.encode $ SHA256.hash $ encodeUtf8 url
+ hashFP <- parseRelFile $ hashStr ++ ".yaml"
+ customPlanDir <- getCustomPlanDir
+
+ let cacheFP = customPlanDir $(mkRelDir "yaml") hashFP
+ _ <- download req cacheFP
+ return cacheFP
+
+ getYamlFPFromFile url = do
+ fp <- liftIO $ canonicalizePath $ toFilePath (parent stackYamlFP) FP. T.unpack (fromMaybe url $
+ T.stripPrefix "file://" url <|> T.stripPrefix "file:" url)
+ parseAbsFile fp
+
+data CustomSnapshot = CustomSnapshot
+ { csGhcVersion :: !Version
+ , csPackages :: !(Set PackageIdentifier)
+ , csFlags :: !(Map PackageName (Map FlagName Bool))
+ }
+instance FromJSON CustomSnapshot where
+ parseJSON = withObject "CustomSnapshot" $ \o -> CustomSnapshot
+ <$> ((o .: "compiler") >>= (\t -> maybe (fail $ "Invalid compiler: " ++ T.unpack t) return $ do
+ t' <- T.stripPrefix "ghc-" t
+ parseVersionFromString $ T.unpack t'))
+ <*> o .: "packages"
+ <*> o .:? "flags" .!= Map.empty
diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs
--- a/src/Stack/Config.hs
+++ b/src/Stack/Config.hs
@@ -21,19 +21,20 @@
-- probably default to behaving like cabal, possibly with spitting out
-- a warning that "you should run `stk init` to make things better".
module Stack.Config
- ( configOptsParser
- , loadConfig
+ (loadConfig
+ ,packagesParser
+ ,resolvePackageEntry
) where
import qualified Codec.Archive.Tar as Tar
import qualified Codec.Compression.GZip as GZip
import Control.Applicative
-import Control.Concurrent (getNumCapabilities)
+import Control.Exception (IOException)
import Control.Monad
-import Control.Monad.Catch
+import Control.Monad.Catch (Handler(..), MonadCatch, MonadThrow, catches, throwM)
import Control.Monad.IO.Class
import Control.Monad.Logger hiding (Loc)
-import Control.Monad.Reader (MonadReader, ask, runReaderT)
+import Control.Monad.Reader (MonadReader, ask, asks, runReaderT)
import Control.Monad.Trans.Control (MonadBaseControl)
import qualified Crypto.Hash.SHA256 as SHA256
import Data.Aeson.Extended
@@ -43,27 +44,27 @@
import qualified Data.Map as Map
import Data.Maybe
import Data.Monoid
-import qualified Data.Set as S
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
import qualified Data.Yaml as Yaml
import Distribution.System (OS (..), Platform (..), buildPlatform)
import qualified Distribution.Text
import Distribution.Version (simplifyVersionRange)
+import GHC.Conc (getNumProcessors)
import Network.HTTP.Client.Conduit (HasHttpManager, getHttpManager, Manager, parseUrl)
import Network.HTTP.Download (download)
-import Options.Applicative (Parser, idm, strOption, long, short, metavar, help, option, auto)
-import Options.Applicative.Builder.Extra (maybeBoolFlags)
+import Options.Applicative (Parser, strOption, long, help)
import Path
import Path.IO
import qualified Paths_stack as Meta
import Stack.BuildPlan
import Stack.Constants
import qualified Stack.Docker as Docker
+import qualified Stack.Image as Image
import Stack.Init
import Stack.Types
import Stack.Types.Internal
-import System.Directory
+import System.Directory (getAppUserDataDirectory, createDirectoryIfMissing, canonicalizePath)
import System.Environment
import System.IO
import System.Process.Read (getEnvOverride, EnvOverride, unEnvOverride, readInNull)
@@ -134,6 +135,8 @@
configConfigMonoid = configMonoid
+ configImage = Image.imgOptsFromMonoid configMonoidImageOpts
+
origEnv <- getEnvOverride configPlatform
let configEnvOverride _ = return origEnv
@@ -146,76 +149,28 @@
return $ progsDir $(mkRelDir stackProgName) platform
_ -> return $ configStackRoot $(mkRelDir "programs") platform
- configLocalBin <- do
- localDir <- liftIO (getAppUserDataDirectory "local") >>= parseAbsDir
- return $ localDir $(mkRelDir "bin")
-
+ configLocalBin <-
+ case configMonoidLocalBinPath of
+ Nothing -> do
+ localDir <- liftIO (getAppUserDataDirectory "local") >>= parseAbsDir
+ return $ localDir $(mkRelDir "bin")
+ Just userPath ->
+ (liftIO $ canonicalizePath userPath >>= parseAbsDir)
+ `catches`
+ [Handler (\(_ :: IOException) -> throwM $ NoSuchDirectory userPath)
+ ,Handler (\(_ :: PathParseException) -> throwM $ NoSuchDirectory userPath)
+ ]
configJobs <-
case configMonoidJobs of
- Nothing -> liftIO getNumCapabilities
+ Nothing -> liftIO getNumProcessors
Just i -> return i
let configConcurrentTests = fromMaybe True configMonoidConcurrentTests
- return Config {..}
+ let configAuthorEmail = configMonoidAuthorEmail
+ configAuthorName = configMonoidAuthorName
+ configScmInit = configMonoidScmInit
--- | Command-line arguments parser for configuration.
-configOptsParser :: Bool -> Parser ConfigMonoid
-configOptsParser docker =
- (\opts systemGHC installGHC arch os jobs includes libs skipGHCCheck skipMsys -> mempty
- { configMonoidDockerOpts = opts
- , configMonoidSystemGHC = systemGHC
- , configMonoidInstallGHC = installGHC
- , configMonoidSkipGHCCheck = skipGHCCheck
- , configMonoidArch = arch
- , configMonoidOS = os
- , configMonoidJobs = jobs
- , configMonoidExtraIncludeDirs = includes
- , configMonoidExtraLibDirs = libs
- , configMonoidSkipMsys = skipMsys
- })
- <$> Docker.dockerOptsParser docker
- <*> maybeBoolFlags
- "system-ghc"
- "using the system installed GHC (on the PATH) if available and a matching version"
- idm
- <*> maybeBoolFlags
- "install-ghc"
- "downloading and installing GHC if necessary (can be done manually with stack setup)"
- idm
- <*> optional (strOption
- ( long "arch"
- <> metavar "ARCH"
- <> help "System architecture, e.g. i386, x86_64"
- ))
- <*> optional (strOption
- ( long "os"
- <> metavar "OS"
- <> help "Operating system, e.g. linux, windows"
- ))
- <*> optional (option auto
- ( long "jobs"
- <> short 'j'
- <> metavar "JOBS"
- <> help "Number of concurrent jobs to run"
- ))
- <*> fmap (S.fromList . map T.pack) (many $ strOption
- ( long "extra-include-dirs"
- <> metavar "DIR"
- <> help "Extra directories to check for C header files"
- ))
- <*> fmap (S.fromList . map T.pack) (many $ strOption
- ( long "extra-lib-dirs"
- <> metavar "DIR"
- <> help "Extra directories to check for libraries"
- ))
- <*> maybeBoolFlags
- "skip-ghc-check"
- "skipping the GHC version and architecture check"
- idm
- <*> maybeBoolFlags
- "skip-msys"
- "skipping the local MSYS installation (Windows only)"
- idm
+ return Config {..}
-- | Get the directory on Windows where we should install extra programs. For
-- more information, see discussion at:
@@ -257,41 +212,33 @@
Just (_, _, projectConfig) -> configArgs : projectConfig : extraConfigs
unless (fromCabalVersion Meta.version `withinRange` configRequireStackVersion config)
(throwM (BadStackVersionException (configRequireStackVersion config)))
- menv <- runReaderT getMinimalEnvOverride config
return $ LoadConfig
{ lcConfig = config
- , lcLoadBuildConfig = loadBuildConfig menv mproject config stackRoot
+ , lcLoadBuildConfig = loadBuildConfig mproject config stackRoot
, lcProjectRoot = fmap (\(_, fp, _) -> parent fp) mproject
}
-- | Load the build configuration, adds build-specific values to config loaded by @loadConfig@.
-- values.
loadBuildConfig :: (MonadLogger m, MonadIO m, MonadCatch m, MonadReader env m, HasHttpManager env, MonadBaseControl IO m, HasTerminal env)
- => EnvOverride
- -> Maybe (Project, Path Abs File, ConfigMonoid)
+ => Maybe (Project, Path Abs File, ConfigMonoid)
-> Config
-> Path Abs Dir
- -> Maybe Resolver -- override resolver
- -> NoBuildConfigStrategy
+ -> Maybe AbstractResolver -- override resolver
-> m BuildConfig
-loadBuildConfig menv mproject config stackRoot mresolver noConfigStrat = do
+loadBuildConfig mproject config stackRoot mresolver = do
env <- ask
let miniConfig = MiniConfig (getHttpManager env) config
(project', stackYamlFP) <- case mproject of
Just (project, fp, _) -> return (project, fp)
- Nothing -> case noConfigStrat of
- ThrowException -> do
- currDir <- getWorkingDir
- cabalFiles <- findCabalFiles True currDir
- throwM $ NoProjectConfigFound currDir
- $ Just $ if null cabalFiles then "new" else "init"
- ExecStrategy -> do
+ Nothing -> do
+ $logInfo "Run from outside a project, using implicit global config"
let dest :: Path Abs File
dest = destDir stackDotYaml
destDir = implicitGlobalDir stackRoot
dest' :: FilePath
dest' = toFilePath dest
- liftIO (createDirectoryIfMissing True (toFilePath destDir))
+ createTree destDir
exists <- fileExists dest
if exists
then do
@@ -299,15 +246,22 @@
when (getTerminal env) $
case mresolver of
Nothing ->
- $logInfo ("Using resolver: " <> renderResolver (projectResolver project) <>
+ $logInfo ("Using resolver: " <> resolverName (projectResolver project) <>
" from global config file: " <> T.pack dest')
- Just resolver ->
- $logInfo ("Using resolver: " <> renderResolver resolver <>
+ Just aresolver -> do
+ let name =
+ case aresolver of
+ ARResolver resolver -> resolverName resolver
+ ARLatestNightly -> "nightly"
+ ARLatestLTS -> "lts"
+ ARLatestLTSMajor x -> T.pack $ "lts-" ++ show x
+ ARGlobal -> "global"
+ $logInfo ("Using resolver: " <> name <>
" specified on command line")
return (project, dest)
else do
r <- runReaderT getLatestResolver miniConfig
- $logInfo ("Using latest snapshot resolver: " <> renderResolver r)
+ $logInfo ("Using latest snapshot resolver: " <> resolverName r)
$logInfo ("Writing global (non-project-specific) config file to: " <> T.pack dest')
$logInfo "Note: You can change the snapshot via the resolver field there."
let p = Project
@@ -318,9 +272,15 @@
}
liftIO $ Yaml.encodeFile dest' p
return (p, dest)
- let project = project'
- { projectResolver = fromMaybe (projectResolver project') mresolver
- }
+ resolver <-
+ case mresolver of
+ Nothing -> return $ projectResolver project'
+ Just aresolver -> do
+ manager <- asks getHttpManager
+ runReaderT
+ (makeConcreteResolver aresolver)
+ (MiniConfig manager config)
+ let project = project' { projectResolver = resolver }
ghcVersion <-
case projectResolver project of
@@ -328,20 +288,19 @@
mbp <- runReaderT (loadMiniBuildPlan snapName) miniConfig
return $ mbpGhcVersion mbp
ResolverGhc m -> return $ fromMajorVersion m
-
- let root = parent stackYamlFP
- packages' <- mapM (resolvePackageEntry menv root) (projectPackages project)
- let packages = Map.fromList $ concat packages'
+ ResolverCustom _name url -> do
+ mbp <- runReaderT (parseCustomMiniBuildPlan stackYamlFP url) miniConfig
+ return $ mbpGhcVersion mbp
return BuildConfig
{ bcConfig = config
, bcResolver = projectResolver project
, bcGhcVersionExpected = ghcVersion
- , bcPackages = packages
+ , bcPackageEntries = projectPackages project
, bcExtraDeps = projectExtraDeps project
- , bcRoot = root
, bcStackYaml = stackYamlFP
, bcFlags = projectFlags project
+ , bcImplicitGlobal = isNothing mproject
}
-- | Resolve a PackageEntry into a list of paths, downloading and cloning as
@@ -384,7 +343,7 @@
dir = root dirRel
dirTmp = root dirRelTmp
- exists <- liftIO $ doesDirectoryExist $ toFilePath dir
+ exists <- dirExists dir
unless exists $ do
req <- parseUrl $ T.unpack url
_ <- download req file
@@ -394,7 +353,7 @@
lbs <- L.hGetContents h
let entries = Tar.read $ GZip.decompress lbs
Tar.unpack (toFilePath dirTmp) entries
- renameDirectory (toFilePath dirTmp) (toFilePath dir)
+ renameDir dirTmp dir
x <- listDirectory dir
case x of
@@ -412,10 +371,10 @@
let dir = root dirRel
dirTmp = root dirRelTmp
- exists <- liftIO $ doesDirectoryExist $ toFilePath dir
+ exists <- dirExists dir
unless exists $ do
removeTreeIfExists dirTmp
- liftIO $ createDirectoryIfMissing True $ toFilePath $ parent dirTmp
+ createTree (parent dirTmp)
readInNull (parent dirTmp) "git" menv
[ "clone"
, T.unpack url
@@ -428,7 +387,7 @@
, T.unpack commit
]
Nothing
- liftIO $ renameDirectory (toFilePath dirTmp) (toFilePath dir)
+ renameDir dirTmp dir
return dir
@@ -465,10 +424,14 @@
: maybe [] return (mstackGlobalConfig <|> defaultStackGlobalConfig)
-- | Load and parse YAML from the given file.
-loadYaml :: (FromJSON a,MonadIO m) => Path Abs File -> m a
-loadYaml path =
- liftIO $ Yaml.decodeFileEither (toFilePath path)
- >>= either (throwM . ParseConfigFileException path) return
+loadYaml :: (FromJSON (a, [JSONWarning]), MonadIO m, MonadLogger m) => Path Abs File -> m a
+loadYaml path = do
+ (result,warnings) <-
+ liftIO $
+ Yaml.decodeFileEither (toFilePath path) >>=
+ either (throwM . ParseConfigFileException path) return
+ logJSONWarnings (toFilePath path) warnings
+ return result
-- | Get the location of the project config file, if it exists.
getProjectConfig :: (MonadIO m, MonadThrow m, MonadLogger m)
@@ -526,3 +489,6 @@
load fp = do
ProjectAndConfigMonoid project config <- loadYaml fp
return $ Just (project, fp, config)
+
+packagesParser :: Parser [String]
+packagesParser = many (strOption (long "package" <> help "Additional packages that must be installed"))
diff --git a/src/Stack/Constants.hs b/src/Stack/Constants.hs
--- a/src/Stack/Constants.hs
+++ b/src/Stack/Constants.hs
@@ -10,7 +10,8 @@
,defaultShakeThreads
,distDirFromDir
,distRelativeDir
- ,haskellFileExts
+ ,haskellModuleExts
+ ,imageStagingDir
,projectDockerSandboxDir
,rawGithubUrl
,stackDotYaml
@@ -20,18 +21,27 @@
,configCabalMod
,buildCacheFile
,testSuccessFile
+ ,testBuiltFile
+ ,benchBuiltFile
,stackProgName
,wiredInPackages
,cabalPackageName
,implicitGlobalDir
+ ,hpcRelativeDir
,hpcDirFromDir
- ,dotHpc)
+ ,dotHpc
+ ,objectInterfaceDir
+ ,templatesDir
+ ,defaultAuthorEmail
+ ,defaultAuthorName
+ ,globalConfigPath
+ ,authorEmailKey
+ ,authorNameKey
+ ,scmInitKey)
where
-
import Control.Monad.Catch (MonadThrow)
import Control.Monad.Reader
-
import Data.HashSet (HashSet)
import qualified Data.HashSet as HashSet
import Data.Text (Text)
@@ -40,14 +50,20 @@
import Prelude
import Stack.Types.Config
import Stack.Types.PackageIdentifier
-
import Stack.Types.PackageName
+-- | Extensions for anything that can be a Haskell module.
+haskellModuleExts :: [Text]
+haskellModuleExts = haskellFileExts ++ haskellPreprocessorExts
--- | Extensions used for Haskell files.
+-- | Extensions used for Haskell modules. Excludes preprocessor ones.
haskellFileExts :: [Text]
-haskellFileExts = ["hs","hsc","lhs"]
+haskellFileExts = ["hs", "hsc", "lhs"]
+-- | Extensions for modules that are preprocessed by common preprocessors.
+haskellPreprocessorExts :: [Text]
+haskellPreprocessorExts = ["gc", "chs", "hsc", "x", "y", "ly", "cpphs"]
+
-- | The filename used for completed build indicators.
builtFileFromDir :: (MonadThrow m, MonadReader env m, HasPlatform env,HasEnvConfig env)
=> Path Abs Dir
@@ -100,6 +116,10 @@
userDocsDir :: Config -> Path Abs Dir
userDocsDir config = configStackRoot config $(mkRelDir "doc/")
+-- | Output .o/.hi directory.
+objectInterfaceDir :: BuildConfig -> Path Abs Dir
+objectInterfaceDir bconfig = bcWorkDir bconfig $(mkRelDir "odir/")
+
-- | The filename used for dirtiness check of source files.
buildCacheFile :: (MonadThrow m, MonadReader env m, HasPlatform env,HasEnvConfig env)
=> Path Abs Dir -- ^ Package directory.
@@ -118,6 +138,24 @@
( $(mkRelFile "stack-test-success"))
(distDirFromDir dir)
+-- | The filename used to mark tests as having built
+testBuiltFile :: (MonadThrow m, MonadReader env m, HasPlatform env,HasEnvConfig env)
+ => Path Abs Dir -- ^ Package directory
+ -> m (Path Abs File)
+testBuiltFile dir =
+ liftM
+ ( $(mkRelFile "stack-test-built"))
+ (distDirFromDir dir)
+
+-- | The filename used to mark benchmarks as having built
+benchBuiltFile :: (MonadThrow m, MonadReader env m, HasPlatform env,HasEnvConfig env)
+ => Path Abs Dir -- ^ Package directory
+ -> m (Path Abs File)
+benchBuiltFile dir =
+ liftM
+ ( $(mkRelFile "stack-bench-built"))
+ (distDirFromDir dir)
+
-- | The filename used for dirtiness check of config.
configCacheFile :: (MonadThrow m, MonadReader env m, HasPlatform env,HasEnvConfig env)
=> Path Abs Dir -- ^ Package directory.
@@ -141,9 +179,15 @@
:: (MonadThrow m, MonadReader env m, HasPlatform env, HasEnvConfig env)
=> Path Abs Dir -- ^ Package directory.
-> m (Path Abs Dir)
-hpcDirFromDir dir = do
- liftM ( $(mkRelDir "hpc")) (distDirFromDir dir)
+hpcDirFromDir fp =
+ liftM (fp ) hpcRelativeDir
+-- | Relative location of directory for HPC work.
+hpcRelativeDir :: (MonadThrow m, MonadReader env m, HasPlatform env, HasEnvConfig env)
+ => m (Path Rel Dir)
+hpcRelativeDir =
+ liftM ( $(mkRelDir "hpc")) distRelativeDir
+
-- | Package's build artifacts directory.
distDirFromDir :: (MonadThrow m, MonadReader env m, HasPlatform env, HasEnvConfig env)
=> Path Abs Dir
@@ -151,6 +195,10 @@
distDirFromDir fp =
liftM (fp ) distRelativeDir
+-- | Directory for project templates.
+templatesDir :: Config -> Path Abs Dir
+templatesDir config = configStackRoot config $(mkRelDir "templates")
+
-- | Relative location of build artifacts.
distRelativeDir :: (MonadThrow m, MonadReader env m, HasPlatform env, HasEnvConfig env)
=> m (Path Rel Dir)
@@ -202,6 +250,10 @@
projectDockerSandboxDir :: Path Abs Dir -> Path Abs Dir
projectDockerSandboxDir projectRoot = projectRoot workDirRel $(mkRelDir "docker/")
+-- | Image staging dir from project root.
+imageStagingDir :: Path Abs Dir -> Path Abs Dir
+imageStagingDir p = p workDirRel $(mkRelDir "image/")
+
-- | Name of the 'stack' program.
stackProgName :: String
stackProgName = "stack"
@@ -247,3 +299,15 @@
-- | Where .mix files go.
dotHpc :: Path Rel Dir
dotHpc = $(mkRelDir ".hpc")
+
+-- | Default author email.
+defaultAuthorEmail :: Text
+defaultAuthorEmail = "example@example.com"
+
+-- | Default author name.
+defaultAuthorName :: Text
+defaultAuthorName = "Example Author Name"
+
+-- | Global config path.
+globalConfigPath :: Config -> Path Abs File
+globalConfigPath = ( $(mkRelFile "stack.yaml")) . configStackRoot
diff --git a/src/Stack/Docker.hs b/src/Stack/Docker.hs
--- a/src/Stack/Docker.hs
+++ b/src/Stack/Docker.hs
@@ -8,15 +8,14 @@
,CleanupAction(..)
,dockerCleanupCmdName
,dockerCmdName
- ,dockerOptsParser
,dockerOptsFromMonoid
,dockerPullCmdName
,execWithOptionalContainer
- ,execWithRequiredContainer
,preventInContainer
,pull
,reexecWithOptionalContainer
,reset
+ ,reExecArgName
) where
import Control.Applicative
@@ -29,94 +28,116 @@
import Control.Monad.Writer (execWriter,runWriter,tell)
import Control.Monad.Trans.Control (MonadBaseControl)
import Data.Aeson.Extended (FromJSON(..),(.:),(.:?),(.!=),eitherDecode)
-import Data.Attoparsec.Args (EscapingMode (Escaping), parseArgs)
import Data.ByteString.Builder (stringUtf8,charUtf8,toLazyByteString)
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy.Char8 as LBS
import Data.Char (isSpace,toUpper,isAscii)
import Data.List (dropWhileEnd,find,intercalate,intersperse,isPrefixOf,isInfixOf,foldl',sortBy)
+import Data.List.Extra (trim)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe
-import Data.Monoid
import Data.Streaming.Process (ProcessExitedUnsuccessfully(..))
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Time (UTCTime,LocalTime(..),diffDays,utcToLocalTime,getZonedTime,ZonedTime(..))
import Data.Typeable (Typeable)
-import Options.Applicative.Builder.Extra (maybeBoolFlags)
-import Options.Applicative (Parser,str,option,help,auto,metavar,long,value,hidden,internal,idm)
import Path
-import Path.IO (getWorkingDir,listDirectory)
+import Path.IO (getWorkingDir,listDirectory,createTree,removeFile,removeTree,dirExists)
import Stack.Constants (projectDockerSandboxDir,stackProgName,stackDotYaml,stackRootEnvVar)
-import Stack.Exec
import Stack.Types
import Stack.Types.Internal
import Stack.Docker.GlobalDB
-import System.Directory (createDirectoryIfMissing,removeDirectoryRecursive,removeFile)
-import System.Directory (doesDirectoryExist)
import System.Environment (lookupEnv,getProgName,getArgs,getExecutablePath)
+import System.Exit (exitSuccess, exitWith)
import System.FilePath (dropTrailingPathSeparator,takeBaseName)
import System.Info (arch,os)
import System.IO (stderr,stdin,stdout,hIsTerminalDevice)
import System.Process.PagerEditor (editByteString)
import System.Process.Read
import System.Process.Run
+import System.Process (CreateProcess(delegate_ctlc))
import Text.Printf (printf)
+#ifndef mingw32_HOST_OS
+import Control.Monad.Trans.Control (liftBaseWith)
+import System.Posix.Signals
+#endif
+
-- | If Docker is enabled, re-runs the currently running OS command in a Docker container.
-- Otherwise, runs the inner action.
+--
+-- This takes an optional release action which should be taken IFF control is
+-- transfering away from the current process to the intra-container one. The main use
+-- for this is releasing a lock. After launching reexecution, the host process becomes
+-- nothing but an manager for the call into docker and thus may not hold the lock.
reexecWithOptionalContainer
:: M env m
=> Maybe (Path Abs Dir)
+ -> Maybe (m ())
-> IO ()
+ -> Maybe (m ())
+ -> Maybe (m ())
-> m ()
reexecWithOptionalContainer mprojectRoot =
execWithOptionalContainer mprojectRoot getCmdArgs
where
getCmdArgs =
- do args <- getArgs
+ do args <- (("--" ++ reExecArgName) :) <$> getArgs
if arch == "x86_64" && os == "linux"
then do exePath <- getExecutablePath
let mountPath = concat ["/opt/host/bin/",takeBaseName exePath]
return (mountPath
,args
+ ,[]
,\c -> c{configDocker=(configDocker c)
{dockerMount=Mount exePath mountPath :
dockerMount (configDocker c)}})
else do progName <- getProgName
- return (takeBaseName progName,args,id)
+ return (takeBaseName progName,args,[],id)
-- | If Docker is enabled, re-runs the OS command returned by the second argument in a
-- Docker container. Otherwise, runs the inner action.
+--
+-- This takes an optional release action just like `reexecWithOptionalContainer`.
execWithOptionalContainer
:: M env m
=> Maybe (Path Abs Dir)
- -> IO (FilePath,[String],Config -> Config)
+ -> IO (FilePath,[String],[(String,String)],Config -> Config)
+ -> Maybe (m ())
-> IO ()
+ -> Maybe (m ())
+ -> Maybe (m ())
-> m ()
-execWithOptionalContainer mprojectRoot getCmdArgs inner =
+execWithOptionalContainer mprojectRoot getCmdArgs mbefore inner mafter mrelease =
do config <- asks getConfig
inContainer <- getInContainer
- if inContainer || not (dockerEnable (configDocker config))
- then liftIO inner
- else do (cmd_,args,modConfig) <- liftIO getCmdArgs
- runContainerAndExit modConfig mprojectRoot cmd_ args []
-
--- | If Docker is enabled, re-runs the OS command returned by the second argument in a
--- Docker container. Otherwise, throws 'DockerMustBeEnabledException'.
-execWithRequiredContainer
- :: M env m
- => Maybe (Path Abs Dir)
- -> IO (FilePath,[String],Config -> Config)
- -> m ()
-execWithRequiredContainer mprojectRoot getCmdArgs =
- do config <- asks getConfig
- unless (dockerEnable (configDocker config))
- (throwM DockerMustBeEnabledException)
- (cmd_,args,modConfig) <- liftIO getCmdArgs
- runContainerAndExit modConfig mprojectRoot cmd_ args []
+ isReExec <- asks getReExec
+ if | inContainer && not isReExec && (isJust mbefore || isJust mafter) ->
+ throwM OnlyOnHostException
+ | inContainer ->
+ liftIO (do inner
+ exitSuccess)
+ | not (dockerEnable (configDocker config)) ->
+ do fromMaybeAction mbefore
+ liftIO inner
+ fromMaybeAction mafter
+ liftIO exitSuccess
+ | otherwise ->
+ do (cmd_,args,envVars,modConfig) <- liftIO getCmdArgs
+ fromMaybeAction mrelease
+ runContainerAndExit
+ modConfig
+ mprojectRoot
+ (fromMaybeAction mbefore)
+ cmd_
+ args
+ envVars
+ (fromMaybeAction mafter)
+ where
+ fromMaybeAction Nothing = return ()
+ fromMaybeAction (Just hook) = hook
-- | Error if running in a container.
preventInContainer :: (MonadIO m,MonadThrow m) => m () -> m ()
@@ -128,35 +149,36 @@
-- | 'True' if we are currently running inside a Docker container.
getInContainer :: (MonadIO m) => m Bool
-getInContainer =
- do maybeEnvVar <- liftIO (lookupEnv inContainerEnvVar)
- case maybeEnvVar of
- Nothing -> return False
- Just _ -> return True
+getInContainer = liftIO (isJust <$> lookupEnv inContainerEnvVar)
-- | Run a command in a new Docker container, then exit the process.
runContainerAndExit :: M env m
=> (Config -> Config)
-> Maybe (Path Abs Dir)
+ -> m ()
-> FilePath
-> [String]
-> [(String, String)]
-> m ()
+ -> m ()
runContainerAndExit modConfig
mprojectRoot
+ before
cmnd
args
- envVars =
+ envVars
+ after =
do config <- fmap modConfig (asks getConfig)
let docker = configDocker config
envOverride <- getEnvOverride (configPlatform config)
checkDockerVersion envOverride
uidOut <- readProcessStdout Nothing envOverride "id" ["-u"]
gidOut <- readProcessStdout Nothing envOverride "id" ["-g"]
- (dockerHost,dockerCertPath,dockerTlsVerify) <-
- liftIO ((,,) <$> lookupEnv "DOCKER_HOST"
- <*> lookupEnv "DOCKER_CERT_PATH"
- <*> lookupEnv "DOCKER_TLS_VERIFY")
+ (dockerHost,dockerCertPath,bamboo,jenkins) <-
+ liftIO ((,,,) <$> lookupEnv "DOCKER_HOST"
+ <*> lookupEnv "DOCKER_CERT_PATH"
+ <*> lookupEnv "bamboo_buildKey"
+ <*> lookupEnv "JENKINS_HOME")
isStdoutTerminal <- asks getTerminal
(isStdinTerminal,isStderrTerminal) <-
liftIO ((,) <$> hIsTerminalDevice stdin
@@ -164,7 +186,7 @@
pwd <- getWorkingDir
when (maybe False (isPrefixOf "tcp://") dockerHost &&
maybe False (isInfixOf "boot2docker") dockerCertPath)
- ($logWarn "WARNING: Using boot2docker is NOT supported, and not likely to perform well.")
+ ($logWarn "Warning: Using boot2docker is NOT supported, and not likely to perform well.")
let image = dockerImage docker
maybeImageInfo <- inspect envOverride image
imageInfo <- case maybeImageInfo of
@@ -180,20 +202,7 @@
let uid = dropWhileEnd isSpace (decodeUtf8 uidOut)
gid = dropWhileEnd isSpace (decodeUtf8 gidOut)
imageEnvVars = map (break (== '=')) (icEnv (iiConfig imageInfo))
- (sandboxID,oldImage) =
- case lookupImageEnv sandboxIDEnvVar imageEnvVars of
- Just x -> (x,False)
- Nothing ->
- --EKB TODO: remove this and oldImage after lts-1.x images no longer in use
- let sandboxName = maybe "default" id (lookupImageEnv "SANDBOX_NAME" imageEnvVars)
- maybeImageCabalRemoteRepoName = lookupImageEnv "CABAL_REMOTE_REPO_NAME" imageEnvVars
- maybeImageStackageSlug = lookupImageEnv "STACKAGE_SLUG" imageEnvVars
- maybeImageStackageDate = lookupImageEnv "STACKAGE_DATE" imageEnvVars
- in (case (maybeImageStackageSlug,maybeImageStackageDate) of
- (Just stackageSlug,_) -> sandboxName ++ "_" ++ stackageSlug
- (_,Just stackageDate) -> sandboxName ++ "_" ++ stackageDate
- _ -> sandboxName ++ maybe "" ("_" ++) maybeImageCabalRemoteRepoName
- ,True)
+ sandboxID = fromMaybe "default" (lookupImageEnv sandboxIDEnvVar imageEnvVars)
sandboxIDDir <- parseRelDir (sandboxID ++ "/")
let stackRoot = configStackRoot config
sandboxDir = projectDockerSandboxDir projectRoot
@@ -202,22 +211,24 @@
sandboxRepoDir = sandboxDir sandboxIDDir
sandboxSubdirs = map (\d -> sandboxRepoDir d)
sandboxedHomeSubdirectories
- isTerm = isStdinTerminal && isStdoutTerminal && isStderrTerminal
+ isTerm = not (dockerDetach docker) &&
+ isStdinTerminal &&
+ isStdoutTerminal &&
+ isStderrTerminal
+ keepStdinOpen = not (dockerDetach docker) &&
+ (isTerm || (isNothing bamboo && isNothing jenkins))
liftIO
(do updateDockerImageLastUsed config
(iiId imageInfo)
(toFilePath projectRoot)
- mapM_ (createDirectoryIfMissing True)
- (concat [[toFilePath sandboxHomeDir
- ,toFilePath sandboxSandboxDir
- ,toFilePath stackRoot] ++
- map toFilePath sandboxSubdirs]))
- exec
- plainEnvSettings
- "docker"
+ mapM_ createTree
+ (concat [[sandboxHomeDir, sandboxSandboxDir, stackRoot] ++
+ sandboxSubdirs]))
+ containerID <- (trim . decodeUtf8) <$> readDockerProcess
+ envOverride
(concat
- [["run"
+ [["create"
,"--net=host"
,"-e",inContainerEnvVar ++ "=1"
,"-e",stackRootEnvVar ++ "=" ++ toFPNoTrailingSep stackRoot
@@ -232,39 +243,47 @@
,"-v",toFPNoTrailingSep sandboxHomeDir ++ ":" ++ toFPNoTrailingSep sandboxRepoDir
,"-v",toFPNoTrailingSep stackRoot ++ ":" ++
toFPNoTrailingSep (sandboxRepoDir $(mkRelDir ("." ++ stackProgName ++ "/")))]
- ,if oldImage
- then ["-e",sandboxIDEnvVar ++ "=" ++ sandboxID
- ,"--entrypoint=/root/entrypoint.sh"]
- else []
- ,case (dockerPassHost docker,dockerHost) of
- (True,Just x@('u':'n':'i':'x':':':'/':'/':s)) -> ["-e","DOCKER_HOST=" ++ x
- ,"-v",s ++ ":" ++ s]
- (True,Just x) -> ["-e","DOCKER_HOST=" ++ x]
- (True,Nothing) -> ["-v","/var/run/docker.sock:/var/run/docker.sock"]
- (False,_) -> []
- ,case (dockerPassHost docker,dockerCertPath) of
- (True,Just x) -> ["-e","DOCKER_CERT_PATH=" ++ x
- ,"-v",x ++ ":" ++ x]
- _ -> []
- ,case (dockerPassHost docker,dockerTlsVerify) of
- (True,Just x )-> ["-e","DOCKER_TLS_VERIFY=" ++ x]
- _ -> []
+ ,concatMap (\(k,v) -> ["-e", k ++ "=" ++ v]) envVars
,concatMap sandboxSubdirArg sandboxSubdirs
,concatMap mountArg (dockerMount docker)
,case dockerContainerName docker of
Just name -> ["--name=" ++ name]
Nothing -> []
- ,if dockerDetach docker
- then ["-d"]
- else concat [["--rm" | not (dockerPersist docker)]
- ,["-t" | isTerm]
- ,["-i"]]
+ ,["-t" | isTerm]
+ ,["-i" | keepStdinOpen]
,dockerRunArgs docker
,[image]
- ,map (\(k,v) -> k ++ "=" ++ v) envVars
,[cmnd]
,args])
-
+ before
+#ifndef mingw32_HOST_OS
+ runInBase <- liftBaseWith $ \run -> return (void . run)
+ oldHandlers <- forM (concat [[(sigINT,sigTERM) | not keepStdinOpen]
+ ,[(sigTERM,sigTERM)]]) $ \(sigIn,sigOut) -> do
+ let sigHandler = runInBase (readProcessNull Nothing envOverride "docker"
+ ["kill","--signal=" ++ show sigOut,containerID])
+ oldHandler <- liftIO $ installHandler sigIn (Catch sigHandler) Nothing
+ return (sigIn, oldHandler)
+#endif
+ e <- try (callProcess'
+ (if keepStdinOpen then id else (\cp -> cp { delegate_ctlc = False }))
+ Nothing
+ envOverride
+ "docker"
+ (concat [["start"]
+ ,["-a" | not (dockerDetach docker)]
+ ,["-i" | keepStdinOpen]
+ ,[containerID]]))
+#ifndef mingw32_HOST_OS
+ forM_ oldHandlers $ \(sig,oldHandler) ->
+ liftIO $ installHandler sig oldHandler Nothing
+#endif
+ unless (dockerPersist docker || dockerDetach docker)
+ (readProcessNull Nothing envOverride "docker" ["rm","-f",containerID])
+ case e of
+ Left (ProcessExitedUnsuccessfully _ ec) -> liftIO (exitWith ec)
+ Right () -> do after
+ liftIO exitSuccess
where
lookupImageEnv name vars =
case lookup name vars of
@@ -537,7 +556,7 @@
pullImage envOverride docker (dockerImage docker)
-- | Pull Docker image from registry.
-pullImage :: (MonadLogger m,MonadIO m,MonadThrow m)
+pullImage :: (MonadLogger m,MonadIO m,MonadThrow m,MonadBaseControl IO m)
=> EnvOverride -> DockerOpts -> String -> m ()
pullImage envOverride docker image =
do $logInfo (concatT ["Pulling image from registry: '",image,"'"])
@@ -552,7 +571,7 @@
,maybe [] (\u -> ["--username=" ++ u]) (dockerRegistryUsername docker)
,maybe [] (\p -> ["--password=" ++ p]) (dockerRegistryPassword docker)
,[takeWhile (/= '/') image]]))
- e <- liftIO (try (callProcess Nothing envOverride "docker" ["pull",image]))
+ e <- try (callProcess Nothing envOverride "docker" ["pull",image])
case e of
Left (ProcessExitedUnsuccessfully _ _) -> throwM (PullFailedException image)
Right () -> return ()
@@ -597,15 +616,15 @@
-> [Path Rel File] -- ^ Top-level file names to exclude from removal
-> IO ()
removeDirectoryContents path excludeDirs excludeFiles =
- do isRootDir <- doesDirectoryExist (toFilePath path)
+ do isRootDir <- dirExists path
when isRootDir
(do (lsd,lsf) <- listDirectory path
forM_ lsd
(\d -> unless (dirname d `elem` excludeDirs)
- (removeDirectoryRecursive (toFilePath d)))
+ (removeTree d))
forM_ lsf
(\f -> unless (filename f `elem` excludeFiles)
- (removeFile (toFilePath f))))
+ (removeFile f)))
-- | Produce a strict 'S.ByteString' from the stdout of a
-- process. Throws a 'ReadProcessException' exception if the
@@ -627,72 +646,6 @@
homeDirName :: Path Rel Dir
homeDirName = $(mkRelDir "_home/")
--- | Options parser configuration for Docker.
-dockerOptsParser :: Bool -> Parser DockerOptsMonoid
-dockerOptsParser showOptions =
- DockerOptsMonoid
- <$> pure Nothing
- <*> maybeBoolFlags dockerCmdName
- "using a Docker container"
- hide
- <*> ((Just . DockerMonoidRepo) <$> option str (long (dockerOptName dockerRepoArgName) <>
- hide <>
- metavar "NAME" <>
- help "Docker repository name") <|>
- (Just . DockerMonoidImage) <$> option str (long (dockerOptName dockerImageArgName) <>
- hide <>
- metavar "IMAGE" <>
- help "Exact Docker image ID (overrides docker-repo)") <|>
- pure Nothing)
- <*> maybeBoolFlags (dockerOptName dockerRegistryLoginArgName)
- "registry requires login"
- hide
- <*> maybeStrOption (long (dockerOptName dockerRegistryUsernameArgName) <>
- hide <>
- metavar "USERNAME" <>
- help "Docker registry username")
- <*> maybeStrOption (long (dockerOptName dockerRegistryPasswordArgName) <>
- hide <>
- metavar "PASSWORD" <>
- help "Docker registry password")
- <*> maybeBoolFlags (dockerOptName dockerAutoPullArgName)
- "automatic pulling latest version of image"
- hide
- <*> maybeBoolFlags (dockerOptName dockerDetachArgName)
- "running a detached Docker container"
- hide
- <*> maybeBoolFlags (dockerOptName dockerPersistArgName)
- "not deleting container after it exits"
- hide
- <*> maybeStrOption (long (dockerOptName dockerContainerNameArgName) <>
- hide <>
- metavar "NAME" <>
- help "Docker container name")
- <*> argsStrOption (long (dockerOptName dockerRunArgsArgName) <>
- hide <>
- value [] <>
- metavar "'ARG1 [ARG2 ...]'" <>
- help "Additional arguments to pass to 'docker run'")
- <*> many (option auto (long (dockerOptName dockerMountArgName) <>
- hide <>
- metavar "(PATH | HOST-PATH:CONTAINER-PATH)" <>
- help ("Mount volumes from host in container " ++
- "(may specify mutliple times)")))
- <*> maybeBoolFlags (dockerOptName dockerPassHostArgName)
- "passing Docker daemon connection information into container"
- hide
- <*> maybeStrOption (long (dockerOptName dockerDatabasePathArgName) <>
- hide <>
- metavar "PATH" <>
- help "Location of image usage tracking database")
- where
- dockerOptName optName = dockerCmdName ++ "-" ++ T.unpack optName
- maybeStrOption = optional . option str
- argsStrOption = option (fmap (either error id . parseArgs Escaping . T.pack) str)
- hide = if showOptions
- then idm
- else internal <> hidden
-
-- | Interprets DockerOptsMonoid options.
dockerOptsFromMonoid :: Maybe Project -> Path Abs Dir -> DockerOptsMonoid -> DockerOpts
dockerOptsFromMonoid mproject stackRoot DockerOptsMonoid{..} = DockerOpts
@@ -723,7 +676,6 @@
,dockerContainerName = emptyToNothing dockerMonoidContainerName
,dockerRunArgs = dockerMonoidRunArgs
,dockerMount = dockerMonoidMount
- ,dockerPassHost = fromMaybe False dockerMonoidPassHost
,dockerDatabasePath =
case dockerMonoidDatabasePath of
Nothing -> stackRoot $(mkRelFile "docker.db")
@@ -767,6 +719,10 @@
dockerCleanupCmdName :: String
dockerCleanupCmdName = "cleanup"
+-- | Command-line option for @--internal-re-exec@.
+reExecArgName :: String
+reExecArgName = "internal-re-exec"
+
-- | Options for 'cleanup'.
data CleanupOpts = CleanupOpts
{ dcAction :: !CleanupAction
@@ -936,4 +892,4 @@
concat ["Invalid database path: ",show ex]
type M env m = (MonadIO m,MonadReader env m,MonadLogger m,MonadBaseControl IO m,MonadCatch m
- ,HasConfig env,HasTerminal env)
+ ,HasConfig env,HasTerminal env,HasReExec env)
diff --git a/src/Stack/Docker/GlobalDB.hs b/src/Stack/Docker/GlobalDB.hs
--- a/src/Stack/Docker/GlobalDB.hs
+++ b/src/Stack/Docker/GlobalDB.hs
@@ -25,7 +25,7 @@
import Database.Persist.Sqlite
import Database.Persist.TH
import Path (toFilePath, parent)
-import System.Directory (createDirectoryIfMissing)
+import Path.IO (createTree)
import Stack.Types.Config
import Stack.Types.Docker
@@ -75,7 +75,7 @@
withGlobalDB :: forall a. Config -> SqlPersistT (NoLoggingT (ResourceT IO)) a -> IO a
withGlobalDB config action =
do let db = dockerDatabasePath (configDocker config)
- createDirectoryIfMissing True (toFilePath (parent db))
+ createTree (parent db)
runSqlite (T.pack (toFilePath db))
(do _ <- runMigrationSilent migrateTables
action)
diff --git a/src/Stack/Dot.hs b/src/Stack/Dot.hs
--- a/src/Stack/Dot.hs
+++ b/src/Stack/Dot.hs
@@ -1,43 +1,43 @@
-{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
module Stack.Dot (dot
+ ,listDependencies
,DotOpts(..)
- ,dotOptsParser
,resolveDependencies
,printGraph
,pruneGraph
) where
-import Control.Monad (void)
-import Control.Monad.Catch (MonadCatch)
+import Control.Applicative
+import Control.Arrow ((&&&))
+import Control.Monad (liftM, void)
+import Control.Monad.Catch (MonadCatch,MonadMask)
import Control.Monad.IO.Class
-import Control.Monad.Logger (MonadLogger, logInfo)
+import Control.Monad.Logger (MonadLogger)
import Control.Monad.Reader (MonadReader)
import Control.Monad.Trans.Control (MonadBaseControl)
-import Data.Char (isSpace)
import qualified Data.Foldable as F
import qualified Data.HashSet as HashSet
-import Data.List.Split (splitOn)
import Data.Map (Map)
import qualified Data.Map as Map
+import Data.Monoid ((<>))
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as Text
+import qualified Data.Text.IO as Text
import qualified Data.Traversable as T
import Network.HTTP.Client.Conduit (HasHttpManager)
-import Options.Applicative
-import Options.Applicative.Builder.Extra (boolFlags)
import Stack.Build (withLoadPackage)
+import Stack.Build.Installed (getInstalled, GetInstalledOpts(..))
import Stack.Build.Source
-import Stack.Build.Types
import Stack.Constants
import Stack.Package
import Stack.Types
+import Stack.Types.Internal (HasLogLevel)
--- | Options record for `stack dot`
+-- | Options record for @stack dot@
data DotOpts = DotOpts
{ dotIncludeExternal :: Bool
-- ^ Include external dependencies
@@ -49,105 +49,130 @@
-- ^ Package names to prune from the graph
}
--- | Parser for arguments to `stack dot`
-dotOptsParser :: Parser DotOpts
-dotOptsParser = DotOpts
- <$> includeExternal
- <*> includeBase
- <*> depthLimit
- <*> fmap (maybe Set.empty Set.fromList . fmap splitNames) prunedPkgs
- where includeExternal = boolFlags False
- "external"
- "inclusion of external dependencies"
- idm
- includeBase = boolFlags True
- "include-base"
- "inclusion of dependencies on base"
- idm
- depthLimit =
- optional (option auto
- (long "depth" <>
- metavar "DEPTH" <>
- help ("Limit the depth of dependency resolution " <>
- "(Default: No limit)")))
- prunedPkgs = optional (strOption
- (long "prune" <>
- metavar "PACKAGES" <>
- help ("Prune each package name " <>
- "from the comma separated list " <>
- "of package names PACKAGES")))
-
- splitNames :: String -> [String]
- splitNames = map (takeWhile (not . isSpace) . dropWhile isSpace) . splitOn ","
-
-- | Visualize the project's dependencies as a graphviz graph
dot :: (HasEnvConfig env
,HasHttpManager env
+ ,HasLogLevel env
,MonadBaseControl IO m
,MonadCatch m
- ,MonadIO m
,MonadLogger m
+ ,MonadIO m
+ ,MonadMask m
,MonadReader env m
)
=> DotOpts
-> m ()
dot dotOpts = do
- (locals,_,_) <- loadLocals defaultBuildOpts Map.empty
- (_,_,_,sourceMap) <- loadSourceMap defaultBuildOpts
- let graph = Map.fromList (localDependencies dotOpts locals)
- menv <- getMinimalEnvOverride
- resultGraph <- withLoadPackage menv (\loader -> do
- let depLoader = createDepLoader sourceMap (fmap3 packageAllDeps loader)
- liftIO $ resolveDependencies (dotDependencyDepth dotOpts) graph depLoader)
+ localNames <- liftM Map.keysSet getLocalPackageViews
+ resultGraph <- createDependencyGraph dotOpts
let pkgsToPrune = if dotIncludeBase dotOpts
then dotPrune dotOpts
else Set.insert "base" (dotPrune dotOpts)
- localNames = Set.fromList (map (packageName . lpPackage) locals)
prunedGraph = pruneGraph localNames pkgsToPrune resultGraph
- printGraph dotOpts locals prunedGraph
+ printGraph dotOpts localNames prunedGraph
+
+-- | Create the dependency graph, the result is a map from a package
+-- name to a tuple of dependencies and a version if available. This
+-- function mainly gathers the required arguments for
+-- @resolveDependencies@.
+createDependencyGraph :: (HasEnvConfig env
+ ,HasHttpManager env
+ ,HasLogLevel env
+ ,MonadLogger m
+ ,MonadBaseControl IO m
+ ,MonadCatch m
+ ,MonadIO m
+ ,MonadMask m
+ ,MonadReader env m)
+ => DotOpts
+ -> m (Map PackageName (Set PackageName, Maybe Version))
+createDependencyGraph dotOpts = do
+ (_,locals,_,sourceMap) <- loadSourceMap defaultBuildOpts
+ let graph = Map.fromList (localDependencies dotOpts locals)
+ menv <- getMinimalEnvOverride
+ installedMap <- fmap thrd . fst <$> getInstalled menv
+ (GetInstalledOpts False False)
+ sourceMap
+ withLoadPackage menv (\loader -> do
+ let depLoader =
+ createDepLoader sourceMap
+ installedMap
+ (fmap3 (packageAllDeps &&& (Just . packageVersion)) loader)
+ liftIO $ resolveDependencies (dotDependencyDepth dotOpts) graph depLoader)
where -- fmap a function over the result of a function with 3 arguments
fmap3 :: Functor f => (d -> e) -> (a -> b -> c -> f d) -> a -> b -> c -> f e
fmap3 f g a b c = f <$> g a b c
--- | `pruneGraph dontPrune toPrune graph` prunes all packages in
--- `graph` with a name in `toPrune` and removes resulting orphans
--- unless they are in `dontPrune`
-pruneGraph :: (F.Foldable f, F.Foldable g)
+ thrd :: (a,b,c) -> c
+ thrd (_,_,x) = x
+
+-- Given an 'Installed' try to get the 'Version'
+libVersionFromInstalled :: Installed -> Maybe Version
+libVersionFromInstalled (Library ghcPkgId) =
+ case ghcPkgIdPackageIdentifier ghcPkgId of
+ PackageIdentifier _ v -> Just v
+libVersionFromInstalled (Executable _) = Nothing
+
+listDependencies :: (HasEnvConfig env
+ ,HasHttpManager env
+ ,HasLogLevel env
+ ,MonadBaseControl IO m
+ ,MonadCatch m
+ ,MonadLogger m
+ ,MonadMask m
+ ,MonadIO m
+ ,MonadReader env m
+ )
+ => Text
+ -> m ()
+listDependencies sep = do
+ let dotOpts = DotOpts True True Nothing Set.empty
+ resultGraph <- createDependencyGraph dotOpts
+ void (Map.traverseWithKey go (snd <$> resultGraph))
+ where go name v = liftIO (Text.putStrLn $
+ Text.pack (packageNameString name) <>
+ sep <>
+ maybe "" (Text.pack . show) v)
+
+-- | @pruneGraph dontPrune toPrune graph@ prunes all packages in
+-- @graph@ with a name in @toPrune@ and removes resulting orphans
+-- unless they are in @dontPrune@
+pruneGraph :: (F.Foldable f, F.Foldable g, Eq a)
=> f PackageName
-> g String
- -> Map PackageName (Set PackageName)
- -> Map PackageName (Set PackageName)
+ -> Map PackageName (Set PackageName, a)
+ -> Map PackageName (Set PackageName, a)
pruneGraph dontPrune names =
- pruneUnreachable dontPrune . Map.mapMaybeWithKey (\pkg pkgDeps ->
+ pruneUnreachable dontPrune . Map.mapMaybeWithKey (\pkg (pkgDeps,x) ->
if show pkg `F.elem` names
then Nothing
else let filtered = Set.filter (\n -> show n `F.notElem` names) pkgDeps
in if Set.null filtered && not (Set.null pkgDeps)
then Nothing
- else Just filtered)
+ else Just (filtered,x))
-- | Make sure that all unreachable nodes (orphans) are pruned
-pruneUnreachable :: F.Foldable f
+pruneUnreachable :: (Eq a, F.Foldable f)
=> f PackageName
- -> Map PackageName (Set PackageName)
- -> Map PackageName (Set PackageName)
+ -> Map PackageName (Set PackageName, a)
+ -> Map PackageName (Set PackageName, a)
pruneUnreachable dontPrune = fixpoint prune
where fixpoint :: Eq a => (a -> a) -> a -> a
fixpoint f v = if f v == v then v else fixpoint f (f v)
prune graph' = Map.filterWithKey (\k _ -> reachable k) graph'
where reachable k = k `F.elem` dontPrune || k `Set.member` reachables
- reachables = F.fold graph'
+ reachables = F.fold (fst <$> graph')
-- | Resolve the dependency graph up to (Just depth) or until fixpoint is reached
resolveDependencies :: (Applicative m, Monad m)
=> Maybe Int
- -> Map PackageName (Set PackageName)
- -> (PackageName -> m (Set PackageName))
- -> m (Map PackageName (Set PackageName))
+ -> Map PackageName (Set PackageName,Maybe Version)
+ -> (PackageName -> m (Set PackageName, Maybe Version))
+ -> m (Map PackageName (Set PackageName,Maybe Version))
resolveDependencies (Just 0) graph _ = return graph
resolveDependencies limit graph loadPackageDeps = do
- let values = Set.unions (Map.elems graph)
+ let values = Set.unions (fst <$> Map.elems graph)
keys = Map.keysSet graph
next = Set.difference values keys
if Set.null next
@@ -155,77 +180,84 @@
else do
x <- T.traverse (\name -> (name,) <$> loadPackageDeps name) (F.toList next)
resolveDependencies (subtract 1 <$> limit)
- (Map.unionWith Set.union graph (Map.fromList x))
+ (Map.unionWith unifier graph (Map.fromList x))
loadPackageDeps
+ where unifier (pkgs1,v1) (pkgs2,_) = (Set.union pkgs1 pkgs2, v1)
-- | Given a SourceMap and a dependency loader, load the set of dependencies for a package
createDepLoader :: Applicative m
=> Map PackageName PackageSource
- -> (PackageName -> Version -> Map FlagName Bool -> m (Set PackageName))
+ -> Map PackageName Installed
+ -> (PackageName -> Version -> Map FlagName Bool -> m (Set PackageName,Maybe Version))
-> PackageName
- -> m (Set PackageName)
-createDepLoader sourceMap loadPackageDeps pkgName =
+ -> m (Set PackageName, Maybe Version)
+createDepLoader sourceMap installed loadPackageDeps pkgName =
case Map.lookup pkgName sourceMap of
- Just (PSLocal lp) -> pure (packageAllDeps (lpPackage lp))
+ Just (PSLocal lp) -> pure ((packageAllDeps &&& (Just . packageVersion)) (lpPackage lp))
Just (PSUpstream version _ flags) -> loadPackageDeps pkgName version flags
- Nothing -> pure Set.empty
+ Nothing -> pure (Set.empty, do m' <- T.traverse libVersionFromInstalled installed
+ Map.lookup pkgName m')
-- | Resolve the direct (depth 0) external dependencies of the given local packages
-localDependencies :: DotOpts -> [LocalPackage] -> [(PackageName,Set PackageName)]
-localDependencies dotOpts locals = map (\lp -> (packageName (lpPackage lp), deps lp)) locals
+localDependencies :: DotOpts -> [LocalPackage] -> [(PackageName,(Set PackageName,Maybe Version))]
+localDependencies dotOpts locals =
+ map (\lp -> (packageName (lpPackage lp), (deps lp,Just (lpVersion lp)))) locals
where deps lp = if dotIncludeExternal dotOpts
then Set.delete (lpName lp) (packageAllDeps (lpPackage lp))
else Set.intersection localNames (packageAllDeps (lpPackage lp))
lpName lp = packageName (lpPackage lp)
localNames = Set.fromList $ map (packageName . lpPackage) locals
+ lpVersion lp = packageVersion (lpPackage lp)
-- | Print a graphviz graph of the edges in the Map and highlight the given local packages
-printGraph :: (Applicative m, MonadLogger m)
+printGraph :: (Applicative m, MonadIO m)
=> DotOpts
- -> [LocalPackage]
- -> Map PackageName (Set PackageName)
+ -> Set PackageName -- ^ all locals
+ -> Map PackageName (Set PackageName, Maybe Version)
-> m ()
printGraph dotOpts locals graph = do
- $logInfo "strict digraph deps {"
+ liftIO $ Text.putStrLn "strict digraph deps {"
printLocalNodes dotOpts filteredLocals
printLeaves graph
- void (Map.traverseWithKey printEdges graph)
- $logInfo "}"
- where filteredLocals = filter (\local ->
- show (packageName (lpPackage local)) `Set.notMember` dotPrune dotOpts) locals
+ void (Map.traverseWithKey printEdges (fst <$> graph))
+ liftIO $ Text.putStrLn "}"
+ where filteredLocals = Set.filter (\local ->
+ packageNameString local `Set.notMember` dotPrune dotOpts) locals
-- | Print the local nodes with a different style depending on options
-printLocalNodes :: (F.Foldable t, MonadLogger m)
+printLocalNodes :: (F.Foldable t, MonadIO m)
=> DotOpts
- -> t LocalPackage
+ -> t PackageName
-> m ()
-printLocalNodes dotOpts locals = $logInfo (Text.intercalate "\n" lpNodes)
+printLocalNodes dotOpts locals = liftIO $ Text.putStrLn (Text.intercalate "\n" lpNodes)
where applyStyle :: Text -> Text
applyStyle n = if dotIncludeExternal dotOpts
then n <> " [style=dashed];"
else n <> " [style=solid];"
lpNodes :: [Text]
- lpNodes = map (applyStyle . nodeName . packageName . lpPackage) (F.toList locals)
+ lpNodes = map (applyStyle . nodeName) (F.toList locals)
-- | Print nodes without dependencies
-printLeaves :: (Applicative m, MonadLogger m) => Map PackageName (Set PackageName) -> m ()
-printLeaves = F.traverse_ printLeaf . Map.keysSet . Map.filter Set.null
+printLeaves :: (Applicative m, MonadIO m)
+ => Map PackageName (Set PackageName,Maybe Version)
+ -> m ()
+printLeaves = F.traverse_ printLeaf . Map.keysSet . Map.filter Set.null . fmap fst
--- | `printDedges p ps` prints an edge from p to every ps
-printEdges :: (Applicative m, MonadLogger m) => PackageName -> Set PackageName -> m ()
+-- | @printDedges p ps@ prints an edge from p to every ps
+printEdges :: (Applicative m, MonadIO m) => PackageName -> Set PackageName -> m ()
printEdges package deps = F.for_ deps (printEdge package)
-- | Print an edge between the two package names
-printEdge :: MonadLogger m => PackageName -> PackageName -> m ()
-printEdge from to = $logInfo (Text.concat [ nodeName from, " -> ", nodeName to, ";"])
+printEdge :: MonadIO m => PackageName -> PackageName -> m ()
+printEdge from to = liftIO $ Text.putStrLn (Text.concat [ nodeName from, " -> ", nodeName to, ";"])
-- | Convert a package name to a graph node name.
nodeName :: PackageName -> Text
nodeName name = "\"" <> Text.pack (packageNameString name) <> "\""
-- | Print a node with no dependencies
-printLeaf :: MonadLogger m => PackageName -> m ()
-printLeaf package = $logInfo . Text.concat $
+printLeaf :: MonadIO m => PackageName -> m ()
+printLeaf package = liftIO . Text.putStrLn . Text.concat $
if isWiredIn package
then ["{rank=max; ", nodeName package, " [shape=box]; };"]
else ["{rank=max; ", nodeName package, "; };"]
diff --git a/src/Stack/Exec.hs b/src/Stack/Exec.hs
--- a/src/Stack/Exec.hs
+++ b/src/Stack/Exec.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
@@ -8,15 +10,20 @@
import Control.Monad.Reader
import Control.Monad.Logger
-import Control.Monad.Catch
-
-
-import Path
+import Control.Monad.Catch hiding (try)
+import Control.Monad.Trans.Control (MonadBaseControl)
import Stack.Types
-import System.Directory (doesFileExist)
+import System.Process.Log
+
+#ifdef mingw32_HOST_OS
+import Control.Exception.Lifted
+import Data.Streaming.Process (ProcessExitedUnsuccessfully(..))
import System.Exit
-import qualified System.Process as P
-import System.Process.Read
+import System.Process.Run (callProcess)
+#else
+import System.Process.Read (envHelper, preProcess)
+import System.Posix.Process (executeFile)
+#endif
-- | Default @EnvSettings@ which includes locals and GHC_PACKAGE_PATH
defaultEnvSettings :: EnvSettings
@@ -35,21 +42,18 @@
}
-- | Execute a process within the Stack configured environment.
-exec :: (HasConfig r, MonadReader r m, MonadIO m, MonadLogger m, MonadThrow m)
- => EnvSettings -> String -> [String] -> m b
-exec envSettings cmd args = do
+exec :: (HasConfig r, MonadReader r m, MonadIO m, MonadLogger m, MonadThrow m, MonadBaseControl IO m)
+ => EnvSettings -> String -> [String] -> m b
+exec envSettings cmd0 args = do
config <- asks getConfig
menv <- liftIO (configEnvOverride config envSettings)
- exists <- liftIO $ doesFileExist cmd
- cmd' <-
- if exists
- then return cmd
- else liftM toFilePath $ join $ System.Process.Read.findExecutable menv cmd
- let cp = (P.proc cmd' args)
- { P.env = envHelper menv
- , P.delegate_ctlc = True
- }
- $logProcessRun cmd' args
- (Nothing, Nothing, Nothing, ph) <- liftIO (P.createProcess cp)
- ec <- liftIO (P.waitForProcess ph)
- liftIO (exitWith ec)
+ $logProcessRun cmd0 args
+#ifdef mingw32_HOST_OS
+ e <- try (callProcess Nothing menv cmd0 args)
+ liftIO $ case e of
+ Left (ProcessExitedUnsuccessfully _ ec) -> exitWith ec
+ Right () -> exitSuccess
+#else
+ cmd <- preProcess Nothing menv cmd0
+ liftIO $ executeFile cmd True args (envHelper menv)
+#endif
diff --git a/src/Stack/Fetch.hs b/src/Stack/Fetch.hs
--- a/src/Stack/Fetch.hs
+++ b/src/Stack/Fetch.hs
@@ -22,57 +22,62 @@
, withCabalLoader
) where
-import qualified Codec.Archive.Tar as Tar
-import qualified Codec.Archive.Tar.Check as Tar
-import Codec.Compression.GZip (decompress)
+import qualified Codec.Archive.Tar as Tar
+import qualified Codec.Archive.Tar.Check as Tar
+import qualified Codec.Archive.Tar.Entry as Tar
+import Codec.Compression.GZip (decompress)
import Control.Applicative
-import Control.Concurrent.Async (Concurrently (..))
-import Control.Concurrent.MVar.Lifted (newMVar, modifyMVar)
-import Control.Concurrent.STM (TVar, atomically, modifyTVar,
- newTVarIO, readTVar,
- readTVarIO, writeTVar)
-import Control.Exception (assert)
-import Control.Monad (liftM, when, join, unless, void)
+import Control.Concurrent.Async (Concurrently (..))
+import Control.Concurrent.MVar.Lifted (modifyMVar, newMVar)
+import Control.Concurrent.STM (TVar, atomically, modifyTVar,
+ newTVarIO, readTVar,
+ readTVarIO, writeTVar)
+import Control.Exception (assert)
+import Control.Monad (join, liftM, unless, void,
+ when)
import Control.Monad.Catch
import Control.Monad.IO.Class
import Control.Monad.Logger
-import Control.Monad.Reader (asks)
-import Control.Monad.Reader (runReaderT)
+import Control.Monad.Reader (asks)
+import Control.Monad.Reader (runReaderT)
import Control.Monad.Trans.Control
-import Crypto.Hash (SHA512(..))
-import Data.ByteString (ByteString)
-import qualified Data.ByteString as S
-import qualified Data.ByteString.Lazy as L
-import Data.Either (partitionEithers)
-import qualified Data.Foldable as F
-import Data.Function (fix)
-import Data.IORef (newIORef, readIORef, writeIORef)
-import Data.List (intercalate)
-import Data.Map (Map)
-import qualified Data.Map as Map
-import Data.Maybe (maybeToList)
-import Data.Monoid ((<>))
-import Data.Set (Set)
-import qualified Data.Set as Set
-import qualified Data.Text as T
-import Data.Text.Encoding (decodeUtf8)
-import Data.Typeable (Typeable)
-import Data.Word (Word64)
+import Crypto.Hash (SHA512 (..))
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as S
+import qualified Data.ByteString.Lazy as L
+import Data.Either (partitionEithers)
+import qualified Data.Foldable as F
+import Data.Function (fix)
+import Data.IORef (newIORef, readIORef,
+ writeIORef)
+import Data.List (intercalate, intersperse)
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Maybe (maybeToList, catMaybes)
+import Data.Monoid ((<>))
+import Data.Set (Set)
+import qualified Data.Set as Set
+import qualified Data.Text as T
+import Data.Text.Encoding (decodeUtf8)
+import Data.Typeable (Typeable)
+import Data.Word (Word64)
import Network.HTTP.Download
import Path
+import Path.IO (dirExists, createTree)
import Prelude -- Fix AMP warning
import Stack.GhcPkg
import Stack.PackageIndex
import Stack.Types
-import System.Directory (canonicalizePath,
- createDirectoryIfMissing,
- doesDirectoryExist,
- renameDirectory)
-import System.FilePath ((<.>))
-import qualified System.FilePath as FP
-import System.IO (IOMode (ReadMode),
- SeekMode (AbsoluteSeek),
- hSeek, withBinaryFile)
+import System.Directory (canonicalizePath,
+ createDirectoryIfMissing,
+ doesDirectoryExist,
+ renameDirectory)
+import System.FilePath ((<.>))
+import qualified System.FilePath as FP
+import System.IO (IOMode (ReadMode),
+ SeekMode (AbsoluteSeek), hSeek,
+ withBinaryFile)
+import System.PosixCompat (setFileMode)
data FetchException
= Couldn'tReadIndexTarball FilePath Tar.FormatError
@@ -170,12 +175,12 @@
return $ alreadyUnpacked <> nowUnpacked
data ResolvedPackage = ResolvedPackage
- { rpCache :: !PackageCache
- , rpIndex :: !PackageIndex
+ { rpCache :: !PackageCache
+ , rpIndex :: !PackageIndex
}
-- | Resolve a set of package names and identifiers into @FetchPackage@ values.
-resolvePackages :: (MonadIO m, MonadReader env m, HasHttpManager env, HasConfig env, MonadLogger m, MonadThrow m, MonadBaseControl IO m, MonadCatch m)
+resolvePackages :: (MonadIO m, MonadReader env m, HasHttpManager env, HasConfig env, MonadLogger m, MonadBaseControl IO m, MonadCatch m)
=> EnvOverride
-> Set PackageIdentifier
-> Set PackageName
@@ -274,39 +279,72 @@
runInBase <- liftBaseWith $ \run -> return (void . run)
-- TODO in the future, keep all of the necessary @Handle@s open
- let doLookup ident = do
- eres <- doLookup' ident
+ let doLookup :: PackageIdentifier
+ -> IO ByteString
+ doLookup ident = do
+ cachesCurr <- liftIO $ readIORef icaches
+ eres <- lookupPackageIdentifierExact ident env cachesCurr
case eres of
- Right bs -> return bs
+ Just bs -> return bs
-- Update the cache and try again
- Left e -> join $ modifyMVar updateRef $ \toUpdate ->
- if toUpdate
- then do
+ Nothing -> do
+ let fuzzy = fuzzyLookupCandidates ident cachesCurr
+ fuzzyCandidatesText = case fuzzy of
+ Nothing -> ""
+ Just cs -> "Possible candidates: "
+ <> commaSeparatedIdents cs
+ <> ". "
+ join $ modifyMVar updateRef $ \toUpdate ->
+ if toUpdate then do
runInBase $ do
$logInfo $ T.concat
[ "Didn't see "
, T.pack $ packageIdentifierString ident
- , " in your package indices, updating and trying again"
+ , " in your package indices. "
+ , T.pack fuzzyCandidatesText
+ , "Updating and trying again."
]
updateAllIndices menv
caches <- getPackageCaches menv
liftIO $ writeIORef icaches caches
return (False, doLookup ident)
- else return (toUpdate, throwM e)
+ else return (toUpdate, throwM (unknownIdent ident))
+ inner doLookup
+ where
+ unknownIdent = UnknownPackageIdentifiers . Set.singleton
+ commaSeparatedIdents = F.fold . intersperse ", " . map packageIdentifierString
- doLookup' ident = do
- caches <- liftIO $ readIORef icaches
- case Map.lookup ident caches of
- Nothing ->
- return $ Left $ UnknownPackageIdentifiers $ Set.singleton ident
- Just (index, cache) -> do
- [bs] <- flip runReaderT env
- $ withCabalFiles (indexName index) [(ident, cache, ())]
- $ \_ _ bs -> return bs
- return $ Right bs
+type PackageCaches = Map PackageIdentifier (PackageIndex, PackageCache)
- inner doLookup
+lookupPackageIdentifierExact :: HasConfig env
+ => PackageIdentifier -> env -> PackageCaches
+ -> IO (Maybe ByteString)
+lookupPackageIdentifierExact ident env caches = do
+ case Map.lookup ident caches of
+ Nothing -> return Nothing
+ Just (index, cache) -> do
+ [bs] <- flip runReaderT env
+ $ withCabalFiles (indexName index) [(ident, cache, ())]
+ $ \_ _ bs -> return bs
+ return $ Just bs
+-- TODO: use 'Maybe (NonEmpty PackageIdentifier)' return-type
+fuzzyLookupCandidates :: PackageIdentifier -> PackageCaches
+ -> Maybe [PackageIdentifier]
+fuzzyLookupCandidates (PackageIdentifier name ver) caches =
+ if null sameMajor then Nothing else Just (map fst sameMajor)
+ where
+ sameMajor = filter (\(PackageIdentifier _ v, _) ->
+ getMajorVersion ver == getMajorVersion v)
+ sameIdentCaches
+ sameIdentCaches = maybe biggerFiltered
+ (\z -> (zeroIdent, z) : biggerFiltered)
+ zeroVer
+ biggerFiltered = takeWhile (\(PackageIdentifier n _, _) -> name == n)
+ (Map.toList bigger)
+ zeroIdent = PackageIdentifier name (fromMajorVersion (MajorVersion 0 0))
+ (_, zeroVer, bigger) = Map.splitLookup zeroIdent caches
+
-- | Figure out where to fetch from.
getToFetch :: (MonadThrow m, MonadIO m, MonadReader env m, HasConfig env)
=> Maybe (Path Abs Dir) -- ^ directory to unpack into, @Nothing@ means no unpack
@@ -327,7 +365,7 @@
case mdestDir of
Nothing -> return Nothing
Just destDir -> do
- exists <- liftIO $ doesDirectoryExist $ toFilePath destDir
+ exists <- dirExists destDir
return $ if exists then Just destDir else Nothing
case mexists of
Just destDir -> return $ Right (ident, destDir)
@@ -396,8 +434,9 @@
{ drRequest = req
, drHashChecks = map toHashCheck $ maybeToList (tfSHA512 toFetch)
, drLengthCheck = fmap fromIntegral $ tfSize toFetch
+ , drRetryPolicy = drRetryPolicyDefault
}
- let progressSink = do
+ let progressSink _ = do
liftIO $ runInBase $ $logInfo $ packageIdentifierText ident <> ": download"
_ <- verifiedDownload downloadReq destpath progressSink
@@ -419,7 +458,19 @@
wrap :: Exception e => e -> FetchException
wrap = Couldn'tReadPackageTarball fp . toException
identStr = packageIdentifierString ident
+
+ getPerms :: Tar.Entry -> (FilePath, Tar.Permissions)
+ getPerms e = (dest FP. Tar.fromTarPath (Tar.entryTarPath e),
+ Tar.entryPermissions e)
+
+ filePerms :: [(FilePath, Tar.Permissions)]
+ filePerms = catMaybes $ Tar.foldEntries (\e -> (:) (Just $ getPerms e))
+ [] (const []) entries
Tar.unpack dest entries
+ -- Reset file permissions as they were in the tarball
+ mapM_ (\(fp', perm) -> setFileMode
+ (FP.dropTrailingPathSeparator fp')
+ perm) filePerms
case mdistDir of
Nothing -> return ()
@@ -435,9 +486,7 @@
-- https://github.com/commercialhaskell/stack/issues/216
--
-- Instead, use Path which is a bit more resilient
- newDist' <- parseAbsDir newDist
- createDirectoryIfMissing True
- $ toFilePath $ parent newDist'
+ createTree . parent =<< parseAbsDir newDist
renameDirectory oldDist newDist
let cabalFP =
diff --git a/src/Stack/GhcPkg.hs b/src/Stack/GhcPkg.hs
--- a/src/Stack/GhcPkg.hs
+++ b/src/Stack/GhcPkg.hs
@@ -16,7 +16,9 @@
,unregisterGhcPkgId
,getCabalPkgVer
,findGhcPkgHaddockHtml
- ,findGhcPkgDepends)
+ ,findGhcPkgDepends
+ ,findTransitiveGhcPkgDepends
+ ,listGhcPkgDbs)
where
import Control.Monad
@@ -28,16 +30,17 @@
import Data.Either
import Data.List
import Data.Maybe
+import Data.Set (Set)
+import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Path (Path, Abs, Dir, toFilePath, parent, parseAbsDir)
+import Path.IO (dirExists, createTree)
import Prelude hiding (FilePath)
-import Stack.Build.Types (StackBuildException (Couldn'tFindPkgId))
import Stack.Constants
import Stack.Types
-import System.Directory (createDirectoryIfMissing, doesDirectoryExist, canonicalizePath,
- doesDirectoryExist)
+import System.Directory (canonicalizePath, doesDirectoryExist)
import System.Process.Read
-- | Get the global package database
@@ -78,14 +81,13 @@
createDatabase :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadThrow m)
=> EnvOverride -> Path Abs Dir -> m ()
createDatabase menv db = do
- let db' = toFilePath db
- exists <- liftIO $ doesDirectoryExist db'
+ exists <- dirExists db
unless exists $ do
-- Creating the parent doesn't seem necessary, as ghc-pkg
-- seems to be sufficiently smart. But I don't feel like
-- finding out it isn't the hard way
- liftIO $ createDirectoryIfMissing True $ toFilePath $ parent db
- _ <- tryProcessStdout Nothing menv "ghc-pkg" ["init", db']
+ createTree (parent db)
+ _ <- tryProcessStdout Nothing menv "ghc-pkg" ["init", toFilePath db]
return ()
-- | Get the necessary ghc-pkg flags for setting up the given package database
@@ -146,6 +148,27 @@
return (parseAbsDir path')
_ -> return Nothing
+-- | Finds dependencies of package, and all their dependencies, etc.
+findTransitiveGhcPkgDepends
+ :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadThrow m)
+ => EnvOverride
+ -> [Path Abs Dir] -- ^ package databases
+ -> PackageIdentifier
+ -> m (Set PackageIdentifier)
+findTransitiveGhcPkgDepends menv pkgDbs pkgId0 =
+ go pkgId0 Set.empty
+ where
+ go pkgId res = do
+ deps <- findGhcPkgDepends menv pkgDbs pkgId
+ loop (map ghcPkgIdPackageIdentifier deps) res
+ loop [] res = return res
+ loop (dep:deps) res = do
+ if Set.member dep res
+ then loop deps res
+ else do
+ res' <- go dep (Set.insert dep res)
+ loop deps (Set.union res res')
+
-- | Get the dependencies of the package.
findGhcPkgDepends :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadThrow m)
=> EnvOverride
@@ -183,3 +206,17 @@
maybe
(throwM $ Couldn'tFindPkgId cabalPackageName)
(return . packageIdentifierVersion . ghcPkgIdPackageIdentifier)
+
+listGhcPkgDbs
+ :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadThrow m)
+ => EnvOverride -> [Path Abs Dir] -> m [PackageIdentifier]
+listGhcPkgDbs menv pkgDbs = do
+ result <-
+ ghcPkg
+ menv
+ pkgDbs
+ ["list", "--simple-output"]
+ return $
+ case result of
+ Left{} -> []
+ Right lbs -> mapMaybe parsePackageIdentifier (S8.words lbs)
diff --git a/src/Stack/Ghci.hs b/src/Stack/Ghci.hs
new file mode 100644
--- /dev/null
+++ b/src/Stack/Ghci.hs
@@ -0,0 +1,135 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE RecordWildCards #-}
+
+-- | Run a GHCi configured with the user's project(s).
+
+module Stack.Ghci where
+
+import Control.Monad.Catch
+import Control.Monad.IO.Class
+import Control.Monad.Logger
+import Control.Monad.Reader
+import Control.Monad.Trans.Control (MonadBaseControl)
+import Data.List
+import qualified Data.Map.Strict as M
+import Data.Maybe
+import Data.Monoid
+import Data.Set (Set)
+import qualified Data.Set as S
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Typeable
+import Distribution.ModuleName (ModuleName)
+import Distribution.Text (display)
+import Network.HTTP.Client.Conduit
+import Path
+import Path.IO
+import Stack.Build.Source
+import Stack.Constants
+import Stack.Exec
+import Stack.Package
+import Stack.Types
+
+data GhciOpts = GhciOpts
+ {ghciTargets :: [Text]
+ ,ghciArgs :: [String]
+ ,ghciGhcCommand :: FilePath
+ ,ghciNoLoadModules :: Bool
+ ,ghciAdditionalPackages :: [String]
+ } deriving (Show,Eq)
+
+-- | Launch a GHCi session for the given local project targets with the
+-- given options and configure it with the load paths and extensions
+-- of those targets.
+ghci :: (HasConfig r, HasBuildConfig r, HasHttpManager r, HasEnvConfig r, MonadReader r m, MonadIO m, MonadThrow m, MonadLogger m, MonadCatch m, MonadBaseControl IO m)
+ => GhciOpts
+ -> m ()
+ghci GhciOpts{..} = do
+ pkgs <- ghciSetup ghciTargets
+ config <- asks getBuildConfig
+ let pkgopts = concatMap ghciPkgOpts pkgs
+ srcfiles
+ | ghciNoLoadModules = []
+ | otherwise = concatMap (map display . S.toList . ghciPkgModules) pkgs
+ odir = ["-odir=" <> toFilePath (objectInterfaceDir config)
+ ,"-hidir=" <> toFilePath (objectInterfaceDir config)]
+ $logInfo
+ ("Configuring GHCi with the following packages: " <>
+ T.intercalate ", " (map (packageNameText . ghciPkgName) pkgs))
+ exec
+ defaultEnvSettings
+ ghciGhcCommand
+ ("--interactive" : odir <> pkgopts <> srcfiles <> ghciArgs)
+
+data GhciPkgInfo = GhciPkgInfo
+ { ghciPkgName :: PackageName
+ , ghciPkgOpts :: [String]
+ , ghciPkgDir :: Path Abs Dir
+ , ghciPkgModules :: Set ModuleName
+ }
+
+ghciSetup
+ :: (HasConfig r, HasHttpManager r, HasBuildConfig r, HasEnvConfig r, MonadReader r m, MonadIO m, MonadThrow m, MonadLogger m, MonadCatch m, MonadBaseControl IO m)
+ => [Text] -> m [GhciPkgInfo]
+ghciSetup targets = do
+ econfig <- asks getEnvConfig
+ bconfig <- asks getBuildConfig
+ pwd <- getWorkingDir
+ (_,_,_,sourceMap) <- loadSourceMap defaultBuildOpts
+ locals <-
+ liftM catMaybes $
+ forM (M.toList (envConfigPackages econfig)) $
+ \(dir,validWanted) ->
+ do cabalfp <- getCabalFileName dir
+ name <- parsePackageNameFromFilePath cabalfp
+ if validWanted && wanted pwd cabalfp name
+ then return (Just (name, cabalfp))
+ else return Nothing
+ let findTarget x = find ((x ==) . packageNameText . fst) locals
+ unmetTargets = filter (isNothing . findTarget) targets
+ when (not (null unmetTargets)) $ throwM (TargetsNotFound unmetTargets)
+ forM locals $
+ \(name,cabalfp) ->
+ do let config =
+ PackageConfig
+ { packageConfigEnableTests = True
+ , packageConfigEnableBenchmarks = True
+ , packageConfigFlags = localFlags mempty bconfig name
+ , packageConfigGhcVersion = envConfigGhcVersion econfig
+ , packageConfigPlatform = configPlatform
+ (getConfig bconfig)
+ }
+ pkg <- readPackage config cabalfp
+ pkgOpts <-
+ getPackageOpts (packageOpts pkg) sourceMap (map fst locals) cabalfp
+ modules <- getPackageModules (packageModules pkg) cabalfp
+ return
+ GhciPkgInfo
+ { ghciPkgName = packageName pkg
+ , ghciPkgOpts = filter (not . badForGhci) pkgOpts
+ , ghciPkgDir = parent cabalfp
+ , ghciPkgModules = modules
+ }
+ where
+ wanted pwd cabalfp name = isInWantedList || targetsEmptyAndInDir
+ where
+ isInWantedList = elem (packageNameText name) targets
+ targetsEmptyAndInDir = null targets || isParentOf (parent cabalfp) pwd
+ badForGhci :: String -> Bool
+ badForGhci x =
+ isPrefixOf "-O" x || elem x (words "-debug -threaded -ticky")
+
+data GhciSetupException =
+ TargetsNotFound [Text]
+ deriving Typeable
+
+instance Exception GhciSetupException
+instance Show GhciSetupException where
+ show (TargetsNotFound targets) = unlines
+ [ "Couldn't find targets: " ++ T.unpack (T.unwords targets)
+ , "(expecting package names)"
+ ]
diff --git a/src/Stack/Ide.hs b/src/Stack/Ide.hs
--- a/src/Stack/Ide.hs
+++ b/src/Stack/Ide.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ExtendedDefaultRules #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
@@ -13,25 +14,29 @@
import Control.Monad.IO.Class
import Control.Monad.Logger
import Control.Monad.Reader
+import Control.Monad.Trans.Control (MonadBaseControl)
import Data.Aeson
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as L
import Data.List
-import qualified Data.Map.Strict as M
import Data.Maybe
import Data.Monoid
import qualified Data.Set as S
import Data.Text (Text)
+import qualified Data.Text as T
+import Distribution.Text (display)
+import Network.HTTP.Client.Conduit
import Path
import Path.IO
-import Stack.Build.Source
import Stack.Constants
import Stack.Exec (defaultEnvSettings)
+import Stack.Ghci (GhciPkgInfo(..), ghciSetup)
import Stack.Package
import Stack.Types
import System.Directory (doesFileExist)
+import System.Environment (lookupEnv)
import System.Exit
import System.IO
import qualified System.Process as P
@@ -41,77 +46,54 @@
-- given options and configure it with the load paths and extensions
-- of those targets.
ide
- :: (HasConfig r, HasBuildConfig r, HasEnvConfig r, MonadReader r m, MonadIO m, MonadThrow m, MonadLogger m, MonadCatch m)
+ :: (HasConfig r, HasBuildConfig r, HasEnvConfig r, MonadReader r m, MonadIO m, MonadThrow m, MonadLogger m, MonadCatch m, MonadBaseControl IO m, HasHttpManager r)
=> [Text] -- ^ Targets.
-> [String] -- ^ GHC options.
-> m ()
ide targets useropts = do
- econfig <- asks getEnvConfig
- bconfig <- asks getBuildConfig
+ pkgs <- ghciSetup targets
pwd <- getWorkingDir
- pkgs <-
- liftM catMaybes $
- forM (M.toList (bcPackages bconfig)) $
- \(dir,validWanted) ->
- do cabalfp <- getCabalFileName dir
- name <- parsePackageNameFromFilePath cabalfp
- let config =
- PackageConfig
- { packageConfigEnableTests = True
- , packageConfigEnableBenchmarks = True
- , packageConfigFlags = localFlags mempty bconfig name
- , packageConfigGhcVersion = envConfigGhcVersion econfig
- , packageConfigPlatform = configPlatform
- (getConfig bconfig)
- }
- pkg <- readPackage config cabalfp
- if validWanted && wanted pwd cabalfp pkg
- then do
- pkgOpts <- getPackageOpts (packageOpts pkg) cabalfp
- srcfiles <-
- getPackageFiles (packageFiles pkg) Modules cabalfp
- dist <- distDirFromDir dir
- autogen <- return (autogenDir dist)
- paths_foo <-
- liftM
- (autogen )
- (parseRelFile
- ("Paths_" ++
- packageNameString name ++ ".hs"))
- paths_foo_exists <- fileExists paths_foo
- return
- (Just
- ( packageName pkg
- , ["--dist-dir=" <> toFilePath dist] ++
- map ("--ghc-option=" ++) (filter (not . badForGhci) pkgOpts)
- , mapMaybe
- (stripDir pwd)
- (S.toList srcfiles <>
- if paths_foo_exists
- then [paths_foo]
- else [])))
- else return Nothing
+ (pkgopts,srcfiles) <-
+ liftM mconcat $
+ forM pkgs $
+ \pkg ->
+ do dist <- distDirFromDir (ghciPkgDir pkg)
+ autogen <- return (autogenDir dist)
+ paths_foo <-
+ liftM
+ (autogen )
+ (parseRelFile
+ ("Paths_" ++
+ packageNameString (ghciPkgName pkg) ++ ".hs"))
+ paths_foo_exists <- fileExists paths_foo
+ return
+ ( ["--dist-dir=" <> toFilePath dist] ++
+ map ("--ghc-option=" ++) (ghciPkgOpts pkg)
+ , (map display (S.toList (ghciPkgModules pkg)) <>
+ (mapMaybe
+ (fmap toFilePath . stripDir pwd)
+ (if paths_foo_exists
+ then [paths_foo]
+ else []))))
localdb <- packageDatabaseLocal
depsdb <- packageDatabaseDeps
- let pkgopts = concat (map _2 pkgs)
- srcfiles = concatMap (map toFilePath . _3) pkgs
- pkgdbs =
+ mpath <- liftIO $ lookupEnv "PATH"
+ bindirs <- extraBinDirs `ap` return True {- include local bin -}
+ let pkgdbs =
["--package-db=" <> toFilePath depsdb <> ":" <> toFilePath localdb]
- exec
- "stack-ide"
- (["--local-work-dir="++toFilePath pwd] ++
- map ("--ghc-option=" ++) (filter (not . badForGhci) useropts) <> pkgopts <> pkgdbs)
- (encode (initialRequest srcfiles))
- where
- wanted pwd cabalfp pkg = isInWantedList || targetsEmptyAndInDir
- where
- isInWantedList = elem (packageNameText (packageName pkg)) targets
- targetsEmptyAndInDir = null targets || isParentOf (parent cabalfp) pwd
- badForGhci x =
- isPrefixOf "-O" x || elem x (words "-debug -threaded -ticky")
- _1 (x,_,_) = x
- _2 (_,x,_) = x
- _3 (_,_,x) = x
+ paths =
+ [ "--ide-backend-tools-path=" <>
+ intercalate ":" (map toFilePath bindirs) <>
+ (maybe "" (':' :) mpath)]
+ args =
+ ["--verbose"] <> ["--local-work-dir=" ++ toFilePath pwd] <>
+ map ("--ghc-option=" ++) useropts <>
+ paths <>
+ pkgopts <>
+ pkgdbs
+ let initialStdin = encode (initialRequest srcfiles)
+ $logDebug $ "Initial stack-ide request: " <> T.pack (show initialStdin)
+ exec "stack-ide" args initialStdin
-- | Make the initial request.
initialRequest :: [FilePath] -> Value
diff --git a/src/Stack/Image.hs b/src/Stack/Image.hs
new file mode 100644
--- /dev/null
+++ b/src/Stack/Image.hs
@@ -0,0 +1,217 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+-- | This module builds Docker (OpenContainer) images.
+module Stack.Image
+ (stageContainerImageArtifacts, createContainerImageFromStage,
+ imgCmdName, imgDockerCmdName, imgOptsFromMonoid,
+ imgDockerOptsFromMonoid, imgOptsParser, imgDockerOptsParser)
+ where
+
+import Control.Applicative
+import Control.Exception.Lifted hiding (finally)
+import Control.Monad
+import Control.Monad.Catch hiding (bracket)
+import Control.Monad.IO.Class
+import Control.Monad.Logger
+import Control.Monad.Reader
+import Control.Monad.Trans.Control
+import Data.Char (toLower)
+import qualified Data.Map.Strict as Map
+import Data.Maybe
+import Data.Monoid
+import qualified Data.Text as T
+import Data.Typeable
+import Options.Applicative
+import Path
+import Path.IO
+import Stack.Constants
+import Stack.Types
+import Stack.Types.Internal
+import System.FilePath (dropTrailingPathSeparator)
+import System.Process
+
+type Build e m = (HasBuildConfig e, HasConfig e, HasEnvConfig e, HasTerminal e, MonadBaseControl IO m, MonadCatch m, MonadIO m, MonadLogger m, MonadReader e m)
+
+type Assemble e m = (HasConfig e, HasTerminal e, MonadBaseControl IO m, MonadCatch m, MonadIO m, MonadLogger m, MonadMask m, MonadReader e m)
+
+-- | Stages the executables & additional content in a staging
+-- directory under '.stack-work'
+stageContainerImageArtifacts :: Build e m
+ => m ()
+stageContainerImageArtifacts = do
+ imageDir <- imageStagingDir <$> getWorkingDir
+ createTree imageDir
+ stageExesInDir imageDir
+ syncAddContentToDir imageDir
+
+-- | Builds a Docker (OpenContainer) image extending the `base` image
+-- specified in the project's stack.yaml. Then new image will be
+-- extended with an ENTRYPOINT specified for each `entrypoint` listed
+-- in the config file.
+createContainerImageFromStage :: Assemble e m
+ => m ()
+createContainerImageFromStage = do
+ imageDir <- imageStagingDir <$> getWorkingDir
+ createDockerImage imageDir
+ extendDockerImageWithEntrypoint imageDir
+
+-- | Stage all the Package executables in the usr/local/bin
+-- subdirectory of a temp directory.
+stageExesInDir :: Build e m => Path Abs Dir -> m ()
+stageExesInDir dir = do
+ srcBinPath <-
+ ( $(mkRelDir "bin")) <$>
+ installationRootLocal
+ let destBinPath = dir
+ $(mkRelDir "usr/local/bin")
+ createTree destBinPath
+ copyDirectoryRecursive srcBinPath destBinPath
+
+-- | Add any additional files into the temp directory, respecting the
+-- (Source, Destination) mapping.
+syncAddContentToDir :: Build e m => Path Abs Dir -> m ()
+syncAddContentToDir dir = do
+ config <- asks getConfig
+ bconfig <- asks getBuildConfig
+ let imgAdd = maybe Map.empty imgDockerAdd (imgDocker (configImage config))
+ forM_
+ (Map.toList imgAdd)
+ (\(source,dest) ->
+ do sourcePath <- parseRelDir source
+ destPath <- parseAbsDir dest
+ let destFullPath = dir dropRoot destPath
+ createTree destFullPath
+ copyDirectoryRecursive
+ (bcRoot bconfig sourcePath)
+ destFullPath)
+
+-- | Derive an image name from the project directory.
+imageName :: Path Abs Dir -> String
+imageName = map toLower . dropTrailingPathSeparator . toFilePath . dirname
+
+-- | Create a general purpose docker image from the temporary
+-- directory of executables & static content.
+createDockerImage :: Assemble e m => Path Abs Dir -> m ()
+createDockerImage dir = do
+ config <- asks getConfig
+ let dockerConfig = imgDocker (configImage config)
+ case imgDockerBase =<< dockerConfig of
+ Nothing -> throwM StackImageDockerBaseUnspecifiedException
+ Just base -> do
+ liftIO
+ (do writeFile
+ (toFilePath
+ (dir
+ $(mkRelFile "Dockerfile")))
+ (unlines ["FROM " ++ base, "ADD ./ /"])
+ callProcess
+ "docker"
+ [ "build"
+ , "-t"
+ , fromMaybe
+ (imageName (parent (parent dir)))
+ (imgDockerImageName =<< dockerConfig)
+ , toFilePath dir])
+
+-- | Extend the general purpose docker image with entrypoints (if
+-- specified).
+extendDockerImageWithEntrypoint :: Assemble e m => Path Abs Dir -> m ()
+extendDockerImageWithEntrypoint dir = do
+ config <- asks getConfig
+ let dockerConfig = imgDocker (configImage config)
+ let dockerImageName = fromMaybe
+ (imageName (parent (parent dir)))
+ (imgDockerImageName =<< dockerConfig)
+ let imgEntrypoints = maybe Nothing imgDockerEntrypoints dockerConfig
+ case imgEntrypoints of
+ Nothing -> return ()
+ Just eps -> do
+ forM_
+ eps
+ (\ep ->
+ liftIO
+ (do writeFile
+ (toFilePath
+ (dir
+ $(mkRelFile "Dockerfile")))
+ (unlines
+ [ "FROM " ++ dockerImageName
+ , "ENTRYPOINT [\"/usr/local/bin/" ++
+ ep ++ "\"]"
+ , "CMD []"])
+ callProcess
+ "docker"
+ [ "build"
+ , "-t"
+ , dockerImageName ++ "-" ++ ep
+ , toFilePath dir]))
+
+-- | The command name for dealing with images.
+imgCmdName :: String
+imgCmdName = "image"
+
+-- | The command name for building a docker container.
+imgDockerCmdName :: String
+imgDockerCmdName = "container"
+
+-- | A parser for ImageOptsMonoid.
+imgOptsParser :: Parser ImageOptsMonoid
+imgOptsParser = ImageOptsMonoid <$>
+ optional
+ (subparser
+ (command
+ imgDockerCmdName
+ (info
+ imgDockerOptsParser
+ (progDesc "Create a container image (EXPERIMENTAL)"))))
+
+-- | A parser for ImageDockerOptsMonoid.
+imgDockerOptsParser :: Parser ImageDockerOptsMonoid
+imgDockerOptsParser = ImageDockerOptsMonoid <$>
+ optional
+ (option
+ str
+ (long (imgDockerCmdName ++ "-" ++ T.unpack imgDockerBaseArgName) <>
+ metavar "NAME" <>
+ help "Docker base image name")) <*>
+ pure Nothing <*>
+ pure Nothing <*>
+ pure Nothing
+
+-- | Convert image opts monoid to image options.
+imgOptsFromMonoid :: ImageOptsMonoid -> ImageOpts
+imgOptsFromMonoid ImageOptsMonoid{..} = ImageOpts
+ { imgDocker = imgDockerOptsFromMonoid <$> imgMonoidDocker
+ }
+
+-- | Convert Docker image opts monoid to Docker image options.
+imgDockerOptsFromMonoid :: ImageDockerOptsMonoid -> ImageDockerOpts
+imgDockerOptsFromMonoid ImageDockerOptsMonoid{..} = ImageDockerOpts
+ { imgDockerBase = emptyToNothing imgDockerMonoidBase
+ , imgDockerEntrypoints = emptyToNothing imgDockerMonoidEntrypoints
+ , imgDockerAdd = fromMaybe Map.empty imgDockerMonoidAdd
+ , imgDockerImageName = emptyToNothing imgDockerMonoidImageName
+ }
+ where emptyToNothing Nothing = Nothing
+ emptyToNothing (Just s)
+ | null s =
+ Nothing
+ | otherwise =
+ Just s
+
+-- | Stack image exceptions.
+data StackImageException =
+ StackImageDockerBaseUnspecifiedException
+ deriving (Typeable)
+
+instance Exception StackImageException
+
+instance Show StackImageException where
+ show StackImageDockerBaseUnspecifiedException = "You must specify a base docker image on which to place your haskell executables."
diff --git a/src/Stack/Init.hs b/src/Stack/Init.hs
--- a/src/Stack/Init.hs
+++ b/src/Stack/Init.hs
@@ -6,21 +6,22 @@
( findCabalFiles
, initProject
, InitOpts (..)
- , initOptsParser
- , readResolver
+ , SnapPref (..)
+ , Method (..)
+ , makeConcreteResolver
) where
import Control.Exception (assert)
import Control.Exception.Enclosed (handleIO, catchAny)
import Control.Monad (liftM, when)
-import Control.Monad.Catch (MonadMask, throwM)
+import Control.Monad.Catch (MonadMask, throwM, MonadThrow)
import Control.Monad.IO.Class
import Control.Monad.Logger
-import Control.Monad.Reader (MonadReader)
+import Control.Monad.Reader (MonadReader, asks)
import Control.Monad.Trans.Control (MonadBaseControl)
import qualified Data.IntMap as IntMap
-import Data.List (sort)
-import Data.List (isSuffixOf)
+import Data.List (isSuffixOf,sort)
+import Data.List.Extra (nubOrd)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (mapMaybe)
@@ -31,8 +32,6 @@
import qualified Data.Yaml as Yaml
import qualified Distribution.PackageDescription as C
import Network.HTTP.Client.Conduit (HasHttpManager)
-import Options.Applicative
-import Options.Applicative.Types (readerAsk)
import Path
import Path.Find
import Path.IO
@@ -61,10 +60,10 @@
-- | Generate stack.yaml
initProject :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, MonadBaseControl IO m)
- => InitOpts
+ => Path Abs Dir
+ -> InitOpts
-> m ()
-initProject initOpts = do
- currDir <- getWorkingDir
+initProject currDir initOpts = do
let dest = currDir stackDotYaml
dest' = toFilePath dest
exists <- fileExists dest
@@ -101,7 +100,7 @@
Just rel -> toFilePath rel
, peSubdirs = []
}
- $logInfo $ "Selected resolver: " <> renderResolver r
+ $logInfo $ "Selected resolver: " <> resolverName r
liftIO $ Yaml.encodeFile dest' p
$logInfo $ "Wrote project config to: " <> T.pack dest'
@@ -144,17 +143,19 @@
Just (snap, flags) ->
return (ResolverSnapshot snap, flags, Map.empty)
Nothing -> throwM $ NoMatchingSnapshot names
- MethodResolver resolver -> do
+ MethodResolver aresolver -> do
+ resolver <- makeConcreteResolver aresolver
mpair <-
case resolver of
ResolverSnapshot name -> findBuildPlan gpds [name]
ResolverGhc _ -> return Nothing
+ ResolverCustom _ _ -> return Nothing
case mpair of
Just (snap, flags) ->
return (ResolverSnapshot snap, flags, Map.empty)
Nothing -> return (resolver, Map.empty, Map.empty)
MethodSolver -> do
- (ghcVersion, extraDeps) <- cabalSolver (map parent cabalfps) []
+ (ghcVersion, extraDeps) <- cabalSolver (map parent cabalfps) Map.empty []
return
( ResolverGhc ghcVersion
, Map.filter (not . Map.null) $ fmap snd extraDeps
@@ -199,7 +200,7 @@
{ ioMethod :: !Method
-- ^ Preferred snapshots
, forceOverwrite :: Bool
- -- ^ Force overwrite of existing stack.yaml
+ -- ^ Overwrite existing files
, includeSubDirs :: Bool
-- ^ If True, include all .cabal files found in any sub directories
}
@@ -207,56 +208,34 @@
data SnapPref = PrefNone | PrefLTS | PrefNightly
-- | Method of initializing
-data Method = MethodSnapshot SnapPref | MethodResolver Resolver | MethodSolver
-
-initOptsParser :: Parser InitOpts
-initOptsParser =
- InitOpts <$> method <*> overwrite <*> fmap not ignoreSubDirs
- where
- ignoreSubDirs = flag False
- True
- (long "ignore-subdirs" <>
- help "Do not search for .cabal files in sub directories")
- overwrite = flag False
- True
- (long "force" <>
- help "Force overwriting of an existing stack.yaml if it exists")
- method = solver
- <|> (MethodResolver <$> resolver)
- <|> (MethodSnapshot <$> snapPref)
-
- solver =
- flag' MethodSolver
- (long "solver" <>
- help "Use a dependency solver to determine dependencies")
-
- snapPref =
- flag' PrefLTS
- (long "prefer-lts" <>
- help "Prefer LTS snapshots over Nightly snapshots") <|>
- flag' PrefNightly
- (long "prefer-nightly" <>
- help "Prefer Nightly snapshots over LTS snapshots") <|>
- pure PrefNone
-
- resolver = option readResolver
- (long "resolver" <>
- metavar "RESOLVER" <>
- help "Use the given resolver, even if not all dependencies are met")
-
-readResolver :: ReadM Resolver
-readResolver = do
- s <- readerAsk
- case parseResolver $ T.pack s of
- Left e -> readerError $ show e
- Right x -> return x
+data Method = MethodSnapshot SnapPref | MethodResolver AbstractResolver | MethodSolver
--- | Same semantics as @nub@, but more efficient by using the @Ord@ constraint.
-nubOrd :: Ord a => [a] -> [a]
-nubOrd =
- go Set.empty
- where
- go _ [] = []
- go s (x:xs)
- | x `Set.member` s = go s xs
- | otherwise = x : go (Set.insert x s) xs
+-- | Turn an 'AbstractResolver' into a 'Resolver'.
+makeConcreteResolver :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m, HasHttpManager env, MonadLogger m)
+ => AbstractResolver
+ -> m Resolver
+makeConcreteResolver (ARResolver r) = return r
+makeConcreteResolver ar = do
+ snapshots <- getSnapshots
+ r <-
+ case ar of
+ ARResolver r -> assert False $ return r
+ ARGlobal -> do
+ stackRoot <- asks $ configStackRoot . getConfig
+ let fp = implicitGlobalDir stackRoot stackDotYaml
+ (ProjectAndConfigMonoid project _, _warnings) <-
+ liftIO (Yaml.decodeFileEither $ toFilePath fp)
+ >>= either throwM return
+ return $ projectResolver project
+ ARLatestNightly -> return $ ResolverSnapshot $ Nightly $ snapshotsNightly snapshots
+ ARLatestLTSMajor x ->
+ case IntMap.lookup x $ snapshotsLts snapshots of
+ Nothing -> error $ "No LTS release found with major version " ++ show x
+ Just y -> return $ ResolverSnapshot $ LTS x y
+ ARLatestLTS
+ | IntMap.null $ snapshotsLts snapshots -> error $ "No LTS releases found"
+ | otherwise ->
+ let (x, y) = IntMap.findMax $ snapshotsLts snapshots
+ in return $ ResolverSnapshot $ LTS x y
+ $logInfo $ "Selected resolver: " <> resolverName r
+ return r
diff --git a/src/Stack/New.hs b/src/Stack/New.hs
--- a/src/Stack/New.hs
+++ b/src/Stack/New.hs
@@ -1,42 +1,291 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+-- | Create new a new project directory populated with a basic working
+-- project.
+
module Stack.New
- ( newProject
- ) where
+ ( new
+ , NewOpts(..)
+ , defaultTemplateName
+ , templateNameArgument
+ , getTemplates
+ , TemplateName
+ , listTemplates)
+ where
-import Control.Monad (filterM, forM_, unless)
-import Control.Monad.IO.Class (MonadIO, liftIO)
-import Control.Monad.Logger (MonadLogger, logInfo)
-import Data.ByteString (ByteString)
-import qualified Data.ByteString as S
-import Data.FileEmbed (embedDir)
-import Data.Map (Map)
-import qualified Data.Map as Map
-import qualified Data.Text as T
-import System.Directory (createDirectoryIfMissing,
- doesFileExist)
-import System.FilePath (takeDirectory)
+import Control.Monad
+import Control.Monad.Catch
+import Control.Monad.IO.Class
+import Control.Monad.Logger
+import Control.Monad.Reader
+import Control.Monad.Trans.Writer.Strict
+import Data.Aeson
+import Data.Aeson.Types
+import qualified Data.ByteString.Lazy as LB
+import qualified Data.ByteString.Lazy.Char8 as L8
+import Data.Conduit
+import Data.List
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as M
+import Data.Maybe
+import Data.Monoid
+import Data.Set (Set)
+import qualified Data.Set as S
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
+import qualified Data.Text.IO as T
+import qualified Data.Text.Lazy as LT
+import Data.Typeable
+import Network.HTTP.Client.Conduit hiding (path)
+import Network.HTTP.Download
+import Network.HTTP.Types.Status
+import Path
+import Path.IO
+import Stack.Constants
+import Stack.Types
+import Stack.Types.TemplateName
+import System.Process.Run
+import Text.Hastache
+import Text.Hastache.Context
+import Text.ProjectTemplate
-newProject :: (MonadIO m, MonadLogger m)
- => m ()
-newProject = do
- $logInfo "NOTE: Currently stack new functionality is very rudimentary"
- $logInfo "There are plans to make this feature more useful in the future"
- $logInfo "For more information, see: https://github.com/commercialhaskell/stack/issues/137"
- $logInfo "For now, we'll just be generating a basic project structure in your current directory"
+--------------------------------------------------------------------------------
+-- Main project creation
- exist <- filterM (liftIO . doesFileExist) (Map.keys files)
- unless (null exist) $
- error $ unlines
- $ "The following files already exist, refusing to overwrite:"
- : map ("- " ++) exist
+-- | Options for creating a new project.
+data NewOpts = NewOpts
+ { newOptsProjectName :: PackageName -- ^ Name of the project to create.
+ , newOptsTemplate :: TemplateName -- ^ Name of the template to use.
+ }
- $logInfo ""
- forM_ (Map.toList files) $ \(fp, bs) -> do
- $logInfo $ T.pack $ "Writing: " ++ fp
- liftIO $ do
- createDirectoryIfMissing True $ takeDirectory fp
- S.writeFile fp bs
+-- | Create a new project with the given options.
+new
+ :: (HasConfig r, MonadReader r m, MonadLogger m, MonadCatch m, MonadThrow m, MonadIO m, HasHttpManager r)
+ => NewOpts -> m (Path Abs Dir)
+new opts = do
+ pwd <- getWorkingDir
+ relDir <- parseRelDir (packageNameString (newOptsProjectName opts))
+ absDir <- liftM (pwd ) (return relDir)
+ exists <- dirExists absDir
+ if exists
+ then throwM (AlreadyExists absDir)
+ else do
+ logUsing relDir
+ templateText <- loadTemplate template
+ files <- applyTemplate project absDir templateText
+ writeTemplateFiles files
+ runTemplateInits absDir
+ return absDir
+ where
+ template = newOptsTemplate opts
+ project = newOptsProjectName opts
+ logUsing relDir =
+ $logInfo
+ ("Downloading template \"" <> templateName template <>
+ "\" to create project \"" <>
+ packageNameText project <>
+ "\" in " <>
+ T.pack (toFilePath relDir) <>
+ " ...")
-files :: Map FilePath ByteString
-files = Map.fromList $(embedDir "new-template")
+-- | Download and read in a template's text content.
+loadTemplate
+ :: (HasConfig r, HasHttpManager r, MonadReader r m, MonadIO m, MonadThrow m, MonadCatch m)
+ => TemplateName -> m Text
+loadTemplate name = do
+ req <-
+ parseUrl (defaultTemplateUrl <> "/" <> toFilePath (templatePath name))
+ config <- asks getConfig
+ let path = templatesDir config templatePath name
+ _ <- catch (redownload req path) (throwM . FailedToDownloadTemplate name)
+ exists <- fileExists path
+ if exists
+ then liftIO (T.readFile (toFilePath path))
+ else throwM (FailedToLoadTemplate name path)
+
+-- | Apply and unpack a template into a directory.
+applyTemplate
+ :: (MonadIO m, MonadThrow m, MonadReader r m, HasConfig r, MonadLogger m)
+ => PackageName -> Path Abs Dir -> Text -> m (Map (Path Abs File) LB.ByteString)
+applyTemplate project dir template = do
+ config <- asks getConfig
+ displayContext config
+ applied <-
+ hastacheStr
+ defaultConfig
+ template
+ (mkStrContext (contextFunction config))
+ files :: Map FilePath LB.ByteString <-
+ execWriterT $
+ yield (T.encodeUtf8 (LT.toStrict applied)) $$
+ unpackTemplate receiveMem id
+ liftM
+ M.fromList
+ (mapM
+ (\(fp,bytes) ->
+ do path <- parseRelFile fp
+ return (dir path, bytes))
+ (M.toList files))
+ where
+ context config =
+ [ ("name", packageNameText project)
+ , ( authorEmailKey
+ , fromMaybe defaultAuthorEmail (configAuthorEmail config))
+ , (authorNameKey, fromMaybe defaultAuthorName (configAuthorName config))]
+ contextFunction :: Config -> String -> MuType m
+ contextFunction config key =
+ case lookup (T.pack key) (context config) of
+ Nothing -> MuNothing
+ Just value -> MuVariable value
+
+-- | Display the context being used for the template.
+displayContext :: MonadLogger m => Config -> m ()
+displayContext config = do
+ $logInfo "Using the following authorship configuration:"
+ $logInfo
+ (authorEmailKey <> ": " <>
+ fromMaybe defaultAuthorEmail (configAuthorEmail config))
+ $logInfo
+ (authorNameKey <> ": " <>
+ fromMaybe defaultAuthorName (configAuthorName config))
+ $logInfo
+ ("Copy these to " <> T.pack (toFilePath (globalConfigPath config)) <>
+ " and edit to use different values.")
+
+-- | Write files to the new project directory.
+writeTemplateFiles
+ :: MonadIO m
+ => Map (Path Abs File) LB.ByteString -> m ()
+writeTemplateFiles files = do
+ forM_
+ (M.toList files)
+ (\(fp,bytes) ->
+ do createTree (parent fp)
+ liftIO (LB.writeFile (toFilePath fp) bytes))
+
+-- | Run any initialization functions, such as Git.
+runTemplateInits
+ :: (MonadIO m, MonadReader r m, HasConfig r, MonadLogger m, MonadCatch m)
+ => Path Abs Dir -> m ()
+runTemplateInits dir = do
+ menv <- getMinimalEnvOverride
+ config <- asks getConfig
+ case configScmInit config of
+ Nothing -> return ()
+ Just Git ->
+ do catch
+ (callProcess (Just dir) menv "git" ["init"])
+ (\(_ :: ProcessExitedUnsuccessfully) ->
+ $logInfo "git init failed to run, ignoring ...")
+
+--------------------------------------------------------------------------------
+-- Getting templates list
+
+listTemplates
+ :: (MonadIO m, MonadThrow m, MonadReader r m, HasHttpManager r, MonadCatch m, MonadLogger m)
+ => m ()
+listTemplates = do
+ templates <- getTemplates
+ mapM_ ($logInfo . templateName) (S.toList templates)
+
+-- | Get the set of templates.
+getTemplates
+ :: (MonadIO m, MonadThrow m, MonadReader r m, HasHttpManager r, MonadCatch m)
+ => m (Set TemplateName)
+getTemplates = do
+ req <- liftM addHeaders (parseUrl defaultTemplatesList)
+ resp <- catch (httpLbs req) (throwM . FailedToDownloadTemplates)
+ case statusCode (responseStatus resp) of
+ 200 ->
+ case eitherDecode (responseBody resp) >>=
+ parseEither parseTemplateSet of
+ Left err -> throwM (BadTemplatesJSON err (responseBody resp))
+ Right value -> return value
+ code -> throwM (BadTemplatesResponse code)
+ where
+ addHeaders req =
+ req
+ { requestHeaders = [ ("User-Agent", "The Haskell Stack")
+ , ("Accept", "application/vnd.github.v3+json")] <>
+ requestHeaders req
+ }
+
+-- | Parser the set of templates from the JSON.
+parseTemplateSet :: Value -> Parser (Set TemplateName)
+parseTemplateSet a = do
+ xs <- parseJSON a
+ fmap (S.fromList . catMaybes) (mapM parseTemplate xs)
+ where
+ parseTemplate v = do
+ o <- parseJSON v
+ name <- o .: "name"
+ if isSuffixOf ".hsfiles" name
+ then case parseTemplateNameFromString name of
+ Left{} ->
+ fail ("Unable to parse template name from " <> name)
+ Right template -> return (Just template)
+ else return Nothing
+
+--------------------------------------------------------------------------------
+-- Defaults
+
+-- | The default template name you can use if you don't have one.
+defaultTemplateName :: TemplateName
+defaultTemplateName = $(mkTemplateName "new-template")
+
+-- | Default web root URL to download from.
+defaultTemplateUrl :: String
+defaultTemplateUrl =
+ "https://raw.githubusercontent.com/commercialhaskell/stack-templates/master"
+
+-- | Default web URL to list the repo contents.
+defaultTemplatesList :: String
+defaultTemplatesList =
+ "https://api.github.com/repos/commercialhaskell/stack-templates/contents/"
+
+--------------------------------------------------------------------------------
+-- Exceptions
+
+-- | Exception that might occur when making a new project.
+data NewException
+ = FailedToLoadTemplate !TemplateName
+ !(Path Abs File)
+ | FailedToDownloadTemplate !TemplateName
+ !DownloadException
+ | FailedToDownloadTemplates !HttpException
+ | BadTemplatesResponse !Int
+ | BadTemplatesJSON !String !LB.ByteString
+ | AlreadyExists !(Path Abs Dir)
+ deriving (Typeable)
+
+instance Exception NewException
+
+instance Show NewException where
+ show (FailedToLoadTemplate name path) =
+ "Failed to load download template " <> T.unpack (templateName name) <>
+ " from " <>
+ toFilePath path
+ show (FailedToDownloadTemplate name (RedownloadFailed _ _ resp)) =
+ case statusCode (responseStatus resp) of
+ 404 ->
+ "That template doesn't exist. Run `stack templates' to see a list of available templates."
+ code ->
+ "Failed to download template " <> T.unpack (templateName name) <>
+ ": unknown reason, status code was: " <>
+ show code
+ show (FailedToDownloadTemplate name _) =
+ "Failed to download template " <> T.unpack (templateName name) <>
+ ", reason unknown."
+ show (AlreadyExists path) =
+ "Directory " <> toFilePath path <> " already exists. Aborting."
+ show (FailedToDownloadTemplates ex) =
+ "Failed to download templates. The HTTP error was: " <> show ex
+ show (BadTemplatesResponse code) =
+ "Unexpected status code while retrieving templates list: " <> show code
+ show (BadTemplatesJSON err bytes) =
+ "Github returned some JSON that couldn't be parsed: " <> err <> "\n\n" <>
+ L8.unpack bytes
diff --git a/src/Stack/Options.hs b/src/Stack/Options.hs
new file mode 100644
--- /dev/null
+++ b/src/Stack/Options.hs
@@ -0,0 +1,607 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Stack.Options
+ (Command(..)
+ ,benchOptsParser
+ ,buildOptsParser
+ ,configOptsParser
+ ,dockerOptsParser
+ ,dockerCleanupOptsParser
+ ,dotOptsParser
+ ,execOptsParser
+ ,globalOptsParser
+ ,initOptsParser
+ ,newOptsParser
+ ,logLevelOptsParser
+ ,ghciOptsParser
+ ,abstractResolverOptsParser
+ ,solverOptsParser
+ ,testOptsParser
+ ) where
+
+import Control.Monad.Logger (LogLevel(..))
+import Data.Char (isSpace, toLower)
+import Data.List.Split (splitOn)
+import qualified Data.Map as Map
+import Data.Map.Strict (Map)
+import Data.Maybe
+import Data.Monoid
+import qualified Data.Set as Set
+import qualified Data.Text as T
+import Data.Text.Read (decimal)
+import Options.Applicative.Args
+import Options.Applicative.Builder.Extra
+import Options.Applicative.Simple
+import Options.Applicative.Types (readerAsk)
+import Stack.Config (packagesParser)
+import Stack.Docker
+import qualified Stack.Docker as Docker
+import Stack.Dot
+import Stack.Ghci (GhciOpts(..))
+import Stack.Init
+import Stack.New
+import Stack.Types
+
+-- | Command sum type for conditional arguments.
+data Command
+ = Build
+ | Test
+ | Haddock
+ | Bench
+ | Install
+ deriving (Eq)
+
+-- | Parser for bench arguments.
+benchOptsParser :: Parser BenchmarkOpts
+benchOptsParser = BenchmarkOpts
+ <$> optional (strOption (long "benchmark-arguments" <>
+ metavar "BENCH_ARGS" <>
+ help ("Forward BENCH_ARGS to the benchmark suite. " <>
+ "Supports templates from `cabal bench`")))
+
+addCoverageFlags :: BuildOpts -> BuildOpts
+addCoverageFlags bopts
+ | toCoverage $ boptsTestOpts bopts
+ = bopts { boptsGhcOptions = "-fhpc" : boptsGhcOptions bopts }
+ | otherwise = bopts
+
+-- | Parser for build arguments.
+buildOptsParser :: Command
+ -> Parser BuildOpts
+buildOptsParser cmd =
+ fmap addCoverageFlags $
+ BuildOpts <$> target <*> libProfiling <*> exeProfiling <*>
+ optimize <*> haddock <*> haddockDeps <*> dryRun <*> ghcOpts <*>
+ flags <*> copyBins <*> preFetch <*>
+ buildSubset <*>
+ fileWatch' <*> keepGoing <*> forceDirty <*>
+ tests <*> testOptsParser <*>
+ benches <*> benchOptsParser <*>
+ many exec
+ where optimize =
+ maybeBoolFlags "optimizations" "optimizations for TARGETs and all its dependencies" idm
+ target =
+ fmap (map T.pack)
+ (many (strArgument
+ (metavar "TARGET" <>
+ help "If none specified, use all packages")))
+ libProfiling =
+ boolFlags False
+ "library-profiling"
+ "library profiling for TARGETs and all its dependencies"
+ idm
+ exeProfiling =
+ boolFlags False
+ "executable-profiling"
+ "library profiling for TARGETs and all its dependencies"
+ idm
+ haddock =
+ boolFlags (cmd == Haddock)
+ "haddock"
+ "generating Haddocks the project(s) in this directory/configuration"
+ idm
+ haddockDeps =
+ if cmd == Haddock
+ then maybeBoolFlags
+ "haddock-deps"
+ "building Haddocks for dependencies"
+ idm
+ else pure Nothing
+
+ copyBins = boolFlags (cmd == Install)
+ "copy-bins"
+ "copying binaries to the local-bin-path (see 'stack path')"
+ idm
+
+ dryRun = flag False True (long "dry-run" <>
+ help "Don't build anything, just prepare to")
+ ghcOpts = (++)
+ <$> flag [] ["-Wall", "-Werror"]
+ ( long "pedantic"
+ <> help "Turn on -Wall and -Werror (note: option name may change in the future"
+ )
+ <*> many (fmap T.pack
+ (strOption (long "ghc-options" <>
+ metavar "OPTION" <>
+ help "Additional options passed to GHC")))
+
+ flags =
+ fmap (Map.unionsWith Map.union) $ many
+ (option readFlag
+ ( long "flag"
+ <> metavar "PACKAGE:[-]FLAG"
+ <> help "Override flags set in stack.yaml (applies to local packages and extra-deps)"
+ ))
+
+ preFetch = flag False True
+ (long "prefetch" <>
+ help "Fetch packages necessary for the build immediately, useful with --dry-run")
+
+ buildSubset =
+ flag' BSOnlySnapshot
+ (long "only-snapshot" <>
+ help "Only build packages for the snapshot database, not the local database")
+ <|> flag' BSOnlyDependencies
+ (long "only-dependencies" <>
+ help "Only build packages that are dependencies of targets on the command line")
+ <|> pure BSAll
+
+ fileWatch' = flag False True
+ (long "file-watch" <>
+ help "Watch for changes in local files and automatically rebuild")
+
+ keepGoing = maybeBoolFlags
+ "keep-going"
+ "continue running after a step fails (default: false for build, true for test/bench)"
+ idm
+
+ forceDirty = flag False True
+ (long "force-dirty" <>
+ help "Force treating all local packages as having dirty files (useful for cases where stack can't detect a file change)")
+
+
+ tests = boolFlags (cmd == Test)
+ "test"
+ "testing the project(s) in this directory/configuration"
+ idm
+
+ benches = boolFlags (cmd == Bench)
+ "bench"
+ "benchmarking the project(s) in this directory/configuration"
+ idm
+
+ exec = cmdOption
+ ( long "exec" <>
+ metavar "CMD [ARGS]" <>
+ help "Command and arguments to run after a successful build" )
+
+-- | Parser for package:[-]flag
+readFlag :: ReadM (Map (Maybe PackageName) (Map FlagName Bool))
+readFlag = do
+ s <- readerAsk
+ case break (== ':') s of
+ (pn, ':':mflag) -> do
+ pn' <-
+ case parsePackageNameFromString pn of
+ Nothing
+ | pn == "*" -> return Nothing
+ | otherwise -> readerError $ "Invalid package name: " ++ pn
+ Just x -> return $ Just x
+ let (b, flagS) =
+ case mflag of
+ '-':x -> (False, x)
+ _ -> (True, mflag)
+ flagN <-
+ case parseFlagNameFromString flagS of
+ Nothing -> readerError $ "Invalid flag name: " ++ flagS
+ Just x -> return x
+ return $ Map.singleton pn' $ Map.singleton flagN b
+ _ -> readerError "Must have a colon"
+
+-- | Command-line arguments parser for configuration.
+configOptsParser :: Bool -> Parser ConfigMonoid
+configOptsParser docker =
+ (\opts systemGHC installGHC arch os jobs includes libs skipGHCCheck skipMsys localBin -> mempty
+ { configMonoidDockerOpts = opts
+ , configMonoidSystemGHC = systemGHC
+ , configMonoidInstallGHC = installGHC
+ , configMonoidSkipGHCCheck = skipGHCCheck
+ , configMonoidArch = arch
+ , configMonoidOS = os
+ , configMonoidJobs = jobs
+ , configMonoidExtraIncludeDirs = includes
+ , configMonoidExtraLibDirs = libs
+ , configMonoidSkipMsys = skipMsys
+ , configMonoidLocalBinPath = localBin
+ })
+ <$> dockerOptsParser docker
+ <*> maybeBoolFlags
+ "system-ghc"
+ "using the system installed GHC (on the PATH) if available and a matching version"
+ idm
+ <*> maybeBoolFlags
+ "install-ghc"
+ "downloading and installing GHC if necessary (can be done manually with stack setup)"
+ idm
+ <*> optional (strOption
+ ( long "arch"
+ <> metavar "ARCH"
+ <> help "System architecture, e.g. i386, x86_64"
+ ))
+ <*> optional (strOption
+ ( long "os"
+ <> metavar "OS"
+ <> help "Operating system, e.g. linux, windows"
+ ))
+ <*> optional (option auto
+ ( long "jobs"
+ <> short 'j'
+ <> metavar "JOBS"
+ <> help "Number of concurrent jobs to run"
+ ))
+ <*> fmap (Set.fromList . map T.pack) (many $ strOption
+ ( long "extra-include-dirs"
+ <> metavar "DIR"
+ <> help "Extra directories to check for C header files"
+ ))
+ <*> fmap (Set.fromList . map T.pack) (many $ strOption
+ ( long "extra-lib-dirs"
+ <> metavar "DIR"
+ <> help "Extra directories to check for libraries"
+ ))
+ <*> maybeBoolFlags
+ "skip-ghc-check"
+ "skipping the GHC version and architecture check"
+ idm
+ <*> maybeBoolFlags
+ "skip-msys"
+ "skipping the local MSYS installation (Windows only)"
+ idm
+ <*> optional (strOption
+ ( long "local-bin-path"
+ <> metavar "DIR"
+ <> help "Install binaries to DIR"
+ ))
+
+-- | Options parser configuration for Docker.
+dockerOptsParser :: Bool -> Parser DockerOptsMonoid
+dockerOptsParser showOptions =
+ DockerOptsMonoid
+ <$> pure Nothing
+ <*> maybeBoolFlags dockerCmdName
+ "using a Docker container"
+ hide
+ <*> ((Just . DockerMonoidRepo) <$> option str (long (dockerOptName dockerRepoArgName) <>
+ hide <>
+ metavar "NAME" <>
+ help "Docker repository name") <|>
+ (Just . DockerMonoidImage) <$> option str (long (dockerOptName dockerImageArgName) <>
+ hide <>
+ metavar "IMAGE" <>
+ help "Exact Docker image ID (overrides docker-repo)") <|>
+ pure Nothing)
+ <*> maybeBoolFlags (dockerOptName dockerRegistryLoginArgName)
+ "registry requires login"
+ hide
+ <*> maybeStrOption (long (dockerOptName dockerRegistryUsernameArgName) <>
+ hide <>
+ metavar "USERNAME" <>
+ help "Docker registry username")
+ <*> maybeStrOption (long (dockerOptName dockerRegistryPasswordArgName) <>
+ hide <>
+ metavar "PASSWORD" <>
+ help "Docker registry password")
+ <*> maybeBoolFlags (dockerOptName dockerAutoPullArgName)
+ "automatic pulling latest version of image"
+ hide
+ <*> maybeBoolFlags (dockerOptName dockerDetachArgName)
+ "running a detached Docker container"
+ hide
+ <*> maybeBoolFlags (dockerOptName dockerPersistArgName)
+ "not deleting container after it exits"
+ hide
+ <*> maybeStrOption (long (dockerOptName dockerContainerNameArgName) <>
+ hide <>
+ metavar "NAME" <>
+ help "Docker container name")
+ <*> argsOption (long (dockerOptName dockerRunArgsArgName) <>
+ hide <>
+ value [] <>
+ metavar "'ARG1 [ARG2 ...]'" <>
+ help "Additional options to pass to 'docker run'")
+ <*> many (option auto (long (dockerOptName dockerMountArgName) <>
+ hide <>
+ metavar "(PATH | HOST-PATH:CONTAINER-PATH)" <>
+ help ("Mount volumes from host in container " ++
+ "(may specify mutliple times)")))
+ <*> maybeStrOption (long (dockerOptName dockerDatabasePathArgName) <>
+ hide <>
+ metavar "PATH" <>
+ help "Location of image usage tracking database")
+ where
+ dockerOptName optName = dockerCmdName ++ "-" ++ T.unpack optName
+ maybeStrOption = optional . option str
+ hide = if showOptions
+ then idm
+ else internal <> hidden
+
+-- | Parser for docker cleanup arguments.
+dockerCleanupOptsParser :: Parser Docker.CleanupOpts
+dockerCleanupOptsParser =
+ Docker.CleanupOpts <$>
+ (flag' Docker.CleanupInteractive
+ (short 'i' <>
+ long "interactive" <>
+ help "Show cleanup plan in editor and allow changes (default)") <|>
+ flag' Docker.CleanupImmediate
+ (short 'y' <>
+ long "immediate" <>
+ help "Immediately execute cleanup plan") <|>
+ flag' Docker.CleanupDryRun
+ (short 'n' <>
+ long "dry-run" <>
+ help "Display cleanup plan but do not execute") <|>
+ pure Docker.CleanupInteractive) <*>
+ opt (Just 14) "known-images" "LAST-USED" <*>
+ opt Nothing "unknown-images" "CREATED" <*>
+ opt (Just 0) "dangling-images" "CREATED" <*>
+ opt Nothing "stopped-containers" "CREATED" <*>
+ opt Nothing "running-containers" "CREATED"
+ where opt def' name mv =
+ fmap Just
+ (option auto
+ (long name <>
+ metavar (mv ++ "-DAYS-AGO") <>
+ help ("Remove " ++
+ toDescr name ++
+ " " ++
+ map toLower (toDescr mv) ++
+ " N days ago" ++
+ case def' of
+ Just n -> " (default " ++ show n ++ ")"
+ Nothing -> ""))) <|>
+ flag' Nothing
+ (long ("no-" ++ name) <>
+ help ("Do not remove " ++
+ toDescr name ++
+ case def' of
+ Just _ -> ""
+ Nothing -> " (default)")) <|>
+ pure def'
+ toDescr = map (\c -> if c == '-' then ' ' else c)
+
+-- | Parser for arguments to `stack dot`
+dotOptsParser :: Parser DotOpts
+dotOptsParser = DotOpts
+ <$> includeExternal
+ <*> includeBase
+ <*> depthLimit
+ <*> fmap (maybe Set.empty Set.fromList . fmap splitNames) prunedPkgs
+ where includeExternal = boolFlags False
+ "external"
+ "inclusion of external dependencies"
+ idm
+ includeBase = boolFlags True
+ "include-base"
+ "inclusion of dependencies on base"
+ idm
+ depthLimit =
+ optional (option auto
+ (long "depth" <>
+ metavar "DEPTH" <>
+ help ("Limit the depth of dependency resolution " <>
+ "(Default: No limit)")))
+ prunedPkgs = optional (strOption
+ (long "prune" <>
+ metavar "PACKAGES" <>
+ help ("Prune each package name " <>
+ "from the comma separated list " <>
+ "of package names PACKAGES")))
+
+ splitNames :: String -> [String]
+ splitNames = map (takeWhile (not . isSpace) . dropWhile isSpace) . splitOn ","
+
+ghciOptsParser :: Parser GhciOpts
+ghciOptsParser = GhciOpts
+ <$> fmap (map T.pack)
+ (many (strArgument
+ (metavar "TARGET" <>
+ help ("If none specified, " <>
+ "use all packages defined in current directory"))))
+ <*> fmap concat (many (argsOption (long "ghc-options" <>
+ metavar "OPTION" <>
+ help "Additional options passed to GHCi")))
+ <*> strOption (long "with-ghc" <>
+ metavar "GHC" <>
+ help "Use this command for the GHC to run" <>
+ value "ghc" <>
+ showDefault)
+ <*> flag False True (long "no-load" <>
+ help "Don't load modules on start-up")
+ <*> packagesParser
+
+
+-- | Parser for exec command
+execOptsParser :: Maybe String -- ^ command
+ -> Parser ExecOpts
+execOptsParser mcmd =
+ ExecOpts
+ <$> maybe eoCmdParser pure mcmd
+ <*> eoArgsParser
+ <*> (eoPlainParser <|>
+ ExecOptsEmbellished
+ <$> eoEnvSettingsParser
+ <*> eoPackagesParser)
+ where
+ eoCmdParser :: Parser String
+ eoCmdParser = strArgument (metavar "CMD")
+
+ eoArgsParser :: Parser [String]
+ eoArgsParser = many (strArgument (metavar "-- ARGS (e.g. stack ghc -- X.hs -o x)"))
+
+ eoEnvSettingsParser :: Parser EnvSettings
+ eoEnvSettingsParser = EnvSettings
+ <$> pure True
+ <*> boolFlags True
+ "ghc-package-path"
+ "setting the GHC_PACKAGE_PATH variable for the subprocess"
+ idm
+ <*> boolFlags True
+ "stack-exe"
+ "setting the STACK_EXE environment variable to the path for the stack executable"
+ idm
+
+ eoPackagesParser :: Parser [String]
+ eoPackagesParser = many (strOption (long "package" <> help "Additional packages that must be installed"))
+
+ eoPlainParser :: Parser ExecOptsExtra
+ eoPlainParser = flag' ExecOptsPlain
+ (long "plain" <>
+ help "Use an unmodified environment (only useful with Docker)")
+
+
+-- | Parser for global command-line options.
+globalOptsParser :: Bool -> Parser GlobalOpts
+globalOptsParser defaultTerminal =
+ GlobalOpts <$>
+ switch (long Docker.reExecArgName <>
+ hidden <>
+ internal) <*>
+ logLevelOptsParser <*>
+ configOptsParser False <*>
+ optional abstractResolverOptsParser <*>
+ flag
+ defaultTerminal
+ False
+ (long "no-terminal" <>
+ help
+ "Override terminal detection in the case of running in a false terminal") <*>
+ (optional (strOption
+ (long "stack-yaml" <>
+ metavar "STACK-YAML" <>
+ help "Override project stack.yaml file (overrides any STACK_YAML environment variable)")))
+
+initOptsParser :: Parser InitOpts
+initOptsParser =
+ InitOpts <$> method <*> overwrite <*> fmap not ignoreSubDirs
+ where
+ ignoreSubDirs = flag False
+ True
+ (long "ignore-subdirs" <>
+ help "Do not search for .cabal files in sub directories")
+ overwrite = flag False
+ True
+ (long "force" <>
+ help "Force overwriting of an existing stack.yaml if it exists")
+ method = solver
+ <|> (MethodResolver <$> resolver)
+ <|> (MethodSnapshot <$> snapPref)
+
+ solver =
+ flag' MethodSolver
+ (long "solver" <>
+ help "Use a dependency solver to determine dependencies")
+
+ snapPref =
+ flag' PrefLTS
+ (long "prefer-lts" <>
+ help "Prefer LTS snapshots over Nightly snapshots") <|>
+ flag' PrefNightly
+ (long "prefer-nightly" <>
+ help "Prefer Nightly snapshots over LTS snapshots") <|>
+ pure PrefNone
+
+ resolver = option readAbstractResolver
+ (long "resolver" <>
+ metavar "RESOLVER" <>
+ help "Use the given resolver, even if not all dependencies are met")
+
+-- | Parse for a logging level.
+logLevelOptsParser :: Parser LogLevel
+logLevelOptsParser =
+ fmap parse
+ (strOption (long "verbosity" <>
+ metavar "VERBOSITY" <>
+ help "Verbosity: silent, error, warn, info, debug")) <|>
+ flag defaultLogLevel
+ verboseLevel
+ (short 'v' <> long "verbose" <>
+ help ("Enable verbose mode: verbosity level \"" <> showLevel verboseLevel <> "\""))
+ where verboseLevel = LevelDebug
+ showLevel l =
+ case l of
+ LevelDebug -> "debug"
+ LevelInfo -> "info"
+ LevelWarn -> "warn"
+ LevelError -> "error"
+ LevelOther x -> T.unpack x
+ parse s =
+ case s of
+ "debug" -> LevelDebug
+ "info" -> LevelInfo
+ "warn" -> LevelWarn
+ "error" -> LevelError
+ _ -> LevelOther (T.pack s)
+
+-- | Parser for the resolver
+abstractResolverOptsParser :: Parser AbstractResolver
+abstractResolverOptsParser =
+ option readAbstractResolver
+ (long "resolver" <>
+ metavar "RESOLVER" <>
+ help "Override resolver in project file")
+
+readAbstractResolver :: ReadM AbstractResolver
+readAbstractResolver = do
+ s <- readerAsk
+ case s of
+ "global" -> return ARGlobal
+ "nightly" -> return ARLatestNightly
+ "lts" -> return ARLatestLTS
+ 'l':'t':'s':'-':x | Right (x', "") <- decimal $ T.pack x ->
+ return $ ARLatestLTSMajor x'
+ _ ->
+ case parseResolverText $ T.pack s of
+ Left e -> readerError $ show e
+ Right x -> return $ ARResolver x
+
+-- | Parser for @solverCmd@
+solverOptsParser :: Parser Bool
+solverOptsParser = boolFlags False
+ "modify-stack-yaml"
+ "Automatically modify stack.yaml with the solver's recommendations"
+ idm
+
+-- | Parser for test arguments.
+testOptsParser :: Parser TestOpts
+testOptsParser = TestOpts
+ <$> boolFlags True
+ "rerun-tests"
+ "running already successful tests"
+ idm
+ <*> fmap (fromMaybe [])
+ (optional (argsOption(long "test-arguments" <>
+ metavar "TEST_ARGS" <>
+ help "Arguments passed in to the test suite program")))
+ <*> flag False
+ True
+ (long "coverage" <>
+ help "Generate a code coverage report")
+ <*> flag False
+ True
+ (long "no-run-tests" <>
+ help "Disable running of tests. (Tests will still be built.)")
+
+-- | Parser for @stack new@.
+newOptsParser :: Parser (NewOpts,InitOpts)
+newOptsParser = (,) <$> newOpts <*> initOptsParser
+ where
+ newOpts =
+ NewOpts <$>
+ packageNameArgument
+ (metavar "PACKAGE_NAME" <> help "A valid package name.") <*>
+ templateNameArgument
+ (metavar "TEMPLATE_NAME" <>
+ help "Name of a template, for example: foo or foo.hsfiles" <>
+ value defaultTemplateName) <*
+ abortOption ShowHelpText (long "help" <> help "Show help text.")
diff --git a/src/Stack/Package.hs b/src/Stack/Package.hs
--- a/src/Stack/Package.hs
+++ b/src/Stack/Package.hs
@@ -29,21 +29,22 @@
,packageToolDependencies
,packageDependencies
,packageIdentifier
- ,CabalFileType(..)
,autogenDir)
where
+import Control.Arrow ((***))
import Control.Exception hiding (try,catch)
import Control.Monad
import Control.Monad.Catch
import Control.Monad.IO.Class
import Control.Monad.Logger (MonadLogger,logWarn)
import Control.Monad.Reader
-import qualified Data.ByteString as S
-import Data.Data
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Char8 as C8
import Data.Either
import Data.Function
import Data.List
+import Data.List.Extra (nubOrd)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Maybe
@@ -53,10 +54,9 @@
import qualified Data.Set as S
import Data.Text (Text)
import qualified Data.Text as T
-import Data.Text.Encoding (decodeUtf8With)
+import Data.Text.Encoding (decodeUtf8, decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)
import Distribution.Compiler
-import Distribution.InstalledPackageInfo (PError)
import Distribution.ModuleName (ModuleName)
import qualified Distribution.ModuleName as Cabal
import Distribution.Package hiding (Package,PackageName,packageName,packageVersion,PackageIdentifier)
@@ -64,133 +64,38 @@
import Distribution.PackageDescription.Parse
import Distribution.Simple.Utils
import Distribution.System (OS (..), Arch, Platform (..))
-import Distribution.Text (display)
-import Distribution.Version (intersectVersionRanges)
+import Distribution.Text (display, simpleParse)
import Path as FL
import Path.Find
import Path.IO
import Prelude hiding (FilePath)
+import Safe (headDef, tailSafe)
import Stack.Constants
import Stack.Types
import qualified Stack.Types.PackageIdentifier
-import System.Directory (getDirectoryContents)
+import System.Directory (doesFileExist, getDirectoryContents)
import System.FilePath (splitExtensions)
import qualified System.FilePath as FilePath
import System.IO.Error
--- | All exceptions thrown by the library.
-data PackageException
- = PackageInvalidCabalFile (Maybe (Path Abs File)) PError
- | PackageNoCabalFileFound (Path Abs Dir)
- | PackageMultipleCabalFilesFound (Path Abs Dir) [Path Abs File]
- | MismatchedCabalName (Path Abs File) PackageName
- deriving Typeable
-instance Exception PackageException
-instance Show PackageException where
- show (PackageInvalidCabalFile mfile err) =
- "Unable to parse cabal file" ++
- (case mfile of
- Nothing -> ""
- Just file -> ' ' : toFilePath file) ++
- ": " ++
- show err
- show (PackageNoCabalFileFound dir) =
- "No .cabal file found in directory " ++
- toFilePath dir
- show (PackageMultipleCabalFilesFound dir files) =
- "Multiple .cabal files found in directory " ++
- toFilePath dir ++
- ": " ++
- intercalate ", " (map (toFilePath . filename) files)
- show (MismatchedCabalName fp name) = concat
- [ "cabal file "
- , toFilePath fp
- , " has a mismatched package name: "
- , packageNameString name
- ]
-
--- | Some package info.
-data Package =
- Package {packageName :: !PackageName -- ^ Name of the package.
- ,packageVersion :: !Version -- ^ Version of the package
- ,packageFiles :: !GetPackageFiles
- ,packageDeps :: !(Map PackageName VersionRange) -- ^ Packages that the package depends on.
- ,packageTools :: ![Dependency] -- ^ A build tool name.
- ,packageAllDeps :: !(Set PackageName) -- ^ Original dependencies (not sieved).
- ,packageFlags :: !(Map FlagName Bool) -- ^ Flags used on package.
- ,packageHasLibrary :: !Bool -- ^ does the package have a buildable library stanza?
- ,packageTests :: !(Set Text) -- ^ names of test suites
- ,packageBenchmarks :: !(Set Text) -- ^ names of benchmarks
- ,packageExes :: !(Set Text) -- ^ names of executables
- ,packageOpts :: !GetPackageOpts -- ^ Args to pass to GHC.
- ,packageHasExposedModules :: !Bool -- ^ Does the package have exposed modules?
- ,packageSimpleType :: !Bool -- ^ Does the package of build-type: Simple
- }
- deriving (Show,Typeable)
-
--- | Files that the package depends on, relative to package directory.
--- Argument is the location of the .cabal file
-newtype GetPackageOpts = GetPackageOpts
- { getPackageOpts :: forall env m. (MonadIO m,HasEnvConfig env, HasPlatform env, MonadThrow m, MonadReader env m)
- => Path Abs File
- -> m [String]
- }
-instance Show GetPackageOpts where
- show _ = ""
-
--- | Files that the package depends on, relative to package directory.
--- Argument is the location of the .cabal file
-newtype GetPackageFiles = GetPackageFiles
- { getPackageFiles :: forall m. (MonadIO m, MonadLogger m, MonadThrow m, MonadCatch m)
- => CabalFileType
- -> Path Abs File
- -> m (Set (Path Abs File))
- }
-instance Show GetPackageFiles where
- show _ = ""
-
--- | Get the identifier of the package.
packageIdentifier :: Package -> Stack.Types.PackageIdentifier.PackageIdentifier
packageIdentifier pkg =
Stack.Types.PackageIdentifier.PackageIdentifier
(packageName pkg)
(packageVersion pkg)
--- | Package build configuration
-data PackageConfig =
- PackageConfig {packageConfigEnableTests :: !Bool -- ^ Are tests enabled?
- ,packageConfigEnableBenchmarks :: !Bool -- ^ Are benchmarks enabled?
- ,packageConfigFlags :: !(Map FlagName Bool) -- ^ Package config flags.
- ,packageConfigGhcVersion :: !Version -- ^ GHC version
- ,packageConfigPlatform :: !Platform -- ^ host platform
- }
- deriving (Show,Typeable)
-
--- | Files to get for a cabal package.
-data CabalFileType
- = AllFiles
- | Modules
-
--- | Compares the package name.
-instance Ord Package where
- compare = on compare packageName
-
--- | Compares the package name.
-instance Eq Package where
- (==) = on (==) packageName
-
-- | Read the raw, unresolved package information.
readPackageUnresolved :: (MonadIO m, MonadThrow m)
=> Path Abs File
-> m GenericPackageDescription
readPackageUnresolved cabalfp =
- liftIO (S.readFile (FL.toFilePath cabalfp))
+ liftIO (BS.readFile (FL.toFilePath cabalfp))
>>= readPackageUnresolvedBS (Just cabalfp)
-- | Read the raw, unresolved package information from a ByteString.
readPackageUnresolvedBS :: (MonadThrow m)
=> Maybe (Path Abs File)
- -> S.ByteString
+ -> BS.ByteString
-> m GenericPackageDescription
readPackageUnresolvedBS mcabalfp bs =
case parsePackageDescription chars of
@@ -214,7 +119,7 @@
-- | Reads and exposes the package information, from a ByteString
readPackageBS :: (MonadThrow m)
=> PackageConfig
- -> S.ByteString
+ -> BS.ByteString
-> m Package
readPackageBS packageConfig bs =
resolvePackage packageConfig `liftM` readPackageUnresolvedBS Nothing bs
@@ -241,12 +146,17 @@
{ packageName = name
, packageVersion = fromCabalVersion (pkgVersion pkgId)
, packageDeps = deps
- , packageFiles = GetPackageFiles $ \ty cabalfp -> do
- files <- runReaderT (packageDescFiles ty pkg) cabalfp
- return $ S.fromList $
- case ty of
- Modules -> files
- AllFiles -> cabalfp : files
+ , packageFiles = GetPackageFiles $ \cabalfp -> do
+ distDir <- distDirFromDir (parent cabalfp)
+ (_,files) <- runReaderT (packageDescModulesAndFiles pkg)
+ (cabalfp, buildDir distDir)
+ return $ S.insert cabalfp files
+
+ , packageModules = GetPackageModules $ \cabalfp -> do
+ distDir <- distDirFromDir (parent cabalfp)
+ (modules,_) <- runReaderT (packageDescModulesAndFiles pkg)
+ (cabalfp, buildDir distDir)
+ return modules
, packageTools = packageDescTools pkg
, packageFlags = packageConfigFlags packageConfig
, packageAllDeps = S.fromList (M.keys deps)
@@ -254,10 +164,11 @@
, packageTests = S.fromList $ [ T.pack (testName t) | t <- testSuites pkg, buildable (testBuildInfo t)]
, packageBenchmarks = S.fromList $ [ T.pack (benchmarkName b) | b <- benchmarks pkg, buildable (benchmarkBuildInfo b)]
, packageExes = S.fromList $ [ T.pack (exeName b) | b <- executables pkg, buildable (buildInfo b)]
- , packageOpts = GetPackageOpts $ \cabalfp ->
- generatePkgDescOpts cabalfp pkg
+ , packageOpts = GetPackageOpts $ \sourceMap locals cabalfp ->
+ generatePkgDescOpts sourceMap locals cabalfp pkg
, packageHasExposedModules = maybe False (not . null . exposedModules) (library pkg)
, packageSimpleType = buildType (packageDescription gpkg) == Just Simple
+ , packageDefinedFlags = S.fromList $ map (fromCabalFlagName . flagName) $ genPackageFlags gpkg
}
where
@@ -267,9 +178,14 @@
deps = M.filterWithKey (const . (/= name)) (packageDependencies pkg)
-- | Generate GHC options for the package.
-generatePkgDescOpts :: (HasEnvConfig env, HasPlatform env, MonadThrow m, MonadReader env m, MonadIO m)
- => Path Abs File -> PackageDescription -> m [String]
-generatePkgDescOpts cabalfp pkg = do
+generatePkgDescOpts
+ :: (HasEnvConfig env, HasPlatform env, MonadThrow m, MonadReader env m, MonadIO m)
+ => SourceMap
+ -> [PackageName]
+ -> Path Abs File
+ -> PackageDescription
+ -> m [String]
+generatePkgDescOpts sourceMap locals cabalfp pkg = do
distDir <- distDirFromDir cabalDir
let cabalmacros = autogenDir distDir $(mkRelFile "cabal_macros.h")
exists <- fileExists cabalmacros
@@ -278,11 +194,11 @@
then Just cabalmacros
else Nothing
return
- (nub
+ (nubOrd
(["-hide-all-packages"] ++
concatMap
(concatMap
- (generateBuildInfoOpts mcabalmacros cabalDir distDir))
+ (generateBuildInfoOpts sourceMap mcabalmacros cabalDir distDir locals))
[ maybe [] (return . libBuildInfo) (library pkg)
, map buildInfo (executables pkg)
, map benchmarkBuildInfo (benchmarks pkg)
@@ -291,14 +207,28 @@
cabalDir = parent cabalfp
-- | Generate GHC options for the target.
-generateBuildInfoOpts :: Maybe (Path Abs File) -> Path Abs Dir -> Path Abs Dir -> BuildInfo -> [String]
-generateBuildInfoOpts mcabalmacros cabalDir distDir b =
- nub (concat [ghcOpts b, extOpts b, srcOpts, includeOpts b, macros, deps])
+generateBuildInfoOpts
+ :: SourceMap
+ -> Maybe (Path Abs File)
+ -> Path Abs Dir
+ -> Path Abs Dir
+ -> [PackageName]
+ -> BuildInfo
+ -> [String]
+generateBuildInfoOpts sourceMap mcabalmacros cabalDir distDir locals b =
+ nubOrd (concat [ghcOpts b, extOpts b, srcOpts, includeOpts, macros, deps, extra b, extraDirs, fworks b])
where
deps =
concat
- [ ["-package=" <> display name]
- | Dependency name _ <- targetBuildDepends b]
+ [ ["-package=" <> display name <>
+ maybe "" -- This empty case applies to e.g. base.
+ ((("-" <>) . versionString) . sourceVersion)
+ (M.lookup (fromCabalPackageName name) sourceMap)]
+ | Dependency name _ <- targetBuildDepends b
+ , not (elem name (map toCabalPackageName locals))]
+ -- Generates: -package=base -package=base16-bytestring-0.1.1.6 ...
+ sourceVersion (PSUpstream ver _ _) = ver
+ sourceVersion (PSLocal localPkg) = packageVersion (lpPackage localPkg)
macros =
case mcabalmacros of
Nothing -> []
@@ -308,22 +238,48 @@
where
isGhc GHC = True
isGhc _ = False
- extOpts = map (("-X" ++) . display) . allExtensions
+ extOpts = map (("-X" ++) . display) . usedExtensions
srcOpts =
map
(("-i" <>) . toFilePath)
(cabalDir :
map (cabalDir ) (mapMaybe parseRelDir (hsSourceDirs b)) <>
- [autogenDir distDir])
- includeOpts
- = map (("-I" <>) . toFilePath . (cabalDir ))
- . mapMaybe parseRelDir
- . includeDirs
+ [autogenDir distDir,buildDir distDir]) ++
+ ["-stubdir=" ++ toFilePath (buildDir distDir)]
+ includeOpts =
+ [ "-I" <> toFilePath absDir
+ | dir <- includeDirs b
+ , absDir <- case (parseAbsDir dir, parseRelDir dir) of
+ (Just ab, _ ) -> [ab]
+ (_ , Just rel) -> [cabalDir rel]
+ (Nothing, Nothing ) -> []
+ ]
+ extra
+ = map ("-l" <>)
+ . extraLibs
+ extraDirs =
+ [ "-L" <> toFilePath absDir
+ | dir <- extraLibDirs b
+ , absDir <- case (parseAbsDir dir, parseRelDir dir) of
+ (Just ab, _ ) -> [ab]
+ (_ , Just rel) -> [cabalDir rel]
+ (Nothing, Nothing ) -> []
+ ]
+ fworks = map (\fwk -> "-framework=" <> fwk) . frameworks
-- | Make the autogen dir.
autogenDir :: Path Abs Dir -> Path Abs Dir
-autogenDir distDir = distDir $(mkRelDir "build/autogen")
+autogenDir distDir = buildDir distDir $(mkRelDir "autogen")
+-- | Make the build dir.
+buildDir :: Path Abs Dir -> Path Abs Dir
+buildDir distDir = distDir $(mkRelDir "build")
+
+-- | Make the component-specific subdirectory of the build directory.
+getBuildComponentDir :: Maybe String -> Maybe (Path Rel Dir)
+getBuildComponentDir Nothing = Nothing
+getBuildComponentDir (Just name) = parseRelDir (name FilePath. (name ++ "-tmp"))
+
-- | Get all dependencies of the package (buildable targets only).
packageDependencies :: PackageDescription -> Map PackageName VersionRange
packageDependencies =
@@ -333,7 +289,7 @@
allBuildInfo'
-- | Get all build tool dependencies of the package (buildable targets only).
-packageToolDependencies :: PackageDescription -> Map S.ByteString VersionRange
+packageToolDependencies :: PackageDescription -> Map BS.ByteString VersionRange
packageToolDependencies =
M.fromList .
concatMap (map (\dep -> ((packageNameByteString $ depName dep),depRange dep)) .
@@ -364,41 +320,42 @@
, benchmarkEnabled tst ]
-- | Get all files referenced by the package.
-packageDescFiles
- :: (MonadLogger m, MonadIO m, MonadThrow m, MonadReader (Path Abs File) m, MonadCatch m)
- => CabalFileType -> PackageDescription -> m [Path Abs File]
-packageDescFiles ty pkg = do
+packageDescModulesAndFiles
+ :: (MonadLogger m, MonadIO m, MonadThrow m, MonadReader (Path Abs File, Path Abs Dir) m, MonadCatch m)
+ => PackageDescription -> m (Set ModuleName,Set (Path Abs File))
+packageDescModulesAndFiles pkg = do
libfiles <-
- liftM concat (mapM (libraryFiles ty) (maybe [] return (library pkg)))
- exefiles <- liftM concat (mapM (executableFiles ty) (executables pkg))
- benchfiles <- liftM concat (mapM (benchmarkFiles ty) (benchmarks pkg))
- testfiles <- liftM concat (mapM (testFiles ty) (testSuites pkg))
- dfiles <- resolveGlobFiles (map (dataDir pkg FilePath.) (dataFiles pkg))
- srcfiles <- resolveGlobFiles (extraSrcFiles pkg)
+ liftM concat2 (mapM libraryFiles (maybe [] return (library pkg)))
+ exefiles <- liftM concat2 (mapM executableFiles (executables pkg))
+ benchfiles <- liftM concat2 (mapM benchmarkFiles (benchmarks pkg))
+ testfiles <- liftM concat2 (mapM testFiles (testSuites pkg))
+ dfiles <-
+ liftM
+ (mempty, )
+ (resolveGlobFiles (map (dataDir pkg FilePath.) (dataFiles pkg)))
+ srcfiles <- liftM (mempty, ) (resolveGlobFiles (extraSrcFiles pkg))
-- extraTmpFiles purposely not included here, as those are files generated
-- by the build script. Another possible implementation: include them, but
-- don't error out if not present
- docfiles <- resolveGlobFiles (extraDocFiles pkg)
- case ty of
- Modules ->
- return (nub (concat [libfiles, exefiles, testfiles, benchfiles]))
- AllFiles ->
- return
- (nub
- (concat
- [ libfiles
- , exefiles
- , dfiles
- , srcfiles
- , docfiles
- , benchfiles
- , testfiles]))
+ docfiles <- liftM (mempty, ) (resolveGlobFiles (extraDocFiles pkg))
+ return
+ (concat2
+ [ libfiles
+ , exefiles
+ , dfiles
+ , srcfiles
+ , docfiles
+ , benchfiles
+ , testfiles])
+ where
+ concat2 :: (Ord a,Ord b) => [(Set a, Set b)] -> (Set a, Set b)
+ concat2 = (mconcat *** mconcat) . unzip
-- | Resolve globbing of files (e.g. data files) to absolute paths.
-resolveGlobFiles :: (MonadLogger m,MonadIO m,MonadThrow m,MonadReader (Path Abs File) m,MonadCatch m)
- => [String] -> m [Path Abs File]
+resolveGlobFiles :: (MonadLogger m,MonadIO m,MonadThrow m,MonadReader (Path Abs File, Path Abs Dir) m,MonadCatch m)
+ => [String] -> m (Set (Path Abs File))
resolveGlobFiles =
- liftM (catMaybes . concat) .
+ liftM (S.fromList . catMaybes . concat) .
mapM resolve
where
resolve name =
@@ -406,7 +363,7 @@
then explode name
else liftM return (resolveFileOrWarn name)
explode name = do
- dir <- asks parent
+ dir <- asks (parent . fst)
names <-
matchDirFileGlob'
(FL.toFilePath dir)
@@ -457,98 +414,102 @@
matches -> return matches
-- | Get all files referenced by the benchmark.
-benchmarkFiles :: (MonadLogger m, MonadIO m, MonadThrow m, MonadReader (Path Abs File) m)
- => CabalFileType -> Benchmark -> m [Path Abs File]
-benchmarkFiles ty bench = do
+benchmarkFiles :: (MonadLogger m, MonadIO m, MonadThrow m, MonadReader (Path Abs File, Path Abs Dir) m)
+ => Benchmark -> m (Set ModuleName,Set (Path Abs File))
+benchmarkFiles bench = do
dirs <- mapMaybeM resolveDirOrWarn (hsSourceDirs build)
- dir <- asks parent
- exposed <-
- resolveFiles
- (dirs ++ [dir])
- (case benchmarkInterface bench of
- BenchmarkExeV10 _ fp ->
- [Right fp]
- BenchmarkUnsupported _ ->
- [])
- haskellFileExts
- bfiles <- buildFiles ty dir build
- case ty of
- AllFiles -> return (concat [bfiles,exposed])
- Modules -> return (concat [bfiles])
+ dir <- asks (parent . fst)
+ (rmodules,rfiles) <- resolveFilesAndDeps
+ (Just $ benchmarkName bench)
+ (dirs ++ [dir])
+ names
+ haskellModuleExts
+ cfiles <- buildCSources build
+ return (rmodules,rfiles <> cfiles)
where
+ names =
+ concat [bnames,exposed]
+ exposed =
+ case benchmarkInterface bench of
+ BenchmarkExeV10 _ fp ->
+ [Right fp]
+ BenchmarkUnsupported _ ->
+ []
+ bnames = map Left (otherModules build)
build = benchmarkBuildInfo bench
-- | Get all files referenced by the test.
-testFiles :: (MonadLogger m, MonadIO m, MonadThrow m, MonadReader (Path Abs File) m)
- => CabalFileType -> TestSuite -> m [Path Abs File]
-testFiles ty test = do
+testFiles :: (MonadLogger m, MonadIO m, MonadThrow m, MonadReader (Path Abs File, Path Abs Dir) m)
+ => TestSuite -> m (Set ModuleName,Set (Path Abs File))
+testFiles test = do
dirs <- mapMaybeM resolveDirOrWarn (hsSourceDirs build)
- dir <- asks parent
- exposed <-
- resolveFiles
- (dirs ++ [dir])
- (case testInterface test of
- TestSuiteExeV10 _ fp ->
- [Right fp]
- TestSuiteLibV09 _ mn ->
- [Left mn]
- TestSuiteUnsupported _ ->
- [])
- haskellFileExts
- bfiles <- buildFiles ty dir build
- case ty of
- AllFiles -> return (concat [bfiles,exposed])
- Modules -> return (concat [bfiles])
+ dir <- asks (parent . fst)
+ (modules,rfiles) <- resolveFilesAndDeps
+ (Just $ testName test)
+ (dirs ++ [dir])
+ names
+ haskellModuleExts
+ cfiles <- buildCSources build
+ return (modules,rfiles <> cfiles)
where
+ names =
+ concat [bnames,exposed]
+ exposed =
+ case testInterface test of
+ TestSuiteExeV10 _ fp ->
+ [Right fp]
+ TestSuiteLibV09 _ mn ->
+ [Left mn]
+ TestSuiteUnsupported _ ->
+ []
+ bnames = map Left (otherModules build)
build = testBuildInfo test
-- | Get all files referenced by the executable.
-executableFiles :: (MonadLogger m,MonadIO m,MonadThrow m,MonadReader (Path Abs File) m)
- => CabalFileType -> Executable -> m [Path Abs File]
-executableFiles ty exe =
+executableFiles :: (MonadLogger m,MonadIO m,MonadThrow m,MonadReader (Path Abs File, Path Abs Dir) m)
+ => Executable -> m (Set ModuleName,Set (Path Abs File))
+executableFiles exe =
do dirs <- mapMaybeM resolveDirOrWarn (hsSourceDirs build)
- dir <- asks parent
- exposed <-
- resolveFiles
+ dir <- asks (parent . fst)
+ (modules,rfiles) <- resolveFilesAndDeps
+ (Just $ exeName exe)
(dirs ++ [dir])
- [Right (modulePath exe)]
- haskellFileExts
- bfiles <- buildFiles ty dir build
- case ty of
- AllFiles -> return (concat [bfiles,exposed])
- Modules -> return (concat [bfiles])
- where build = buildInfo exe
+ names
+ haskellModuleExts
+ cfiles <- buildCSources build
+ return (modules,rfiles <> cfiles)
+ where
+ names =
+ concat [bnames,exposed]
+ bnames = map Left (otherModules build)
+ exposed = [Right (modulePath exe)]
+ build = buildInfo exe
-- | Get all files referenced by the library.
-libraryFiles :: (MonadLogger m,MonadIO m,MonadThrow m,MonadReader (Path Abs File) m)
- => CabalFileType -> Library -> m [Path Abs File]
-libraryFiles ty lib =
+libraryFiles :: (MonadLogger m,MonadIO m,MonadThrow m,MonadReader (Path Abs File, Path Abs Dir) m)
+ => Library -> m (Set ModuleName,Set (Path Abs File))
+libraryFiles lib =
do dirs <- mapMaybeM resolveDirOrWarn (hsSourceDirs build)
- dir <- asks parent
- exposed <- resolveFiles
- (dirs ++ [dir])
- (map Left (exposedModules lib))
- haskellFileExts
- bfiles <- buildFiles ty dir build
- case ty of
- AllFiles -> return (concat [bfiles,exposed])
- Modules -> return (concat [bfiles,exposed])
- where build = libBuildInfo lib
+ dir <- asks (parent . fst)
+ (modules,rfiles) <- resolveFilesAndDeps
+ Nothing
+ (dirs ++ [dir])
+ names
+ haskellModuleExts
+ cfiles <- buildCSources build
+ return (modules,rfiles <> cfiles)
+ where
+ names =
+ concat [bnames,exposed]
+ exposed = map Left (exposedModules lib)
+ bnames = map Left (otherModules build)
+ build = libBuildInfo lib
--- | Get all files in a build.
-buildFiles :: (MonadLogger m,MonadIO m,MonadThrow m,MonadReader (Path Abs File) m)
- => CabalFileType -> Path Abs Dir -> BuildInfo -> m [Path Abs File]
-buildFiles ty dir build = do
- dirs <- mapMaybeM resolveDirOrWarn (hsSourceDirs build)
- other <-
- resolveFiles
- (dirs ++ [dir])
- (map Left (otherModules build))
- haskellFileExts
- cSources' <- mapMaybeM resolveFileOrWarn (cSources build)
- case ty of
- Modules -> return other
- AllFiles -> return (other ++ cSources')
+-- | Get all C sources in a build.
+buildCSources :: (MonadLogger m,MonadIO m,MonadThrow m,MonadReader (Path Abs File, Path Abs Dir) m)
+ => BuildInfo -> m (Set (Path Abs File))
+buildCSources build =
+ liftM S.fromList (mapMaybeM resolveFileOrWarn (cSources build))
-- | Get all dependencies of a package, including library,
-- executables, tests, benchmarks.
@@ -668,30 +629,203 @@
-- | Try to resolve the list of base names in the given directory by
-- looking for unique instances of base names applied with the given
+-- extensions, plus find any of their module and TemplateHaskell
+-- dependencies.
+resolveFilesAndDeps
+ :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader (Path Abs File, Path Abs Dir) m)
+ => Maybe (String) -- ^ Package component name
+ -> [Path Abs Dir] -- ^ Directories to look in.
+ -> [Either ModuleName String] -- ^ Base names.
+ -> [Text] -- ^ Extentions.
+ -> m (Set ModuleName,Set (Path Abs File))
+resolveFilesAndDeps component dirs names0 exts = do
+ (moduleFiles,thFiles,foundModules) <- loop names0 S.empty
+ cabalfp <- asks fst
+ let unlistedModules =
+ foundModules `S.difference` (S.fromList (lefts names0))
+ unless (S.null unlistedModules) $
+ $(logWarn) $
+ T.pack $
+ "Warning: " ++
+ (if S.size unlistedModules == 1
+ then "module"
+ else "modules") ++
+ " not listed in " ++
+ toFilePath (filename cabalfp) ++
+ (case component of
+ Nothing -> " for library"
+ Just c -> " for '" ++ c ++ "'") ++
+ " component (add to other-modules):\n " ++
+ intercalate "\n " (map display (S.toList unlistedModules))
+ return (foundModules,moduleFiles <> S.fromList thFiles)
+ where
+ loop [] doneModules = return (S.empty, [], doneModules)
+ loop names doneModules0 = do
+ resolvedFiles <- resolveFiles dirs names exts
+ pairs <- mapM getDependencies resolvedFiles
+ let doneModules' = S.union doneModules0 (S.fromList (lefts names))
+ moduleDeps = S.unions (map fst pairs)
+ thDepFiles = concatMap snd pairs
+ modulesRemaining = S.difference moduleDeps doneModules'
+ (moduleDepFiles',thDepFiles',doneModules'') <-
+ loop (map Left (S.toList modulesRemaining)) doneModules'
+ return
+ ( S.union (S.fromList resolvedFiles) moduleDepFiles'
+ , thDepFiles ++ thDepFiles'
+ , doneModules'')
+ getDependencies resolvedFile = do
+ dir <- asks (parent . fst)
+ dumpHIDir <- getDumpHIDir
+ case stripDir dir resolvedFile of
+ Nothing -> return (S.empty, [])
+ Just fileRel -> do
+ let dumpHIPath =
+ FilePath.replaceExtension
+ (toFilePath (dumpHIDir fileRel))
+ ".dump-hi"
+ dumpHIExists <- liftIO $ doesFileExist dumpHIPath
+ if dumpHIExists
+ then parseDumpHI dumpHIPath
+ else return (S.empty, [])
+ parseDumpHI dumpHIPath = do
+ dir <- asks (parent . fst)
+ dumpHI <- liftIO $ fmap C8.lines (C8.readFile dumpHIPath)
+ let startModuleDeps =
+ dropWhile
+ (not . ("module dependencies:" `C8.isPrefixOf`))
+ dumpHI
+ moduleDeps =
+ S.fromList $
+ mapMaybe (simpleParse . T.unpack . decodeUtf8) $
+ C8.words $
+ C8.concat $
+ C8.dropWhile (/= ' ') (headDef "" startModuleDeps) :
+ takeWhile (" " `C8.isPrefixOf`) (tailSafe startModuleDeps)
+ thDeps =
+ -- The dependent file path is surrounded by quotes but is not escaped.
+ -- It can be an absolute or relative path.
+ mapMaybe
+ (parseAbsOrRelFile dir <=<
+ (fmap T.unpack .
+ (T.stripSuffix "\"" <=< T.stripPrefix "\"") .
+ T.dropWhileEnd (== '\r') .
+ decodeUtf8 . C8.dropWhile (/= '"'))) $
+ filter ("addDependentFile \"" `C8.isPrefixOf`) dumpHI
+ return
+ (moduleDeps, thDeps)
+ getDumpHIDir = do
+ bld <- asks snd
+ return $ maybe bld (bld ) (getBuildComponentDir component)
+ parseAbsOrRelFile dir fp =
+ case parseRelFile fp of
+ Just rel -> Just (dir rel)
+ Nothing -> parseAbsFile fp
+
+-- | Try to resolve the list of base names in the given directory by
+-- looking for unique instances of base names applied with the given
-- extensions.
-resolveFiles :: MonadIO m
- => [Path Abs Dir] -- ^ Directories to look in.
- -> [Either ModuleName String] -- ^ Base names.
- -> [Text] -- ^ Extentions.
- -> m [Path Abs File]
-resolveFiles dirs names exts =
- liftM catMaybes (forM names (liftIO . makeNameCandidates))
- where makeNameCandidates name =
- fmap (listToMaybe . rights . concat)
- (mapM (makeDirCandidates name) dirs)
- makeDirCandidates :: Either ModuleName String
- -> Path Abs Dir
- -> IO [Either ResolveException (Path Abs File)]
- makeDirCandidates name dir =
- mapM (\ext ->
- try (case name of
- Left mn ->
- resolveFile dir
- (Cabal.toFilePath mn ++ "." ++ ext)
- Right fp ->
- resolveFile dir fp))
- (map T.unpack exts)
+resolveFiles
+ :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader (Path Abs File, Path Abs Dir) m)
+ => [Path Abs Dir] -- ^ Directories to look in.
+ -> [Either ModuleName String] -- ^ Base names.
+ -> [Text] -- ^ Extentions.
+ -> m [Path Abs File]
+resolveFiles dirs names exts = do
+ liftM catMaybes (forM names (findCandidate dirs exts))
+-- | Find a candidate for the given module-or-filename from the list
+-- of directories and given extensions.
+findCandidate
+ :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader (Path Abs File, Path Abs Dir) m)
+ => [Path Abs Dir]
+ -> [Text]
+ -> Either ModuleName String
+ -> m (Maybe (Path Abs File))
+findCandidate dirs exts name = do
+ pkg <- asks fst >>= parsePackageNameFromFilePath
+ candidates <- liftIO makeNameCandidates
+ case candidates of
+ [candidate] -> return (Just candidate)
+ [] -> do
+ case name of
+ Left mn
+ | not (display mn == paths_pkg pkg) -> do
+ logPossibilities dirs mn
+ _ -> return ()
+ return Nothing
+ (candidate:rest) -> do
+ warnMultiple name candidate rest
+ return (Just candidate)
+ where
+ paths_pkg pkg = "Paths_" ++ packageNameString pkg
+ makeNameCandidates =
+ liftM (nubOrd . rights . concat) (mapM makeDirCandidates dirs)
+ makeDirCandidates
+ :: Path Abs Dir
+ -> IO [Either ResolveException (Path Abs File)]
+ makeDirCandidates dir =
+ case name of
+ Right fp -> liftM return (try (resolveFile dir fp))
+ Left mn ->
+ mapM
+ (\ext ->
+ try
+ (resolveFile
+ dir
+ (Cabal.toFilePath mn ++ "." ++ ext)))
+ (map T.unpack exts)
+
+-- | Warn the user that multiple candidates are available for an
+-- entry, but that we picked one anyway and continued.
+warnMultiple
+ :: MonadLogger m
+ => Either ModuleName String -> Path b t -> [Path b t] -> m ()
+warnMultiple name candidate rest =
+ $logWarn
+ ("There were multiple candidates for the Cabal entry \"" <>
+ showName name <>
+ "(" <>
+ T.intercalate "," (map (T.pack . toFilePath) rest) <>
+ "), picking " <>
+ T.pack (toFilePath candidate))
+ where showName (Left name') = T.pack (display name')
+ showName (Right fp) = T.pack fp
+
+-- | Log that we couldn't find a candidate, but there are
+-- possibilities for custom preprocessor extensions.
+--
+-- For example: .erb for a Ruby file might exist in one of the
+-- directories.
+logPossibilities
+ :: (MonadIO m, MonadThrow m, MonadLogger m)
+ => [Path Abs Dir] -> ModuleName -> m ()
+logPossibilities dirs mn = do
+ possibilities <- liftM concat (makePossibilities mn)
+ case possibilities of
+ [] -> return ()
+ _ ->
+ $logWarn
+ ("Unable to find a known candidate for the Cabal entry \"" <>
+ T.pack (display mn) <>
+ "\", but did find: " <>
+ T.intercalate ", " (map (T.pack . toFilePath) possibilities) <>
+ ". If you are using a custom preprocessor for this module \
+ \with its own file extension, consider adding the file(s) \
+ \to your .cabal under extra-source-files.")
+ where
+ makePossibilities name =
+ mapM
+ (\dir ->
+ do (_,files) <- listDirectory dir
+ return
+ (map
+ filename
+ (filter
+ (isPrefixOf (display name) .
+ toFilePath . filename)
+ files)))
+ dirs
+
-- | Get the filename for the cabal file in the given directory.
--
-- If no .cabal file is present, or more than one is present, an exception is
@@ -713,28 +847,25 @@
-- | Path for the package's build log.
buildLogPath :: (MonadReader env m, HasBuildConfig env, MonadThrow m)
- => Package -> m (Path Abs File)
-buildLogPath package' = do
+ => Package -> Maybe String -> m (Path Abs File)
+buildLogPath package' msuffix = do
env <- ask
let stack = configProjectWorkDir env
- fp <- parseRelFile $ concat
- [ packageNameString $ packageName package'
- , "-"
- , versionString $ packageVersion package'
- , ".log"
- ]
+ fp <- parseRelFile $ concat $
+ (packageIdentifierString (packageIdentifier package')) :
+ (maybe id (\suffix -> ("-" :) . (suffix :)) msuffix) [".log"]
return $ stack $(mkRelDir "logs") fp
-- Internal helper to define resolveFileOrWarn and resolveDirOrWarn
-resolveOrWarn :: (MonadLogger m, MonadIO m, MonadReader (Path Abs File) m)
+resolveOrWarn :: (MonadLogger m, MonadIO m, MonadReader (Path Abs File, Path Abs Dir) m)
=> Text
-> (Path Abs Dir -> String -> m (Maybe a))
-> FilePath.FilePath
-> m (Maybe a)
resolveOrWarn subject resolver path =
do cwd <- getWorkingDir
- file <- ask
- dir <- asks parent
+ file <- asks fst
+ dir <- asks (parent . fst)
result <- resolver dir path
when (isNothing result) $
$logWarn ("Warning: " <> subject <> " listed in " <>
@@ -745,14 +876,14 @@
-- | Resolve the file, if it can't be resolved, warn for the user
-- (purely to be helpful).
-resolveFileOrWarn :: (MonadThrow m,MonadIO m,MonadLogger m,MonadReader (Path Abs File) m)
+resolveFileOrWarn :: (MonadThrow m,MonadIO m,MonadLogger m,MonadReader (Path Abs File, Path Abs Dir) m)
=> FilePath.FilePath
-> m (Maybe (Path Abs File))
resolveFileOrWarn = resolveOrWarn "File" resolveFileMaybe
-- | Resolve the directory, if it can't be resolved, warn for the user
-- (purely to be helpful).
-resolveDirOrWarn :: (MonadThrow m,MonadIO m,MonadLogger m,MonadReader (Path Abs File) m)
+resolveDirOrWarn :: (MonadThrow m,MonadIO m,MonadLogger m,MonadReader (Path Abs File, Path Abs Dir) m)
=> FilePath.FilePath
-> m (Maybe (Path Abs Dir))
resolveDirOrWarn = resolveOrWarn "Directory" resolveDirMaybe
diff --git a/src/Stack/PackageDump.hs b/src/Stack/PackageDump.hs
--- a/src/Stack/PackageDump.hs
+++ b/src/Stack/PackageDump.hs
@@ -33,8 +33,7 @@
import Control.Monad.Trans.Control
import Data.Attoparsec.Args
import Data.Attoparsec.Text as P
-import Data.Binary (Binary)
-import Data.Binary.VersionTagged (taggedDecodeOrLoad, taggedEncodeFile, BinarySchema (..))
+import Data.Binary.VersionTagged
import Data.ByteString (ByteString)
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
@@ -52,16 +51,17 @@
import Data.Typeable (Typeable)
import GHC.Generics (Generic)
import Path
+import Path.IO (createTree)
import Prelude -- Fix AMP warning
import Stack.GhcPkg
import Stack.Types
-import System.Directory (createDirectoryIfMissing, getDirectoryContents, doesFileExist)
+import System.Directory (getDirectoryContents, doesFileExist)
import System.Process.Read
-- | Cached information on whether package have profiling libraries and haddocks.
newtype InstalledCache = InstalledCache (IORef InstalledCacheInner)
newtype InstalledCacheInner = InstalledCacheInner (Map GhcPkgId InstalledCacheEntry)
- deriving Binary
+ deriving (Binary, NFData)
instance BinarySchema InstalledCacheInner where
-- Don't forget to update this if you change the datatype in any way!
binarySchema _ = 1
@@ -72,6 +72,8 @@
, installedCacheHaddock :: !Bool }
deriving (Eq, Generic)
instance Binary InstalledCacheEntry
+instance NFData InstalledCacheEntry where
+ rnf = genericRnf
-- | Call ghc-pkg dump with appropriate flags and stream to the given @Sink@, for a single database
ghcPkgDump
@@ -106,7 +108,7 @@
-- | Save a @InstalledCache@ to disk
saveInstalledCache :: MonadIO m => Path Abs File -> InstalledCache -> m ()
saveInstalledCache path (InstalledCache ref) = liftIO $ do
- createDirectoryIfMissing True $ toFilePath $ parent path
+ createTree (parent path)
readIORef ref >>= taggedEncodeFile (toFilePath path)
-- | Prune a list of possible packages down to those whose dependencies are met.
@@ -224,7 +226,7 @@
let gid = dpGhcPkgId dp
h <- case Map.lookup gid m of
Just installed -> return (installedCacheHaddock installed)
- Nothing | null (dpLibraries dp) -> return True
+ Nothing | not (dpHasExposedModules dp) -> return True
Nothing -> do
let loop [] = return False
loop (ifc:ifcs) = do
@@ -240,6 +242,7 @@
{ dpGhcPkgId :: !GhcPkgId
, dpLibDirs :: ![FilePath]
, dpLibraries :: ![ByteString]
+ , dpHasExposedModules :: !Bool
, dpDepends :: ![GhcPkgId]
, dpHaddockInterfaces :: ![ByteString]
, dpProfiling :: !profiling
@@ -310,6 +313,7 @@
let libDirKey = "library-dirs"
libDirs = parseM libDirKey
libraries = parseM "hs-libraries"
+ exposedModules = parseM "exposed-modules"
haddockInterfaces = parseM "haddock-interfaces"
depends <- mapM parseDepend $ parseM "depends"
@@ -322,6 +326,7 @@
{ dpGhcPkgId = ghcPkgId
, dpLibDirs = libDirPaths
, dpLibraries = S8.words $ S8.unwords libraries
+ , dpHasExposedModules = not (null libraries || null exposedModules)
, dpDepends = catMaybes (depends :: [Maybe GhcPkgId])
, dpHaddockInterfaces = S8.words $ S8.unwords haddockInterfaces
, dpProfiling = ()
diff --git a/src/Stack/PackageIndex.hs b/src/Stack/PackageIndex.hs
--- a/src/Stack/PackageIndex.hs
+++ b/src/Stack/PackageIndex.hs
@@ -27,6 +27,7 @@
import Control.Exception.Enclosed (tryIO)
import Control.Monad (unless, when, liftM, mzero)
import Control.Monad.Catch (MonadThrow, throwM, MonadCatch)
+import qualified Control.Monad.Catch as C
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Logger (MonadLogger, logDebug,
logInfo, logWarn)
@@ -35,7 +36,7 @@
import Data.Aeson.Extended
import qualified Data.Binary as Binary
-import Data.Binary.VersionTagged (taggedDecodeOrLoad, BinarySchema (..))
+import Data.Binary.VersionTagged
import Data.ByteString (ByteString)
import qualified Data.Word8 as Word8
import qualified Data.ByteString as S
@@ -70,12 +71,11 @@
import Network.HTTP.Download
import Path (mkRelDir, parent,
parseRelDir, toFilePath,
- ())
+ parseAbsFile, ())
import Path.IO
import Prelude -- Fix AMP warning
import Stack.Types
import Stack.Types.StackT
-import System.Directory
import System.FilePath (takeBaseName, (<.>))
import System.IO (IOMode (ReadMode, WriteMode),
withBinaryFile)
@@ -90,26 +90,35 @@
}
deriving Generic
instance Binary.Binary PackageCache
+instance NFData PackageCache where
+ rnf = genericRnf
newtype PackageCacheMap = PackageCacheMap (Map PackageIdentifier PackageCache)
- deriving Binary.Binary
+ deriving (Binary.Binary, NFData)
instance BinarySchema PackageCacheMap where
-- Don't forget to update this if you change the datatype in any way!
binarySchema _ = 1
-- | Populate the package index caches and return them.
populateCache
- :: (MonadIO m, MonadThrow m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, MonadBaseControl IO m, MonadCatch m)
+ :: (MonadIO m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, MonadBaseControl IO m, MonadCatch m)
=> EnvOverride
-> PackageIndex
-> m (Map PackageIdentifier PackageCache)
populateCache menv index = do
- $logSticky "Populating index cache ..."
requireIndex menv index
-- This uses full on lazy I/O instead of ResourceT to provide some
-- protections. Caveat emptor
path <- configPackageIndex (indexName index)
- lbs <- liftIO $ L.readFile $ Path.toFilePath path
- pis <- loop 0 Map.empty (Tar.read lbs)
+ let loadPIS = do
+ $logSticky "Populating index cache ..."
+ lbs <- liftIO $ L.readFile $ Path.toFilePath path
+ loop 0 Map.empty (Tar.read lbs)
+ pis <- loadPIS `C.catch` \e -> do
+ $logWarn $ "Exception encountered when parsing index tarball: "
+ <> T.pack (show (e :: Tar.FormatError))
+ $logWarn "Automatically updating index and trying again"
+ updateIndex menv index
+ loadPIS
when (indexRequireHashes index) $ forM_ (Map.toList pis) $ \(ident, pc) ->
case pcDownload pc of
@@ -246,7 +255,7 @@
updateIndexGit menv indexName' index gitUrl = do
tarFile <- configPackageIndex indexName'
let idxPath = parent tarFile
- liftIO (createDirectoryIfMissing True (toFilePath idxPath))
+ createTree idxPath
do
repoName <- parseRelDir $ takeBaseName $ T.unpack gitUrl
let cloneArgs =
@@ -262,15 +271,13 @@
sDir
$(mkRelDir "git-update")
acfDir = suDir repoName
- repoExists <-
- liftIO (doesDirectoryExist (toFilePath acfDir))
+ repoExists <- dirExists acfDir
unless repoExists
(readInNull suDir "git" menv cloneArgs Nothing)
$logSticky "Fetching package index ..."
readInNull acfDir "git" menv ["fetch","--tags","--depth=1"] Nothing
$logStickyDone "Fetched package index."
- _ <-
- (liftIO . tryIO) (removeFile (toFilePath tarFile))
+ removeFileIfExists tarFile
when (indexGpgVerify index)
(do readInNull acfDir
"git"
@@ -294,7 +301,8 @@
,tarFileTmp
,"current-hackage"]
Nothing
- liftIO $ renameFile tarFileTmp (toFilePath tarFile)
+ tarFileTmpPath <- parseAbsFile tarFileTmp
+ renameFile tarFileTmpPath tarFile
-- | Update the index tarball via HTTP
updateIndexHTTP :: (MonadIO m,MonadLogger m
@@ -316,6 +324,7 @@
when toUnpack $ do
let tmp = toFilePath tar <.> "tmp"
+ tmpPath <- parseAbsFile tmp
deleteCache indexName'
@@ -325,7 +334,7 @@
sourceHandle input
$$ ungzip
=$ sinkHandle output
- renameFile tmp $ toFilePath tar
+ renameFile tmpPath tar
when (indexGpgVerify index)
$ $logWarn
@@ -341,11 +350,11 @@
-- | Delete the package index cache
deleteCache :: (MonadIO m, MonadReader env m, HasConfig env, MonadLogger m, MonadThrow m) => IndexName -> m ()
deleteCache indexName' = do
- fp <- liftM toFilePath $ configPackageIndexCache indexName'
+ fp <- configPackageIndexCache indexName'
eres <- liftIO $ tryIO $ removeFile fp
case eres of
Left e -> $logDebug $ "Could not delete cache: " <> T.pack (show e)
- Right () -> $logDebug $ "Deleted index cache at " <> T.pack fp
+ Right () -> $logDebug $ "Deleted index cache at " <> T.pack (toFilePath fp)
data PackageDownload = PackageDownload
{ pdSHA512 :: !ByteString
@@ -354,6 +363,8 @@
}
deriving (Show, Generic)
instance Binary.Binary PackageDownload
+instance NFData PackageDownload where
+ rnf = genericRnf
instance FromJSON PackageDownload where
parseJSON = withObject "Package" $ \o -> do
hashes <- o .: "package-hashes"
diff --git a/src/Stack/Repl.hs b/src/Stack/Repl.hs
deleted file mode 100644
--- a/src/Stack/Repl.hs
+++ /dev/null
@@ -1,82 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE TupleSections #-}
-
--- | Run a REPL configured with the user's project(s).
-
-module Stack.Repl where
-
-import Control.Monad.Catch
-import Control.Monad.IO.Class
-import Control.Monad.Logger
-import Control.Monad.Reader
-import Data.List
-import qualified Data.Map.Strict as M
-import Data.Maybe
-import Data.Monoid
-import qualified Data.Set as S
-import Data.Text (Text)
-import qualified Data.Text as T
-import Path
-import Path.IO
-import Stack.Build.Source
-import Stack.Exec
-import Stack.Package
-import Stack.Types
-
--- | Launch a GHCi REPL for the given local project targets with the
--- given options and configure it with the load paths and extensions
--- of those targets.
-repl
- :: (HasConfig r, HasBuildConfig r, HasEnvConfig r, MonadReader r m, MonadIO m, MonadThrow m, MonadLogger m, MonadCatch m)
- => [Text] -- ^ Targets.
- -> [String] -- ^ GHC options.
- -> FilePath
- -> Bool
- -> m ()
-repl targets useropts ghciPath noload = do
- econfig <- asks getEnvConfig
- bconfig <- asks getBuildConfig
- pwd <- getWorkingDir
- pkgs <-
- liftM catMaybes $
- forM (M.toList (bcPackages bconfig)) $
- \(dir,validWanted) ->
- do cabalfp <- getCabalFileName dir
- name <- parsePackageNameFromFilePath cabalfp
- let config =
- PackageConfig
- { packageConfigEnableTests = True
- , packageConfigEnableBenchmarks = True
- , packageConfigFlags = localFlags mempty bconfig name
- , packageConfigGhcVersion = envConfigGhcVersion econfig
- , packageConfigPlatform = configPlatform
- (getConfig bconfig)
- }
- pkg <- readPackage config cabalfp
- if validWanted && wanted pwd cabalfp pkg
- then do
- pkgOpts <- getPackageOpts (packageOpts pkg) cabalfp
- srcfiles <-
- getPackageFiles (packageFiles pkg) Modules cabalfp
- return
- (Just (packageName pkg, pkgOpts, S.toList srcfiles))
- else return Nothing
- let pkgopts = filter (not . badForGhci) (concat (map _2 pkgs))
- srcfiles
- | noload = []
- | otherwise = concatMap (map toFilePath . _3) pkgs
- $logInfo
- ("Configuring GHCi with the following packages: " <>
- T.intercalate ", " (map packageNameText (map _1 pkgs)))
- exec defaultEnvSettings ghciPath ("--interactive" : pkgopts <> srcfiles <> useropts)
- where
- wanted pwd cabalfp pkg = isInWantedList || targetsEmptyAndInDir
- where
- isInWantedList = elem (packageNameText (packageName pkg)) targets
- targetsEmptyAndInDir = null targets || isParentOf (parent cabalfp) pwd
- badForGhci x =
- isPrefixOf "-O" x || elem x (words "-debug -threaded -ticky")
- _1 (x,_,_) = x
- _2 (_,x,_) = x
- _3 (_,_,x) = x
diff --git a/src/Stack/SDist.hs b/src/Stack/SDist.hs
new file mode 100644
--- /dev/null
+++ b/src/Stack/SDist.hs
@@ -0,0 +1,156 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+-- Create a source distribution tarball
+module Stack.SDist
+ ( getSDistTarball
+ ) where
+
+import qualified Codec.Archive.Tar as Tar
+import qualified Codec.Archive.Tar.Entry as Tar
+import qualified Codec.Compression.GZip as GZip
+import Control.Applicative ((<$>))
+import Control.Concurrent.Execute (ActionContext(..))
+import Control.Monad (when)
+import Control.Monad.Catch (MonadCatch, MonadMask)
+import Control.Monad.IO.Class
+import Control.Monad.Logger
+import Control.Monad.Reader (MonadReader, asks)
+import Control.Monad.Trans.Resource
+import qualified Data.ByteString.Lazy as L
+import Data.Either (partitionEithers)
+import Data.List
+import qualified Data.Map.Strict as Map
+import Data.Monoid ((<>))
+import qualified Data.Set as Set
+import qualified Data.Text as T
+import Network.HTTP.Client.Conduit (HasHttpManager)
+import Path
+import Stack.Build (mkBaseConfigOpts)
+import Stack.Build.Execute
+import Stack.Build.Source (loadSourceMap, localFlags)
+import Stack.Types.Build
+import Stack.Constants
+import Stack.Package
+import Stack.Types
+import Stack.Types.Internal
+import qualified System.FilePath as FP
+import System.IO.Temp (withSystemTempDirectory)
+
+type M env m = (MonadIO m,MonadReader env m,HasHttpManager env,HasBuildConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,MonadMask m,HasLogLevel env,HasEnvConfig env,HasTerminal env)
+
+-- | Given the path to a local package, creates its source
+-- distribution tarball.
+--
+-- While this yields a 'FilePath', the name of the tarball, this
+-- tarball is not written to the disk and instead yielded as a lazy
+-- bytestring.
+getSDistTarball :: M env m => Path Abs Dir -> m (FilePath, L.ByteString)
+getSDistTarball pkgDir = do
+ let pkgFp = toFilePath pkgDir
+ lp <- readLocalPackage pkgDir
+ $logInfo $ "Getting file list for " <> T.pack pkgFp
+ fileList <- getSDistFileList lp
+ $logInfo $ "Building sdist tarball for " <> T.pack pkgFp
+ files <- normalizeTarballPaths (lines fileList)
+ liftIO $ do
+ -- NOTE: Could make this use lazy I/O to only read files as needed
+ -- for upload (both GZip.compress and Tar.write are lazy).
+ -- However, it seems less error prone and more predictable to read
+ -- everything in at once, so that's what we're doing for now:
+ let packWith f isDir fp =
+ f (pkgFp FP. fp)
+ (either error id (Tar.toTarPath isDir (pkgId FP. fp)))
+ tarName = pkgId FP.<.> "tar.gz"
+ pkgId = packageIdentifierString (packageIdentifier (lpPackage lp))
+ dirEntries <- mapM (packWith Tar.packDirectoryEntry True) (dirsFromFiles files)
+ fileEntries <- mapM (packWith Tar.packFileEntry False) files
+ return (tarName, GZip.compress (Tar.write (dirEntries ++ fileEntries)))
+
+-- Read in a 'LocalPackage' config. This makes some default decisions
+-- about 'LocalPackage' fields that might not be appropriate for other
+-- usecases.
+--
+-- TODO: Dedupe with similar code in "Stack.Build.Source".
+readLocalPackage :: M env m => Path Abs Dir -> m LocalPackage
+readLocalPackage pkgDir = do
+ econfig <- asks getEnvConfig
+ bconfig <- asks getBuildConfig
+ cabalfp <- getCabalFileName pkgDir
+ name <- parsePackageNameFromFilePath cabalfp
+ let config = PackageConfig
+ { packageConfigEnableTests = False
+ , packageConfigEnableBenchmarks = False
+ , packageConfigFlags = localFlags Map.empty bconfig name
+ , packageConfigGhcVersion = envConfigGhcVersion econfig
+ , packageConfigPlatform = configPlatform $ getConfig bconfig
+ }
+ package <- readPackage config cabalfp
+ return LocalPackage
+ { lpPackage = package
+ , lpExeComponents = Nothing -- HACK: makes it so that sdist output goes to a log instead of a file.
+ , lpDir = pkgDir
+ , lpCabalFile = cabalfp
+ -- NOTE: these aren't the 'correct values, but aren't used in
+ -- the usage of this function in this module.
+ , lpTestBench = Nothing
+ , lpDirtyFiles = True
+ , lpNewBuildCache = Map.empty
+ , lpFiles = Set.empty
+ , lpComponents = Set.empty
+ }
+
+getSDistFileList :: M env m => LocalPackage -> m String
+getSDistFileList lp =
+ withSystemTempDirectory (stackProgName <> "-sdist") $ \tmpdir -> do
+ menv <- getMinimalEnvOverride
+ let bopts = defaultBuildOpts
+ baseConfigOpts <- mkBaseConfigOpts bopts
+ (_mbp, locals, _extraToBuild, sourceMap) <- loadSourceMap bopts
+ withExecuteEnv menv bopts baseConfigOpts locals sourceMap $ \ee -> do
+ withSingleContext ac ee task (Just "sdist") $ \_package _cabalfp _pkgDir cabal _announce _console _mlogFile -> do
+ let outFile = tmpdir FP. "source-files-list"
+ cabal False ["sdist", "--list-sources", outFile]
+ liftIO (readFile outFile)
+ where
+ package = lpPackage lp
+ ac = ActionContext Set.empty
+ task = Task
+ { taskProvides = PackageIdentifier (packageName package) (packageVersion package)
+ , taskType = TTLocal lp
+ , taskConfigOpts = TaskConfigOpts
+ { tcoMissing = Set.empty
+ , tcoOpts = \_ -> []
+ }
+ , taskPresent = Set.empty
+ }
+
+normalizeTarballPaths :: M env m => [FilePath] -> m [FilePath]
+normalizeTarballPaths fps = do
+ --TODO: consider whether erroring out is better - otherwise the
+ --user might upload an incomplete tar?
+ when (not (null outsideDir)) $
+ $logWarn $ T.concat
+ [ "Warning: These files are outside of the package directory, and will be omitted from the tarball: "
+ , T.pack (show outsideDir)]
+ return files
+ where
+ (outsideDir, files) = partitionEithers (map pathToEither fps)
+ pathToEither fp = maybe (Left fp) Right (normalizePath fp)
+
+normalizePath :: FilePath -> (Maybe FilePath)
+normalizePath = fmap FP.joinPath . go . FP.splitDirectories . FP.normalise
+ where
+ go [] = Just []
+ go ("..":_) = Nothing
+ go (_:"..":xs) = go xs
+ go (x:xs) = (x :) <$> go xs
+
+dirsFromFiles :: [FilePath] -> [FilePath]
+dirsFromFiles dirs = Set.toAscList (Set.delete "." results)
+ where
+ results = foldl' (\s -> go s . FP.takeDirectory) Set.empty dirs
+ go s x
+ | Set.member x s = s
+ | otherwise = go (Set.insert x s) (FP.takeDirectory x)
diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs
--- a/src/Stack/Setup.hs
+++ b/src/Stack/Setup.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
@@ -16,19 +17,22 @@
import Control.Applicative
import Control.Exception.Enclosed (catchIO)
-import Control.Monad (liftM, when, join, void)
+import Control.Monad (liftM, when, join, void, unless)
import Control.Monad.Catch
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Logger
import Control.Monad.Reader (MonadReader, ReaderT (..), asks)
import Control.Monad.State (get, put, modify)
import Control.Monad.Trans.Control
+import Crypto.Hash (SHA1(SHA1))
import Data.Aeson.Extended
+import Data.ByteString (ByteString)
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import Data.Conduit (Conduit, ($$), (=$), await, yield, awaitForever)
import Data.Conduit.Lift (evalStateC)
import qualified Data.Conduit.List as CL
+import Data.Either
import Data.IORef
import Data.List (intercalate)
import Data.Map (Map)
@@ -47,17 +51,19 @@
import Distribution.System (OS (..), Arch (..), Platform (..))
import Distribution.Text (simpleParse)
import Network.HTTP.Client.Conduit
-import Network.HTTP.Download (verifiedDownload, DownloadRequest(..))
+import Network.HTTP.Download.Verified
import Path
import Path.IO
import Prelude -- Fix AMP warning
import Safe (headMay, readMay)
-import Stack.Build.Types
+import Stack.Types.Build
+import Stack.Config (resolvePackageEntry)
+import Stack.Constants (distRelativeDir)
+import Stack.Fetch
import Stack.GhcPkg (createDatabase, getCabalPkgVer, getGlobalDB)
import Stack.Solver (getGhcVersion)
import Stack.Types
import Stack.Types.StackT
-import System.Directory (createDirectoryIfMissing, removeFile)
import System.Environment (getExecutablePath)
import System.Exit (ExitCode (ExitSuccess))
import System.FilePath (searchPathSeparator)
@@ -65,6 +71,8 @@
import System.IO.Temp (withSystemTempDirectory)
import System.Process (rawSystem)
import System.Process.Read
+import System.Process.Run (runIn)
+import Text.Printf (printf)
data SetupOpts = SetupOpts
{ soptsInstallIfMissing :: !Bool
@@ -79,6 +87,9 @@
-- ^ Don't check for a compatible GHC version/architecture
, soptsSkipMsys :: !Bool
-- ^ Do not use a custom msys installation on Windows
+ , soptsUpgradeCabal :: !Bool
+ -- ^ Upgrade the global Cabal library in the database to the newest
+ -- version. Only works reliably with a stack-managed installation.
}
deriving Show
data SetupException = UnsupportedSetupCombo OS Arch
@@ -130,13 +141,14 @@
, soptsSanityCheck = False
, soptsSkipGhcCheck = configSkipGHCCheck $ bcConfig bconfig
, soptsSkipMsys = configSkipMsys $ bcConfig bconfig
+ , soptsUpgradeCabal = False
}
mghcBin <- ensureGHC sopts
menv0 <- getMinimalEnvOverride
-- Modify the initial environment to include the GHC path, if a local GHC
-- is being used
- let env0 = case mghcBin of
+ let env = removeHaskellEnvVars $ case mghcBin of
Nothing -> unEnvOverride menv0
Just ghcBin ->
let x = unEnvOverride menv0
@@ -146,39 +158,39 @@
++ maybe [] return mpath
in Map.insert "PATH" path x
- -- Remove potentially confusing environment variables
- env1 = Map.delete "GHC_PACKAGE_PATH"
- $ Map.delete "HASKELL_PACKAGE_SANDBOX"
- $ Map.delete "HASKELL_PACKAGE_SANDBOXES"
- env0
-
- menv1 <- mkEnvOverride platform env1
- ghcVer <- getGhcVersion menv1
- cabalVer <- getCabalPkgVer menv1
+ menv <- mkEnvOverride platform env
+ ghcVer <- getGhcVersion menv
+ cabalVer <- getCabalPkgVer menv
+ packages <- mapM
+ (resolvePackageEntry menv (bcRoot bconfig))
+ (bcPackageEntries bconfig)
let envConfig0 = EnvConfig
{ envConfigBuildConfig = bconfig
, envConfigCabalVersion = cabalVer
, envConfigGhcVersion = ghcVer
+ , envConfigPackages = Map.fromList $ concat packages
}
-- extra installation bin directories
mkDirs <- runReaderT extraBinDirs envConfig0
- let mpath = Map.lookup "PATH" env1
+ let mpath = Map.lookup "PATH" env
mkDirs' = map toFilePath . mkDirs
depsPath = augmentPath (mkDirs' False) mpath
localsPath = augmentPath (mkDirs' True) mpath
deps <- runReaderT packageDatabaseDeps envConfig0
- createDatabase menv1 deps
+ createDatabase menv deps
localdb <- runReaderT packageDatabaseLocal envConfig0
- createDatabase menv1 localdb
- globalDB <- mkEnvOverride platform env1 >>= getGlobalDB
+ createDatabase menv localdb
+ globalDB <- getGlobalDB menv
let mkGPP locals = T.pack $ intercalate [searchPathSeparator] $ concat
[ [toFilePathNoTrailingSlash localdb | locals]
, [toFilePathNoTrailingSlash deps]
, [toFilePathNoTrailingSlash globalDB]
]
+ distDir <- runReaderT distRelativeDir envConfig0
+
executablePath <- liftIO getExecutablePath
envRef <- liftIO $ newIORef Map.empty
@@ -210,7 +222,8 @@
[ toFilePathNoTrailingSlash deps
, ""
])
- $ env1
+ $ Map.insert "HASKELL_DIST_DIR" (T.pack $ toFilePathNoTrailingSlash distDir)
+ $ env
!() <- atomicModifyIORef envRef $ \m' ->
(Map.insert es eo m', ())
return eo
@@ -221,6 +234,7 @@
}
, envConfigCabalVersion = cabalVer
, envConfigGhcVersion = ghcVer
+ , envConfigPackages = envConfigPackages envConfig0
}
-- | Augment the PATH environment variable with the given extra paths
@@ -241,6 +255,12 @@
=> SetupOpts
-> m (Maybe [FilePath])
ensureGHC sopts = do
+ when (getMajorVersion expected < MajorVersion 7 8) $ do
+ $logWarn "stack will almost certainly fail with GHC below version 7.8"
+ $logWarn "Valiantly attempting to run anyway, but I know this is doomed"
+ $logWarn "For more information, see: https://github.com/commercialhaskell/stack/issues/648"
+ $logWarn ""
+
-- Check the available GHCs
menv0 <- getMinimalEnvOverride
@@ -293,23 +313,91 @@
return $ Just $ map toFilePathNoTrailingSlash $ concat paths
else return Nothing
- when (soptsSanityCheck sopts) $ do
- menv <-
- case mpaths of
- Nothing -> return menv0
- Just paths -> do
- config <- asks getConfig
- let m0 = unEnvOverride menv0
- path0 = Map.lookup "PATH" m0
- path = augmentPath paths path0
- m = Map.insert "PATH" path m0
- mkEnvOverride (configPlatform config) m
- sanityCheck menv
+ menv <-
+ case mpaths of
+ Nothing -> return menv0
+ Just paths -> do
+ config <- asks getConfig
+ let m0 = unEnvOverride menv0
+ path0 = Map.lookup "PATH" m0
+ path = augmentPath paths path0
+ m = Map.insert "PATH" path m0
+ mkEnvOverride (configPlatform config) (removeHaskellEnvVars m)
+ when (soptsUpgradeCabal sopts) $ do
+ unless needLocal $ do
+ $logWarn "Trying to upgrade Cabal library on a GHC not installed by stack."
+ $logWarn "This may fail, caveat emptor!"
+
+ upgradeCabal menv
+
+ when (soptsSanityCheck sopts) $ sanityCheck menv
+
return mpaths
where
expected = soptsExpected sopts
+-- | Install the newest version of Cabal globally
+upgradeCabal :: (MonadIO m, MonadLogger m, MonadReader env m, HasHttpManager env, HasConfig env, MonadBaseControl IO m, MonadMask m)
+ => EnvOverride
+ -> m ()
+upgradeCabal menv = do
+ let name = $(mkPackageName "Cabal")
+ rmap <- resolvePackages menv Set.empty (Set.singleton name)
+ newest <-
+ case Map.keys rmap of
+ [] -> error "No Cabal library found in index, cannot upgrade"
+ [PackageIdentifier name' version]
+ | name == name' -> return version
+ x -> error $ "Unexpected results for resolvePackages: " ++ show x
+ installed <- getCabalPkgVer menv
+ if installed >= newest
+ then $logInfo $ T.concat
+ [ "Currently installed Cabal is "
+ , T.pack $ versionString installed
+ , ", newest is "
+ , T.pack $ versionString newest
+ , ". I'm not upgrading Cabal."
+ ]
+ else withSystemTempDirectory "stack-cabal-upgrade" $ \tmpdir -> do
+ $logInfo $ T.concat
+ [ "Installing Cabal-"
+ , T.pack $ versionString newest
+ , " to replace "
+ , T.pack $ versionString installed
+ ]
+ tmpdir' <- parseAbsDir tmpdir
+ let ident = PackageIdentifier name newest
+ m <- unpackPackageIdents menv tmpdir' Nothing (Set.singleton ident)
+
+ ghcPath <- join $ findExecutable menv "ghc"
+ newestDir <- parseRelDir $ versionString newest
+ let installRoot = toFilePath $ parent (parent ghcPath)
+ $(mkRelDir "new-cabal")
+ newestDir
+
+ dir <-
+ case Map.lookup ident m of
+ Nothing -> error $ "upgradeCabal: Invariant violated, dir missing"
+ Just dir -> return dir
+
+ runIn dir "ghc" menv ["Setup.hs"] Nothing
+ let setupExe = toFilePath $ dir $(mkRelFile "Setup")
+ dirArgument name' = concat
+ [ "--"
+ , name'
+ , "dir="
+ , installRoot FP. name'
+ ]
+ runIn dir setupExe menv
+ ( "configure"
+ : map dirArgument (words "lib bin data doc")
+ )
+ Nothing
+ runIn dir setupExe menv ["build"] Nothing
+ runIn dir setupExe menv ["install"] Nothing
+ $logInfo "New Cabal library installed"
+
-- | Get the major version of the system GHC, if available
getSystemGHC :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) => EnvOverride -> m (Maybe (Version, Arch))
getSystemGHC menv = do
@@ -325,24 +413,52 @@
Just (version, arch)
else return Nothing
-data DownloadPair = DownloadPair Version Text
+data DownloadInfo = DownloadInfo
+ { downloadInfoUrl :: Text
+ , downloadInfoContentLength :: Int
+ , downloadInfoSha1 :: Maybe ByteString
+ }
deriving Show
-instance FromJSON DownloadPair where
- parseJSON = withObject "DownloadPair" $ \o -> DownloadPair
- <$> o .: "version"
- <*> o .: "url"
+data VersionedDownloadInfo = VersionedDownloadInfo
+ { vdiVersion :: Version
+ , vdiDownloadInfo :: DownloadInfo
+ }
+ deriving Show
+
+parseDownloadInfoFromObject :: Yaml.Object -> Yaml.Parser DownloadInfo
+parseDownloadInfoFromObject o = do
+ url <- o .: "url"
+ contentLength <- o .: "content-length"
+ sha1TextMay <- o .:? "sha1"
+ return DownloadInfo
+ { downloadInfoUrl = url
+ , downloadInfoContentLength = contentLength
+ , downloadInfoSha1 = fmap T.encodeUtf8 sha1TextMay
+ }
+
+instance FromJSON DownloadInfo where
+ parseJSON = withObject "DownloadInfo" parseDownloadInfoFromObject
+instance FromJSON VersionedDownloadInfo where
+ parseJSON = withObject "VersionedDownloadInfo" $ \o -> do
+ version <- o .: "version"
+ downloadInfo <- parseDownloadInfoFromObject o
+ return VersionedDownloadInfo
+ { vdiVersion = version
+ , vdiDownloadInfo = downloadInfo
+ }
+
data SetupInfo = SetupInfo
- { siSevenzExe :: Text
- , siSevenzDll :: Text
- , siPortableGit :: DownloadPair
- , siGHCs :: Map Text (Map MajorVersion DownloadPair)
+ { siSevenzExe :: DownloadInfo
+ , siSevenzDll :: DownloadInfo
+ , siPortableGit :: VersionedDownloadInfo
+ , siGHCs :: Map Text (Map MajorVersion VersionedDownloadInfo)
}
deriving Show
instance FromJSON SetupInfo where
parseJSON = withObject "SetupInfo" $ \o -> SetupInfo
- <$> o .: "sevenzexe"
- <*> o .: "sevenzdll"
+ <$> o .: "sevenzexe-info"
+ <*> o .: "sevenzdll-info"
<*> o .: "portable-git"
<*> o .: "ghc"
@@ -376,7 +492,7 @@
=> m [PackageIdentifier]
listInstalled = do
dir <- asks $ configLocalPrograms . getConfig
- liftIO $ createDirectoryIfMissing True $ toFilePath dir
+ createTree dir
(_, files) <- listDirectory dir
return $ mapMaybe toIdent files
where
@@ -435,7 +551,7 @@
return Nothing
| otherwise = do
si <- getSetupInfo'
- (pair@(DownloadPair version _), installer) <-
+ (VersionedDownloadInfo version downloadInfo, installer) <-
case packageNameString name of
"git" -> do
let pair = siPortableGit si
@@ -463,7 +579,7 @@
x -> error $ "Invariant violated: ensureTool on " ++ x
let ident = PackageIdentifier name version
- (file, at) <- downloadPair pair ident
+ (file, at) <- downloadFromInfo downloadInfo ident
dir <- installDir ident
unmarkInstalled ident
installer si file at dir ident
@@ -514,11 +630,11 @@
hasLineWithFirstWord w =
elem (Just w) . map (headMay . T.words) . T.lines . T.decodeUtf8With T.lenientDecode
-downloadPair :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m)
- => DownloadPair
+downloadFromInfo :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m)
+ => DownloadInfo
-> PackageIdentifier
-> m (Path Abs File, ArchiveType)
-downloadPair (DownloadPair _ url) ident = do
+downloadFromInfo downloadInfo ident = do
config <- asks getConfig
at <-
case extension of
@@ -528,9 +644,10 @@
_ -> error $ "Unknown extension: " ++ extension
relfile <- parseRelFile $ packageIdentifierString ident ++ extension
let path = configLocalPrograms config relfile
- chattyDownload (packageIdentifierText ident) url path
+ chattyDownload (packageIdentifierText ident) downloadInfo path
return (path, at)
where
+ url = downloadInfoUrl downloadInfo
extension =
loop $ T.unpack url
where
@@ -553,28 +670,38 @@
-> PackageIdentifier
-> m ()
installGHCPosix _ archiveFile archiveType destDir ident = do
- menv <- getMinimalEnvOverride
- zipTool <-
+ platform <- asks getPlatform
+ menv0 <- getMinimalEnvOverride
+ menv <- mkEnvOverride platform (removeHaskellEnvVars (unEnvOverride menv0))
+ $logDebug $ "menv = " <> T.pack (show (unEnvOverride menv))
+ zipTool' <-
case archiveType of
TarXz -> return "xz"
TarBz2 -> return "bzip2"
SevenZ -> error "Don't know how to deal with .7z files on non-Windows"
- checkDependencies $ zipTool : ["make", "tar"]
+ (zipTool, makeTool, tarTool) <- checkDependencies $ (,,)
+ <$> checkDependency zipTool'
+ <*> (checkDependency "gmake" <|> checkDependency "make")
+ <*> checkDependency "tar"
+ $logDebug $ "ziptool: " <> T.pack zipTool
+ $logDebug $ "make: " <> T.pack makeTool
+ $logDebug $ "tar: " <> T.pack tarTool
+
withSystemTempDirectory "stack-setup" $ \root' -> do
root <- parseAbsDir root'
dir <- liftM (root Path.) $ parseRelDir $ packageIdentifierString ident
$logSticky $ "Unpacking GHC ..."
$logDebug $ "Unpacking " <> T.pack (toFilePath archiveFile)
- readInNull root "tar" menv ["xf", toFilePath archiveFile] Nothing
+ readInNull root tarTool menv ["xf", toFilePath archiveFile] Nothing
$logSticky "Configuring GHC ..."
readInNull dir (toFilePath $ dir Path. $(mkRelFile "configure"))
menv ["--prefix=" ++ toFilePath destDir] Nothing
$logSticky "Installing GHC ..."
- readInNull dir "make" menv ["install"] Nothing
+ readInNull dir makeTool menv ["install"] Nothing
$logStickyDone $ "Installed GHC."
$logDebug $ "GHC installed to " <> T.pack (toFilePath destDir)
@@ -582,18 +709,37 @@
-- | Check if given processes appear to be present, throwing an exception if
-- missing.
checkDependencies :: (MonadIO m, MonadThrow m, MonadReader env m, HasConfig env)
- => [String] -> m ()
- checkDependencies tools = do
+ => CheckDependency a -> m a
+ checkDependencies (CheckDependency f) = do
menv <- getMinimalEnvOverride
- missing <- liftM catMaybes $ mapM (check menv) tools
- if null missing
- then return ()
- else throwM $ MissingDependencies missing
- where
- check menv tool = do
- exists <- doesExecutableExist menv tool
- return $ if exists then Nothing else Just tool
+ liftIO (f menv) >>= either (throwM . MissingDependencies) return
+checkDependency :: String -> CheckDependency String
+checkDependency tool = CheckDependency $ \menv -> do
+ exists <- doesExecutableExist menv tool
+ return $ if exists then Right tool else Left [tool]
+
+newtype CheckDependency a = CheckDependency (EnvOverride -> IO (Either [String] a))
+ deriving Functor
+instance Applicative CheckDependency where
+ pure x = CheckDependency $ \_ -> return (Right x)
+ CheckDependency f <*> CheckDependency x = CheckDependency $ \menv -> do
+ f' <- f menv
+ x' <- x menv
+ return $
+ case (f', x') of
+ (Left e1, Left e2) -> Left $ e1 ++ e2
+ (Left e, Right _) -> Left e
+ (Right _, Left e) -> Left e
+ (Right f'', Right x'') -> Right $ f'' x''
+instance Alternative CheckDependency where
+ empty = CheckDependency $ \_ -> return $ Left []
+ CheckDependency x <|> CheckDependency y = CheckDependency $ \menv -> do
+ res1 <- x menv
+ case res1 of
+ Left _ -> y menv
+ Right x' -> return $ Right x'
+
installGHCWindows :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m)
=> SetupInfo
-> Path Abs File
@@ -617,7 +763,7 @@
run7z (parent archiveFile) archiveFile
run7z (parent archiveFile) tarFile
- liftIO (removeFile $ toFilePath tarFile) `catchIO` \e ->
+ removeFile tarFile `catchIO` \e ->
$logWarn (T.concat
[ "Exception when removing "
, T.pack $ toFilePath tarFile
@@ -668,11 +814,12 @@
dll = dir $(mkRelFile "7z.dll")
chattyDownload :: (MonadReader env m, HasHttpManager env, MonadIO m, MonadLogger m, MonadThrow m, MonadBaseControl IO m)
- => Text
- -> Text -- ^ URL
+ => Text -- ^ label
+ -> DownloadInfo -- ^ URL, content-length, and sha1
-> Path Abs File -- ^ destination
-> m ()
-chattyDownload label url path = do
+chattyDownload label downloadInfo path = do
+ let url = downloadInfoUrl downloadInfo
req <- parseUrl $ T.unpack url
$logSticky $ T.concat
[ "Preparing to download "
@@ -686,11 +833,25 @@
, T.pack $ toFilePath path
, " ..."
]
-
+ hashChecks <- case downloadInfoSha1 downloadInfo of
+ Just sha1ByteString -> do
+ let sha1 = CheckHexDigestByteString sha1ByteString
+ $logDebug $ T.concat
+ [ "Will check against sha1 hash: "
+ , T.decodeUtf8With T.lenientDecode sha1ByteString
+ ]
+ return [HashCheck SHA1 sha1]
+ Nothing -> do
+ $logWarn $ T.concat
+ [ "No sha1 found in metadata,"
+ , " download hash won't be checked."
+ ]
+ return []
let dReq = DownloadRequest
{ drRequest = req
- , drHashChecks = []
- , drLengthCheck = Nothing
+ , drHashChecks = hashChecks
+ , drLengthCheck = Just totalSize
+ , drRetryPolicy = drRetryPolicyDefault
}
runInBase <- liftBaseWith $ \run -> return (void . run)
x <- verifiedDownload dReq path (chattyDownloadProgress runInBase)
@@ -698,7 +859,8 @@
then $logStickyDone ("Downloaded " <> label <> ".")
else $logStickyDone "Already downloaded."
where
- chattyDownloadProgress runInBase = do
+ totalSize = downloadInfoContentLength downloadInfo
+ chattyDownloadProgress runInBase _ = do
_ <- liftIO $ runInBase $ $logSticky $
label <> ": download has begun"
CL.map (Sum . S.length)
@@ -708,10 +870,51 @@
go = evalStateC 0 $ awaitForever $ \(Sum size) -> do
modify (+ size)
totalSoFar <- get
- liftIO $ runInBase $ $logSticky $
- label <> ": " <> T.pack (show totalSoFar) <> " bytes downloaded..."
+ liftIO $ runInBase $ $logSticky $ T.pack $
+ chattyProgressWithTotal totalSoFar totalSize
+ -- Note(DanBurton): Total size is now always known in this file.
+ -- However, printing in the case where it isn't known may still be
+ -- useful in other parts of the codebase.
+ -- So I'm just commenting out the code rather than deleting it.
+ -- case mcontentLength of
+ -- Nothing -> chattyProgressNoTotal totalSoFar
+ -- Just 0 -> chattyProgressNoTotal totalSoFar
+ -- Just total -> chattyProgressWithTotal totalSoFar total
+ ---- Example: ghc: 42.13 KiB downloaded...
+ --chattyProgressNoTotal totalSoFar =
+ -- printf ("%s: " <> bytesfmt "%7.2f" totalSoFar <> " downloaded...")
+ -- (T.unpack label)
+
+ -- Example: ghc: 50.00 MiB / 100.00 MiB (50.00%) downloaded...
+ chattyProgressWithTotal totalSoFar total =
+ printf ("%s: " <>
+ bytesfmt "%7.2f" totalSoFar <> " / " <>
+ bytesfmt "%.2f" total <>
+ " (%6.2f%%) downloaded...")
+ (T.unpack label)
+ percentage
+ where percentage :: Double
+ percentage = (fromIntegral totalSoFar / fromIntegral total * 100)
+
+-- | Given a printf format string for the decimal part and a number of
+-- bytes, formats the bytes using an appropiate unit and returns the
+-- formatted string.
+--
+-- >>> bytesfmt "%.2" 512368
+-- "500.359375 KiB"
+bytesfmt :: Integral a => String -> a -> String
+bytesfmt formatter bs = printf (formatter <> " %s")
+ (fromIntegral (signum bs) * dec :: Double)
+ (bytesSuffixes !! i)
+ where
+ (dec,i) = getSuffix (abs bs)
+ getSuffix n = until p (\(x,y) -> (x / 1024, y+1)) (fromIntegral n,0)
+ where p (n',numDivs) = n' < 1024 || numDivs == (length bytesSuffixes - 1)
+ bytesSuffixes :: [String]
+ bytesSuffixes = ["B","KiB","MiB","GiB","TiB","PiB","EiB","ZiB","YiB"]
+
-- Await eagerly (collect with monoidal append),
-- but space out yields by at least the given amount of time.
-- The final yield may come sooner, and may be a superfluous mempty.
@@ -762,3 +965,11 @@
toFilePathNoTrailingSlash :: Path loc Dir -> FilePath
toFilePathNoTrailingSlash = FP.dropTrailingPathSeparator . toFilePath
+
+-- Remove potentially confusing environment variables
+removeHaskellEnvVars :: Map Text Text -> Map Text Text
+removeHaskellEnvVars =
+ Map.delete "GHC_PACKAGE_PATH" .
+ Map.delete "HASKELL_PACKAGE_SANDBOX" .
+ Map.delete "HASKELL_PACKAGE_SANDBOXES" .
+ Map.delete "HASKELL_DIST_DIR"
diff --git a/src/Stack/Solver.hs b/src/Stack/Solver.hs
--- a/src/Stack/Solver.hs
+++ b/src/Stack/Solver.hs
@@ -14,7 +14,7 @@
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.Trans.Control
-import Data.Aeson (object, (.=), toJSON)
+import Data.Aeson.Extended (object, (.=), toJSON, logJSONWarnings)
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import Data.Either
@@ -38,10 +38,11 @@
cabalSolver :: (MonadIO m, MonadLogger m, MonadMask m, MonadBaseControl IO m, MonadReader env m, HasConfig env)
=> [Path Abs Dir] -- ^ cabal files
- -> [String] -- ^ additional arguments, usually constraints
+ -> Map PackageName Version -- ^ constraints
+ -> [String] -- ^ additional arguments
-> m (MajorVersion, Map PackageName (Version, Map FlagName Bool))
-cabalSolver cabalfps cabalArgs = withSystemTempDirectory "cabal-solver" $ \dir -> do
- configLines <- getCabalConfig dir
+cabalSolver cabalfps constraints cabalArgs = withSystemTempDirectory "cabal-solver" $ \dir -> do
+ configLines <- getCabalConfig dir constraints
let configFile = dir FP. "cabal.config"
liftIO $ S.writeFile configFile $ encodeUtf8 $ T.unlines configLines
@@ -115,12 +116,13 @@
getCabalConfig :: (MonadReader env m, HasConfig env, MonadIO m, MonadThrow m)
=> FilePath -- ^ temp dir
+ -> Map PackageName Version -- ^ constraints
-> m [Text]
-getCabalConfig dir = do
+getCabalConfig dir constraints = do
indices <- asks $ configPackageIndices . getConfig
remotes <- mapM goIndex indices
let cache = T.pack $ "remote-repo-cache: " ++ dir
- return $ cache : remotes
+ return $ cache : remotes ++ map goConstraint (Map.toList constraints)
where
goIndex index = do
src <- configPackageIndex $ indexName index
@@ -135,6 +137,13 @@
, ":http://0.0.0.0/fake-url"
]
+ goConstraint (name, version) = T.concat
+ [ "constraint: "
+ , T.pack $ packageNameString name
+ , "=="
+ , T.pack $ versionString version
+ ]
+
-- | Determine missing extra-deps
solveExtraDeps :: (MonadReader env m, HasEnvConfig env, MonadIO m, MonadMask m, MonadLogger m, MonadBaseControl IO m, HasHttpManager env)
=> Bool -- ^ modify stack.yaml?
@@ -142,27 +151,24 @@
solveExtraDeps modStackYaml = do
$logInfo "This command is not guaranteed to give you a perfect build plan"
$logInfo "It's possible that even with the changes generated below, you will still need to do some manual tweaking"
+ econfig <- asks getEnvConfig
bconfig <- asks getBuildConfig
snapshot <-
case bcResolver bconfig of
ResolverSnapshot snapName -> liftM mbpPackages $ loadMiniBuildPlan snapName
ResolverGhc _ -> return Map.empty
+ ResolverCustom _ url -> liftM mbpPackages $ parseCustomMiniBuildPlan
+ (bcStackYaml bconfig)
+ url
let packages = Map.union
(bcExtraDeps bconfig)
(fmap mpiVersion snapshot)
- constraints = map
- (\(k, v) -> concat
- [ "--constraint="
- , packageNameString k
- , "=="
- , versionString v
- ])
- (Map.toList packages)
(_ghc, extraDeps) <- cabalSolver
- (Map.keys $ bcPackages bconfig)
- constraints
+ (Map.keys $ envConfigPackages econfig)
+ packages
+ []
let newDeps = extraDeps `Map.difference` packages
newFlags = Map.filter (not . Map.null) $ fmap snd newDeps
@@ -180,7 +186,9 @@
when modStackYaml $ do
let fp = toFilePath $ bcStackYaml bconfig
obj <- liftIO (Yaml.decodeFileEither fp) >>= either throwM return
- ProjectAndConfigMonoid project _ <- liftIO (Yaml.decodeFileEither fp) >>= either throwM return
+ (ProjectAndConfigMonoid project _, warnings) <-
+ liftIO (Yaml.decodeFileEither fp) >>= either throwM return
+ logJSONWarnings fp warnings
let obj' =
HashMap.insert "extra-deps"
(toJSON $ map fromTuple $ Map.toList
diff --git a/src/Stack/Types.hs b/src/Stack/Types.hs
--- a/src/Stack/Types.hs
+++ b/src/Stack/Types.hs
@@ -12,3 +12,6 @@
import Stack.Types.Version as X
import Stack.Types.Config as X
import Stack.Types.Docker as X
+import Stack.Types.Image as X
+import Stack.Types.Build as X
+import Stack.Types.Package as X
diff --git a/src/Stack/Types/Build.hs b/src/Stack/Types/Build.hs
new file mode 100644
--- /dev/null
+++ b/src/Stack/Types/Build.hs
@@ -0,0 +1,615 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE ViewPatterns #-}
+
+-- | Build-specific types.
+
+module Stack.Types.Build
+ (StackBuildException(..)
+ ,FlagSource(..)
+ ,UnusedFlags(..)
+ ,InstallLocation(..)
+ ,ModTime
+ ,modTime
+ ,Installed(..)
+ ,PackageInstallInfo(..)
+ ,Task(..)
+ ,taskLocation
+ ,LocalPackage(..)
+ ,BaseConfigOpts(..)
+ ,Plan(..)
+ ,TestOpts(..)
+ ,BenchmarkOpts(..)
+ ,BuildOpts(..)
+ ,BuildSubset(..)
+ ,defaultBuildOpts
+ ,TaskType(..)
+ ,TaskConfigOpts(..)
+ ,ConfigCache(..)
+ ,ConstructPlanException(..)
+ ,configureOpts
+ ,BadDependency(..)
+ ,wantedLocalPackages
+ ,FileCacheInfo (..))
+ where
+
+import Control.DeepSeq
+import Control.Exception
+
+import Data.Binary.VersionTagged
+import qualified Data.ByteString as S
+import Data.Char (isSpace)
+import Data.Data
+import Data.Hashable
+import Data.List (dropWhileEnd, nub, intercalate)
+import qualified Data.Map as Map
+import Data.Map.Strict (Map)
+import Data.Maybe
+import Data.Monoid
+import Data.Set (Set)
+import qualified Data.Set as Set
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Text.Encoding (decodeUtf8With)
+import Data.Text.Encoding.Error (lenientDecode)
+import Data.Time.Calendar
+import Data.Time.Clock
+import Distribution.System (Arch)
+import Distribution.Text (display)
+import GHC.Generics
+import Path (Path, Abs, File, Dir, mkRelDir, toFilePath, parseRelDir, ())
+import Prelude
+import Stack.Types.FlagName
+import Stack.Types.GhcPkgId
+import Stack.Types.Config
+import Stack.Types.Package
+import Stack.Types.PackageIdentifier
+import Stack.Types.PackageName
+import Stack.Types.Version
+import System.Exit (ExitCode)
+import System.FilePath (dropTrailingPathSeparator, pathSeparator)
+
+----------------------------------------------
+-- Exceptions
+data StackBuildException
+ = Couldn'tFindPkgId PackageName
+ | GHCVersionMismatch (Maybe (Version, Arch)) (Version, Arch) (Maybe (Path Abs File))
+ -- ^ Path to the stack.yaml file
+ | Couldn'tParseTargets [Text]
+ | UnknownTargets
+ (Set PackageName) -- no known version
+ (Map PackageName Version) -- not in snapshot, here's the most recent version in the index
+ (Path Abs File) -- stack.yaml
+ | TestSuiteFailure PackageIdentifier (Map Text (Maybe ExitCode)) (Maybe (Path Abs File)) S.ByteString
+ | ConstructPlanExceptions
+ [ConstructPlanException]
+ (Path Abs File) -- stack.yaml
+ | CabalExitedUnsuccessfully
+ ExitCode
+ PackageIdentifier
+ (Path Abs File) -- cabal Executable
+ [String] -- cabal arguments
+ (Maybe (Path Abs File)) -- logfiles location
+ S.ByteString -- log contents
+ | ExecutionFailure [SomeException]
+ | LocalPackageDoesn'tMatchTarget
+ PackageName
+ Version -- local version
+ Version -- version specified on command line
+ | NoSetupHsFound (Path Abs Dir)
+ | InvalidFlagSpecification (Set UnusedFlags)
+ | TargetParseException [Text]
+ deriving Typeable
+
+data FlagSource = FSCommandLine | FSStackYaml
+ deriving (Show, Eq, Ord)
+
+data UnusedFlags = UFNoPackage FlagSource PackageName
+ | UFFlagsNotDefined FlagSource Package (Set FlagName)
+ deriving (Show, Eq, Ord)
+
+instance Show StackBuildException where
+ show (Couldn'tFindPkgId name) =
+ ("After installing " <> packageNameString name <>
+ ", the package id couldn't be found " <> "(via ghc-pkg describe " <>
+ packageNameString name <> "). This shouldn't happen, " <>
+ "please report as a bug")
+ show (GHCVersionMismatch mactual (expected, earch) mstack) = concat
+ [ case mactual of
+ Nothing -> "No GHC found, expected version "
+ Just (actual, arch) -> concat
+ [ "GHC version mismatched, found "
+ , versionString actual
+ , " ("
+ , display arch
+ , ")"
+ , ", but expected version "
+ ]
+ , versionString expected
+ , " ("
+ , display earch
+ , ") (based on "
+ , case mstack of
+ Nothing -> "command line arguments"
+ Just stack -> "resolver setting in " ++ toFilePath stack
+ , "). Try running stack setup"
+ ]
+ show (Couldn'tParseTargets targets) = unlines
+ $ "The following targets could not be parsed as package names or directories:"
+ : map T.unpack targets
+ show (UnknownTargets noKnown notInSnapshot stackYaml) =
+ unlines $ noKnown' ++ notInSnapshot'
+ where
+ noKnown'
+ | Set.null noKnown = []
+ | otherwise = return $
+ "The following target packages were not found: " ++
+ intercalate ", " (map packageNameString $ Set.toList noKnown)
+ notInSnapshot'
+ | Map.null notInSnapshot = []
+ | otherwise =
+ "The following packages are not in your snapshot, but exist"
+ : "in your package index. Recommended action: add them to your"
+ : ("extra-deps in " ++ toFilePath stackYaml)
+ : "(Note: these are the most recent versions,"
+ : "but there's no guarantee that they'll build together)."
+ : ""
+ : map
+ (\(name, version) -> "- " ++ packageIdentifierString
+ (PackageIdentifier name version))
+ (Map.toList notInSnapshot)
+ show (TestSuiteFailure ident codes mlogFile bs) = unlines $ concat
+ [ ["Test suite failure for package " ++ packageIdentifierString ident]
+ , flip map (Map.toList codes) $ \(name, mcode) -> concat
+ [ " "
+ , T.unpack name
+ , ": "
+ , case mcode of
+ Nothing -> " executable not found"
+ Just ec -> " exited with: " ++ show ec
+ ]
+ , return $ case mlogFile of
+ Nothing -> "Logs printed to console"
+ -- TODO Should we load up the full error output and print it here?
+ Just logFile -> "Full log available at " ++ toFilePath logFile
+ , if S.null bs
+ then []
+ else ["", "", doubleIndent $ T.unpack $ decodeUtf8With lenientDecode bs]
+ ]
+ where
+ indent = dropWhileEnd isSpace . unlines . fmap (\line -> " " ++ line) . lines
+ doubleIndent = indent . indent
+ show (ConstructPlanExceptions exceptions stackYaml) =
+ "While constructing the BuildPlan the following exceptions were encountered:" ++
+ appendExceptions exceptions' ++
+ if Map.null extras then "" else (unlines
+ $ ("\n\nRecommended action: try adding the following to your extra-deps in "
+ ++ toFilePath stackYaml)
+ : map (\(name, version) -> concat
+ [ "- "
+ , packageNameString name
+ , "-"
+ , versionString version
+ ]) (Map.toList extras)
+ ++ ["", "You may also want to try the 'stack solver' command"]
+ )
+ where
+ exceptions' = removeDuplicates exceptions
+ appendExceptions = foldr (\e -> (++) ("\n\n--" ++ show e)) ""
+ removeDuplicates = nub
+ extras = Map.unions $ map getExtras exceptions'
+
+ getExtras (DependencyCycleDetected _) = Map.empty
+ getExtras (UnknownPackage _) = Map.empty
+ getExtras (DependencyPlanFailures _ m) =
+ Map.unions $ map go $ Map.toList m
+ where
+ go (name, (_range, Just version, NotInBuildPlan)) =
+ Map.singleton name version
+ go _ = Map.empty
+ -- Supressing duplicate output
+ show (CabalExitedUnsuccessfully exitCode taskProvides' execName fullArgs logFiles bs) =
+ let fullCmd = (dropQuotes (show execName) ++ " " ++ (unwords fullArgs))
+ logLocations = maybe "" (\fp -> "\n Logs have been written to: " ++ toFilePath fp) logFiles
+ in "\n-- While building package " ++ dropQuotes (show taskProvides') ++ " using:\n" ++
+ " " ++ fullCmd ++ "\n" ++
+ " Process exited with code: " ++ show exitCode ++
+ logLocations ++
+ (if S.null bs
+ then ""
+ else "\n\n" ++ doubleIndent (T.unpack $ decodeUtf8With lenientDecode bs))
+ where
+ -- appendLines = foldr (\pName-> (++) ("\n" ++ show pName)) ""
+ indent = dropWhileEnd isSpace . unlines . fmap (\line -> " " ++ line) . lines
+ dropQuotes = filter ('\"' /=)
+ doubleIndent = indent . indent
+ show (ExecutionFailure es) = intercalate "\n\n" $ map show es
+ show (LocalPackageDoesn'tMatchTarget name localV requestedV) = concat
+ [ "Version for local package "
+ , packageNameString name
+ , " is "
+ , versionString localV
+ , ", but you asked for "
+ , versionString requestedV
+ , " on the command line"
+ ]
+ show (NoSetupHsFound dir) =
+ "No Setup.hs or Setup.lhs file found in " ++ toFilePath dir
+ show (InvalidFlagSpecification unused) = unlines
+ $ "Invalid flag specification:"
+ : map go (Set.toList unused)
+ where
+ showFlagSrc :: FlagSource -> String
+ showFlagSrc FSCommandLine = " (specified on command line)"
+ showFlagSrc FSStackYaml = " (specified in stack.yaml)"
+
+ go :: UnusedFlags -> String
+ go (UFNoPackage src name) = concat
+ [ "- Package '"
+ , packageNameString name
+ , "' not found"
+ , showFlagSrc src
+ ]
+ go (UFFlagsNotDefined src pkg flags) = concat
+ [ "- Package '"
+ , name
+ , "' does not define the following flags"
+ , showFlagSrc src
+ , ":\n"
+ , intercalate "\n"
+ (map (\flag -> " " ++ flagNameString flag)
+ (Set.toList flags))
+ , "\n- Flags defined by package '" ++ name ++ "':\n"
+ , intercalate "\n"
+ (map (\flag -> " " ++ name ++ ":" ++ flagNameString flag)
+ (Set.toList pkgFlags))
+ ]
+ where name = packageNameString (packageName pkg)
+ pkgFlags = packageDefinedFlags pkg
+ show (TargetParseException [err]) = "Error parsing targets: " ++ T.unpack err
+ show (TargetParseException errs) = unlines
+ $ "The following errors occurred while parsing the build targets:"
+ : map (("- " ++) . T.unpack) errs
+
+instance Exception StackBuildException
+
+data ConstructPlanException
+ = DependencyCycleDetected [PackageName]
+ | DependencyPlanFailures PackageIdentifier (Map PackageName (VersionRange, LatestVersion, BadDependency))
+ | UnknownPackage PackageName -- TODO perhaps this constructor will be removed, and BadDependency will handle it all
+ -- ^ Recommend adding to extra-deps, give a helpful version number?
+ deriving (Typeable, Eq)
+
+-- | For display purposes only, Nothing if package not found
+type LatestVersion = Maybe Version
+
+-- | Reason why a dependency was not used
+data BadDependency
+ = NotInBuildPlan
+ | Couldn'tResolveItsDependencies
+ | DependencyMismatch Version
+ deriving (Typeable, Eq)
+
+instance Show ConstructPlanException where
+ show e =
+ let details = case e of
+ (DependencyCycleDetected pNames) ->
+ "While checking call stack,\n" ++
+ " dependency cycle detected in packages:" ++ indent (appendLines pNames)
+ (DependencyPlanFailures pIdent (Map.toList -> pDeps)) ->
+ "Failure when adding dependencies:" ++ doubleIndent (appendDeps pDeps) ++ "\n" ++
+ " needed for package: " ++ packageIdentifierString pIdent
+ (UnknownPackage pName) ->
+ "While attempting to add dependency,\n" ++
+ " Could not find package " ++ show pName ++ " in known packages"
+ in indent details
+ where
+ appendLines = foldr (\pName-> (++) ("\n" ++ show pName)) ""
+ indent = dropWhileEnd isSpace . unlines . fmap (\line -> " " ++ line) . lines
+ doubleIndent = indent . indent
+ appendDeps = foldr (\dep-> (++) ("\n" ++ showDep dep)) ""
+ showDep (name, (range, mlatest, badDep)) = concat
+ [ show name
+ , ": needed ("
+ , display range
+ , ")"
+ , case mlatest of
+ Nothing -> ""
+ Just latest -> ", latest is " ++ versionString latest
+ , ", but "
+ , case badDep of
+ NotInBuildPlan -> "not present in build plan"
+ Couldn'tResolveItsDependencies -> "couldn't resolve its dependencies"
+ DependencyMismatch version -> versionString version ++ " found"
+ ]
+ {- TODO Perhaps change the showDep function to look more like this:
+ dropQuotes = filter ((/=) '\"')
+ (VersionOutsideRange pName pIdentifier versionRange) ->
+ "Exception: Stack.Build.VersionOutsideRange\n" ++
+ " While adding dependency for package " ++ show pName ++ ",\n" ++
+ " " ++ dropQuotes (show pIdentifier) ++ " was found to be outside its allowed version range.\n" ++
+ " Allowed version range is " ++ display versionRange ++ ",\n" ++
+ " should you correct the version range for " ++ dropQuotes (show pIdentifier) ++ ", found in [extra-deps] in the project's stack.yaml?"
+ -}
+
+
+----------------------------------------------
+
+-- | Which subset of packages to build
+data BuildSubset
+ = BSAll
+ | BSOnlySnapshot
+ -- ^ Only install packages in the snapshot database, skipping
+ -- packages intended for the local database.
+ | BSOnlyDependencies
+ deriving Show
+
+-- | Configuration for building.
+data BuildOpts =
+ BuildOpts {boptsTargets :: ![Text]
+ ,boptsLibProfile :: !Bool
+ ,boptsExeProfile :: !Bool
+ ,boptsEnableOptimizations :: !(Maybe Bool)
+ ,boptsHaddock :: !Bool
+ -- ^ Build haddocks?
+ ,boptsHaddockDeps :: !(Maybe Bool)
+ -- ^ Build haddocks for dependencies?
+ ,boptsDryrun :: !Bool
+ ,boptsGhcOptions :: ![Text]
+ ,boptsFlags :: !(Map (Maybe PackageName) (Map FlagName Bool))
+ ,boptsInstallExes :: !Bool
+ -- ^ Install executables to user path after building?
+ ,boptsPreFetch :: !Bool
+ -- ^ Fetch all packages immediately
+ ,boptsBuildSubset :: !BuildSubset
+ ,boptsFileWatch :: !Bool
+ -- ^ Watch files for changes and automatically rebuild
+ ,boptsKeepGoing :: !(Maybe Bool)
+ -- ^ Keep building/running after failure
+ ,boptsForceDirty :: !Bool
+ -- ^ Force treating all local packages as having dirty files
+
+ ,boptsTests :: !Bool
+ -- ^ Turn on tests for local targets
+ ,boptsTestOpts :: !TestOpts
+ -- ^ Additional test arguments
+
+ ,boptsBenchmarks :: !Bool
+ -- ^ Turn on benchmarks for local targets
+ ,boptsBenchmarkOpts :: !BenchmarkOpts
+ -- ^ Additional test arguments
+ ,boptsExec :: ![(String, [String])]
+ -- ^ Commands (with arguments) to run after a successful build
+ }
+ deriving (Show)
+
+defaultBuildOpts :: BuildOpts
+defaultBuildOpts = BuildOpts
+ { boptsTargets = []
+ , boptsLibProfile = False
+ , boptsExeProfile = False
+ , boptsEnableOptimizations = Nothing
+ , boptsHaddock = False
+ , boptsHaddockDeps = Nothing
+ , boptsDryrun = False
+ , boptsGhcOptions = []
+ , boptsFlags = Map.empty
+ , boptsInstallExes = False
+ , boptsPreFetch = False
+ , boptsBuildSubset = BSAll
+ , boptsFileWatch = False
+ , boptsKeepGoing = Nothing
+ , boptsForceDirty = False
+ , boptsTests = False
+ , boptsTestOpts = defaultTestOpts
+ , boptsBenchmarks = False
+ , boptsBenchmarkOpts = defaultBenchmarkOpts
+ , boptsExec = []
+ }
+
+-- | Options for the 'FinalAction' 'DoTests'
+data TestOpts =
+ TestOpts {toRerunTests :: !Bool -- ^ Whether successful tests will be run gain
+ ,toAdditionalArgs :: ![String] -- ^ Arguments passed to the test program
+ ,toCoverage :: !Bool -- ^ Generate a code coverage report
+ ,toDisableRun :: !Bool -- ^ Disable running of tests
+ } deriving (Eq,Show)
+
+defaultTestOpts :: TestOpts
+defaultTestOpts = TestOpts
+ { toRerunTests = True
+ , toAdditionalArgs = []
+ , toCoverage = False
+ , toDisableRun = False
+ }
+
+-- | Options for the 'FinalAction' 'DoBenchmarks'
+data BenchmarkOpts =
+ BenchmarkOpts {beoAdditionalArgs :: !(Maybe String) -- ^ Arguments passed to the benchmark program
+ } deriving (Eq,Show)
+
+defaultBenchmarkOpts :: BenchmarkOpts
+defaultBenchmarkOpts = BenchmarkOpts
+ { beoAdditionalArgs = Nothing
+ }
+
+-- | Package dependency oracle.
+newtype PkgDepsOracle =
+ PkgDeps PackageName
+ deriving (Show,Typeable,Eq,Hashable,Binary,NFData)
+
+-- | Stored on disk to know whether the flags have changed or any
+-- files have changed.
+data ConfigCache = ConfigCache
+ { configCacheOpts :: ![S.ByteString]
+ -- ^ All options used for this package.
+ , configCacheDeps :: !(Set GhcPkgId)
+ -- ^ The GhcPkgIds of all of the dependencies. Since Cabal doesn't take
+ -- the complete GhcPkgId (only a PackageIdentifier) in the configure
+ -- options, just using the previous value is insufficient to know if
+ -- dependencies have changed.
+ , configCacheComponents :: !(Set S.ByteString)
+ -- ^ The components to be built. It's a bit of a hack to include this in
+ -- here, as it's not a configure option (just a build option), but this
+ -- is a convenient way to force compilation when the components change.
+ , configCacheHaddock :: !Bool
+ -- ^ Are haddocks to be built?
+ }
+ deriving (Generic,Eq,Show)
+instance Binary ConfigCache
+instance NFData ConfigCache where
+ rnf = genericRnf
+
+-- | A task to perform when building
+data Task = Task
+ { taskProvides :: !PackageIdentifier -- ^ the package/version to be built
+ , taskType :: !TaskType -- ^ the task type, telling us how to build this
+ , taskConfigOpts :: !TaskConfigOpts
+ , taskPresent :: !(Set GhcPkgId) -- ^ GhcPkgIds of already-installed dependencies
+ }
+ deriving Show
+
+-- | Given the IDs of any missing packages, produce the configure options
+data TaskConfigOpts = TaskConfigOpts
+ { tcoMissing :: !(Set PackageIdentifier)
+ -- ^ Dependencies for which we don't yet have an GhcPkgId
+ , tcoOpts :: !(Set GhcPkgId -> [Text])
+ -- ^ Produce the list of options given the missing @GhcPkgId@s
+ }
+instance Show TaskConfigOpts where
+ show (TaskConfigOpts missing f) = concat
+ [ "Missing: "
+ , show missing
+ , ". Without those: "
+ , show $ f Set.empty
+ ]
+
+-- | The type of a task, either building local code or something from the
+-- package index (upstream)
+data TaskType = TTLocal LocalPackage
+ | TTUpstream Package InstallLocation
+ deriving Show
+
+taskLocation :: Task -> InstallLocation
+taskLocation task =
+ case taskType task of
+ TTLocal _ -> Local
+ TTUpstream _ loc -> loc
+
+-- | A complete plan of what needs to be built and how to do it
+data Plan = Plan
+ { planTasks :: !(Map PackageName Task)
+ , planFinals :: !(Map PackageName (Task, LocalPackageTB))
+ -- ^ Final actions to be taken (test, benchmark, etc)
+ , planUnregisterLocal :: !(Map GhcPkgId Text)
+ -- ^ Text is reason we're unregistering, for display only
+ , planInstallExes :: !(Map Text InstallLocation)
+ -- ^ Executables that should be installed after successful building
+ }
+ deriving Show
+
+-- | Basic information used to calculate what the configure options are
+data BaseConfigOpts = BaseConfigOpts
+ { bcoSnapDB :: !(Path Abs Dir)
+ , bcoLocalDB :: !(Path Abs Dir)
+ , bcoSnapInstallRoot :: !(Path Abs Dir)
+ , bcoLocalInstallRoot :: !(Path Abs Dir)
+ , bcoBuildOpts :: !BuildOpts
+ }
+
+-- | Render a @BaseConfigOpts@ to an actual list of options
+configureOpts :: EnvConfig
+ -> BaseConfigOpts
+ -> Set GhcPkgId -- ^ dependencies
+ -> Bool -- ^ wanted?
+ -> InstallLocation
+ -> Package
+ -> [Text]
+configureOpts econfig bco deps wanted loc package = map T.pack $ concat
+ [ ["--user", "--package-db=clear", "--package-db=global"]
+ , map (("--package-db=" ++) . toFilePath) $ case loc of
+ Snap -> [bcoSnapDB bco]
+ Local -> [bcoSnapDB bco, bcoLocalDB bco]
+ , depOptions
+ , [ "--libdir=" ++ toFilePathNoTrailingSlash (installRoot $(mkRelDir "lib"))
+ , "--bindir=" ++ toFilePathNoTrailingSlash (installRoot bindirSuffix)
+ , "--datadir=" ++ toFilePathNoTrailingSlash (installRoot $(mkRelDir "share"))
+ , "--docdir=" ++ toFilePathNoTrailingSlash docDir
+ , "--htmldir=" ++ toFilePathNoTrailingSlash docDir
+ , "--haddockdir=" ++ toFilePathNoTrailingSlash docDir]
+ , ["--enable-library-profiling" | boptsLibProfile bopts || boptsExeProfile bopts]
+ , ["--enable-executable-profiling" | boptsExeProfile bopts]
+ , map (\(name,enabled) ->
+ "-f" <>
+ (if enabled
+ then ""
+ else "-") <>
+ flagNameString name)
+ (Map.toList (packageFlags package))
+ -- FIXME Chris: where does this come from now? , ["--ghc-options=-O2" | gconfigOptimize gconfig]
+ , if wanted
+ then concatMap (\x -> ["--ghc-options", T.unpack x]) (boptsGhcOptions bopts)
+ else []
+ , map (("--extra-include-dirs=" ++) . T.unpack) (Set.toList (configExtraIncludeDirs config))
+ , map (("--extra-lib-dirs=" ++) . T.unpack) (Set.toList (configExtraLibDirs config))
+ ]
+ where
+ config = getConfig econfig
+ bopts = bcoBuildOpts bco
+ toFilePathNoTrailingSlash = dropTrailingPathSeparator . toFilePath
+ docDir =
+ case pkgVerDir of
+ Nothing -> installRoot docDirSuffix
+ Just dir -> installRoot docDirSuffix dir
+ installRoot =
+ case loc of
+ Snap -> bcoSnapInstallRoot bco
+ Local -> bcoLocalInstallRoot bco
+ pkgVerDir =
+ parseRelDir (packageIdentifierString (PackageIdentifier (packageName package)
+ (packageVersion package)) ++
+ [pathSeparator])
+
+ depOptions = map toDepOption $ Set.toList deps
+ where
+ toDepOption =
+ if envConfigCabalVersion econfig >= $(mkVersion "1.22")
+ then toDepOption1_22
+ else toDepOption1_18
+
+ toDepOption1_22 gid = concat
+ [ "--dependency="
+ , packageNameString $ packageIdentifierName $ ghcPkgIdPackageIdentifier gid
+ , "="
+ , ghcPkgIdString gid
+ ]
+
+ toDepOption1_18 gid = concat
+ [ "--constraint="
+ , packageNameString name
+ , "=="
+ , versionString version
+ ]
+ where
+ PackageIdentifier name version = ghcPkgIdPackageIdentifier gid
+
+-- | Get set of wanted package names from locals.
+wantedLocalPackages :: [LocalPackage] -> Set PackageName
+wantedLocalPackages = Set.fromList . map (packageName . lpPackage) . filter lpWanted
+
+-- | One-way conversion to serialized time.
+modTime :: UTCTime -> ModTime
+modTime x =
+ ModTime
+ ( toModifiedJulianDay
+ (utctDay x)
+ , toRational
+ (utctDayTime x))
+
+data Installed = Library GhcPkgId | Executable PackageIdentifier
+ deriving (Show, Eq, Ord)
diff --git a/src/Stack/Types/BuildPlan.hs b/src/Stack/Types/BuildPlan.hs
--- a/src/Stack/Types/BuildPlan.hs
+++ b/src/Stack/Types/BuildPlan.hs
@@ -32,8 +32,7 @@
import Data.Aeson (FromJSON (..), ToJSON (..),
object, withObject, withText,
(.!=), (.:), (.:?), (.=))
-import Data.Binary as Binary (Binary)
-import Data.Binary.VersionTagged (BinarySchema (..))
+import Data.Binary.VersionTagged
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as S8
import Data.Hashable (Hashable)
@@ -241,7 +240,7 @@
-- | Name of an executable.
newtype ExeName = ExeName { unExeName :: ByteString }
- deriving (Show, Eq, Ord, Hashable, IsString, Generic)
+ deriving (Show, Eq, Ord, Hashable, IsString, Generic, NFData)
instance Binary ExeName
instance ToJSON ExeName where
toJSON = toJSON . S8.unpack . unExeName
@@ -365,7 +364,9 @@
, mbpPackages :: !(Map PackageName MiniPackageInfo)
}
deriving (Generic, Show, Eq)
-instance Binary.Binary MiniBuildPlan
+instance Binary MiniBuildPlan
+instance NFData MiniBuildPlan where
+ rnf = genericRnf
instance BinarySchema MiniBuildPlan where
-- Don't forget to update this if you change the datatype in any way!
binarySchema _ = 1
@@ -386,7 +387,9 @@
-- ^ Is there a library present?
}
deriving (Generic, Show, Eq)
-instance Binary.Binary MiniPackageInfo
+instance Binary MiniPackageInfo
+instance NFData MiniPackageInfo where
+ rnf = genericRnf
isWindows :: OS -> Bool
diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs
--- a/src/Stack/Types/Config.hs
+++ b/src/Stack/Types/Config.hs
@@ -1,8 +1,10 @@
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE RecordWildCards #-}
-- | The Config type.
@@ -13,9 +15,13 @@
import Control.Exception
import Control.Monad (liftM, mzero)
import Control.Monad.Catch (MonadThrow, throwM)
+import Control.Monad.Logger (LogLevel(..))
import Control.Monad.Reader (MonadReader, ask, asks, MonadIO, liftIO)
-import Data.Aeson.Extended (ToJSON, toJSON, FromJSON, parseJSON, withText, withObject, object
- ,(.=), (.:?), (.!=), (.:), Value (String, Object))
+import Data.Aeson.Extended
+ (ToJSON, toJSON, FromJSON, parseJSON, withText, withObject, object,
+ (.=), (.:), (..:), (..:?), (..!=), Value(String, Object),
+ withObjectWarnings, WarningParser, Object, jsonSubWarnings, JSONWarning,
+ jsonSubWarningsMT)
import Data.Binary (Binary)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as S8
@@ -23,9 +29,9 @@
import Data.Hashable (Hashable)
import Data.Map (Map)
import qualified Data.Map as Map
+import Data.Monoid
import Data.Set (Set)
import qualified Data.Set as Set
-import Data.Monoid
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
@@ -33,13 +39,14 @@
import Data.Yaml (ParseException)
import Distribution.System (Platform)
import qualified Distribution.Text
-import Distribution.Version (anyVersion, intersectVersionRanges)
-import qualified Paths_stack as Meta
+import Distribution.Version (anyVersion)
import Network.HTTP.Client (parseUrl)
import Path
+import qualified Paths_stack as Meta
import Stack.Types.BuildPlan (SnapName, renderSnapName, parseSnapName)
import Stack.Types.Docker
import Stack.Types.FlagName
+import Stack.Types.Image
import Stack.Types.PackageIdentifier
import Stack.Types.PackageName
import Stack.Types.Version
@@ -103,6 +110,13 @@
-- ^ @ConfigMonoid@ used to generate this
,configConcurrentTests :: !Bool
-- ^ Run test suites concurrently
+ ,configImage :: !ImageOpts
+ ,configAuthorEmail :: !(Maybe Text)
+ -- ^ Email of the author using stack.
+ ,configAuthorName :: !(Maybe Text)
+ -- ^ Name of the author using stack.
+ ,configScmInit :: !(Maybe SCM)
+ -- ^ Initialize SCM (e.g. git) when creating new projects.
}
-- | Information on a single package index
@@ -118,12 +132,12 @@
-- ^ Require that hashes and package size information be available for packages in this index
}
deriving Show
-instance FromJSON PackageIndex where
- parseJSON = withObject "PackageIndex" $ \o -> do
- name <- o .: "name"
- prefix <- o .: "download-prefix"
- mgit <- o .:? "git"
- mhttp <- o .:? "http"
+instance FromJSON (PackageIndex, [JSONWarning]) where
+ parseJSON = withObjectWarnings "PackageIndex" $ \o -> do
+ name <- o ..: "name"
+ prefix <- o ..: "download-prefix"
+ mgit <- o ..:? "git"
+ mhttp <- o ..:? "http"
loc <-
case (mgit, mhttp) of
(Nothing, Nothing) -> fail $
@@ -132,8 +146,8 @@
(Just git, Nothing) -> return $ ILGit git
(Nothing, Just http) -> return $ ILHttp http
(Just git, Just http) -> return $ ILGitHttp git http
- gpgVerify <- o .:? "gpg-verify" .!= False
- reqHashes <- o .:? "require-hashes" .!= False
+ gpgVerify <- o ..:? "gpg-verify" ..!= False
+ reqHashes <- o ..:? "require-hashes" ..!= False
return PackageIndex
{ indexName = name
, indexLocation = loc
@@ -171,6 +185,42 @@
}
deriving (Show, Eq, Ord)
+data ExecOpts = ExecOpts
+ { eoCmd :: !String
+ , eoArgs :: ![String]
+ , eoExtra :: !ExecOptsExtra
+ }
+
+data ExecOptsExtra
+ = ExecOptsPlain
+ | ExecOptsEmbellished
+ { eoEnvSettings :: !EnvSettings
+ , eoPackages :: ![String]
+ }
+-- | Parsed global command-line options.
+data GlobalOpts = GlobalOpts
+ { globalReExec :: !Bool
+ , globalLogLevel :: !LogLevel -- ^ Log level
+ , globalConfigMonoid :: !ConfigMonoid -- ^ Config monoid, for passing into 'loadConfig'
+ , globalResolver :: !(Maybe AbstractResolver) -- ^ Resolver override
+ , globalTerminal :: !Bool -- ^ We're in a terminal?
+ , globalStackYaml :: !(Maybe FilePath) -- ^ Override project stack.yaml
+ } deriving (Show)
+
+-- | Either an actual resolver value, or an abstract description of one (e.g.,
+-- latest nightly).
+data AbstractResolver
+ = ARLatestNightly
+ | ARLatestLTS
+ | ARLatestLTSMajor !Int
+ | ARResolver !Resolver
+ | ARGlobal
+ deriving Show
+
+-- | Default logging level should be something useful but not crazy.
+defaultLogLevel :: LogLevel
+defaultLogLevel = LevelInfo
+
-- | A superset of 'Config' adding information on how to build code. The reason
-- for this breakdown is because we will need some of the information from
-- 'Config' in order to determine the values here.
@@ -181,7 +231,7 @@
-- packages.
, bcGhcVersionExpected :: !Version
-- ^ Version of GHC we expected for this build
- , bcPackages :: !(Map (Path Abs Dir) Bool)
+ , bcPackageEntries :: ![PackageEntry]
-- ^ Local packages identified by a path, Bool indicates whether it is
-- a non-dependency (the opposite of 'peExtraDep')
, bcExtraDeps :: !(Map PackageName Version)
@@ -189,8 +239,6 @@
--
-- These dependencies will not be installed to a shared location, and
-- will override packages provided by the resolver.
- , bcRoot :: !(Path Abs Dir)
- -- ^ Directory containing the project's stack.yaml file
, bcStackYaml :: !(Path Abs File)
-- ^ Location of the stack.yaml file.
--
@@ -198,13 +246,25 @@
-- different from bcRoot "stack.yaml"
, bcFlags :: !(Map PackageName (Map FlagName Bool))
-- ^ Per-package flag overrides
+ , bcImplicitGlobal :: !Bool
+ -- ^ Are we loading from the implicit global stack.yaml? This is useful
+ -- for providing better error messages.
}
+-- | Directory containing the project's stack.yaml file
+bcRoot :: BuildConfig -> Path Abs Dir
+bcRoot = parent . bcStackYaml
+
+-- | Directory containing the project's stack.yaml file
+bcWorkDir :: BuildConfig -> Path Abs Dir
+bcWorkDir = ( workDirRel) . parent . bcStackYaml
+
-- | Configuration after the environment has been setup.
data EnvConfig = EnvConfig
{envConfigBuildConfig :: !BuildConfig
,envConfigCabalVersion :: !Version
- ,envConfigGhcVersion :: !Version}
+ ,envConfigGhcVersion :: !Version
+ ,envConfigPackages :: !(Map (Path Abs Dir) Bool)}
instance HasBuildConfig EnvConfig where
getBuildConfig = envConfigBuildConfig
instance HasConfig EnvConfig
@@ -219,17 +279,12 @@
data LoadConfig m = LoadConfig
{ lcConfig :: !Config
-- ^ Top-level Stack configuration.
- , lcLoadBuildConfig :: !(Maybe Resolver -> NoBuildConfigStrategy -> m BuildConfig)
+ , lcLoadBuildConfig :: !(Maybe AbstractResolver -> m BuildConfig)
-- ^ Action to load the remaining 'BuildConfig'.
, lcProjectRoot :: !(Maybe (Path Abs Dir))
-- ^ The project root directory, if in a project.
}
-data NoBuildConfigStrategy
- = ThrowException
- | ExecStrategy
- deriving (Show, Eq, Ord)
-
data PackageEntry = PackageEntry
{ peExtraDepMaybe :: !(Maybe Bool)
-- ^ Is this package a dependency? This means the local package will be
@@ -265,20 +320,20 @@
, "location" .= peLocation pe
, "subdirs" .= peSubdirs pe
]
-instance FromJSON PackageEntry where
+instance FromJSON (PackageEntry, [JSONWarning]) where
parseJSON (String t) = do
loc <- parseJSON $ String t
- return PackageEntry
- { peExtraDepMaybe = Nothing
- , peValidWanted = Nothing
- , peLocation = loc
- , peSubdirs = []
- }
- parseJSON v = withObject "PackageEntry" (\o -> PackageEntry
- <$> o .:? "extra-dep"
- <*> o .:? "valid-wanted"
- <*> o .: "location"
- <*> o .:? "subdirs" .!= []) v
+ return (PackageEntry
+ { peExtraDepMaybe = Nothing
+ , peValidWanted = Nothing
+ , peLocation = loc
+ , peSubdirs = []
+ }, [])
+ parseJSON v = withObjectWarnings "PackageEntry" (\o -> PackageEntry
+ <$> o ..:? "extra-dep"
+ <*> o ..:? "valid-wanted"
+ <*> o ..: "location"
+ <*> o ..:? "subdirs" ..!= []) v
data PackageLocation
= PLFilePath FilePath
@@ -337,31 +392,45 @@
-- ^ Require a specific GHC major version, but otherwise provide no build
-- plan. Intended for use cases where end user wishes to specify all upstream
-- dependencies manually, such as using a dependency solver.
+
+ | ResolverCustom !Text !Text
+ -- ^ A custom resolver based on the given name and URL. This file is assumed
+ -- to be completely immutable.
deriving (Show)
instance ToJSON Resolver where
- toJSON = toJSON . renderResolver
+ toJSON (ResolverSnapshot name) = toJSON $ renderSnapName name
+ toJSON (ResolverGhc (MajorVersion x y)) = toJSON $ T.pack $ concat ["ghc-", show x, ".", show y]
+ toJSON (ResolverCustom name location) = object
+ [ "name" .= name
+ , "location" .= location
+ ]
instance FromJSON Resolver where
- parseJSON = withText "Resolver" $
- either (fail . show) return . parseResolver
+ -- Strange structuring is to give consistent error messages
+ parseJSON v@(Object _) = withObject "Resolver" (\o -> ResolverCustom
+ <$> o .: "name"
+ <*> o .: "location") v
--- | Convert a Resolver into its @Text@ representation, as will be used by JSON/YAML
-renderResolver :: Resolver -> Text
-renderResolver (ResolverSnapshot name) = renderSnapName name
-renderResolver (ResolverGhc (MajorVersion x y)) = T.pack $ concat ["ghc-", show x, ".", show y]
+ parseJSON (String t) = either (fail . show) return (parseResolverText t)
--- | Try to parse a @Resolver@, using same format as JSON/YAML/'renderResolver'
-parseResolver :: MonadThrow m => Text -> m Resolver
-parseResolver t =
- case parseSnapName t of
- Right x -> return $ ResolverSnapshot x
- Left _ ->
- case parseGhc of
- Just m -> return $ ResolverGhc m
- Nothing -> throwM $ ParseResolverException t
- where
- parseGhc = T.stripPrefix "ghc-" t >>= parseMajorVersionFromString . T.unpack
+ parseJSON _ = fail $ "Invalid Resolver, must be Object or String"
+-- | Convert a Resolver into its @Text@ representation, as will be used by
+-- directory names
+resolverName :: Resolver -> Text
+resolverName (ResolverSnapshot name) = renderSnapName name
+resolverName (ResolverGhc (MajorVersion x y)) = T.pack $ concat ["ghc-", show x, ".", show y]
+resolverName (ResolverCustom name _) = "custom-" <> name
+
+-- | Try to parse a @Resolver@ from a @Text@. Won't work for complex resolvers (like custom).
+parseResolverText :: MonadThrow m => Text -> m Resolver
+parseResolverText t
+ | Right x <- parseSnapName t = return $ ResolverSnapshot x
+ | Just t' <- T.stripPrefix "ghc-" t
+ , Just v <- parseMajorVersionFromString $ T.unpack t'
+ = return $ ResolverGhc v
+ | otherwise = throwM $ ParseResolverException t
+
-- | Class for environment values which have access to the stack root
class HasStackRoot env where
getStackRoot :: env -> Path Abs Dir
@@ -436,6 +505,16 @@
-- ^ See: 'configExtraLibDirs'
,configMonoidConcurrentTests :: !(Maybe Bool)
-- ^ See: 'configConcurrentTests'
+ ,configMonoidLocalBinPath :: !(Maybe FilePath)
+ -- ^ Used to override the binary installation dir
+ ,configMonoidImageOpts :: !ImageOptsMonoid
+ -- ^ Image creation options.
+ ,configMonoidAuthorEmail :: !(Maybe Text)
+ -- ^ Author's email address.
+ ,configMonoidAuthorName :: !(Maybe Text)
+ -- ^ Author's name.
+ ,configMonoidScmInit :: !(Maybe SCM)
+ -- ^ Initialize SCM (e.g. git init) when making new projects?
}
deriving Show
@@ -457,6 +536,11 @@
, configMonoidExtraIncludeDirs = Set.empty
, configMonoidExtraLibDirs = Set.empty
, configMonoidConcurrentTests = Nothing
+ , configMonoidLocalBinPath = Nothing
+ , configMonoidImageOpts = mempty
+ , configMonoidAuthorEmail = mempty
+ , configMonoidAuthorName = mempty
+ , configMonoidScmInit = Nothing
}
mappend l r = ConfigMonoid
{ configMonoidDockerOpts = configMonoidDockerOpts l <> configMonoidDockerOpts r
@@ -476,32 +560,46 @@
, configMonoidExtraIncludeDirs = Set.union (configMonoidExtraIncludeDirs l) (configMonoidExtraIncludeDirs r)
, configMonoidExtraLibDirs = Set.union (configMonoidExtraLibDirs l) (configMonoidExtraLibDirs r)
, configMonoidConcurrentTests = configMonoidConcurrentTests l <|> configMonoidConcurrentTests r
+ , configMonoidLocalBinPath = configMonoidLocalBinPath l <|> configMonoidLocalBinPath r
+ , configMonoidImageOpts = configMonoidImageOpts l <> configMonoidImageOpts r
+ , configMonoidAuthorName = configMonoidAuthorName l <|> configMonoidAuthorName r
+ , configMonoidAuthorEmail = configMonoidAuthorEmail l <|> configMonoidAuthorEmail r
+ , configMonoidScmInit = configMonoidScmInit l <|> configMonoidScmInit r
}
-instance FromJSON ConfigMonoid where
- parseJSON =
- withObject "ConfigMonoid" $
- \obj ->
- do configMonoidDockerOpts <- obj .:? T.pack "docker" .!= mempty
- configMonoidConnectionCount <- obj .:? "connection-count"
- configMonoidHideTHLoading <- obj .:? "hide-th-loading"
- configMonoidLatestSnapshotUrl <- obj .:? "latest-snapshot-url"
- configMonoidPackageIndices <- obj .:? "package-indices"
- configMonoidSystemGHC <- obj .:? "system-ghc"
- configMonoidInstallGHC <- obj .:? "install-ghc"
- configMonoidSkipGHCCheck <- obj .:? "skip-ghc-check"
- configMonoidSkipMsys <- obj .:? "skip-msys"
- configMonoidRequireStackVersion <- unVersionRangeJSON <$>
- obj .:? "require-stack-version"
- .!= VersionRangeJSON anyVersion
- configMonoidOS <- obj .:? "os"
- configMonoidArch <- obj .:? "arch"
- configMonoidJobs <- obj .:? "jobs"
- configMonoidExtraIncludeDirs <- obj .:? "extra-include-dirs" .!= Set.empty
- configMonoidExtraLibDirs <- obj .:? "extra-lib-dirs" .!= Set.empty
- configMonoidConcurrentTests <- obj .:? "concurrent-tests"
- return ConfigMonoid {..}
+instance FromJSON (ConfigMonoid, [JSONWarning]) where
+ parseJSON = withObjectWarnings "ConfigMonoid" parseConfigMonoidJSON
+-- | Parse a partial configuration. Used both to parse both a standalone config
+-- file and a project file, so that a sub-parser is not required, which would interfere with
+-- warnings for missing fields.
+parseConfigMonoidJSON :: Object -> WarningParser ConfigMonoid
+parseConfigMonoidJSON obj = do
+ configMonoidDockerOpts <- jsonSubWarnings (obj ..:? "docker" ..!= mempty)
+ configMonoidConnectionCount <- obj ..:? "connection-count"
+ configMonoidHideTHLoading <- obj ..:? "hide-th-loading"
+ configMonoidLatestSnapshotUrl <- obj ..:? "latest-snapshot-url"
+ configMonoidPackageIndices <- jsonSubWarningsMT (obj ..:? "package-indices")
+ configMonoidSystemGHC <- obj ..:? "system-ghc"
+ configMonoidInstallGHC <- obj ..:? "install-ghc"
+ configMonoidSkipGHCCheck <- obj ..:? "skip-ghc-check"
+ configMonoidSkipMsys <- obj ..:? "skip-msys"
+ configMonoidRequireStackVersion <- unVersionRangeJSON <$>
+ obj ..:? "require-stack-version"
+ ..!= VersionRangeJSON anyVersion
+ configMonoidOS <- obj ..:? "os"
+ configMonoidArch <- obj ..:? "arch"
+ configMonoidJobs <- obj ..:? "jobs"
+ configMonoidExtraIncludeDirs <- obj ..:? "extra-include-dirs" ..!= Set.empty
+ configMonoidExtraLibDirs <- obj ..:? "extra-lib-dirs" ..!= Set.empty
+ configMonoidConcurrentTests <- obj ..:? "concurrent-tests"
+ configMonoidLocalBinPath <- obj ..:? "local-bin-path"
+ configMonoidImageOpts <- jsonSubWarnings (obj ..:? "image" ..!= mempty)
+ configMonoidAuthorName <- obj ..:? authorNameKey
+ configMonoidAuthorEmail <- obj ..:? authorEmailKey
+ configMonoidScmInit <- obj ..:? scmInitKey
+ return ConfigMonoid {..}
+
-- | Newtype for non-orphan FromJSON instance.
newtype VersionRangeJSON = VersionRangeJSON { unVersionRangeJSON :: VersionRange }
@@ -519,6 +617,7 @@
| UnexpectedTarballContents [Path Abs Dir] [Path Abs File]
| BadStackVersionException VersionRange
| NoMatchingSnapshot [SnapName]
+ | NoSuchDirectory FilePath
deriving Typeable
instance Show ConfigException where
show (ParseConfigFileException configFile exception) = concat
@@ -568,6 +667,10 @@
, "\n\nYou can also try falling back to a dependency solver with:\n\n"
, " stack init --solver"
]
+ show (NoSuchDirectory dir) = concat
+ ["No directory could be located matching the supplied path: "
+ ,dir
+ ]
instance Exception ConfigException
-- | Helper function to ask the environment and apply getConfig
@@ -644,7 +747,7 @@
snapshots <- snapshotsDir
bc <- asks getBuildConfig
ec <- asks getEnvConfig
- name <- parseRelDir $ T.unpack $ renderResolver $ bcResolver bc
+ name <- parseRelDir $ T.unpack $ resolverName $ bcResolver bc
ghc <- parseRelDir $ versionString $ envConfigGhcVersion ec
return $ snapshots name ghc
@@ -653,7 +756,7 @@
installationRootLocal = do
bc <- asks getBuildConfig
ec <- asks getEnvConfig
- name <- parseRelDir $ T.unpack $ renderResolver $ bcResolver bc
+ name <- parseRelDir $ T.unpack $ resolverName $ bcResolver bc
ghc <- parseRelDir $ versionString $ envConfigGhcVersion ec
platform <- platformRelDir
return $ configProjectWorkDir bc $(mkRelDir "install") platform name ghc
@@ -692,9 +795,13 @@
bindirSuffix = $(mkRelDir "bin")
-- | Suffix applied to an installation root to get the doc dir
-docdirSuffix :: Path Rel Dir
-docdirSuffix = $(mkRelDir "doc")
+docDirSuffix :: Path Rel Dir
+docDirSuffix = $(mkRelDir "doc")
+-- | Suffix applied to an installation root to get the hpc dir
+hpcDirSuffix :: Path Rel Dir
+hpcDirSuffix = $(mkRelDir "hpc")
+
-- | Get the extra bin directories (for the PATH). Puts more local first
--
-- Bool indicates whether or not to include the locals
@@ -721,18 +828,18 @@
data ProjectAndConfigMonoid
= ProjectAndConfigMonoid !Project !ConfigMonoid
-instance FromJSON ProjectAndConfigMonoid where
- parseJSON = withObject "Project, ConfigMonoid" $ \o -> do
- dirs <- o .:? "packages" .!= [packageEntryCurrDir]
- extraDeps' <- o .:? "extra-deps" .!= []
+instance (warnings ~ [JSONWarning]) => FromJSON (ProjectAndConfigMonoid, warnings) where
+ parseJSON = withObjectWarnings "ProjectAndConfigMonoid" $ \o -> do
+ dirs <- jsonSubWarningsMT (o ..:? "packages") ..!= [packageEntryCurrDir]
+ extraDeps' <- o ..:? "extra-deps" ..!= []
extraDeps <-
case partitionEithers $ goDeps extraDeps' of
([], x) -> return $ Map.fromList x
(errs, _) -> fail $ unlines errs
- flags <- o .:? "flags" .!= mempty
- resolver <- o .: "resolver"
- config <- parseJSON $ Object o
+ flags <- o ..:? "flags" ..!= mempty
+ resolver <- o ..: "resolver"
+ config <- parseConfigMonoidJSON o
let project = Project
{ projectPackages = dirs
, projectExtraDeps = extraDeps
@@ -766,3 +873,29 @@
, peLocation = PLFilePath "."
, peSubdirs = []
}
+
+-- | A software control system.
+data SCM = Git
+ deriving (Show)
+
+instance FromJSON SCM where
+ parseJSON v = do
+ s <- parseJSON v
+ case s of
+ "git" -> return Git
+ _ -> fail ("Unknown or unsupported SCM: " <> s)
+
+instance ToJSON SCM where
+ toJSON Git = toJSON ("git" :: Text)
+
+-- | Key used for the YAML file and templates.
+authorEmailKey :: Text
+authorEmailKey = "author-email"
+
+-- | Key used for the YAML file and templates.
+authorNameKey :: Text
+authorNameKey = "author-name"
+
+-- | Key used for the YAML file and templates.
+scmInitKey :: Text
+scmInitKey = "scm-init"
diff --git a/src/Stack/Types/Docker.hs b/src/Stack/Types/Docker.hs
--- a/src/Stack/Types/Docker.hs
+++ b/src/Stack/Types/Docker.hs
@@ -36,8 +36,6 @@
-- ^ Arguments to pass directly to @docker run@.
,dockerMount :: ![Mount]
-- ^ Volumes to mount in the container.
- ,dockerPassHost :: !Bool
- -- ^ Pass Docker daemon connection information into container.
,dockerDatabasePath :: !(Path Abs File)
-- ^ Location of image usage database.
}
@@ -72,32 +70,29 @@
-- ^ Arguments to pass directly to @docker run@
,dockerMonoidMount :: ![Mount]
-- ^ Volumes to mount in the container
- ,dockerMonoidPassHost :: !(Maybe Bool)
- -- ^ Pass Docker daemon connection information into container.
,dockerMonoidDatabasePath :: !(Maybe String)
-- ^ Location of image usage database.
}
deriving (Show)
-- | Decode uninterpreted docker options from JSON/YAML.
-instance FromJSON DockerOptsMonoid where
- parseJSON = withObject "DockerOptsMonoid"
+instance FromJSON (DockerOptsMonoid, [JSONWarning]) where
+ parseJSON = withObjectWarnings "DockerOptsMonoid"
(\o -> do dockerMonoidExists <- pure (Just True)
- dockerMonoidEnable <- o .:? dockerEnableArgName
- dockerMonoidRepoOrImage <- ((Just . DockerMonoidImage) <$> o .: dockerImageArgName) <|>
- ((Just . DockerMonoidRepo) <$> o .: dockerRepoArgName) <|>
+ dockerMonoidEnable <- o ..:? dockerEnableArgName
+ dockerMonoidRepoOrImage <- ((Just . DockerMonoidImage) <$> o ..: dockerImageArgName) <|>
+ ((Just . DockerMonoidRepo) <$> o ..: dockerRepoArgName) <|>
pure Nothing
- dockerMonoidRegistryLogin <- o .:? dockerRegistryLoginArgName
- dockerMonoidRegistryUsername <- o .:? dockerRegistryUsernameArgName
- dockerMonoidRegistryPassword <- o .:? dockerRegistryPasswordArgName
- dockerMonoidAutoPull <- o .:? dockerAutoPullArgName
- dockerMonoidDetach <- o .:? dockerDetachArgName
- dockerMonoidPersist <- o .:? dockerPersistArgName
- dockerMonoidContainerName <- o .:? dockerContainerNameArgName
- dockerMonoidRunArgs <- o .:? dockerRunArgsArgName .!= []
- dockerMonoidMount <- o .:? dockerMountArgName .!= []
- dockerMonoidPassHost <- o .:? dockerPassHostArgName
- dockerMonoidDatabasePath <- o .:? dockerDatabasePathArgName
+ dockerMonoidRegistryLogin <- o ..:? dockerRegistryLoginArgName
+ dockerMonoidRegistryUsername <- o ..:? dockerRegistryUsernameArgName
+ dockerMonoidRegistryPassword <- o ..:? dockerRegistryPasswordArgName
+ dockerMonoidAutoPull <- o ..:? dockerAutoPullArgName
+ dockerMonoidDetach <- o ..:? dockerDetachArgName
+ dockerMonoidPersist <- o ..:? dockerPersistArgName
+ dockerMonoidContainerName <- o ..:? dockerContainerNameArgName
+ dockerMonoidRunArgs <- o ..:? dockerRunArgsArgName ..!= []
+ dockerMonoidMount <- o ..:? dockerMountArgName ..!= []
+ dockerMonoidDatabasePath <- o ..:? dockerDatabasePathArgName
return DockerOptsMonoid{..})
-- | Left-biased combine Docker options
@@ -115,7 +110,6 @@
,dockerMonoidContainerName = Nothing
,dockerMonoidRunArgs = []
,dockerMonoidMount = []
- ,dockerMonoidPassHost = Nothing
,dockerMonoidDatabasePath = Nothing
}
mappend l r = DockerOptsMonoid
@@ -131,7 +125,6 @@
,dockerMonoidContainerName = dockerMonoidContainerName l <|> dockerMonoidContainerName r
,dockerMonoidRunArgs = dockerMonoidRunArgs r <> dockerMonoidRunArgs l
,dockerMonoidMount = dockerMonoidMount r <> dockerMonoidMount l
- ,dockerMonoidPassHost = dockerMonoidPassHost l <|> dockerMonoidPassHost r
,dockerMonoidDatabasePath = dockerMonoidDatabasePath l <|> dockerMonoidDatabasePath r
}
@@ -209,10 +202,6 @@
-- | Docker persist argument name.
dockerPersistArgName :: Text
dockerPersistArgName = "persist"
-
--- | Docker pass host argument name.
-dockerPassHostArgName :: Text
-dockerPassHostArgName = "pass-host"
-- | Docker database path argument name.
dockerDatabasePathArgName :: Text
diff --git a/src/Stack/Types/FlagName.hs b/src/Stack/Types/FlagName.hs
--- a/src/Stack/Types/FlagName.hs
+++ b/src/Stack/Types/FlagName.hs
@@ -26,7 +26,7 @@
import Data.Aeson.Extended
import Data.Attoparsec.ByteString.Char8
import Data.Attoparsec.Combinators
-import Data.Binary (Binary)
+import Data.Binary.VersionTagged
import qualified Data.ByteString as S
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as S8
@@ -54,7 +54,7 @@
-- | A flag name.
newtype FlagName =
FlagName ByteString
- deriving (Typeable,Data,Generic,Hashable,Binary)
+ deriving (Typeable,Data,Generic,Hashable,Binary,NFData)
instance Eq FlagName where
x == y = (compare x y) == EQ
instance Ord FlagName where
diff --git a/src/Stack/Types/GhcPkgId.hs b/src/Stack/Types/GhcPkgId.hs
--- a/src/Stack/Types/GhcPkgId.hs
+++ b/src/Stack/Types/GhcPkgId.hs
@@ -16,7 +16,7 @@
import Control.Monad.Catch
import Data.Aeson.Extended
import Data.Attoparsec.ByteString.Char8
-import Data.Binary (Binary)
+import Data.Binary.VersionTagged
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as S8
import Data.Char (isLetter)
@@ -43,6 +43,8 @@
instance Hashable GhcPkgId
instance Binary GhcPkgId
+instance NFData GhcPkgId where
+ rnf = genericRnf
instance Show GhcPkgId where
show = show . ghcPkgIdString
diff --git a/src/Stack/Types/Image.hs b/src/Stack/Types/Image.hs
new file mode 100644
--- /dev/null
+++ b/src/Stack/Types/Image.hs
@@ -0,0 +1,107 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Stack.Types.Image where
+
+import Control.Applicative
+import Data.Aeson.Extended
+import Data.Monoid
+import Data.Map (Map)
+import Data.Text (Text)
+
+-- | Image options. Currently only Docker image options.
+data ImageOpts = ImageOpts
+ { imgDocker :: !(Maybe ImageDockerOpts)
+ -- ^ Maybe a section for docker image settings.
+ } deriving (Show)
+
+data ImageDockerOpts = ImageDockerOpts
+ { imgDockerBase :: !(Maybe String)
+ -- ^ Maybe have a docker base image name. (Although we will not
+ -- be able to create any Docker images without this.)
+ , imgDockerEntrypoints :: !(Maybe [String])
+ -- ^ Maybe have a specific ENTRYPOINT list that will be used to
+ -- create images.
+ , imgDockerAdd :: !(Map FilePath FilePath)
+ -- ^ Maybe have some static project content to include in a
+ -- specific directory in all the images.
+ , imgDockerImageName :: !(Maybe String)
+ -- ^ Maybe have a name for the image we are creating
+ } deriving (Show)
+
+data ImageOptsMonoid = ImageOptsMonoid
+ { imgMonoidDocker :: !(Maybe ImageDockerOptsMonoid)
+ } deriving (Show)
+
+data ImageDockerOptsMonoid = ImageDockerOptsMonoid
+ { imgDockerMonoidBase :: !(Maybe String)
+ , imgDockerMonoidEntrypoints :: !(Maybe [String])
+ , imgDockerMonoidAdd :: !(Maybe (Map String FilePath))
+ , imgDockerMonoidImageName :: !(Maybe String)
+ } deriving (Show)
+
+instance FromJSON (ImageOptsMonoid, [JSONWarning]) where
+ parseJSON = withObjectWarnings
+ "ImageOptsMonoid"
+ (\o ->
+ do imgMonoidDocker <- jsonSubWarningsT (o ..:? imgDockerArgName)
+ return
+ ImageOptsMonoid
+ { ..
+ })
+
+instance Monoid ImageOptsMonoid where
+ mempty = ImageOptsMonoid
+ { imgMonoidDocker = Nothing
+ }
+ mappend l r = ImageOptsMonoid
+ { imgMonoidDocker = imgMonoidDocker l <|> imgMonoidDocker r
+ }
+
+instance FromJSON (ImageDockerOptsMonoid, [JSONWarning]) where
+ parseJSON = withObjectWarnings
+ "ImageDockerOptsMonoid"
+ (\o ->
+ do imgDockerMonoidBase <- o ..:? imgDockerBaseArgName
+ imgDockerMonoidEntrypoints <- o ..:?
+ imgDockerEntrypointsArgName
+ imgDockerMonoidAdd <- o ..:? imgDockerAddArgName
+ imgDockerMonoidImageName <- o ..:? imgDockerImageNameArgName
+ return
+ ImageDockerOptsMonoid
+ { ..
+ })
+
+instance Monoid ImageDockerOptsMonoid where
+ mempty = ImageDockerOptsMonoid
+ { imgDockerMonoidBase = Nothing
+ , imgDockerMonoidEntrypoints = Nothing
+ , imgDockerMonoidAdd = Nothing
+ , imgDockerMonoidImageName = Nothing
+ }
+ mappend l r = ImageDockerOptsMonoid
+ { imgDockerMonoidBase = imgDockerMonoidBase l <|> imgDockerMonoidBase r
+ , imgDockerMonoidEntrypoints = imgDockerMonoidEntrypoints l <|> imgDockerMonoidEntrypoints
+ r
+ , imgDockerMonoidAdd = imgDockerMonoidAdd l <|> imgDockerMonoidAdd r
+ , imgDockerMonoidImageName = imgDockerMonoidImageName l <|> imgDockerMonoidImageName r
+ }
+
+imgArgName :: Text
+imgArgName = "image"
+
+imgDockerArgName :: Text
+imgDockerArgName = "container"
+
+imgDockerBaseArgName :: Text
+imgDockerBaseArgName = "base"
+
+imgDockerAddArgName :: Text
+imgDockerAddArgName = "add"
+
+imgDockerEntrypointsArgName :: Text
+imgDockerEntrypointsArgName = "entrypoints"
+
+imgDockerImageNameArgName :: Text
+imgDockerImageNameArgName = "name"
diff --git a/src/Stack/Types/Internal.hs b/src/Stack/Types/Internal.hs
--- a/src/Stack/Types/Internal.hs
+++ b/src/Stack/Types/Internal.hs
@@ -13,6 +13,7 @@
Env {envConfig :: !config
,envLogLevel :: !LogLevel
,envTerminal :: !Bool
+ ,envReExec :: !Bool
,envManager :: !Manager
,envSticky :: !Sticky}
@@ -44,6 +45,12 @@
instance HasTerminal (Env config) where
getTerminal = envTerminal
+
+class HasReExec r where
+ getReExec :: r -> Bool
+
+instance HasReExec (Env config) where
+ getReExec = envReExec
newtype Sticky = Sticky
{ unSticky :: Maybe (MVar (Maybe Text))
diff --git a/src/Stack/Types/Package.hs b/src/Stack/Types/Package.hs
new file mode 100644
--- /dev/null
+++ b/src/Stack/Types/Package.hs
@@ -0,0 +1,231 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+-- |
+
+module Stack.Types.Package where
+
+import Control.DeepSeq
+import Control.Exception hiding (try,catch)
+import Control.Monad.Catch
+import Control.Monad.IO.Class
+import Control.Monad.Logger (MonadLogger)
+import Control.Monad.Reader
+import Data.Binary
+import Data.Binary.VersionTagged
+import qualified Data.ByteString as S
+import Data.Data
+import Data.Function
+import Data.List
+import Data.Map.Strict (Map)
+import Data.Maybe
+import Data.Monoid
+import Data.Set (Set)
+import Data.Text (Text)
+import Data.Text.Encoding (encodeUtf8)
+import Distribution.InstalledPackageInfo (PError)
+import Distribution.ModuleName (ModuleName)
+import Distribution.Package hiding (Package,PackageName,packageName,packageVersion,PackageIdentifier)
+import Distribution.System (Platform (..))
+import GHC.Generics
+import Path as FL
+import Prelude
+import Stack.Types.Config
+import Stack.Types.FlagName
+import Stack.Types.PackageName
+import Stack.Types.Version
+
+-- | All exceptions thrown by the library.
+data PackageException
+ = PackageInvalidCabalFile (Maybe (Path Abs File)) PError
+ | PackageNoCabalFileFound (Path Abs Dir)
+ | PackageMultipleCabalFilesFound (Path Abs Dir) [Path Abs File]
+ | MismatchedCabalName (Path Abs File) PackageName
+ deriving Typeable
+instance Exception PackageException
+instance Show PackageException where
+ show (PackageInvalidCabalFile mfile err) =
+ "Unable to parse cabal file" ++
+ (case mfile of
+ Nothing -> ""
+ Just file -> ' ' : toFilePath file) ++
+ ": " ++
+ show err
+ show (PackageNoCabalFileFound dir) =
+ "No .cabal file found in directory " ++
+ toFilePath dir
+ show (PackageMultipleCabalFilesFound dir files) =
+ "Multiple .cabal files found in directory " ++
+ toFilePath dir ++
+ ": " ++
+ intercalate ", " (map (toFilePath . filename) files)
+ show (MismatchedCabalName fp name) = concat
+ [ "cabal file "
+ , toFilePath fp
+ , " has a mismatched package name: "
+ , packageNameString name
+ ]
+
+-- | Some package info.
+data Package =
+ Package {packageName :: !PackageName -- ^ Name of the package.
+ ,packageVersion :: !Version -- ^ Version of the package
+ ,packageFiles :: !GetPackageFiles -- ^ Get all files of the package.
+ ,packageModules :: !GetPackageModules -- ^ Get the modules of the package.
+ ,packageDeps :: !(Map PackageName VersionRange) -- ^ Packages that the package depends on.
+ ,packageTools :: ![Dependency] -- ^ A build tool name.
+ ,packageAllDeps :: !(Set PackageName) -- ^ Original dependencies (not sieved).
+ ,packageFlags :: !(Map FlagName Bool) -- ^ Flags used on package.
+ ,packageHasLibrary :: !Bool -- ^ does the package have a buildable library stanza?
+ ,packageTests :: !(Set Text) -- ^ names of test suites
+ ,packageBenchmarks :: !(Set Text) -- ^ names of benchmarks
+ ,packageExes :: !(Set Text) -- ^ names of executables
+ ,packageOpts :: !GetPackageOpts -- ^ Args to pass to GHC.
+ ,packageHasExposedModules :: !Bool -- ^ Does the package have exposed modules?
+ ,packageSimpleType :: !Bool -- ^ Does the package of build-type: Simple
+ ,packageDefinedFlags :: !(Set FlagName) -- ^ All flags defined in the .cabal file
+ }
+ deriving (Show,Typeable)
+
+-- | Files that the package depends on, relative to package directory.
+-- Argument is the location of the .cabal file
+newtype GetPackageOpts = GetPackageOpts
+ { getPackageOpts :: forall env m. (MonadIO m,HasEnvConfig env, HasPlatform env, MonadThrow m, MonadReader env m)
+ => SourceMap
+ -> [PackageName]
+ -> Path Abs File
+ -> m [String]
+ }
+instance Show GetPackageOpts where
+ show _ = ""
+
+-- | Files that the package depends on, relative to package directory.
+-- Argument is the location of the .cabal file
+newtype GetPackageFiles = GetPackageFiles
+ { getPackageFiles :: forall m env. (MonadIO m, MonadLogger m, MonadThrow m, MonadCatch m, MonadReader env m, HasPlatform env, HasEnvConfig env)
+ => Path Abs File
+ -> m (Set (Path Abs File))
+ }
+instance Show GetPackageFiles where
+ show _ = ""
+
+-- | Modules in the package.
+newtype GetPackageModules = GetPackageModules
+ { getPackageModules :: forall m env. (MonadIO m, MonadLogger m, MonadThrow m, MonadCatch m, MonadReader env m, HasPlatform env, HasEnvConfig env)
+ => Path Abs File
+ -> m (Set ModuleName)
+ }
+instance Show GetPackageModules where
+ show _ = ""
+
+-- | Package build configuration
+data PackageConfig =
+ PackageConfig {packageConfigEnableTests :: !Bool -- ^ Are tests enabled?
+ ,packageConfigEnableBenchmarks :: !Bool -- ^ Are benchmarks enabled?
+ ,packageConfigFlags :: !(Map FlagName Bool) -- ^ Package config flags.
+ ,packageConfigGhcVersion :: !Version -- ^ GHC version
+ ,packageConfigPlatform :: !Platform -- ^ host platform
+ }
+ deriving (Show,Typeable)
+
+-- | Compares the package name.
+instance Ord Package where
+ compare = on compare packageName
+
+-- | Compares the package name.
+instance Eq Package where
+ (==) = on (==) packageName
+
+type SourceMap = Map PackageName PackageSource
+
+-- | Where the package's source is located: local directory or package index
+data PackageSource
+ = PSLocal LocalPackage
+ | PSUpstream Version InstallLocation (Map FlagName Bool)
+ -- ^ Upstream packages could be installed in either local or snapshot
+ -- databases; this is what 'InstallLocation' specifies.
+ deriving Show
+
+instance PackageInstallInfo PackageSource where
+ piiVersion (PSLocal lp) = packageVersion $ lpPackage lp
+ piiVersion (PSUpstream v _ _) = v
+
+ piiLocation (PSLocal _) = Local
+ piiLocation (PSUpstream _ loc _) = loc
+
+-- | Datatype which tells how which version of a package to install and where
+-- to install it into
+class PackageInstallInfo a where
+ piiVersion :: a -> Version
+ piiLocation :: a -> InstallLocation
+
+-- | Second-stage build information: tests and benchmarks
+data LocalPackageTB = LocalPackageTB
+ { lptbPackage :: !Package
+ -- ^ Package resolved with dependencies for tests and benchmarks, depending
+ -- on which components are active
+ , lptbTests :: !(Set Text)
+ -- ^ Test components
+ , lptbBenches :: !(Set Text)
+ -- ^ Benchmark components
+ }
+ deriving Show
+
+-- | Information on a locally available package of source code
+data LocalPackage = LocalPackage
+ { lpPackage :: !Package -- ^ The @Package@ info itself, after resolution with package flags, not including any tests or benchmarks
+ , lpExeComponents :: !(Maybe (Set Text)) -- ^ Executable components to build, Nothing if not a target
+
+ , lpTestBench :: !(Maybe LocalPackageTB)
+
+ , lpDir :: !(Path Abs Dir) -- ^ Directory of the package.
+ , lpCabalFile :: !(Path Abs File) -- ^ The .cabal file
+ , lpDirtyFiles :: !Bool -- ^ are there files that have changed since the last build?
+ , lpNewBuildCache :: !(Map FilePath FileCacheInfo) -- ^ current state of the files
+ , lpFiles :: !(Set (Path Abs File)) -- ^ all files used by this package
+ , lpComponents :: !(Set NamedComponent)
+ }
+ deriving Show
+
+-- | Is the given local a target
+lpWanted :: LocalPackage -> Bool
+lpWanted lp = isJust (lpExeComponents lp) || isJust (lpTestBench lp)
+
+-- | A single, fully resolved component of a package
+data NamedComponent
+ = CLib
+ | CExe !Text
+ | CTest !Text
+ | CBench !Text
+ deriving (Show, Eq, Ord)
+
+renderComponent :: NamedComponent -> S.ByteString
+renderComponent CLib = "lib"
+renderComponent (CExe x) = "exe:" <> encodeUtf8 x
+renderComponent (CTest x) = "test:" <> encodeUtf8 x
+renderComponent (CBench x) = "bench:" <> encodeUtf8 x
+
+-- | A location to install a package into, either snapshot or local
+data InstallLocation = Snap | Local
+ deriving (Show, Eq)
+instance Monoid InstallLocation where
+ mempty = Snap
+ mappend Local _ = Local
+ mappend _ Local = Local
+ mappend Snap Snap = Snap
+
+data FileCacheInfo = FileCacheInfo
+ { fciModTime :: !ModTime
+ , fciSize :: !Word64
+ , fciHash :: !S.ByteString
+ }
+ deriving (Generic, Show)
+instance Binary FileCacheInfo
+instance NFData FileCacheInfo where
+ rnf = genericRnf
+
+-- | Used for storage and comparison.
+newtype ModTime = ModTime (Integer,Rational)
+ deriving (Ord,Show,Generic,Eq,NFData,Binary)
diff --git a/src/Stack/Types/PackageName.hs b/src/Stack/Types/PackageName.hs
--- a/src/Stack/Types/PackageName.hs
+++ b/src/Stack/Types/PackageName.hs
@@ -20,7 +20,8 @@
,fromCabalPackageName
,toCabalPackageName
,parsePackageNameFromFilePath
- ,mkPackageName)
+ ,mkPackageName
+ ,packageNameArgument)
where
import Control.Applicative
@@ -45,6 +46,7 @@
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Path
+import qualified Options.Applicative as O
-- | A parse fail.
data PackageNameParseFail
@@ -150,3 +152,17 @@
fmap Map.fromList $ mapM go $ Map.toList m
where
go (k, v) = fmap (, v) $ either (fail . show) return $ parsePackageNameFromString k
+
+-- | An argument which accepts a template name of the format
+-- @foo.hsfiles@.
+packageNameArgument :: O.Mod O.ArgumentFields PackageName
+ -> O.Parser PackageName
+packageNameArgument =
+ O.argument
+ (do s <- O.str
+ either O.readerError return (p s))
+ where
+ p s =
+ case parsePackageNameFromString s of
+ Just x -> Right x
+ Nothing -> Left ("Expected valid package name, but got: " ++ s)
diff --git a/src/Stack/Types/StackT.hs b/src/Stack/Types/StackT.hs
--- a/src/Stack/Types/StackT.hs
+++ b/src/Stack/Types/StackT.hs
@@ -8,6 +8,7 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- | The monad used for the command-line executable @stack@.
@@ -16,7 +17,9 @@
(StackT
,StackLoggingT
,runStackT
+ ,runStackTGlobal
,runStackLoggingT
+ ,runStackLoggingTGlobal
,newTLSManager
,logSticky
,logStickyDone)
@@ -45,6 +48,7 @@
import Network.HTTP.Conduit
import Prelude -- Fix AMP warning
import Stack.Types.Internal
+import Stack.Types.Config (GlobalOpts (..))
import System.IO
import System.Log.FastLogger
@@ -79,16 +83,22 @@
instance (MonadIO m) => MonadLogger (StackT config m) where
monadLoggerLog = stickyLoggerFunc
+-- | Run a Stack action, using global options.
+runStackTGlobal :: (MonadIO m,MonadBaseControl IO m)
+ => Manager -> config -> GlobalOpts -> StackT config m a -> m a
+runStackTGlobal manager config GlobalOpts{..} m =
+ runStackT manager globalLogLevel config globalTerminal globalReExec m
+
-- | Run a Stack action.
runStackT :: (MonadIO m,MonadBaseControl IO m)
- => Manager -> LogLevel -> config -> Bool -> StackT config m a -> m a
-runStackT manager logLevel config terminal m =
+ => Manager -> LogLevel -> config -> Bool -> Bool -> StackT config m a -> m a
+runStackT manager logLevel config terminal reExec m =
withSticky
terminal
(\sticky ->
runReaderT
(unStackT m)
- (Env config logLevel terminal manager sticky))
+ (Env config logLevel terminal reExec manager sticky))
--------------------------------------------------------------------------------
-- Logging only StackLoggingT monad transformer
@@ -97,6 +107,7 @@
data LoggingEnv = LoggingEnv
{ lenvLogLevel :: !LogLevel
, lenvTerminal :: !Bool
+ , lenvReExec :: !Bool
, lenvManager :: !Manager
, lenvSticky :: !Sticky
}
@@ -135,10 +146,19 @@
instance HasTerminal LoggingEnv where
getTerminal = lenvTerminal
+instance HasReExec LoggingEnv where
+ getReExec = lenvReExec
+
+-- | Run the logging monad, using global options.
+runStackLoggingTGlobal :: MonadIO m
+ => Manager -> GlobalOpts -> StackLoggingT m a -> m a
+runStackLoggingTGlobal manager GlobalOpts{..} m =
+ runStackLoggingT manager globalLogLevel globalTerminal globalReExec m
+
-- | Run the logging monad.
runStackLoggingT :: MonadIO m
- => Manager -> LogLevel -> Bool -> StackLoggingT m a -> m a
-runStackLoggingT manager logLevel terminal m =
+ => Manager -> LogLevel -> Bool -> Bool -> StackLoggingT m a -> m a
+runStackLoggingT manager logLevel terminal reExec m =
withSticky
terminal
(\sticky ->
@@ -149,6 +169,7 @@
, lenvManager = manager
, lenvSticky = sticky
, lenvTerminal = terminal
+ , lenvReExec = reExec
})
-- | Convenience for getting a 'Manager'
@@ -224,8 +245,9 @@
do maxLogLevel <- asks getLogLevel
when (level >= maxLogLevel)
(liftIO (do out <- getOutput maxLogLevel
- S8.putStrLn (S8.pack out)))
- where getOutput maxLogLevel =
+ S8.hPutStrLn outputChannel (S8.pack out)))
+ where outputChannel = stderr
+ getOutput maxLogLevel =
do date <- getDate
l <- getLevel
lc <- getLoc
diff --git a/src/Stack/Types/TemplateName.hs b/src/Stack/Types/TemplateName.hs
new file mode 100644
--- /dev/null
+++ b/src/Stack/Types/TemplateName.hs
@@ -0,0 +1,59 @@
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+-- | Template name handling.
+
+module Stack.Types.TemplateName where
+
+import Data.Monoid
+import Data.Text (Text)
+import qualified Data.Text as T
+import Language.Haskell.TH
+import qualified Options.Applicative as O
+import Path
+import Path.Internal
+
+-- | A template name of the format @foo.hsfiles@.
+data TemplateName = TemplateName !Text !(Path Rel File)
+ deriving (Ord,Eq,Show)
+
+-- | An argument which accepts a template name of the format
+-- @foo.hsfiles@ or @foo@, ultimately normalized to @foo.hsfiles@.
+templateNameArgument :: O.Mod O.ArgumentFields TemplateName
+ -> O.Parser TemplateName
+templateNameArgument =
+ O.argument
+ (do string <- O.str
+ either O.readerError return (parseTemplateNameFromString string))
+
+-- | Parse a template name from a string.
+parseTemplateNameFromString :: String -> Either String TemplateName
+parseTemplateNameFromString fname =
+ case T.stripSuffix ".hsfiles" (T.pack fname) of
+ Nothing -> parseValidFile (T.pack fname) (fname <> ".hsfiles")
+ Just prefix -> parseValidFile prefix fname
+ where
+ parseValidFile prefix str =
+ case parseRelFile str of
+ Nothing -> Left expected
+ Just fp -> return (TemplateName prefix fp)
+ expected = "Expected a template filename like: foo or foo.hsfiles"
+
+
+-- | Make a template name.
+mkTemplateName :: String -> Q Exp
+mkTemplateName s =
+ case parseTemplateNameFromString s of
+ Left{} -> error ("Invalid template name: " ++ show s)
+ Right (TemplateName (T.unpack -> prefix) (Path pn)) ->
+ [|TemplateName (T.pack prefix) (Path pn)|]
+
+-- | Get a text representation of the template name.
+templateName :: TemplateName -> Text
+templateName (TemplateName prefix _) = prefix
+
+-- | Get the path of the template.
+templatePath :: TemplateName -> Path Rel File
+templatePath (TemplateName _ fp) = fp
diff --git a/src/Stack/Types/Version.hs b/src/Stack/Types/Version.hs
--- a/src/Stack/Types/Version.hs
+++ b/src/Stack/Types/Version.hs
@@ -24,7 +24,8 @@
,fromCabalVersion
,mkVersion
,versionRangeText
- ,withinRange)
+ ,withinRange
+ ,Stack.Types.Version.intersectVersionRanges)
where
import Control.Applicative
@@ -201,3 +202,7 @@
-- | Check if a version is within a version range.
withinRange :: Version -> Cabal.VersionRange -> Bool
withinRange v r = toCabalVersion v `Cabal.withinRange` r
+
+-- | A modified intersection which also simplifies, for better display.
+intersectVersionRanges :: Cabal.VersionRange -> Cabal.VersionRange -> Cabal.VersionRange
+intersectVersionRanges x y = Cabal.simplifyVersionRange $ Cabal.intersectVersionRanges x y
diff --git a/src/Stack/Upgrade.hs b/src/Stack/Upgrade.hs
--- a/src/Stack/Upgrade.hs
+++ b/src/Stack/Upgrade.hs
@@ -16,7 +16,7 @@
import Path
import qualified Paths_stack as Paths
import Stack.Build
-import Stack.Build.Types
+import Stack.Types.Build
import Stack.Config
import Stack.Fetch
import Stack.PackageIndex
@@ -27,9 +27,9 @@
import System.IO.Temp (withSystemTempDirectory)
import System.Process.Run
-upgrade :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, HasTerminal env, HasLogLevel env, MonadBaseControl IO m)
+upgrade :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, HasTerminal env, HasReExec env, HasLogLevel env, MonadBaseControl IO m)
=> Bool -- ^ use Git?
- -> Maybe Resolver
+ -> Maybe AbstractResolver
-> m ()
upgrade fromGit mresolver = withSystemTempDirectory "stack-upgrade" $ \tmp' -> do
menv <- getMinimalEnvOverride
@@ -40,7 +40,7 @@
$logInfo "Cloning stack"
runIn tmp "git" menv
[ "clone"
- , "git@github.com:commercialhaskell/stack" -- TODO allow to be configured
+ , "https://github.com/commercialhaskell/stack" -- TODO allow to be configured
, "stack"
, "--depth"
, "1"
@@ -75,16 +75,18 @@
manager <- asks getHttpManager
logLevel <- asks getLogLevel
terminal <- asks getTerminal
+ reExec <- asks getReExec
configMonoid <- asks $ configConfigMonoid . getConfig
forM_ mdir $ \dir -> liftIO $ do
- bconfig <- runStackLoggingT manager logLevel terminal $ do
+ bconfig <- runStackLoggingT manager logLevel terminal reExec $ do
lc <- loadConfig
configMonoid
(Just $ dir $(mkRelFile "stack.yaml"))
- lcLoadBuildConfig lc mresolver ThrowException
- envConfig1 <- runStackT manager logLevel bconfig terminal setupEnv
- runStackT manager logLevel envConfig1 terminal $ build (const $ return ()) defaultBuildOpts
+ lcLoadBuildConfig lc mresolver
+ envConfig1 <- runStackT manager logLevel bconfig terminal reExec setupEnv
+ runStackT manager logLevel envConfig1 terminal reExec $
+ build (const $ return ()) Nothing defaultBuildOpts
{ boptsTargets = ["stack"]
, boptsInstallExes = True
}
diff --git a/src/Stack/Upload.hs b/src/Stack/Upload.hs
--- a/src/Stack/Upload.hs
+++ b/src/Stack/Upload.hs
@@ -7,6 +7,7 @@
mkUploader
, Uploader
, upload
+ , uploadBytes
, UploadSettings
, defaultUploadSettings
, setUploadUrl
@@ -44,6 +45,7 @@
import Data.Typeable (Typeable)
import Network.HTTP.Client (BodyReader, Manager,
Response,
+ RequestBody(RequestBodyLBS),
applyBasicAuth, brRead,
checkStatus, newManager,
parseUrl,
@@ -51,26 +53,16 @@
responseBody,
responseStatus,
withResponse)
-import Network.HTTP.Client.MultipartFormData (formDataBody, partFile)
+import Network.HTTP.Client.MultipartFormData (formDataBody, partFileRequestBody)
import Network.HTTP.Client.TLS (tlsManagerSettings)
import Network.HTTP.Types (statusCode)
import Path (toFilePath)
import Stack.Types
import System.Directory (createDirectoryIfMissing,
- doesDirectoryExist,
- doesFileExist,
- getDirectoryContents,
removeFile)
-import System.Exit (ExitCode (ExitSuccess))
-import System.FilePath (takeExtension, ())
-import System.IO (hClose, hFlush,
- hGetEcho, hSetEcho,
+import System.FilePath ((), takeFileName)
+import System.IO (hFlush, hGetEcho, hSetEcho,
stdin, stdout)
-import System.IO.Temp (withSystemTempDirectory)
-import System.Process (StdStream (CreatePipe),
- createProcess, cwd,
- proc, std_in,
- waitForProcess)
-- | Username and password to log into Hackage.
--
@@ -202,14 +194,14 @@
, checkStatus = \_ _ _ -> Nothing
}
return Uploader
- { upload_ = \fp0 -> withTarball fp0 $ \fp -> do
- let formData = [partFile "package" fp]
+ { upload_ = \tarName bytes -> do
+ let formData = [partFileRequestBody "package" tarName (RequestBodyLBS bytes)]
req2 <- formDataBody formData req1
let req3 = applyBasicAuth
(encodeUtf8 $ hcUsername creds)
(encodeUtf8 $ hcPassword creds)
req2
- putStr $ "Uploading " ++ fp ++ "... "
+ putStr $ "Uploading " ++ tarName ++ "... "
hFlush stdout
withResponse req3 manager $ \res ->
case statusCode $ responseStatus res of
@@ -232,39 +224,9 @@
code -> do
putStrLn $ "unhandled status code: " ++ show code
printBody res
- error $ "Upload failed on " ++ fp
+ error $ "Upload failed on " ++ tarName
}
--- | Given either a file, return it. Given a directory, run @cabal sdist@ and
--- get the resulting tarball.
-withTarball :: FilePath -> (FilePath -> IO a) -> IO a
-withTarball fp0 inner = do
- isFile <- doesFileExist fp0
- if isFile then inner fp0 else withSystemTempDirectory "stackage-upload-tarball" $ \dir -> do
- isDir <- doesDirectoryExist fp0
- when (not isDir) $ error $ "Invalid argument: " ++ fp0
-
- (Just h, Nothing, Nothing, ph) <-
- -- The insanity: the Cabal library seems to sometimes generate tarballs
- -- in the wrong format. For now, just falling back to cabal-install.
- -- Sigh.
-
- createProcess $ (proc "cabal"
- [ "sdist"
- , "--builddir=" ++ dir
- ])
- { cwd = Just fp0
- , std_in = CreatePipe
- }
- hClose h
- ec <- waitForProcess ph
- when (ec /= ExitSuccess) $
- error $ "Could not create tarball for " ++ fp0
- contents <- getDirectoryContents dir
- case filter ((== ".gz") . takeExtension) contents of
- [x] -> inner (dir x)
- _ -> error $ "Unexpected directory contents after cabal sdist: " ++ show contents
-
printBody :: Response BodyReader -> IO ()
printBody res =
loop
@@ -281,14 +243,21 @@
--
-- Since 0.1.0.0
data Uploader = Uploader
- { upload_ :: !(FilePath -> IO ())
+ { upload_ :: !(String -> L.ByteString -> IO ())
}
-- | Upload a single tarball with the given @Uploader@.
--
-- Since 0.1.0.0
upload :: Uploader -> FilePath -> IO ()
-upload = upload_
+upload uploader fp = upload_ uploader (takeFileName fp) =<< L.readFile fp
+
+-- | Upload a single tarball with the given @Uploader@. Instead of
+-- sending a file like 'upload', this sends a lazy bytestring.
+--
+-- Since 0.1.2.1
+uploadBytes :: Uploader -> String -> L.ByteString -> IO ()
+uploadBytes = upload_
-- | Settings for creating an @Uploader@.
--
diff --git a/src/System/Process/Read.hs b/src/System/Process/Read.hs
--- a/src/System/Process/Read.hs
+++ b/src/System/Process/Read.hs
@@ -59,8 +59,9 @@
import Data.Typeable (Typeable)
import Distribution.System (OS (Windows, OtherOS), Platform (Platform))
import Path (Path, Abs, Dir, toFilePath, File, parseAbsFile)
+import Path.IO (createTree)
import Prelude -- Fix AMP warning
-import System.Directory (createDirectoryIfMissing, doesFileExist, getCurrentDirectory)
+import System.Directory (doesFileExist, getCurrentDirectory)
import System.Environment (getEnvironment)
import System.Exit
import qualified System.FilePath as FP
@@ -267,8 +268,12 @@
-- executable path.
preProcess :: (MonadIO m) => Maybe (Path Abs Dir) -> EnvOverride -> String -> m FilePath
preProcess wd menv name = do
- name' <- liftIO $ liftM toFilePath $ join $ findExecutable menv name
- liftIO (maybe (return ()) (createDirectoryIfMissing True . toFilePath) wd)
+ exists <- liftIO $ doesFileExist name
+ name' <-
+ if exists
+ then return name
+ else liftIO $ liftM toFilePath $ join $ findExecutable menv name
+ maybe (return ()) createTree wd
return name'
-- | Check if the given executable exists on the given PATH
diff --git a/src/System/Process/Run.hs b/src/System/Process/Run.hs
--- a/src/System/Process/Run.hs
+++ b/src/System/Process/Run.hs
@@ -4,15 +4,19 @@
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleContexts #-}
-- | Reading from external processes.
module System.Process.Run
(runIn
- ,callProcess)
+ ,callProcess
+ ,callProcess'
+ ,ProcessExitedUnsuccessfully)
where
-import Control.Exception
+import Control.Exception.Lifted
+import Control.Monad.Trans.Control (MonadBaseControl)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Logger (MonadLogger, logError)
import Data.Conduit.Process hiding (callProcess)
@@ -29,7 +33,7 @@
-- and stderr. If it exits with anything but success, prints an error
-- and then calls 'exitWith' to exit the program.
runIn :: forall (m :: * -> *).
- (MonadLogger m,MonadIO m)
+ (MonadLogger m,MonadIO m,MonadBaseControl IO m)
=> Path Abs Dir -- ^ directory to run in
-> FilePath -- ^ command to run
-> EnvOverride
@@ -37,7 +41,7 @@
-> Maybe Text
-> m ()
runIn wd cmd menv args errMsg = do
- result <- liftIO (try (callProcess (Just wd) menv cmd args))
+ result <- try (callProcess (Just wd) menv cmd args)
case result of
Left (ProcessExitedUnsuccessfully _ ec) -> do
$logError $
@@ -56,20 +60,34 @@
-- | Like as @System.Process.callProcess@, but takes an optional working directory and
-- environment override, and throws ProcessExitedUnsuccessfully if the
-- process exits unsuccessfully. Inherits stdout and stderr.
-callProcess :: (MonadIO m)
- => Maybe (Path Abs Dir)
+callProcess :: (MonadIO m, MonadLogger m)
+ => Maybe (Path Abs Dir)
+ -> EnvOverride
+ -> String
+ -> [String]
+ -> m ()
+callProcess =
+ callProcess' id
+
+-- | Like as @System.Process.callProcess@, but takes an optional working directory and
+-- environment override, and throws ProcessExitedUnsuccessfully if the
+-- process exits unsuccessfully. Inherits stdout and stderr.
+callProcess' :: (MonadIO m, MonadLogger m)
+ => (CreateProcess -> CreateProcess)
+ -> Maybe (Path Abs Dir)
-> EnvOverride
-> String
-> [String]
-> m ()
-callProcess wd menv cmd0 args = do
+callProcess' modCP wd menv cmd0 args = do
cmd <- preProcess wd menv cmd0
- let c = (proc cmd args) { delegate_ctlc = True
- , cwd = fmap toFilePath wd
- , env = envHelper menv }
+ let c = modCP $ (proc cmd args) { delegate_ctlc = True
+ , cwd = fmap toFilePath wd
+ , env = envHelper menv }
action (_, _, _, p) = do
exit_code <- waitForProcess p
case exit_code of
ExitSuccess -> return ()
ExitFailure _ -> throwIO (ProcessExitedUnsuccessfully c exit_code)
+ $logProcessRun cmd args
liftIO (System.Process.createProcess c >>= action)
diff --git a/src/main/Main.hs b/src/main/Main.hs
--- a/src/main/Main.hs
+++ b/src/main/Main.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
@@ -10,34 +11,38 @@
module Main where
import Control.Exception
+import qualified Control.Exception.Lifted as EL
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Logger
-import Control.Monad.Reader (ask)
+import Control.Monad.Reader (ask, asks)
+import Control.Monad.Trans.Control (MonadBaseControl)
import Data.Attoparsec.Args (withInterpreterArgs)
-import Data.Char (toLower)
+import qualified Data.ByteString.Lazy as L
+import Data.IORef
import Data.List
import qualified Data.List as List
-import Data.Map (Map)
import qualified Data.Map as Map
+import qualified Data.Map.Strict as M
import Data.Maybe
import Data.Monoid
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.IO as T
-import Data.Traversable
+import Data.Traversable (sequenceA)
import Network.HTTP.Client
import Options.Applicative.Args
import Options.Applicative.Builder.Extra
import Options.Applicative.Simple
import Options.Applicative.Types (readerAsk)
import Path
+import Path.IO
import qualified Paths_stack as Meta
import Plugins
import Prelude hiding (pi)
import Stack.Build
-import Stack.Build.Types
+import Stack.Types.Build
import Stack.Config
import Stack.Constants
import qualified Stack.Docker as Docker
@@ -45,11 +50,15 @@
import Stack.Exec
import Stack.Fetch
import Stack.FileWatch
+import Stack.Ide
+import qualified Stack.Image as Image
import Stack.Init
import Stack.New
+import Stack.Options
+import Stack.Package (getCabalFileName)
import qualified Stack.PackageIndex
-import Stack.Repl
-import Stack.Ide
+import Stack.Ghci
+import Stack.SDist (getSDistTarball)
import Stack.Setup
import Stack.Solver (solveExtraDeps)
import Stack.Types
@@ -57,17 +66,69 @@
import Stack.Types.StackT
import Stack.Upgrade
import qualified Stack.Upload as Upload
-import System.Directory (canonicalizePath)
+import System.Directory (canonicalizePath, doesFileExist, doesDirectoryExist, createDirectoryIfMissing)
import System.Environment (getArgs, getProgName)
import System.Exit
-import System.FilePath (searchPathSeparator,dropTrailingPathSeparator)
+import System.FileLock (lockFile, tryLockFile, unlockFile, SharedExclusive(Exclusive), FileLock)
+import System.FilePath (dropTrailingPathSeparator)
import System.IO (hIsTerminalDevice, stderr, stdin, stdout, hSetBuffering, BufferMode(..))
import System.Process.Read
+#if WINDOWS
+import System.Win32.Console (setConsoleCP, setConsoleOutputCP, getConsoleCP, getConsoleOutputCP)
+import System.IO (hSetEncoding, utf8, hPutStrLn)
+#endif
+
+-- | Set the code page for this process as necessary. Only applies to Windows.
+-- See: https://github.com/commercialhaskell/stack/issues/738
+fixCodePage :: IO a -> IO a
+#if WINDOWS
+fixCodePage inner = do
+ origCPI <- getConsoleCP
+ origCPO <- getConsoleOutputCP
+
+ let setInput = origCPI /= expected
+ setOutput = origCPO /= expected
+ fixInput
+ | setInput = bracket_
+ (do
+ setConsoleCP expected
+ hSetEncoding stdin utf8
+ )
+ (setConsoleCP origCPI)
+ | otherwise = id
+ fixOutput
+ | setInput = bracket_
+ (do
+ setConsoleOutputCP expected
+ hSetEncoding stdout utf8
+ hSetEncoding stderr utf8
+ )
+ (setConsoleOutputCP origCPO)
+ | otherwise = id
+
+ case (setInput, setOutput) of
+ (False, False) -> return ()
+ (True, True) -> warn ""
+ (True, False) -> warn " input"
+ (False, True) -> warn " output"
+
+ fixInput $ fixOutput inner
+ where
+ expected = 65001 -- UTF-8
+ warn typ = hPutStrLn stderr $ concat
+ [ "Setting"
+ , typ
+ , " codepage to UTF-8 (65001) to ensure correct output from GHC"
+ ]
+#else
+fixCodePage = id
+#endif
+
-- | Commandline dispatcher.
main :: IO ()
-main = withInterpreterArgs stackProgName $ \args isInterpreter ->
- do -- Line buffer the output by default, particularly for non-terminal runs.
+main = withInterpreterArgs stackProgName $ \args isInterpreter -> do
+ -- Line buffer the output by default, particularly for non-terminal runs.
-- See https://github.com/commercialhaskell/stack/pull/360
hSetBuffering stdout LineBuffering
hSetBuffering stdin LineBuffering
@@ -79,7 +140,7 @@
isTerminal <- hIsTerminalDevice stdout
execExtraHelp args
dockerHelpOptName
- (Docker.dockerOptsParser True)
+ (dockerOptsParser True)
("Only showing --" ++ Docker.dockerCmdName ++ "* options.")
let versionString' = $(simpleVersion Meta.version)
eGlobalRun <- try $
@@ -88,36 +149,39 @@
"stack - The Haskell Tool Stack"
""
(extraHelpOption progName (Docker.dockerCmdName ++ "*") dockerHelpOptName <*>
- globalOpts isTerminal)
+ globalOptsParser isTerminal)
(do addCommand "build"
"Build the project(s) in this directory/configuration"
- (buildCmd DoNothing)
- (buildOpts Build)
+ (buildCmd Nothing)
+ (buildOptsParser Build)
addCommand "install"
- "Build executables and install to a user path"
- installCmd
- (buildOpts Build)
+ "Shortcut for 'build --copy-bins'"
+ (buildCmd $ Just ("install", "copy-bins"))
+ (buildOptsParser Install)
+ addCommand "uninstall"
+ "DEPRECATED: This command performs no actions, and is present for documentation only"
+ uninstallCmd
+ (many $ strArgument $ metavar "IGNORED")
addCommand "test"
- "Build and test the project(s) in this directory/configuration"
- (\(rerun, bopts) -> buildCmd (DoTests rerun) bopts)
- ((,)
- <$> boolFlags True
- "rerun-tests"
- "running already successful tests"
- idm
- <*> (buildOpts Test))
+ "Shortcut for 'build --test'"
+ (buildCmd $ Just ("test", "test"))
+ (buildOptsParser Test)
addCommand "bench"
- "Build and benchmark the project(s) in this directory/configuration"
- (buildCmd DoBenchmarks)
- (buildOpts Build)
+ "Shortcut for 'build --bench'"
+ (buildCmd $ Just ("bench", "bench"))
+ (buildOptsParser Bench)
addCommand "haddock"
- "Generate haddocks for the project(s) in this directory/configuration"
- (buildCmd DoNothing)
- (buildOpts Haddock)
+ "Shortcut for 'build --haddock'"
+ (buildCmd $ Just ("haddock", "haddock"))
+ (buildOptsParser Haddock)
addCommand "new"
- "Create a brand new project"
+ "Create a new project from a template. Run `stack templates' to see available templates."
newCmd
- initOptsParser
+ newOptsParser
+ addCommand "templates"
+ "List the templates available for `stack new'."
+ templatesCmd
+ (pure ())
addCommand "init"
"Initialize a stack project based on one or more cabal packages"
initCmd
@@ -127,7 +191,7 @@
solverCmd
solverOptsParser
addCommand "setup"
- "Get the appropriate ghc for your project"
+ "Get the appropriate GHC for your project"
setupCmd
setupParser
addCommand "path"
@@ -162,6 +226,10 @@
"Upload a package to Hackage"
uploadCmd
(many $ strArgument $ metavar "TARBALL/DIR")
+ addCommand "sdist"
+ "Create source distribution tarballs"
+ sdistCmd
+ (many $ strArgument $ metavar "DIR")
addCommand "dot"
"Visualize your project's dependency graph using Graphviz dot"
dotCmd
@@ -176,34 +244,8 @@
(execOptsParser $ Just "ghc")
addCommand "ghci"
"Run ghci in the context of project(s)"
- replCmd
- ((,,,) <$>
- fmap (map T.pack)
- (many (strArgument
- (metavar "TARGET" <>
- help "If none specified, use all packages defined in current directory"))) <*>
- fmap (fromMaybe [])
- (optional (argsOption (long "ghc-options" <>
- metavar "OPTION" <>
- help "Additional options passed to GHCi"))) <*>
- fmap (fromMaybe "ghc")
- (optional (strOption (long "with-ghc" <>
- metavar "GHC" <>
- help "Use this command for the GHC to run"))) <*>
- flag False True (long "no-load" <>
- help "Don't load modules on start-up"))
- addCommand "ide"
- "Run ide-backend-client with the correct arguments"
- ideCmd
- ((,) <$>
- fmap (map T.pack)
- (many (strArgument
- (metavar "TARGET" <>
- help "If none specified, use all packages defined in current directory"))) <*>
- fmap (fromMaybe [])
- (optional (argsOption (long "ghc-options" <>
- metavar "OPTION" <>
- help "Additional options passed to GHCi"))))
+ ghciCmd
+ ghciOptsParser
addCommand "runghc"
"Run runghc"
execCmd
@@ -212,7 +254,37 @@
"Clean the local packages"
cleanCmd
(pure ())
+ addCommand "list-dependencies"
+ "List the dependencies"
+ listDependenciesCmd
+ (T.pack <$> strOption (long "separator" <>
+ metavar "SEP" <>
+ help ("Separator between package name " <>
+ "and package version.") <>
+ value " " <>
+ showDefault))
addSubCommands
+ "ide"
+ "IDE-specific commands"
+ (do addCommand
+ "start"
+ "Start the ide-backend service"
+ ideCmd
+ (((,) <$>
+ fmap (map T.pack)
+ (many (strArgument
+ (metavar "TARGET" <>
+ help "If none specified, use all packages defined in current directory"))) <*>
+ argsOption (long "ghc-options" <>
+ metavar "OPTION" <>
+ help "Additional options passed to GHCi" <>
+ value [])))
+ addCommand
+ "packages"
+ "List all available local loadable packages"
+ packagesCmd
+ (pure ()))
+ addSubCommands
Docker.dockerCmdName
"Subcommands specific to Docker use"
(do addCommand Docker.dockerPullCmdName
@@ -227,8 +299,14 @@
addCommand Docker.dockerCleanupCmdName
"Clean up Docker images and containers"
dockerCleanupCmd
- dockerCleanupOpts)
- )
+ dockerCleanupOptsParser)
+ addSubCommands
+ Image.imgCmdName
+ "Subcommands specific to imaging (EXPERIMENTAL)"
+ (addCommand Image.imgDockerCmdName
+ "Build a Docker image for the project"
+ imgDockerCmd
+ (pure ())))
-- commandsFromPlugins plugins pluginShouldHaveRun) https://github.com/commercialhaskell/stack/issues/322
case eGlobalRun of
Left (exitCode :: ExitCode) -> do
@@ -243,7 +321,7 @@
throwIO exitCode
Right (global,run) -> do
when (globalLogLevel global == LevelDebug) $ putStrLn versionString'
- run global `catch` \e -> do
+ fixCodePage $ run global `catch` \e -> do
-- This special handler stops "stack: " from being printed before the
-- exception
case fromException e of
@@ -281,10 +359,10 @@
-- support others later).
pathCmd :: [Text] -> GlobalOpts -> IO ()
pathCmd keys go =
- withBuildConfig
+ withBuildConfigAndLock
go
- ExecStrategy
- (do env <- ask
+ (\_ ->
+ do env <- ask
let cfg = envConfig env
bc = envConfigBuildConfig cfg
menv <- getMinimalEnvOverride
@@ -299,7 +377,7 @@
null keys || elem key keys)
paths)
(\(_,key,path) ->
- $logInfo
+ liftIO $ T.putStrLn
((if length keys == 1
then ""
else key <> ": ") <>
@@ -385,6 +463,14 @@
, "local-install-root"
, \pi ->
T.pack (toFilePathNoTrailing (piLocalRoot pi)))
+ , ( "Snapshot documentation root"
+ , "snapshot-doc-root"
+ , \pi ->
+ T.pack (toFilePathNoTrailing (piSnapRoot pi docDirSuffix)))
+ , ( "Local project documentation root"
+ , "local-doc-root"
+ , \pi ->
+ T.pack (toFilePathNoTrailing (piLocalRoot pi docDirSuffix)))
, ( "Dist work directory"
, "dist-dir"
, \pi ->
@@ -394,15 +480,23 @@
data SetupCmdOpts = SetupCmdOpts
{ scoGhcVersion :: !(Maybe Version)
, scoForceReinstall :: !Bool
+ , scoUpgradeCabal :: !Bool
}
setupParser :: Parser SetupCmdOpts
setupParser = SetupCmdOpts
- <$> (optional $ argument readVersion (metavar "VERSION"))
+ <$> (optional $ argument readVersion
+ (metavar "GHC_MAJOR_VERSION" <>
+ help ("Major version of GHC to install, e.g. 7.10. " ++
+ "The default is to install the version implied by the resolver.")))
<*> boolFlags False
"reinstall"
- "Reinstall GHC, even if available (implies no-system-ghc)"
+ "reinstalling GHC, even if available (implies no-system-ghc)"
idm
+ <*> boolFlags False
+ "upgrade-cabal"
+ "installing the newest version of the Cabal library globally"
+ idm
where
readVersion = do
s <- readerAsk
@@ -413,17 +507,20 @@
setupCmd :: SetupCmdOpts -> GlobalOpts -> IO ()
setupCmd SetupCmdOpts{..} go@GlobalOpts{..} = do
(manager,lc) <- loadConfigWithOpts go
- runStackT manager globalLogLevel (lcConfig lc) globalTerminal $
+ withUserFileLock (configStackRoot $ lcConfig lc) $ \lk ->
+ runStackTGlobal manager (lcConfig lc) go $
Docker.reexecWithOptionalContainer
(lcProjectRoot lc)
- (runStackLoggingT manager globalLogLevel globalTerminal $ do
+ Nothing
+ (runStackLoggingTGlobal manager go $ do
(ghc, mstack) <-
case scoGhcVersion of
Just v -> return (v, Nothing)
Nothing -> do
- bc <- lcLoadBuildConfig lc globalResolver ExecStrategy
+ bc <- lcLoadBuildConfig lc globalResolver
return (bcGhcVersionExpected bc, Just $ bcStackYaml bc)
- mpaths <- runStackT manager globalLogLevel (lcConfig lc) globalTerminal $ ensureGHC SetupOpts
+ mpaths <- runStackTGlobal manager (lcConfig lc) go $
+ ensureGHC SetupOpts
{ soptsInstallIfMissing = True
, soptsUseSystem =
(configSystemGHC $ lcConfig lc)
@@ -434,174 +531,219 @@
, soptsSanityCheck = True
, soptsSkipGhcCheck = False
, soptsSkipMsys = configSkipMsys $ lcConfig lc
+ , soptsUpgradeCabal = scoUpgradeCabal
}
case mpaths of
- Nothing -> $logInfo "GHC on PATH would be used"
- Just ps -> $logInfo $ "Would add the following to PATH: "
- <> T.pack (intercalate [searchPathSeparator] ps)
- )
+ Nothing -> $logInfo "stack will use the GHC on your PATH"
+ Just _ -> $logInfo "stack will use a locally installed GHC"
+ $logInfo "For more information on paths, see 'stack path' and 'stack exec env'"
+ $logInfo "To use this GHC and packages outside of a project, consider using:"
+ $logInfo "stack ghc, stack ghci, stack runghc, or stack exec"
+ )
+ Nothing
+ (Just $ liftIO$ unlockFile lk)
-withConfig :: GlobalOpts
+-- | Enforce mutual exclusion of every action running via this
+-- function, on this path, on this users account.
+--
+-- A lock file is created inside the given directory. Currently,
+-- stack uses locks per-snapshot. In the future, stack may refine
+-- this to an even more fine-grain locking approach.
+--
+withUserFileLock :: (MonadBaseControl IO m, MonadIO m)
+ => Path Abs Dir
+ -> (FileLock -> m a)
+ -> m a
+withUserFileLock dir act = do
+ let lockfile = $(mkRelFile "lockfile")
+ let pth = dir lockfile
+ liftIO $ createDirectoryIfMissing True (toFilePath dir)
+ -- Just in case of asynchronous exceptions, we need to be careful
+ -- when using tryLockFile here:
+ EL.bracket (liftIO $ tryLockFile (toFilePath pth) Exclusive)
+ (\fstTry -> maybe (return ()) (liftIO . unlockFile) fstTry)
+ (\fstTry ->
+ case fstTry of
+ Just lk -> EL.finally (act lk) (liftIO $ unlockFile lk)
+ Nothing ->
+ do liftIO $ putStrLn $ "Failed to grab lock ("++show pth++
+ "); other stack instance running. Waiting..."
+ EL.bracket (liftIO $ lockFile (toFilePath pth) Exclusive)
+ (liftIO . unlockFile)
+ (\lk -> do
+ liftIO $ putStrLn "Lock acquired, proceeding."
+ act lk))
+
+withConfigAndLock :: GlobalOpts
-> StackT Config IO ()
-> IO ()
-withConfig go@GlobalOpts{..} inner = do
+withConfigAndLock go@GlobalOpts{..} inner = do
(manager, lc) <- loadConfigWithOpts go
- runStackT manager globalLogLevel (lcConfig lc) globalTerminal $
- Docker.reexecWithOptionalContainer (lcProjectRoot lc) $
- runStackT manager globalLogLevel (lcConfig lc) globalTerminal
- inner
+ withUserFileLock (configStackRoot $ lcConfig lc) $ \lk ->
+ runStackTGlobal manager (lcConfig lc) go $
+ Docker.reexecWithOptionalContainer (lcProjectRoot lc)
+ Nothing
+ (runStackTGlobal manager (lcConfig lc) go inner)
+ Nothing
+ (Just $ liftIO $ unlockFile lk)
+-- For now the non-locking version just unlocks immediately.
+-- That is, there's still a serialization point.
withBuildConfig :: GlobalOpts
- -> NoBuildConfigStrategy
- -> StackT EnvConfig IO ()
- -> IO ()
-withBuildConfig go@GlobalOpts{..} strat inner = do
+ -> (StackT EnvConfig IO ())
+ -> IO ()
+withBuildConfig go inner =
+ withBuildConfigAndLock go (\lk -> do liftIO $ unlockFile lk
+ inner)
+
+withBuildConfigAndLock :: GlobalOpts
+ -> (FileLock -> StackT EnvConfig IO ())
+ -> IO ()
+withBuildConfigAndLock go inner =
+ withBuildConfigExt go Nothing inner Nothing
+
+withBuildConfigExt
+ :: GlobalOpts
+ -> Maybe (StackT Config IO ())
+ -- ^ Action to perform after before build. This will be run on the host
+ -- OS even if Docker is enabled for builds. The build config is not
+ -- available in this action, since that would require build tools to be
+ -- installed on the host OS.
+ -> (FileLock -> StackT EnvConfig IO ())
+ -- ^ Action that uses the build config. If Docker is enabled for builds,
+ -- this will be run in a Docker container.
+ -> Maybe (StackT Config IO ())
+ -- ^ Action to perform after the build. This will be run on the host
+ -- OS even if Docker is enabled for builds. The build config is not
+ -- available in this action, since that would require build tools to be
+ -- installed on the host OS.
+ -> IO ()
+withBuildConfigExt go@GlobalOpts{..} mbefore inner mafter = do
(manager, lc) <- loadConfigWithOpts go
- runStackT manager globalLogLevel (lcConfig lc) globalTerminal $
- Docker.reexecWithOptionalContainer (lcProjectRoot lc) $ do
- bconfig <- runStackLoggingT manager globalLogLevel globalTerminal $
- lcLoadBuildConfig lc globalResolver strat
- envConfig <-
- runStackT
- manager globalLogLevel bconfig globalTerminal
- setupEnv
- runStackT
- manager
- globalLogLevel
- envConfig
- globalTerminal
- inner
-cleanCmd :: () -> GlobalOpts -> IO ()
-cleanCmd () go = withBuildConfig go ThrowException clean
+ withUserFileLock (configStackRoot $ lcConfig lc) $ \lk0 -> do
+ -- A local bit of state for communication between callbacks:
+ curLk <- newIORef lk0
+ let inner' lk =
+ -- Locking policy: This is only used for build commands, which
+ -- only need to lock the snapshot, not the global lock. We
+ -- trade in the lock here.
+ do dir <- installationRootDeps
+ -- Hand-over-hand locking:
+ withUserFileLock dir $ \lk2 -> do
+ liftIO $ writeIORef curLk lk2
+ liftIO $ unlockFile lk
+ inner lk2
--- | Parser for package names
-readPackageName :: ReadM PackageName
-readPackageName = do
- s <- readerAsk
- case parsePackageNameFromString s of
- Nothing -> readerError $ "Invalid package name: " ++ s
- Just x -> return x
+ let inner'' lk = do
+ bconfig <- runStackLoggingTGlobal manager go $
+ lcLoadBuildConfig lc globalResolver
+ envConfig <-
+ runStackTGlobal
+ manager bconfig go
+ setupEnv
+ runStackTGlobal
+ manager
+ envConfig
+ go
+ (inner' lk)
--- | Parser for package:[-]flag
-readFlag :: ReadM (Map (Maybe PackageName) (Map FlagName Bool))
-readFlag = do
- s <- readerAsk
- case break (== ':') s of
- (pn, ':':mflag) -> do
- pn' <-
- case parsePackageNameFromString pn of
- Nothing
- | pn == "*" -> return Nothing
- | otherwise -> readerError $ "Invalid package name: " ++ pn
- Just x -> return $ Just x
- let (b, flagS) =
- case mflag of
- '-':x -> (False, x)
- _ -> (True, mflag)
- flagN <-
- case parseFlagNameFromString flagS of
- Nothing -> readerError $ "Invalid flag name: " ++ flagS
- Just x -> return x
- return $ Map.singleton pn' $ Map.singleton flagN b
- _ -> readerError "Must have a colon"
+ runStackTGlobal manager (lcConfig lc) go $
+ Docker.reexecWithOptionalContainer (lcProjectRoot lc) mbefore (inner'' lk0) mafter
+ (Just $ liftIO $
+ do lk' <- readIORef curLk
+ unlockFile lk')
+cleanCmd :: () -> GlobalOpts -> IO ()
+cleanCmd () go = withBuildConfigAndLock go (\_ -> clean)
+
-- | Helper for build and install commands
-buildCmdHelper :: NoBuildConfigStrategy -> FinalAction -> BuildOpts -> GlobalOpts -> IO ()
-buildCmdHelper strat finalAction opts go
+buildCmd :: Maybe (Text, Text) -- ^ option synonym
+ -> BuildOpts -> GlobalOpts -> IO ()
+buildCmd moptionSynonym opts go
| boptsFileWatch opts = fileWatch inner
| otherwise = inner $ const $ return ()
where
- inner setLocalFiles =
- withBuildConfig go strat $
- Stack.Build.build setLocalFiles opts { boptsFinalAction = finalAction }
-
--- | Build the project.
-buildCmd :: FinalAction -> BuildOpts -> GlobalOpts -> IO ()
-buildCmd = buildCmdHelper ThrowException
+ inner setLocalFiles = withBuildConfigAndLock go $ \lk -> do
+ case moptionSynonym of
+ Nothing -> return ()
+ Just (cmd, opt) -> $logInfo $ T.concat
+ [ "NOTE: the "
+ , cmd
+ , " command is functionally equivalent to 'build --"
+ , opt
+ , "'"
+ ]
+ Stack.Build.build setLocalFiles (Just lk) opts
--- | Install
-installCmd :: BuildOpts -> GlobalOpts -> IO ()
-installCmd opts = buildCmdHelper ExecStrategy DoNothing opts { boptsInstallExes = True }
+uninstallCmd :: [String] -> GlobalOpts -> IO ()
+uninstallCmd _ go = withConfigAndLock go $ do
+ $logError "stack does not manage installations in global locations"
+ $logError "The only global mutation stack performs is executable copying"
+ $logError "For the default executable destination, please run 'stack path --local-bin-path'"
-- | Unpack packages to the filesystem
unpackCmd :: [String] -> GlobalOpts -> IO ()
-unpackCmd names go = withConfig go $ do
+unpackCmd names go = withConfigAndLock go $ do
menv <- getMinimalEnvOverride
Stack.Fetch.unpackPackages menv "." names
-- | Update the package index
updateCmd :: () -> GlobalOpts -> IO ()
-updateCmd () go = withConfig go $
+updateCmd () go = withConfigAndLock go $
getMinimalEnvOverride >>= Stack.PackageIndex.updateAllIndices
upgradeCmd :: Bool -> GlobalOpts -> IO ()
-upgradeCmd fromGit go = withConfig go $
+upgradeCmd fromGit go = withConfigAndLock go $
upgrade fromGit (globalResolver go)
-- | Upload to Hackage
uploadCmd :: [String] -> GlobalOpts -> IO ()
+uploadCmd [] _ = error "To upload the current package, please run 'stack upload .'"
uploadCmd args go = do
- (manager,lc) <- loadConfigWithOpts go
- let config = lcConfig lc
- if null args
- then error "To upload the current project, please run 'stack upload .'"
- else liftIO $ do
- uploader <- Upload.mkUploader
- config
- $ Upload.setGetManager (return manager)
- Upload.defaultUploadSettings
- mapM_ (Upload.upload uploader) args
-
-data ExecOpts = ExecOpts
- { eoCmd :: !String
- , eoArgs :: ![String]
- , eoExtra :: !ExecOptsExtra
- }
-
-data ExecOptsExtra
- = ExecOptsPlain
- | ExecOptsEmbellished
- { eoEnvSettings :: !EnvSettings
- , eoPackages :: ![String]
- }
-
-execOptsParser :: Maybe String -- ^ command
- -> Parser ExecOpts
-execOptsParser mcmd =
- ExecOpts
- <$> maybe eoCmdParser pure mcmd
- <*> eoArgsParser
- <*> (eoPlainParser <|>
- ExecOptsEmbellished
- <$> eoEnvSettingsParser
- <*> eoPackagesParser)
- where
- eoCmdParser :: Parser String
- eoCmdParser = strArgument (metavar "CMD")
-
- eoArgsParser :: Parser [String]
- eoArgsParser = many (strArgument (metavar "-- ARGS (e.g. stack ghc -- X.hs -o x)"))
-
- eoEnvSettingsParser :: Parser EnvSettings
- eoEnvSettingsParser = EnvSettings
- <$> pure True
- <*> boolFlags True
- "ghc-package-path"
- "setting the GHC_PACKAGE_PATH variable for the subprocess"
- idm
- <*> boolFlags True
- "stack-exe"
- "setting the STACK_EXE environment variable to the path for the stack executable"
- idm
-
- eoPackagesParser :: Parser [String]
- eoPackagesParser = many (strOption (long "package" <> help "Additional packages that must be installed"))
+ let partitionM _ [] = return ([], [])
+ partitionM f (x:xs) = do
+ r <- f x
+ (as, bs) <- partitionM f xs
+ return $ if r then (x:as, bs) else (as, x:bs)
+ (files, nonFiles) <- partitionM doesFileExist args
+ (dirs, invalid) <- partitionM doesDirectoryExist nonFiles
+ when (not (null invalid)) $ error $
+ "stack upload expects a list sdist tarballs or cabal directories. Can't find " ++
+ show invalid
+ let getUploader :: (HasStackRoot config, HasPlatform config, HasConfig config) => StackT config IO Upload.Uploader
+ getUploader = do
+ config <- asks getConfig
+ manager <- asks envManager
+ let uploadSettings =
+ Upload.setGetManager (return manager) $
+ Upload.defaultUploadSettings
+ liftIO $ Upload.mkUploader config uploadSettings
+ if null dirs
+ then withConfigAndLock go $ do
+ uploader <- getUploader
+ liftIO $ forM_ files (canonicalizePath >=> Upload.upload uploader)
+ else withBuildConfigAndLock go $ \_ -> do
+ uploader <- getUploader
+ liftIO $ forM_ files (canonicalizePath >=> Upload.upload uploader)
+ forM_ dirs $ \dir -> do
+ pkgDir <- parseAbsDir =<< liftIO (canonicalizePath dir)
+ (tarName, tarBytes) <- getSDistTarball pkgDir
+ liftIO $ Upload.uploadBytes uploader tarName tarBytes
- eoPlainParser :: Parser ExecOptsExtra
- eoPlainParser = flag' ExecOptsPlain
- (long "plain" <>
- help "Use an unmodified environment (only useful with Docker)")
+sdistCmd :: [String] -> GlobalOpts -> IO ()
+sdistCmd dirs go =
+ withBuildConfig go $ do -- No locking needed.
+ -- If no directories are specified, build all sdist tarballs.
+ dirs' <- if null dirs
+ then asks (Map.keys . envConfigPackages . getEnvConfig)
+ else mapM (parseAbsDir <=< liftIO . canonicalizePath) dirs
+ forM_ dirs' $ \dir -> do
+ (tarName, tarBytes) <- getSDistTarball dir
+ distDir <- distDirFromDir dir
+ tarPath <- fmap (distDir ) $ parseRelFile tarName
+ liftIO $ L.writeFile (toFilePath tarPath) tarBytes
+ $logInfo $ "Wrote sdist tarball to " <> T.pack (toFilePath tarPath)
-- | Execute a command.
execCmd :: ExecOpts -> GlobalOpts -> IO ()
@@ -609,268 +751,102 @@
case eoExtra of
ExecOptsPlain -> do
(manager,lc) <- liftIO $ loadConfigWithOpts go
- runStackT manager globalLogLevel (lcConfig lc) globalTerminal $
+ withUserFileLock (configStackRoot $ lcConfig lc) $ \lk ->
+ runStackTGlobal manager (lcConfig lc) go $
Docker.execWithOptionalContainer
(lcProjectRoot lc)
- (return (eoCmd, eoArgs, id)) $
- runStackT manager globalLogLevel (lcConfig lc) globalTerminal $
- exec plainEnvSettings eoCmd eoArgs
+ (return (eoCmd, eoArgs, [], id))
+ -- Unlock before transferring control away, whether using docker or not:
+ (Just $ liftIO $ unlockFile lk)
+ (runStackTGlobal manager (lcConfig lc) go $ do
+ exec plainEnvSettings eoCmd eoArgs)
+ Nothing
+ Nothing -- Unlocked already above.
ExecOptsEmbellished {..} ->
- withBuildConfig go ExecStrategy $ do
+ withBuildConfigAndLock go $ \lk -> do
let targets = concatMap words eoPackages
unless (null targets) $
- Stack.Build.build (const $ return ()) defaultBuildOpts
+ Stack.Build.build (const $ return ()) (Just lk) defaultBuildOpts
{ boptsTargets = map T.pack targets
}
+ liftIO $ unlockFile lk -- Unlock before transferring control away.
exec eoEnvSettings eoCmd eoArgs
--- | Run the REPL in the context of a project.
-replCmd :: ([Text], [String], FilePath, Bool) -> GlobalOpts -> IO ()
-replCmd (targets,args,path,noload) go@GlobalOpts{..} = withBuildConfig go ExecStrategy $ do
- repl targets args path noload
+-- | Run GHCi in the context of a project.
+ghciCmd :: GhciOpts -> GlobalOpts -> IO ()
+ghciCmd ghciOpts go@GlobalOpts{..} =
+ withBuildConfigAndLock go $ \lk -> do
+ let packageTargets = concatMap words (ghciAdditionalPackages ghciOpts)
+ unless (null packageTargets) $
+ Stack.Build.build (const $ return ()) (Just lk) defaultBuildOpts
+ { boptsTargets = map T.pack packageTargets
+ }
+ liftIO $ unlockFile lk -- Don't hold the lock while in the GHCI.
+ ghci ghciOpts
-- | Run ide-backend in the context of a project.
ideCmd :: ([Text], [String]) -> GlobalOpts -> IO ()
-ideCmd (targets,args) go@GlobalOpts{..} = withBuildConfig go ExecStrategy $ do
+ideCmd (targets,args) go@GlobalOpts{..} =
+ withBuildConfig go $ -- No locking needed.
ide targets args
+-- | Run ide-backend in the context of a project.
+packagesCmd :: () -> GlobalOpts -> IO ()
+packagesCmd () go@GlobalOpts{..} =
+ withBuildConfig go $
+ do econfig <- asks getEnvConfig
+ locals <-
+ forM (M.toList (envConfigPackages econfig)) $
+ \(dir,_) ->
+ do cabalfp <- getCabalFileName dir
+ parsePackageNameFromFilePath cabalfp
+ forM_ locals (liftIO . putStrLn . packageNameString)
+
-- | Pull the current Docker image.
dockerPullCmd :: () -> GlobalOpts -> IO ()
dockerPullCmd _ go@GlobalOpts{..} = do
(manager,lc) <- liftIO $ loadConfigWithOpts go
- runStackT manager globalLogLevel (lcConfig lc) globalTerminal $
- Docker.preventInContainer Docker.pull
+ -- TODO: can we eliminate this lock if it doesn't touch ~/.stack/?
+ withUserFileLock (configStackRoot $ lcConfig lc) $ \_ ->
+ runStackTGlobal manager (lcConfig lc) go $
+ Docker.preventInContainer Docker.pull
-- | Reset the Docker sandbox.
dockerResetCmd :: Bool -> GlobalOpts -> IO ()
dockerResetCmd keepHome go@GlobalOpts{..} = do
(manager,lc) <- liftIO (loadConfigWithOpts go)
- runStackLoggingT manager globalLogLevel globalTerminal$ Docker.preventInContainer $
- Docker.reset (lcProjectRoot lc) keepHome
+ -- TODO: can we eliminate this lock if it doesn't touch ~/.stack/?
+ withUserFileLock (configStackRoot $ lcConfig lc) $ \_ ->
+ runStackLoggingTGlobal manager go $
+ Docker.preventInContainer $ Docker.reset (lcProjectRoot lc) keepHome
-- | Cleanup Docker images and containers.
dockerCleanupCmd :: Docker.CleanupOpts -> GlobalOpts -> IO ()
dockerCleanupCmd cleanupOpts go@GlobalOpts{..} = do
(manager,lc) <- liftIO $ loadConfigWithOpts go
- runStackT manager globalLogLevel (lcConfig lc) globalTerminal $
+ -- TODO: can we eliminate this lock if it doesn't touch ~/.stack/?
+ withUserFileLock (configStackRoot $ lcConfig lc) $ \_ ->
+ runStackTGlobal manager (lcConfig lc) go $
Docker.preventInContainer $
Docker.cleanup cleanupOpts
--- | Command sum type for conditional arguments.
-data Command
- = Build
- | Test
- | Haddock
- deriving (Eq)
-
--- | Parser for build arguments.
-buildOpts :: Command -> Parser BuildOpts
-buildOpts cmd = fmap process $
- BuildOpts <$> target <*> libProfiling <*> exeProfiling <*>
- optimize <*> haddock <*> haddockDeps <*> finalAction <*> dryRun <*> ghcOpts <*>
- flags <*> installExes <*> preFetch <*> testArgs <*> onlySnapshot <*> coverage <*>
- fileWatch' <*> keepGoing
- where process bopts =
- if boptsCoverage bopts
- then bopts { boptsExeProfile = True
- , boptsLibProfile = True
- , boptsGhcOptions = "-fhpc" : boptsGhcOptions bopts}
- else bopts
- optimize =
- maybeBoolFlags "optimizations" "optimizations for TARGETs and all its dependencies" idm
- target =
- fmap (map T.pack)
- (many (strArgument
- (metavar "TARGET" <>
- help "If none specified, use all packages defined in current directory")))
- libProfiling =
- boolFlags False
- "library-profiling"
- "library profiling for TARGETs and all its dependencies"
- idm
- exeProfiling =
- boolFlags False
- "executable-profiling"
- "library profiling for TARGETs and all its dependencies"
- idm
- haddock =
- boolFlags (cmd == Haddock)
- "haddock"
- "building Haddocks"
- idm
- haddockDeps =
- if cmd == Haddock
- then maybeBoolFlags
- "haddock-deps"
- "building Haddocks for dependencies"
- idm
- else pure Nothing
- finalAction = pure DoNothing
- installExes = pure False
- dryRun = flag False True (long "dry-run" <>
- help "Don't build anything, just prepare to")
- ghcOpts = (++)
- <$> flag [] ["-Wall", "-Werror"]
- ( long "pedantic"
- <> help "Turn on -Wall and -Werror (note: option name may change in the future"
- )
- <*> many (fmap T.pack
- (strOption (long "ghc-options" <>
- metavar "OPTION" <>
- help "Additional options passed to GHC")))
-
- flags =
- fmap (Map.unionsWith Map.union) $ many
- (option readFlag
- ( long "flag"
- <> metavar "PACKAGE:[-]FLAG"
- <> help "Override flags set in stack.yaml (applies to local packages and extra-deps)"
- ))
-
- preFetch = flag False True
- (long "prefetch" <>
- help "Fetch packages necessary for the build immediately, useful with --dry-run")
- testArgs =
- fmap (fromMaybe [])
- (if cmd == Test
- then optional
- (argsOption
- (long "test-arguments" <> metavar "TEST_ARGS" <>
- help "Arguments passed in to the test suite program"))
- else pure Nothing)
-
- onlySnapshot = flag False True
- (long "only-snapshot" <>
- help "Only build packages for the snapshot database, not the local database")
- coverage =
- if cmd == Test
- then flag False True
- (long "coverage" <>
- help "Generate a code coverage report")
- else pure False
-
- fileWatch' = flag False True
- (long "file-watch" <>
- help "Watch for changes in local files and automatically rebuild")
-
- keepGoing = maybeBoolFlags
- "keep-going"
- "continue running after a step fails (default: false for build, true for test/bench)"
- idm
-
--- | Parser for docker cleanup arguments.
-dockerCleanupOpts :: Parser Docker.CleanupOpts
-dockerCleanupOpts =
- Docker.CleanupOpts <$>
- (flag' Docker.CleanupInteractive
- (short 'i' <>
- long "interactive" <>
- help "Show cleanup plan in editor and allow changes (default)") <|>
- flag' Docker.CleanupImmediate
- (short 'y' <>
- long "immediate" <>
- help "Immediately execute cleanup plan") <|>
- flag' Docker.CleanupDryRun
- (short 'n' <>
- long "dry-run" <>
- help "Display cleanup plan but do not execute") <|>
- pure Docker.CleanupInteractive) <*>
- opt (Just 14) "known-images" "LAST-USED" <*>
- opt Nothing "unknown-images" "CREATED" <*>
- opt (Just 0) "dangling-images" "CREATED" <*>
- opt Nothing "stopped-containers" "CREATED" <*>
- opt Nothing "running-containers" "CREATED"
- where opt def' name mv =
- fmap Just
- (option auto
- (long name <>
- metavar (mv ++ "-DAYS-AGO") <>
- help ("Remove " ++
- toDescr name ++
- " " ++
- map toLower (toDescr mv) ++
- " N days ago" ++
- case def' of
- Just n -> " (default " ++ show n ++ ")"
- Nothing -> ""))) <|>
- flag' Nothing
- (long ("no-" ++ name) <>
- help ("Do not remove " ++
- toDescr name ++
- case def' of
- Just _ -> ""
- Nothing -> " (default)")) <|>
- pure def'
- toDescr = map (\c -> if c == '-' then ' ' else c)
-
--- | Parser for global command-line options.
-globalOpts :: Bool -> Parser GlobalOpts
-globalOpts defaultTerminal =
- GlobalOpts <$> logLevelOpt <*>
- configOptsParser False <*>
- optional resolverParser <*>
- flag
- defaultTerminal
- False
- (long "no-terminal" <>
- help
- "Override terminal detection in the case of running in a false terminal") <*>
- (optional (strOption
- (long "stack-yaml" <>
- metavar "STACK-YAML" <>
- help "Override project stack.yaml file (overrides any STACK_YAML environment variable)")))
-
--- | Parse for a logging level.
-logLevelOpt :: Parser LogLevel
-logLevelOpt =
- fmap parse
- (strOption (long "verbosity" <>
- metavar "VERBOSITY" <>
- help "Verbosity: silent, error, warn, info, debug")) <|>
- flag defaultLogLevel
- verboseLevel
- (short 'v' <> long "verbose" <>
- help ("Enable verbose mode: verbosity level \"" <> showLevel verboseLevel <> "\""))
- where verboseLevel = LevelDebug
- showLevel l =
- case l of
- LevelDebug -> "debug"
- LevelInfo -> "info"
- LevelWarn -> "warn"
- LevelError -> "error"
- LevelOther x -> T.unpack x
- parse s =
- case s of
- "debug" -> LevelDebug
- "info" -> LevelInfo
- "warn" -> LevelWarn
- "error" -> LevelError
- _ -> LevelOther (T.pack s)
-
-resolverParser :: Parser Resolver
-resolverParser =
- option readResolver
- (long "resolver" <>
- metavar "RESOLVER" <>
- help "Override resolver in project file")
-
--- | Default logging level should be something useful but not crazy.
-defaultLogLevel :: LogLevel
-defaultLogLevel = LevelInfo
-
--- | Parsed global command-line options.
-data GlobalOpts = GlobalOpts
- { globalLogLevel :: LogLevel -- ^ Log level
- , globalConfigMonoid :: ConfigMonoid -- ^ Config monoid, for passing into 'loadConfig'
- , globalResolver :: Maybe Resolver -- ^ Resolver override
- , globalTerminal :: Bool -- ^ We're in a terminal?
- , globalStackYaml :: Maybe FilePath -- ^ Override project stack.yaml
- } deriving (Show)
+imgDockerCmd :: () -> GlobalOpts -> IO ()
+imgDockerCmd () go@GlobalOpts{..} = do
+ withBuildConfigExt
+ go
+ Nothing
+ (\lk ->
+ do Stack.Build.build
+ (const (return ()))
+ (Just lk)
+ defaultBuildOpts
+ Image.stageContainerImageArtifacts)
+ (Just Image.createContainerImageFromStage)
-- | Load the configuration with a manager. Convenience function used
-- throughout this module.
loadConfigWithOpts :: GlobalOpts -> IO (Manager,LoadConfig (StackLoggingT IO))
-loadConfigWithOpts GlobalOpts{..} = do
+loadConfigWithOpts go@GlobalOpts{..} = do
manager <- newTLSManager
mstackYaml <-
case globalStackYaml of
@@ -878,37 +854,42 @@
Just fp -> do
path <- canonicalizePath fp >>= parseAbsFile
return $ Just path
- lc <- runStackLoggingT
+ lc <- runStackLoggingTGlobal
manager
- globalLogLevel
- globalTerminal
+ go
(loadConfig globalConfigMonoid mstackYaml)
return (manager,lc)
-- | Project initialization
initCmd :: InitOpts -> GlobalOpts -> IO ()
-initCmd initOpts go = withConfig go $ initProject initOpts
+initCmd initOpts go =
+ withConfigAndLock go $
+ do pwd <- getWorkingDir
+ initProject pwd initOpts
--- | Project creation
-newCmd :: InitOpts -> GlobalOpts -> IO ()
-newCmd initOpts go@GlobalOpts{..} = withConfig go $ do
- newProject
- initProject initOpts
+-- | Create a project directory structure and initialize the stack config.
+newCmd :: (NewOpts,InitOpts) -> GlobalOpts -> IO ()
+newCmd (newOpts,initOpts) go@GlobalOpts{..} =
+ withConfigAndLock go $
+ do dir <- new newOpts
+ initProject dir initOpts
+-- | List the available templates.
+templatesCmd :: () -> GlobalOpts -> IO ()
+templatesCmd _ go@GlobalOpts{..} = withConfigAndLock go listTemplates
+
-- | Fix up extra-deps for a project
solverCmd :: Bool -- ^ modify stack.yaml automatically?
-> GlobalOpts
-> IO ()
solverCmd fixStackYaml go =
- withBuildConfig go ThrowException (solveExtraDeps fixStackYaml)
-
--- | Parser for @solverCmd@
-solverOptsParser :: Parser Bool
-solverOptsParser = boolFlags False
- "modify-stack-yaml"
- "Automatically modify stack.yaml with the solver's recommendations"
- idm
+ withBuildConfigAndLock go (\_ -> solveExtraDeps fixStackYaml)
-- | Visualize dependencies
dotCmd :: DotOpts -> GlobalOpts -> IO ()
-dotCmd dotOpts go = withBuildConfig go ThrowException (dot dotOpts)
+dotCmd dotOpts go = withBuildConfigAndLock go (\_ -> dot dotOpts)
+
+-- | List the dependencies
+listDependenciesCmd :: Text -> GlobalOpts -> IO ()
+listDependenciesCmd sep go = withBuildConfig go (listDependencies sep')
+ where sep' = T.replace "\\t" "\t" (T.replace "\\n" "\n" sep)
diff --git a/src/test/Network/HTTP/Download/VerifiedSpec.hs b/src/test/Network/HTTP/Download/VerifiedSpec.hs
--- a/src/test/Network/HTTP/Download/VerifiedSpec.hs
+++ b/src/test/Network/HTTP/Download/VerifiedSpec.hs
@@ -4,6 +4,7 @@
import Crypto.Hash
import Control.Monad (unless)
import Control.Monad.Trans.Reader
+import Control.Retry (limitRetries)
import Data.Maybe
import Network.HTTP.Client.Conduit
import Network.HTTP.Download.Verified
@@ -34,6 +35,7 @@
{ drRequest = req
, drHashChecks = [exampleHashCheck]
, drLengthCheck = Just exampleLengthCheck
+ , drRetryPolicy = limitRetries 1
}
exampleHashCheck :: HashCheck
@@ -90,7 +92,7 @@
spec :: Spec
spec = beforeAll setup $ afterAll teardown $ do
- let exampleProgressHook = return ()
+ let exampleProgressHook _ = return ()
describe "verifiedDownload" $ do
-- Preconditions:
@@ -154,9 +156,9 @@
{ drRequest = req
, drHashChecks = []
, drLengthCheck = Nothing
+ , drRetryPolicy = limitRetries 1
}
- let progressHook = return ()
- let go = runWith manager $ verifiedDownload dReq dest progressHook
+ let go = runWith manager $ verifiedDownload dReq dest exampleProgressHook
doesFileExist destFp `shouldReturn` False
go `shouldReturn` True
doesFileExist destFp `shouldReturn` True
diff --git a/src/test/Stack/Build/ExecuteSpec.hs b/src/test/Stack/Build/ExecuteSpec.hs
--- a/src/test/Stack/Build/ExecuteSpec.hs
+++ b/src/test/Stack/Build/ExecuteSpec.hs
@@ -8,17 +8,4 @@
main = hspec spec
spec :: Spec
-spec = describe "compareTestComponents" $ do
- let test comps names expected = it (show (comps, names)) $
- compareTestsComponents
- (T.words $ T.pack comps)
- (T.words $ T.pack names)
- `shouldBe`
- (T.words $ T.pack expected)
-
- test "" "" ""
- test "" "foo" "foo"
- test "foo" "bar" ""
- test "foo" "foo bar" "foo"
- test "test:foo" "foo bar" "foo"
- test "test:foo exe:bar" "foo bar" "foo"
+spec = return ()
diff --git a/src/test/Stack/Build/TargetSpec.hs b/src/test/Stack/Build/TargetSpec.hs
new file mode 100644
--- /dev/null
+++ b/src/test/Stack/Build/TargetSpec.hs
@@ -0,0 +1,26 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+module Stack.Build.TargetSpec (main, spec) where
+
+import qualified Data.Text as T
+import Stack.Build.Target
+import Stack.Types
+import Test.Hspec
+
+main :: IO ()
+main = hspec spec
+
+spec :: Spec
+spec = do
+ describe "parseRawTarget" $ do
+ let test s e = it s $ parseRawTarget (T.pack s) `shouldBe` e
+ test "foobar" $ Just $ RTPackage $(mkPackageName "foobar")
+ test "foobar-1.2.3" $ Just $ RTPackageIdentifier $ PackageIdentifier
+ $(mkPackageName "foobar") $(mkVersion "1.2.3")
+ test "./foobar" Nothing
+ test "foobar/" Nothing
+ test "/foobar" Nothing
+ test ":some-exe" $ Just $ RTComponent "some-exe"
+ test "foobar:some-exe" $ Just $ RTPackageComponent $(mkPackageName "foobar") $ UnresolvedComponent "some-exe"
+ test "foobar:exe:some-exe" $ Just $ RTPackageComponent $(mkPackageName "foobar")
+ $ ResolvedComponent $ CExe "some-exe"
diff --git a/src/test/Stack/BuildPlanSpec.hs b/src/test/Stack/BuildPlanSpec.hs
--- a/src/test/Stack/BuildPlanSpec.hs
+++ b/src/test/Stack/BuildPlanSpec.hs
@@ -39,8 +39,8 @@
spec :: Spec
spec = beforeAll setup $ afterAll teardown $ do
let logLevel = LevelDebug
- let loadConfig' m = runStackLoggingT m logLevel False (loadConfig mempty Nothing)
- let loadBuildConfigRest m = runStackLoggingT m logLevel False
+ let loadConfig' m = runStackLoggingT m logLevel False False (loadConfig mempty Nothing)
+ let loadBuildConfigRest m = runStackLoggingT m logLevel False False
let inTempDir action = do
currentDirectory <- getCurrentDirectory
withSystemTempDirectory "Stack_BuildPlanSpec" $ \tempDir -> do
@@ -53,8 +53,8 @@
-- github still depends on failure.
writeFile "stack.yaml" "resolver: lts-2.9"
LoadConfig{..} <- loadConfig' manager
- bconfig <- loadBuildConfigRest manager (lcLoadBuildConfig Nothing ThrowException)
- runStackT manager logLevel bconfig False $ do
+ bconfig <- loadBuildConfigRest manager (lcLoadBuildConfig Nothing)
+ runStackT manager logLevel bconfig False False $ do
menv <- getMinimalEnvOverride
mbp <- loadMiniBuildPlan $ LTS 2 9
eres <- try $ resolveBuildPlan
diff --git a/src/test/Stack/ConfigSpec.hs b/src/test/Stack/ConfigSpec.hs
--- a/src/test/Stack/ConfigSpec.hs
+++ b/src/test/Stack/ConfigSpec.hs
@@ -60,8 +60,8 @@
describe "loadConfig" $ do
- let loadConfig' m = runStackLoggingT m logLevel False (loadConfig mempty Nothing)
- let loadBuildConfigRest m = runStackLoggingT m logLevel False
+ let loadConfig' m = runStackLoggingT m logLevel False False (loadConfig mempty Nothing)
+ let loadBuildConfigRest m = runStackLoggingT m logLevel False False
-- TODO(danburton): make sure parent dirs also don't have config file
it "works even if no config file exists" $ \T{..} -> example $ do
_config <- loadConfig' manager
@@ -79,9 +79,9 @@
createDirectory childDir
setCurrentDirectory childDir
LoadConfig{..} <- loadConfig' manager
- BuildConfig{..} <- loadBuildConfigRest manager
- (lcLoadBuildConfig Nothing ThrowException)
- bcRoot `shouldBe` parentDir
+ bc@BuildConfig{..} <- loadBuildConfigRest manager
+ (lcLoadBuildConfig Nothing)
+ bcRoot bc `shouldBe` parentDir
it "respects the STACK_YAML env variable" $ \T{..} -> inTempDir $ do
withSystemTempDirectory "config-is-here" $ \dirFilePath -> do
@@ -91,8 +91,9 @@
withEnvVar "STACK_YAML" stackYamlFp $ do
LoadConfig{..} <- loadConfig' manager
BuildConfig{..} <- loadBuildConfigRest manager
- (lcLoadBuildConfig Nothing ThrowException)
- bcRoot `shouldBe` dir
+ (lcLoadBuildConfig Nothing)
+ bcStackYaml `shouldBe` dir stackDotYaml
+ parent bcStackYaml `shouldBe` dir
it "STACK_YAML can be relative" $ \T{..} -> inTempDir $ do
parentDir <- getCurrentDirectory >>= parseAbsDir
@@ -104,5 +105,5 @@
withEnvVar "STACK_YAML" (toFilePath yamlRel) $ do
LoadConfig{..} <- loadConfig' manager
BuildConfig{..} <- loadBuildConfigRest manager
- (lcLoadBuildConfig Nothing ThrowException)
+ (lcLoadBuildConfig Nothing)
bcStackYaml `shouldBe` yamlAbs
diff --git a/src/test/Stack/DotSpec.hs b/src/test/Stack/DotSpec.hs
--- a/src/test/Stack/DotSpec.hs
+++ b/src/test/Stack/DotSpec.hs
@@ -1,31 +1,33 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections #-}
-- | Test suite for Stack.Dot
module Stack.DotSpec where
+import Control.Monad (filterM)
import Data.ByteString.Char8 (ByteString)
-import qualified Data.Foldable as F
+import Data.Foldable as F
import Data.Functor.Identity
import Data.List ((\\))
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
import Data.Set (Set)
import qualified Data.Set as Set
-import Options.Applicative (execParserPure,idm,prefs,info,getParseResult)
import Stack.Types
import Test.Hspec
import Test.Hspec.QuickCheck (prop)
-#if MIN_VERSION_QuickCheck(2,8,0)
-import Test.QuickCheck (forAll,sublistOf)
-#endif
+import Test.QuickCheck (forAll,choose,Gen)
import Stack.Dot
+dummyVersion :: Version
+dummyVersion = fromMaybe (error "dotspec: parser error") (parseVersionFromString "0.0.0.0")
+
spec :: Spec
spec = do
let graph =
Map.mapKeys pkgName
- . fmap (Set.map pkgName)
+ . fmap (\p -> (Set.map pkgName p, Just dummyVersion))
. Map.fromList $ [("one",Set.fromList ["base","free"])
,("two",Set.fromList ["base","free","mtl","transformers","one"])
]
@@ -34,37 +36,42 @@
resolveDependencies (Just 0) graph stubLoader `shouldBe` return graph
it "with depth 1, more dependencies are resolved" $ do
- let graph' = Map.insert (pkgName "cycle") (Set.singleton (pkgName "cycle")) graph
+ let graph' = Map.insert (pkgName "cycle")
+ (Set.singleton (pkgName "cycle"), Just dummyVersion)
+ graph
resultGraph = runIdentity (resolveDependencies (Just 0) graph stubLoader)
resultGraph' = runIdentity (resolveDependencies (Just 1) graph' stubLoader)
Map.size resultGraph < Map.size resultGraph' `shouldBe` True
it "cycles are ignored" $ do
- let graph' = Map.insert (pkgName "cycle") (Set.singleton (pkgName "cycle")) graph
+ let graph' = Map.insert (pkgName "cycle")
+ (Set.singleton (pkgName "cycle"), Just dummyVersion)
+ graph
resultGraph = resolveDependencies Nothing graph stubLoader
resultGraph' = resolveDependencies Nothing graph' stubLoader
fmap Map.size resultGraph' `shouldBe` fmap ((+1) . Map.size) resultGraph
-#if MIN_VERSION_QuickCheck(2,8,0)
+ let graphElem e = Set.member e . Set.unions . Map.elems
+
prop "requested packages are pruned" $ do
let resolvedGraph = runIdentity (resolveDependencies Nothing graph stubLoader)
- allPackages g = Set.map show (Map.keysSet g `Set.union` F.fold g)
+ allPackages g = Set.map show (Map.keysSet g `Set.union` F.fold (fmap fst g))
forAll (sublistOf (Set.toList (allPackages resolvedGraph))) $ \toPrune ->
let pruned = pruneGraph [pkgName "one", pkgName "two"] toPrune resolvedGraph
in Set.null (allPackages pruned `Set.intersection` Set.fromList toPrune)
prop "pruning removes orhpans" $ do
let resolvedGraph = runIdentity (resolveDependencies Nothing graph stubLoader)
- allPackages g = Set.map show (Map.keysSet g `Set.union` F.fold g)
+ allPackages g = Set.map show (Map.keysSet g `Set.union` F.fold (fmap fst g))
orphans g = Map.filterWithKey (\k _ -> not (graphElem k g)) g
forAll (sublistOf (Set.toList (allPackages resolvedGraph))) $ \toPrune ->
let pruned = pruneGraph [pkgName "one", pkgName "two"] toPrune resolvedGraph
- in null (Map.keys (orphans pruned) \\ [pkgName "one", pkgName "two"])
-#endif
-
- where graphElem e graph = Set.member e . Set.unions . Map.elems $ graph
+ in null (Map.keys (orphans (fmap fst pruned)) \\ [pkgName "one", pkgName "two"])
{- Helper functions below -}
+-- Backport from QuickCheck 2.8 to 2.7.6
+sublistOf :: [a] -> Gen [a]
+sublistOf = filterM (\_ -> choose (False, True))
-- Unsafe internal helper to create a package name
pkgName :: ByteString -> PackageName
@@ -73,8 +80,8 @@
failure = error "Internal error during package name creation in DotSpec.pkgName"
-- Stub, simulates the function to load package dependecies
-stubLoader :: PackageName -> Identity (Set PackageName)
-stubLoader name = return . Set.fromList . map pkgName $ case show name of
+stubLoader :: PackageName -> Identity (Set PackageName, Maybe Version)
+stubLoader name = return . (, Just dummyVersion) . Set.fromList . map pkgName $ case show name of
"StateVar" -> ["stm","transformers"]
"array" -> []
"bifunctors" -> ["semigroupoids","semigroups","tagged"]
diff --git a/src/test/Stack/PackageDumpSpec.hs b/src/test/Stack/PackageDumpSpec.hs
--- a/src/test/Stack/PackageDumpSpec.hs
+++ b/src/test/Stack/PackageDumpSpec.hs
@@ -76,6 +76,7 @@
, dpLibDirs = ["/opt/ghc/7.8.4/lib/ghc-7.8.4/haskell2010-1.1.2.0"]
, dpDepends = depends
, dpLibraries = ["HShaskell2010-1.1.2.0"]
+ , dpHasExposedModules = True
, dpHaddockInterfaces = ["/opt/ghc/7.8.4/share/doc/ghc/html/libraries/haskell2010-1.1.2.0/haskell2010.haddock"]
, dpProfiling = ()
, dpHaddock = ()
@@ -109,6 +110,7 @@
, dpHaddockInterfaces = ["/opt/ghc/7.10.1/share/doc/ghc/html/libraries/ghc-7.10.1/ghc.haddock"]
, dpDepends = depends
, dpLibraries = ["HSghc-7.10.1-EMlWrQ42XY0BNVbSrKixqY"]
+ , dpHasExposedModules = True
, dpProfiling = ()
, dpHaddock = ()
}
@@ -138,6 +140,7 @@
, dpHaddockInterfaces = ["/Users/alexbiehl/.stack/snapshots/x86_64-osx/lts-2.13/7.8.4/doc/html/hmatrix.haddock"]
, dpDepends = depends
, dpLibraries = ["HShmatrix-0.16.1.5"]
+ , dpHasExposedModules = True
, dpProfiling = ()
, dpHaddock = ()
}
diff --git a/stack.cabal b/stack.cabal
--- a/stack.cabal
+++ b/stack.cabal
@@ -1,5 +1,5 @@
name: stack
-version: 0.1.2.0
+version: 0.1.3.0
synopsis: The Haskell Tool Stack
description: Please see the README.md for usage information, and
the wiki on Github for more details. Also, note that
@@ -23,13 +23,6 @@
test/package-dump/ghc-7.8.4-osx.txt
test/package-dump/ghc-7.10.txt
- new-template/src/Lib.hs
- new-template/new-template.cabal
- new-template/test/Spec.hs
- new-template/app/Main.hs
- new-template/LICENSE
- new-template/Setup.hs
-
stack.yaml
flag integration-tests
@@ -54,11 +47,14 @@
Stack.GhcPkg
Stack.Init
Stack.New
+ Stack.Options
Stack.Package
Stack.PackageDump
Stack.PackageIndex
- Stack.Repl
+ Stack.Ghci
Stack.Ide
+ Stack.Image
+ Stack.SDist
Stack.Setup
Stack.Solver
Stack.Types
@@ -68,18 +64,23 @@
Stack.Types.Docker
Stack.Types.FlagName
Stack.Types.GhcPkgId
+ Stack.Types.Image
Stack.Types.PackageIdentifier
Stack.Types.PackageName
+ Stack.Types.TemplateName
Stack.Types.Version
Stack.Types.StackT
+ Stack.Types.Build
+ Stack.Types.Package
Stack.Build
Stack.Build.Cache
+ Stack.Build.Coverage
Stack.Build.ConstructPlan
Stack.Build.Execute
Stack.Build.Haddock
Stack.Build.Installed
Stack.Build.Source
- Stack.Build.Types
+ Stack.Build.Target
Stack.Upgrade
Stack.Upload
System.Process.Read
@@ -87,10 +88,10 @@
System.Process.Run
Network.HTTP.Download.Verified
Data.Attoparsec.Args
+ Path.IO
other-modules: Network.HTTP.Download
Control.Concurrent.Execute
Path.Find
- Path.IO
System.Process.PagerEditor
Paths_stack
Data.Aeson.Extended
@@ -116,10 +117,13 @@
, containers >= 0.5.5.1
, cryptohash >= 0.11.6
, cryptohash-conduit
+ , deepseq-generics
, directory >= 1.2.1.0
, enclosed-exceptions
, exceptions >= 0.8.0.2
+ , extra
, fast-logger >= 2.3.1
+ , filelock >= 0.1.0.1
, filepath >= 1.3.0.2
, fsnotify
, hashable >= 1.2.3.2
@@ -134,6 +138,7 @@
, mtl >= 2.1.3.1
, old-locale >= 1.0.0.6
, optparse-applicative
+ , optparse-simple >= 0.0.3
, path >= 0.5.1
, persistent >= 2.1.2
, persistent-sqlite >= 2.1.4
@@ -141,6 +146,7 @@
, pretty
, process >= 1.2.0.0
, resourcet >= 1.1.4.1
+ , retry >= 0.6
, safe >= 0.3
, split
, stm >= 2.4.4
@@ -152,6 +158,7 @@
, time >= 1.4.2
, transformers >= 0.3.0.0
, transformers-base >= 0.4.4
+ , unix-compat
, unordered-containers >= 0.2.5.1
, vector >= 0.10.12.3
, vector-binary-instances
@@ -161,6 +168,8 @@
, deepseq
, file-embed
, word8
+ , hastache
+ , project-template >= 0.2
if !os(windows)
build-depends: unix >= 2.7.0.1
default-language: Haskell2010
@@ -168,16 +177,20 @@
executable stack
hs-source-dirs: src/main
main-is: Main.hs
- ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N
+ ghc-options: -Wall -threaded -rtsopts
other-modules: Plugins
Plugins.Commands
+ Paths_stack
build-depends: base >=4.7 && < 5
, bytestring >= 0.10.4.0
, containers
, exceptions
, filepath
+ , filelock >= 0.1.0.1
, http-conduit >= 2.1.5
+ , lifted-base
+ , monad-control
, monad-logger >= 0.3.13.1
, mtl >= 2.1.3.1
, old-locale >= 1.0.0.6
@@ -197,6 +210,9 @@
, transformers
, http-client
default-language: Haskell2010
+ if os(windows)
+ build-depends: Win32
+ cpp-options: -DWINDOWS
test-suite stack-test
type: exitcode-stdio-1.0
@@ -205,6 +221,7 @@
other-modules: Spec
, Stack.BuildPlanSpec
, Stack.Build.ExecuteSpec
+ , Stack.Build.TargetSpec
, Stack.ConfigSpec
, Stack.DotSpec
, Stack.PackageDumpSpec
@@ -232,6 +249,7 @@
, optparse-applicative
, bytestring
, QuickCheck
+ , retry >= 0.6
default-language: Haskell2010
test-suite stack-integration-test
diff --git a/stack.yaml b/stack.yaml
--- a/stack.yaml
+++ b/stack.yaml
@@ -4,4 +4,13 @@
- path-0.5.2
- Win32-notify-0.3.0.1
- hfsevents-0.1.5
+- project-template-0.2.0
+- filelock-0.1.0.1
resolver: lts-2.17
+image:
+ container:
+ base: "fpco/ubuntu-with-libgmp:14.04"
+ add:
+ man/: /usr/local/share/man/
+ entrypoints:
+ - stack