stack 0.1.4.1 → 0.1.5.0
raw patch · 47 files changed
+2359/−1084 lines, 47 filesdep +binary-taggeddep −deepseq-genericsdep ~deepseq
Dependencies added: binary-tagged
Dependencies removed: deepseq-generics
Dependency ranges changed: deepseq
Files
- ChangeLog.md +42/−1
- LICENSE +1/−1
- README.md +77/−19
- src/Data/Aeson/Extended.hs +25/−20
- src/Data/Binary/VersionTagged.hs +14/−38
- src/Distribution/Version/Extra.hs +30/−0
- src/Stack/Build.hs +12/−3
- src/Stack/Build/Cache.hs +11/−9
- src/Stack/Build/ConstructPlan.hs +28/−20
- src/Stack/Build/Coverage.hs +64/−48
- src/Stack/Build/Execute.hs +256/−109
- src/Stack/Build/Haddock.hs +7/−8
- src/Stack/Build/Installed.hs +22/−17
- src/Stack/Build/Source.hs +70/−31
- src/Stack/BuildPlan.hs +3/−3
- src/Stack/Config.hs +65/−20
- src/Stack/Constants.hs +1/−1
- src/Stack/Docker.hs +1/−1
- src/Stack/Dot.hs +5/−4
- src/Stack/FileWatch.hs +24/−8
- src/Stack/GhcPkg.hs +89/−24
- src/Stack/Ghci.hs +7/−6
- src/Stack/Init.hs +57/−6
- src/Stack/Options.hs +66/−28
- src/Stack/Package.hs +283/−177
- src/Stack/PackageDump.hs +29/−29
- src/Stack/PackageIndex.hs +11/−10
- src/Stack/SDist.hs +109/−25
- src/Stack/Setup.hs +320/−213
- src/Stack/Solver.hs +6/−1
- src/Stack/Types/Build.hs +43/−23
- src/Stack/Types/BuildPlan.hs +7/−16
- src/Stack/Types/Compiler.hs +7/−4
- src/Stack/Types/Config.hs +263/−36
- src/Stack/Types/FlagName.hs +1/−0
- src/Stack/Types/GhcPkgId.hs +30/−23
- src/Stack/Types/Internal.hs +2/−0
- src/Stack/Types/Package.hs +93/−13
- src/Stack/Types/PackageIdentifier.hs +2/−1
- src/Stack/Types/PackageName.hs +3/−1
- src/Stack/Types/Version.hs +12/−3
- src/Stack/Upgrade.hs +23/−14
- src/System/Process/Read.hs +1/−2
- src/main/Main.hs +122/−65
- src/test/Stack/PackageDumpSpec.hs +9/−0
- stack.cabal +5/−3
- stack.yaml +1/−0
ChangeLog.md view
@@ -1,3 +1,44 @@+## 0.1.5.0++Major changes:++* On Windows, we now use a full MSYS2 installation in place of the previous PortableGit. This gives you access to the pacman package manager for more easily installing libraries.+* Support for custom GHC binary distributions [#530](https://github.com/commercialhaskell/stack/issues/530)+ * `ghc-variant` option in stack.yaml to specify the variant (also+ `--ghc-variant` command-line option)+ * `setup-info` in stack.yaml, to specify where to download custom binary+ distributions (also `--ghc-bindist` command-line option)+ * Note: On systems with libgmp4 (aka `libgmp.so.3`), such as CentOS 6, you+ may need to re-run `stack setup` due to the centos6 GHC bindist being+ treated like a variant+* A new `--pvp-bounds` flag to the sdist and upload commands allows automatic adding of PVP upper and/or lower bounds to your dependencies++Other enhancements:++* Adapt to upcoming Cabal installed package identifier format change [#851](https://github.com/commercialhaskell/stack/issues/851)+* `stack setup` takes a `--stack-setup-yaml` argument+* `--file-watch` is more discerning about which files to rebuild for [#912](https://github.com/commercialhaskell/stack/issues/912)+* `stack path` now supports `--global-pkg-db` and `--ghc-package-path`+* `--reconfigure` flag [#914](https://github.com/commercialhaskell/stack/issues/914) [#946](https://github.com/commercialhaskell/stack/issues/946)+* Cached data is written with a checksum of its structure [#889](https://github.com/commercialhaskell/stack/issues/889)+* Fully removed `--optimizations` flag+* Added `--cabal-verbose` flag+* Added `--file-watch-poll` flag for polling instead of using filesystem events (useful for running tests in a Docker container while modifying code in the host environment. When code is injected into the container via a volume, the container won't propagate filesystem events).+* Give a preemptive error message when `-prof` is given as a GHC option [#1015](https://github.com/commercialhaskell/stack/issues/1015)+* Locking is now optional, and will be turned on by setting the `STACK_LOCK` environment variable to `true` [#950](https://github.com/commercialhaskell/stack/issues/950)+* Create default stack.yaml with documentation comments and commented out options [#226](https://github.com/commercialhaskell/stack/issues/226)+* Out of memory warning if Cabal exits with -9 [#947](https://github.com/commercialhaskell/stack/issues/947)++Bug fixes:++* Hacky workaround for optparse-applicative issue with `stack exec --help` [#806](https://github.com/commercialhaskell/stack/issues/806)+* Build executables for local extra deps [#920](https://github.com/commercialhaskell/stack/issues/920)+* copyFile can't handle directories [#942](https://github.com/commercialhaskell/stack/pull/942)+* Support for spaces in Haddock interface files [fpco/minghc#85](https://github.com/fpco/minghc/issues/85)+* Temporarily building against a "shadowing" local package? [#992](https://github.com/commercialhaskell/stack/issues/992)+* Fix Setup.exe name for --upgrade-cabal on Windows [#1002](https://github.com/commercialhaskell/stack/issues/1002)+* Unlisted dependencies no longer trigger extraneous second build [#838](https://github.com/commercialhaskell/stack/issues/838)+ ## 0.1.4.1 Fix stack's own Haddocks. No changes to functionality (only comments updated).@@ -54,7 +95,7 @@ * 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)+ * For details, see [Build commands documentation](doc/build_command.md) Other enhancements:
LICENSE view
@@ -8,7 +8,7 @@ * 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 stackage-common nor the+ * Neither the name of stack nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.
README.md view
@@ -1,6 +1,7 @@ ## The Haskell Tool Stack [](https://travis-ci.org/commercialhaskell/stack)+[](https://ci.appveyor.com/project/snoyberg/stack) [](https://github.com/commercialhaskell/stack/releases) `stack` is a cross-platform program for developing Haskell@@ -20,18 +21,21 @@ Downloads are available by operating system: -* [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--amazon-linux)-* [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)+* [Windows](doc/install_and_upgrade.md#windows)+* [OS X](doc/install_and_upgrade.md#os-x)+* [Ubuntu](doc/install_and_upgrade.md#ubuntu)+* [Debian](doc/install_and_upgrade.md#debian)+* [CentOS / Red Hat / Amazon Linux](doc/install_and_upgrade.md#centos--red-hat--amazon-linux)+* [Fedora](doc/install_and_upgrade.md#fedora)+* [Arch Linux](doc/install_and_upgrade.md#arch-linux)+* [Linux (general)](doc/install_and_upgrade.md#linux) -[Upgrade instructions](https://github.com/commercialhaskell/stack/wiki/Downloads#upgrade)+[Upgrade instructions](doc/install_and_upgrade.md#upgrade) -Note: if you are using cabal-install to install stack, you may need to pass a constraint to work around a [Cabal issue](https://github.com/haskell/cabal/issues/2759): `cabal install --constraint 'mono-traversable >= 0.9' stack`.+Note: if you are using cabal-install to install stack, you may need to pass a+constraint to work around a+[Cabal issue](https://github.com/haskell/cabal/issues/2759): `cabal install+--constraint 'mono-traversable >= 0.9' stack`. #### How to use @@ -48,26 +52,50 @@ * `stack init` to create a stack configuration file for an existing project. stack will figure out what Stackage release (LTS or nightly) is appropriate for the dependencies.-* `stack setup` to download and install the correct GHC version in an isolated- location that won't interfere with any system-level installations. (For- information on installation paths, please use the `stack path` command.)+* `stack setup` to download and install the correct GHC version in an+ isolated location (default `~/.stack`) that won't interfere with any+ system-level installations. (For information on installation paths,+ please use the `stack path` command.) If you just want to install an executable using stack, then all you have to do is `stack install <package-name>`. Run `stack` for a complete list of commands. +#### How to contribute++This assumes that you have already installed a version of stack, and have `git`+installed.++1. Clone `stack` from git with+ `git clone https://github.com/commercialhaskell/stack.git`.+2. Enter into the stack folder with `cd stack`.+3. Build `stack` using a pre-existing `stack` install with+ `stack setup && stack build`.+4. Once `stack` finishes building, check the stack version with+ `stack --version`. Make sure the version is the latest.+5. Look for issues tagged with+ [`newcomer` and `awaiting-pr` labels](https://github.com/commercialhaskell/stack/issues?q=is%3Aopen+is%3Aissue+label%3Anewcomer+label%3Aawaiting-pr)++Build from source as a one-liner:++```bash+git clone https://github.com/commercialhaskell/stack.git && \+cd stack && \+stack setup && \+stack build+```+ #### Complete guide to stack -This repository also contains [a complete guide to using-stack](https://github.com/commercialhaskell/stack/blob/master/GUIDE.md),-covering all of the most common use cases.+This repository also contains a complete [user guide to using stack+](doc/GUIDE.md), covering all of the most common use cases. + #### Questions, Feedback, Discussion -* For frequently asked questions about detailed or specific use-cases,- please see- [the FAQ](https://github.com/commercialhaskell/stack/wiki/FAQ).+* For frequently asked questions about detailed or specific use-cases, please+ see [the FAQ](doc/faq.md). * For general questions, comments, feedback and support please write to [the stack mailing list](https://groups.google.com/d/forum/haskell-stack). * For bugs, issues, or requests please@@ -95,3 +123,33 @@ Haskell](https://www.fpcomplete.com/blog/2015/05/thousand-user-haskell-survey), which rated build issues as a major concern. The stack team hopes that stack can address these concerns.++<hr>++## Documentation Table Of Contents++* Project Documentation+ * [Maintainer Guide](doc/MAINTAINER_GUIDE.md): includes releasing information+ * [Signing Key](doc/SIGNING_KEY.md): downloadable stack binaries are signed+ with this key+* Tool Documentation+ * [Build Command](doc/build_command.md): reference for the syntax of the+ build command and the command line targets+ * [Dependency Visualization](doc/dependency_visualization.md): uses Graphviz+ * [Docker Integration](doc/docker_integration.md)+ * [FAQ](doc/faq.md): frequently asked questions about detailed or specific+ use-cases+ * [Install/Upgrade](doc/install_and_upgrade.md): a list of downloads+ available by operating system, installation instructions, and upgrade+ instructions+ * [Nonstandard Project Initialization](doc/nonstandard_project_init.md)+ * [Shell Autocompletion](doc/shell_autocompletion.md)+ * [User Guide](doc/GUIDE.md): in-depth tutorial covering the most common use+ cases and all major stack features (requires no prior Haskell tooling+ experience)+ * [YAML Configuration](doc/yaml_configuration.md): reference for writing+ `stack.yaml` files+* Advanced Documentation+ * [Architecture](doc/architecture.md): reference for people curious about+ stack internals, wanting to get involved deeply in the codebase, or+ wanting to use stack in unusual ways
src/Data/Aeson/Extended.hs view
@@ -10,13 +10,15 @@ , WarningParser , JSONWarning (..) , withObjectWarnings- , (..:)- , (..:?)- , (..!=) , jsonSubWarnings , jsonSubWarningsT- , jsonSubWarningsMT+ , jsonSubWarningsTT , logJSONWarnings+ , tellJSONField+ , unWarningParser+ , (..:)+ , (..:?)+ , (..!=) ) where import Control.Monad.Logger (MonadLogger, logWarn)@@ -49,13 +51,13 @@ (..:) :: FromJSON a => Object -> Text -> WarningParser a-o ..: k = tellField k >> lift (o .: k)+o ..: k = tellJSONField k >> lift (o .: k) -- | 'WarningParser' version of @.:?@. (..:?) :: FromJSON a => Object -> Text -> WarningParser (Maybe a)-o ..:? k = tellField k >> lift (o .:? k)+o ..:? k = tellJSONField k >> lift (o .:? k) -- | 'WarningParser' version of @.!=@. (..!=) :: WarningParser (Maybe a) -> a -> WarningParser a@@ -65,11 +67,11 @@ 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})+-- | Tell warning parser about about an expected field, so it doesn't warn about it.+tellJSONField :: Text -> WarningParser ()+tellJSONField key = tell (mempty { wpmExpectedFields = Set.singleton key}) --- | 'MonadParser' version of 'withObject'.+-- | 'WarningParser' version of 'withObject'. withObjectWarnings :: String -> (Object -> WarningParser a) -> Value@@ -90,6 +92,12 @@ [] -> [] _ -> [JSONUnrecognizedFields expected unrecognizedFields]) +-- | Convert a 'WarningParser' to a 'Parser'.+unWarningParser :: WarningParser a -> Parser a+unWarningParser wp = do+ (a,_) <- runWriterT wp+ return a+ -- | Log JSON warnings. logJSONWarnings :: MonadLogger m@@ -115,20 +123,17 @@ 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))+jsonSubWarningsTT+ :: (Traversable t, Traversable u)+ => WarningParser (u (t (a, [JSONWarning])))+ -> WarningParser (u (t a))+jsonSubWarningsTT f =+ Traversable.mapM (jsonSubWarningsT . return) =<< f -- | 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.+-- | Monoid used by 'WarningParser' to track expected fields and warnings. data WarningParserMonoid = WarningParserMonoid { wpmExpectedFields :: !(Set Text) , wpmWarnings :: [JSONWarning]
src/Data/Binary/VersionTagged.hs view
@@ -1,70 +1,46 @@ {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ConstraintKinds #-} -- | Tag a Binary instance with the stack version number to ensure we're -- reading a compatible format. module Data.Binary.VersionTagged ( taggedDecodeOrLoad , taggedEncodeFile , Binary (..)- , BinarySchema (..)+ , BinarySchema+ , HasStructuralInfo+ , HasSemanticVersion , decodeFileOrFailDeep- , encodeFile , NFData (..)- , genericRnf ) where -import Control.DeepSeq.Generics (NFData (..), genericRnf)+import Control.DeepSeq (NFData (..)) import Control.Exception (Exception) import Control.Monad.Catch (MonadThrow (..)) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Logger-import Data.Binary (Binary (..), encodeFile, decodeFileOrFail, putWord8, getWord8)+import Data.Binary (Binary (..)) import Data.Binary.Get (ByteOffset)+import Data.Binary.Tagged (HasStructuralInfo, HasSemanticVersion)+import qualified Data.Binary.Tagged as BinaryTagged import Data.Typeable (Typeable) import Control.Exception.Enclosed (tryAnyDeep) import System.FilePath (takeDirectory) import System.Directory (createDirectoryIfMissing)-import qualified Data.ByteString as S-import Data.ByteString (ByteString)-import Control.Monad (forM_, when)-import Data.Proxy import qualified Data.Text as T -magic :: ByteString-magic = "stack"---- | A @Binary@ instance that also has a schema version-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- w' <- getWord8- when (w /= w')- $ fail "Mismatched magic string, forcing a recompute"- tag' <- get- if binarySchema (Proxy :: Proxy a) == tag'- then fmap WithTag get- else fail "Mismatched tags, forcing a recompute"- put (WithTag x) = do- mapM_ putWord8 $ S.unpack magic- put (binarySchema (Proxy :: Proxy a))- put x+type BinarySchema a = (Binary a, NFData a, HasStructuralInfo a, HasSemanticVersion a) --- | Write to the given file, with a version tag.+-- | Write to the given file, with a binary-tagged tag. taggedEncodeFile :: (BinarySchema a, MonadIO m) => FilePath -> a -> m () taggedEncodeFile fp x = liftIO $ do createDirectoryIfMissing True $ takeDirectory fp- encodeFile fp $ WithTag x+ BinaryTagged.taggedEncodeFile fp x -- | Read from the given file. If the read fails, run the given action and -- write that back to the file. Always starts the file off with the version@@ -82,18 +58,18 @@ x <- mx taggedEncodeFile fp x return x- Right (WithTag x) -> do+ Right x -> do $logDebug $ T.pack $ "Success decoding " ++ fp 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)+decodeFileOrFailDeep :: (BinarySchema a, MonadIO m, MonadThrow n) => FilePath -> m (n a) decodeFileOrFailDeep fp = liftIO $ fmap (either throwM return) $ tryAnyDeep $ do- eres <- decodeFileOrFail fp+ eres <- BinaryTagged.taggedDecodeFileOrFail fp case eres of Left (offset, str) -> throwM $ DecodeFileFailure fp offset str Right x -> return x
+ src/Distribution/Version/Extra.hs view
@@ -0,0 +1,30 @@+-- A separate module so that we can contain all usage of deprecated identifiers here+{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}+module Distribution.Version.Extra+ ( hasUpper+ , hasLower+ ) where++import Distribution.Version (VersionRange (..))++-- | Does the version range have an upper bound?+hasUpper :: VersionRange -> Bool+hasUpper AnyVersion = False+hasUpper (ThisVersion _) = True+hasUpper (LaterVersion _) = False+hasUpper (EarlierVersion _) = True+hasUpper (WildcardVersion _) = True+hasUpper (UnionVersionRanges x y) = hasUpper x && hasUpper y+hasUpper (IntersectVersionRanges x y) = hasUpper x || hasUpper y+hasUpper (VersionRangeParens x) = hasUpper x++-- | Does the version range have a lower bound?+hasLower :: VersionRange -> Bool+hasLower AnyVersion = False+hasLower (ThisVersion _) = True+hasLower (LaterVersion _) = True+hasLower (EarlierVersion _) = False+hasLower (WildcardVersion _) = True+hasLower (UnionVersionRanges x y) = hasLower x && hasLower y+hasLower (IntersectVersionRanges x y) = hasLower x || hasLower y+hasLower (VersionRangeParens x) = hasLower x
src/Stack/Build.hs view
@@ -72,7 +72,7 @@ $ Set.unions $ map lpFiles locals - (installedMap, locallyRegistered) <-+ (installedMap, globallyRegistered, locallyRegistered) <- getInstalled menv GetInstalledOpts { getInstalledProfiling = profiling@@ -98,7 +98,11 @@ if boptsDryrun bopts then printPlan plan- else executePlan menv bopts baseConfigOpts locals sourceMap installedMap plan+ else executePlan menv bopts baseConfigOpts locals+ globallyRegistered+ sourceMap+ installedMap+ plan where profiling = boptsLibProfile bopts || boptsExeProfile bopts @@ -142,7 +146,12 @@ withCabalLoader menv $ \cabalLoader -> inner $ \name version flags -> do bs <- cabalLoader $ PackageIdentifier name version -- TODO automatically update index the first time this fails- readPackageBS (depPackageConfig econfig flags) bs++ -- Intentionally ignore warnings, as it's not really+ -- appropriate to print a bunch of warnings out while+ -- resolving the package index.+ (_warnings,pkg) <- readPackageBS (depPackageConfig econfig flags) bs+ return pkg where -- | Package config to be used for dependencies depPackageConfig :: EnvConfig -> Map FlagName Bool -> PackageConfig
src/Stack/Build/Cache.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-}+{-# LANGUAGE ConstraintKinds #-} -- | Cache information about previous builds module Stack.Build.Cache ( tryGetBuildCache@@ -36,7 +37,7 @@ import Control.Monad.Logger (MonadLogger) import Control.Monad.Reader import qualified Crypto.Hash.SHA256 as SHA256-import qualified Data.Binary as Binary+import qualified Data.Binary as Binary (encode) import Data.Binary.VersionTagged import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Base16 as B16@@ -96,8 +97,9 @@ } deriving (Generic) instance Binary BuildCache-instance NFData BuildCache where- rnf = genericRnf+instance HasStructuralInfo BuildCache+instance HasSemanticVersion BuildCache+instance NFData BuildCache -- | 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)@@ -115,7 +117,7 @@ tryGetCabalMod = tryGetCache configCabalMod -- | Try to load a cache.-tryGetCache :: (MonadIO m, Binary a, NFData a)+tryGetCache :: (MonadIO m, BinarySchema a) => (Path Abs Dir -> m (Path Abs File)) -> Path Abs Dir -> m (Maybe a)@@ -158,14 +160,14 @@ removeFileIfExists cfp -- | Write to a cache.-writeCache :: (Binary a, MonadIO m)+writeCache :: (BinarySchema a, MonadIO m) => Path Abs Dir -> (Path Abs Dir -> m (Path Abs File)) -> a -> m () writeCache dir get' content = do fp <- get' dir- liftIO $ encodeFile (toFilePath fp) content+ taggedEncodeFile (toFilePath fp) content flagCacheFile :: (MonadIO m, MonadThrow m, MonadReader env m, HasEnvConfig env) => Installed@@ -173,7 +175,7 @@ flagCacheFile installed = do rel <- parseRelFile $ case installed of- Library gid -> ghcPkgIdString gid+ Library _ gid -> ghcPkgIdString gid Executable ident -> packageIdentifierString ident dir <- flagCacheLocal return $ dir </> rel@@ -193,7 +195,7 @@ file <- flagCacheFile gid liftIO $ do createTree (parent file)- encodeFile (toFilePath file) cache+ taggedEncodeFile (toFilePath file) cache -- | Mark a test suite as having succeeded setTestSuccess :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env, HasEnvConfig env)@@ -335,7 +337,7 @@ exes' <- forM (Set.toList exes) $ \exe -> do name <- parseRelFile $ T.unpack exe return $ toFilePath $ bcoSnapInstallRoot baseConfigOpts </> bindirSuffix </> name- liftIO $ encodeFile (toFilePath file) PrecompiledCache+ liftIO $ taggedEncodeFile (toFilePath file) PrecompiledCache { pcLibrary = mlibpath , pcExes = exes' }
src/Stack/Build/ConstructPlan.hs view
@@ -108,6 +108,7 @@ instance HasStackRoot Ctx instance HasPlatform Ctx+instance HasGHCVariant Ctx instance HasConfig Ctx instance HasBuildConfig Ctx where getBuildConfig = getBuildConfig . getEnvConfig@@ -120,7 +121,7 @@ -> BaseConfigOpts -> [LocalPackage] -> Set PackageName -- ^ additional packages that must be built- -> Set GhcPkgId -- ^ locally registered+ -> Map GhcPkgId PackageIdentifier -- ^ locally registered -> (PackageName -> Version -> Map FlagName Bool -> IO Package) -- ^ load upstream package -> SourceMap -> InstalledMap@@ -161,7 +162,7 @@ return $ takeSubset Plan { planTasks = tasks , planFinals = M.fromList finals- , planUnregisterLocal = mkUnregisterLocal tasks dirtyReason locallyRegistered+ , planUnregisterLocal = mkUnregisterLocal tasks dirtyReason locallyRegistered sourceMap , planInstallExes = if boptsInstallExes $ bcoBuildOpts baseConfigOpts0 then installExes@@ -192,19 +193,26 @@ -- already registered local packages mkUnregisterLocal :: Map PackageName Task -> Map PackageName Text- -> Set GhcPkgId- -> Map GhcPkgId Text-mkUnregisterLocal tasks dirtyReason locallyRegistered =- Map.unions $ map toUnregisterMap $ Set.toList locallyRegistered+ -> Map GhcPkgId PackageIdentifier+ -> SourceMap+ -> Map GhcPkgId (PackageIdentifier, Maybe Text)+mkUnregisterLocal tasks dirtyReason locallyRegistered sourceMap =+ Map.unions $ map toUnregisterMap $ Map.toList locallyRegistered where- toUnregisterMap gid =+ toUnregisterMap (gid, ident) = case M.lookup name tasks of- Nothing -> Map.empty+ Nothing ->+ case M.lookup name sourceMap of+ Just (PSUpstream _ Snap _) -> Map.singleton gid+ ( ident+ , Just "Switching to snapshot installed package"+ )+ _ -> Map.empty Just _ -> Map.singleton gid- $ fromMaybe "likely unregistering due to a version change"- $ Map.lookup name dirtyReason+ ( ident+ , Map.lookup name dirtyReason+ ) where- ident = ghcPkgIdPackageIdentifier gid name = packageIdentifierName ident addFinal :: LocalPackage -> LocalPackageTB -> M ()@@ -219,7 +227,7 @@ (packageName package) (packageVersion package) , taskConfigOpts = TaskConfigOpts missing $ \missing' ->- let allDeps = Set.union present missing'+ let allDeps = Map.union present missing' in configureOpts (getEnvConfig ctx) (baseConfigOpts ctx)@@ -335,7 +343,7 @@ (packageName package) (packageVersion package) , taskConfigOpts = TaskConfigOpts missing $ \missing' ->- let allDeps = Set.union present missing'+ let allDeps = Map.union present missing' destLoc = piiLocation ps <> minLoc in configureOpts (getEnvConfig ctx)@@ -372,7 +380,7 @@ return True addPackageDeps :: Bool -- ^ is this being used by a dependency?- -> Package -> M (Either ConstructPlanException (Set PackageIdentifier, Set GhcPkgId, InstallLocation))+ -> Package -> M (Either ConstructPlanException (Set PackageIdentifier, Map PackageIdentifier GhcPkgId, InstallLocation)) addPackageDeps treatAsDep package = do ctx <- ask deps' <- packageDepsWithTools package@@ -389,11 +397,11 @@ Right adr | not $ adrVersion adr `withinRange` range -> return $ Left (depname, (range, mlatest, DependencyMismatch $ adrVersion adr)) Right (ADRToInstall task) -> return $ Right- (Set.singleton $ taskProvides task, Set.empty, taskLocation task)+ (Set.singleton $ taskProvides task, Map.empty, taskLocation task) Right (ADRFound loc _ (Executable _)) -> return $ Right- (Set.empty, Set.empty, loc)- Right (ADRFound loc _ (Library gid)) -> return $ Right- (Set.empty, Set.singleton gid, loc)+ (Set.empty, Map.empty, loc)+ Right (ADRFound loc _ (Library ident gid)) -> return $ Right+ (Set.empty, Map.singleton ident gid, loc) case partitionEithers deps of ([], pairs) -> return $ Right $ mconcat pairs (errs, _) -> return $ Left $ DependencyPlanFailures@@ -408,7 +416,7 @@ checkDirtiness :: PackageSource -> Installed -> Package- -> Set GhcPkgId+ -> Map PackageIdentifier GhcPkgId -> Set PackageName -> M Bool checkDirtiness ps installed package present wanted = do@@ -424,7 +432,7 @@ buildOpts = bcoBuildOpts (baseConfigOpts ctx) wantConfigCache = ConfigCache { configCacheOpts = configOpts- , configCacheDeps = present+ , configCacheDeps = Set.fromList $ Map.elems present , configCacheComponents = case ps of PSLocal lp -> Set.map renderComponent $ lpComponents lp
src/Stack/Build/Coverage.hs view
@@ -34,6 +34,7 @@ import Path.IO import Prelude hiding (FilePath, writeFile) import Stack.Constants+import Stack.Package import Stack.Types import System.Process.Read import Text.Hastache (htmlEscape)@@ -41,54 +42,69 @@ -- | 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"))))+ => Path Abs Dir -> Package -> [Text] -> (PackageName -> m (Maybe Text)) -> m ()+generateHpcReport pkgDir package tests getGhcPkgKey = do+ -- If we're using > GHC 7.10, the hpc 'include' parameter must specify a+ -- ghc package key. See+ -- https://github.com/commercialhaskell/stack/issues/785+ let pkgName = packageNameText (packageName package)+ pkgId = packageIdentifierString (packageIdentifier package)+ compilerVersion <- asks (envConfigCompilerVersion . getEnvConfig)+ includeName <-+ if getGhcVersion compilerVersion < $(mkVersion "7.10")+ then return pkgId+ else do+ mghcPkgKey <- getGhcPkgKey (packageName package)+ case mghcPkgKey of+ Nothing -> fail $ "Before computing test coverage report, failed to find GHC package key for " ++ T.unpack pkgName+ Just ghcPkgKey -> return $ T.unpack ghcPkgKey+ forM_ tests $ \testName -> do+ let whichTest = pkgName <> "'s test-suite \"" <> testName <> "\""+ -- Compute destination directory.+ installDir <- installationRootLocal+ testNamePath <- parseRelDir (T.unpack testName)+ pkgIdPath <- parseRelDir 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", includeName ++ ":"]+ -- 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 ()
src/Stack/Build/Execute.hs view
@@ -17,13 +17,14 @@ ) where import Control.Applicative+import Control.Arrow ((&&&)) import Control.Concurrent.Execute import Control.Concurrent.Async (withAsync, wait) import Control.Concurrent.MVar.Lifted import Control.Concurrent.STM import Control.Exception.Enclosed (catchIO, tryIO) import Control.Exception.Lifted-import Control.Monad (liftM, when, unless, void, join, guard)+import Control.Monad (liftM, when, unless, void, join, guard, filterM, (<=<)) import Control.Monad.Catch (MonadCatch, MonadMask) import Control.Monad.IO.Class import Control.Monad.Logger@@ -51,6 +52,7 @@ import Data.Traversable (forM) import Data.Text (Text) import qualified Data.Text as T+import Data.Time.Clock (getCurrentTime) import Data.Word8 (_colon) import Distribution.System (OS (Windows), Platform (Platform))@@ -69,6 +71,7 @@ import Stack.Fetch as Fetch import Stack.GhcPkg import Stack.Package+import Stack.PackageDump import Stack.Constants import Stack.Types import Stack.Types.StackT@@ -114,15 +117,19 @@ => Plan -> m () printPlan plan = do- case Map.toList $ planUnregisterLocal plan of+ case Map.elems $ planUnregisterLocal plan of [] -> $logInfo "No packages would be unregistered." xs -> do $logInfo "Would unregister locally:"- forM_ xs $ \(gid, reason) -> $logInfo $ T.concat- [ T.pack $ ghcPkgIdString gid- , " ("- , reason- , ")"+ forM_ xs $ \(ident, mreason) -> $logInfo $ T.concat+ [ T.pack $ packageIdentifierString ident+ , case mreason of+ Nothing -> ""+ Just reason -> T.concat+ [ " ("+ , reason+ , ")"+ ] ] $logInfo ""@@ -201,6 +208,7 @@ , eeLocals :: ![LocalPackage] , eeSourceMap :: !SourceMap , eeGlobalDB :: !(Path Abs Dir)+ , eeGlobalPackages :: ![DumpPackage () ()] } -- | Get a compiled Setup exe@@ -273,10 +281,11 @@ -> BuildOpts -> BaseConfigOpts -> [LocalPackage]+ -> [DumpPackage () ()] -- ^ global packages -> SourceMap -> (ExecuteEnv -> m a) -> m a-withExecuteEnv menv bopts baseConfigOpts locals sourceMap inner = do+withExecuteEnv menv bopts baseConfigOpts locals globals sourceMap inner = do withSystemTempDirectory stackProgName $ \tmpdir -> do tmpdir' <- parseAbsDir tmpdir configLock <- newMVar ()@@ -307,6 +316,7 @@ , eeLocals = locals , eeSourceMap = sourceMap , eeGlobalDB = globalDB+ , eeGlobalPackages = globals } -- | Perform the actual plan@@ -315,12 +325,13 @@ -> BuildOpts -> BaseConfigOpts -> [LocalPackage]+ -> [DumpPackage () ()] -- ^ globals -> SourceMap -> InstalledMap -> Plan -> m ()-executePlan menv bopts baseConfigOpts locals sourceMap installedMap plan = do- withExecuteEnv menv bopts baseConfigOpts locals sourceMap (executePlan' installedMap plan)+executePlan menv bopts baseConfigOpts locals globals sourceMap installedMap plan = do+ withExecuteEnv menv bopts baseConfigOpts locals globals sourceMap (executePlan' installedMap plan) unless (Map.null $ planInstallExes plan) $ do snapBin <- (</> bindirSuffix) `liftM` installationRootDeps@@ -328,8 +339,9 @@ destDir <- asks $ configLocalBin . getConfig createTree destDir - let destDir' = toFilePath destDir- when (not $ any (FP.equalFilePath destDir') (envSearchPath menv)) $+ destDir' <- liftIO . D.canonicalizePath . toFilePath $ destDir+ isInPATH <- liftIO . fmap (any (FP.equalFilePath destDir')) . (mapM D.canonicalizePath <=< filterM D.doesDirectoryExist) $ (envSearchPath menv)+ when (not isInPATH) $ $logWarn $ T.concat [ "Installation path " , T.pack destDir'@@ -413,18 +425,24 @@ -> m () executePlan' installedMap plan ee@ExecuteEnv {..} = do wc <- getWhichCompiler+ cv <- asks $ envConfigCompilerVersion . getEnvConfig case Map.toList $ planUnregisterLocal plan of [] -> return () ids -> do localDB <- packageDatabaseLocal- forM_ ids $ \(id', reason) -> do+ forM_ ids $ \(id', (ident, mreason)) -> do $logInfo $ T.concat- [ T.pack $ ghcPkgIdString id'- , ": unregistering ("- , reason- , ")"+ [ T.pack $ packageIdentifierString ident+ , ": unregistering"+ , case mreason of+ Nothing -> ""+ Just reason -> T.concat+ [ " ("+ , reason+ , ")"+ ] ]- unregisterGhcPkgId eeEnvOverride wc localDB id'+ unregisterGhcPkgId eeEnvOverride wc cv localDB id' ident -- Yes, we're explicitly discarding result values, which in general would -- be bad. monad-unlift does this all properly at the type system level,@@ -477,8 +495,8 @@ where installedMap' = Map.difference installedMap $ Map.fromList- $ map (\gid -> (packageIdentifierName $ ghcPkgIdPackageIdentifier gid, ()))- $ Map.keys+ $ map (\(ident, _) -> (packageIdentifierName ident, ()))+ $ Map.elems $ planUnregisterLocal plan toActions :: M env m@@ -529,30 +547,32 @@ -- | Generate the ConfigCache getConfigCache :: MonadIO m => ExecuteEnv -> Task -> [Text]- -> m ConfigCache+ -> m (Map PackageIdentifier GhcPkgId, ConfigCache) getConfigCache ExecuteEnv {..} Task {..} extra = do idMap <- liftIO $ readTVarIO eeGhcPkgIds let getMissing ident = case Map.lookup ident idMap of Nothing -> error "singleBuild: invariant violated, missing package ID missing"- Just (Library x) -> Just x+ Just (Library ident' x) -> assert (ident == ident') $ Just (ident, x) Just (Executable _) -> Nothing- missing' = Set.fromList $ mapMaybe getMissing $ Set.toList missing+ missing' = Map.fromList $ mapMaybe getMissing $ Set.toList missing TaskConfigOpts missing mkOpts = taskConfigOpts opts = mkOpts missing'- allDeps = Set.union missing' taskPresent- return ConfigCache- { configCacheOpts = opts- { coNoDirs = coNoDirs opts ++ map T.unpack extra+ allDeps = Set.fromList $ Map.elems missing' ++ Map.elems taskPresent+ cache = ConfigCache+ { configCacheOpts = opts+ { coNoDirs = coNoDirs opts ++ map T.unpack extra+ }+ , configCacheDeps = allDeps+ , configCacheComponents =+ case taskType of+ TTLocal lp -> Set.map renderComponent $ lpComponents lp+ TTUpstream _ _ -> Set.empty+ , configCacheHaddock =+ shouldHaddockPackage eeBuildOpts eeWanted (packageIdentifierName taskProvides) }- , configCacheDeps = allDeps- , configCacheComponents =- case taskType of- TTLocal lp -> Set.map renderComponent $ lpComponents lp- TTUpstream _ _ -> Set.empty- , configCacheHaddock =- shouldHaddockPackage eeBuildOpts eeWanted (packageIdentifierName taskProvides)- }+ allDepsMap = Map.union missing' taskPresent+ return (allDepsMap, cache) -- | Ensure that the configuration for the package matches what is given ensureConfig :: M env m@@ -564,16 +584,20 @@ -> Path Abs File -- ^ .cabal file -> m Bool ensureConfig newConfigCache pkgDir ExecuteEnv {..} announce cabal cabalfp = do- -- Determine the old and new configuration in the local directory, to- -- determine if we need to reconfigure.- mOldConfigCache <- tryGetConfigCache pkgDir-- mOldCabalMod <- tryGetCabalMod pkgDir newCabalMod <- liftIO (fmap modTime (D.getModificationTime (toFilePath cabalfp)))+ needConfig <-+ if boptsReconfigure eeBuildOpts+ then return True+ else do+ -- Determine the old and new configuration in the local directory, to+ -- determine if we need to reconfigure.+ mOldConfigCache <- tryGetConfigCache pkgDir - let needConfig = mOldConfigCache /= Just newConfigCache- || mOldCabalMod /= Just newCabalMod- ConfigureOpts dirs nodirs = configCacheOpts newConfigCache+ mOldCabalMod <- tryGetCabalMod pkgDir++ return $ mOldConfigCache /= Just newConfigCache+ || mOldCabalMod /= Just newCabalMod+ let ConfigureOpts dirs nodirs = configCacheOpts newConfigCache when needConfig $ withMVar eeConfigureLock $ \_ -> do deleteCaches pkgDir announce@@ -595,6 +619,10 @@ -> ActionContext -> ExecuteEnv -> Task+ -> Maybe (Map PackageIdentifier GhcPkgId)+ -- ^ All dependencies' package ids to provide to Setup.hs. If+ -- Nothing, just provide global and snapshot package+ -- databases. -> Maybe String -> ( Package -> Path Abs File@@ -605,7 +633,7 @@ -> Maybe (Path Abs File, Handle) -> m a) -> m a-withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} msuffix inner0 =+withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} mdeps msuffix inner0 = withPackage $ \package cabalfp pkgDir -> withLogFile package $ \mlogFile -> withCabal package pkgDir mlogFile $ \cabal ->@@ -667,30 +695,46 @@ (True, Just setupExe) -> return $ Left setupExe _ -> liftIO $ fmap Right $ getSetupHs pkgDir inner $ \stripTHLoading args -> do- let packageArgs =- ("-package=" ++- packageIdentifierString- (PackageIdentifier cabalPackageName- eeCabalPkgVer))- : "-clear-package-db"- : "-global-package-db"+ let cabalPackageArg =+ "-package=" ++ packageIdentifierString+ (PackageIdentifier cabalPackageName+ eeCabalPkgVer)+ packageArgs =+ case mdeps of+ Just deps ->+ -- Stack always builds with the global Cabal for various+ -- reproducibility issues.+ let depsMinusCabal+ = map ghcPkgIdString+ $ Set.toList+ $ addGlobalPackages deps eeGlobalPackages+ in+ "-clear-package-db"+ : "-global-package-db"+ : ("-package-db=" ++ toFilePath (bcoSnapDB eeBaseConfigOpts))+ : ("-package-db=" ++ toFilePath (bcoLocalDB eeBaseConfigOpts))+ : "-hide-all-packages"+ : cabalPackageArg+ : map ("-package-id=" ++) depsMinusCabal+ -- This branch is debatable. It adds access to the+ -- snapshot package database for Cabal. There are two+ -- possible objections:+ --+ -- 1. This doesn't isolate the build enough; arbitrary+ -- other packages available could cause the build to+ -- succeed or fail.+ --+ -- 2. This doesn't provide enough packages: we should also+ -- include the local database when building local packages.+ --+ -- Currently, this branch is only taken via `stack sdist`.+ Nothing ->+ [ cabalPackageArg+ , "-clear-package-db"+ , "-global-package-db"+ , "-package-db=" ++ toFilePath (bcoSnapDB eeBaseConfigOpts)+ ] - -- This next line is debatable. It adds access to the- -- snapshot package database for Cabal. There are two- -- possible objections:- --- -- 1. This doesn't isolate the build enough; arbitrary- -- other packages available could cause the build to- -- succeed or fail.- --- -- 2. This doesn't provide enough packages: we should also- -- include the local database when building local packages.- --- -- One possible solution to these points would be to use- -- -hide-all-packages and explicitly list which packages- -- can be used by Setup.hs, and have that based on the- -- dependencies of the package itself.- : ["-package-db=" ++ toFilePath (bcoSnapDB eeBaseConfigOpts)] setupArgs = ("--builddir=" ++ toFilePath distRelativeDir') : args runExe exeName fullArgs = do $logProcessRun (toFilePath exeName) fullArgs@@ -770,7 +814,7 @@ , "-build-runner" ] return (outputFile, setupArgs)- runExe exeName fullArgs+ runExe exeName $ (if boptsCabalVerbose eeBuildOpts then ("--verbose":) else id) fullArgs maybePrintBuildOutput stripTHLoading makeAbsolute level mlogFile mh = case mh of@@ -788,12 +832,12 @@ -> InstalledMap -> m () singleBuild runInBase ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} installedMap = do- cache <- getCache+ (allDepsMap, cache) <- getCache mprecompiled <- getPrecompiled cache minstalled <- case mprecompiled of Just precompiled -> copyPreCompiled precompiled- Nothing -> realConfigAndBuild cache+ Nothing -> realConfigAndBuild cache allDepsMap case minstalled of Nothing -> return () Just installed -> do@@ -852,7 +896,7 @@ liftIO $ forM_ exes $ \exe -> do D.createDirectoryIfMissing True bindir let dst = bindir FP.</> FP.takeFileName exe- createLink exe dst `catchIO` \_ -> D.copyFile exe bindir+ createLink exe dst `catchIO` \_ -> D.copyFile exe dst -- Find the package in the database wc <- getWhichCompiler@@ -862,11 +906,11 @@ return $ Just $ case mpkgid of Nothing -> Executable taskProvides- Just pkgid -> Library pkgid+ Just pkgid -> Library taskProvides pkgid where bindir = toFilePath $ bcoSnapInstallRoot eeBaseConfigOpts </> bindirSuffix - realConfigAndBuild cache = withSingleContext runInBase ac ee task Nothing+ realConfigAndBuild cache allDepsMap = withSingleContext runInBase ac ee task (Just allDepsMap) Nothing $ \package cabalfp pkgDir cabal announce console _mlogFile -> do _neededConfig <- ensureConfig cache pkgDir ee (announce "configure") cabal cabalfp @@ -884,7 +928,8 @@ () <- announce "build" config <- asks getConfig- extraOpts <- extraBuildOptions+ extraOpts <- extraBuildOptions eeBuildOpts+ preBuildTime <- modTime <$> liftIO getCurrentTime cabal (console && configHideTHLoading config) $ (case taskType of TTLocal lp -> concat@@ -894,17 +939,36 @@ -- which will allow users to turn off library building if -- desired | packageHasLibrary package]- , map (T.unpack . T.append "exe:")- (maybe [] Set.toList $ lpExeComponents lp)+ , map (T.unpack . T.append "exe:") $ Set.toList $+ case lpExeComponents lp of+ Just exes -> exes+ -- Build all executables in the event that no+ -- specific list is provided (as happens with+ -- extra-deps).+ Nothing -> packageExes package ] TTUpstream _ _ -> ["build"]) ++ extraOpts + case taskType of+ TTLocal lp -> do+ (addBuildCache,warnings) <-+ addUnlistedToBuildCache+ preBuildTime+ (lpPackage lp)+ (lpCabalFile lp)+ (lpNewBuildCache lp)+ mapM_ ($logWarn . ("Warning: " <>) . T.pack . show) warnings+ unless (null addBuildCache) $+ writeBuildCache pkgDir $+ Map.unions (lpNewBuildCache lp : addBuildCache)+ TTUpstream _ _ -> return ()+ when (doHaddock package) $ do announce "haddock" 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).")+ "found on PATH (use 'stack install hscolour' to install).") cabal False (concat [["haddock", "--html", "--hoogle", "--html-location=../$pkg-$version/"] ,["--hyperlink-source" | hscolourExists] ,["--ghcjs" | wc == Ghcjs]])@@ -921,14 +985,13 @@ , bcoLocalDB eeBaseConfigOpts ] mpkgid <- findGhcPkgId eeEnvOverride wc pkgDbs (packageName package)+ let ident = PackageIdentifier (packageName package) (packageVersion package) mpkgid' <- case (packageHasLibrary package, mpkgid) of (False, _) -> assert (isNothing mpkgid) $ do markExeInstalled (taskLocation task) taskProvides -- TODO unify somehow with writeFlagCache?- return $ Executable $ PackageIdentifier- (packageName package)- (packageVersion package)+ return $ Executable ident (True, Nothing) -> throwM $ Couldn'tFindPkgId $ packageName package- (True, Just pkgid) -> return $ Library pkgid+ (True, Just pkgid) -> return $ Library ident pkgid when (doHaddock package && shouldHaddockDeps eeBuildOpts) $ withMVar eeInstallLock $ \() ->@@ -964,15 +1027,15 @@ -> Task -> InstalledMap -> m ()-singleTest runInBase topts lptb ac ee task installedMap =- withSingleContext runInBase ac ee task (Just "test") $ \package cabalfp pkgDir cabal announce console mlogFile -> do- cache <- getConfigCache ee task $- case taskType task of- TTLocal lp -> concat- [ ["--enable-tests"]- , ["--enable-benchmarks" | depsPresent installedMap $ lpBenchDeps lp]- ]- _ -> []+singleTest runInBase topts lptb ac ee task installedMap = do+ (allDepsMap, cache) <- getConfigCache ee task $+ case taskType task of+ TTLocal lp -> concat+ [ ["--enable-tests"]+ , ["--enable-benchmarks" | depsPresent installedMap $ lpBenchDeps lp]+ ]+ _ -> []+ withSingleContext runInBase ac ee task (Just allDepsMap) (Just "test") $ \package cabalfp pkgDir cabal announce console mlogFile -> do neededConfig <- ensureConfig cache pkgDir ee (announce "configure (test)") cabal cabalfp config <- asks getConfig @@ -996,7 +1059,7 @@ case taskType task of TTLocal lp -> writeBuildCache pkgDir $ lpNewBuildCache lp TTUpstream _ _ -> assert False $ return ()- extraOpts <- extraBuildOptions+ extraOpts <- extraBuildOptions (eeBuildOpts ee) cabal (console && configHideTHLoading config) $ "build" : (components ++ extraOpts) setTestBuilt pkgDir@@ -1086,10 +1149,13 @@ ] return $ Map.singleton testName Nothing - when needHpc $ forM_ testsToRun $ \testName -> do- let pkgName = packageNameText (packageName package)- pkgId = packageIdentifierText (packageIdentifier package)- generateHpcReport pkgDir pkgName pkgId testName+ when needHpc $ do+ wc <- getWhichCompiler+ let pkgDbs =+ [ bcoSnapDB (eeBaseConfigOpts ee)+ , bcoLocalDB (eeBaseConfigOpts ee)+ ]+ generateHpcReport pkgDir package testsToRun (findGhcPkgKey (eeEnvOverride ee) wc pkgDbs) bs <- liftIO $ case mlogFile of@@ -1115,15 +1181,15 @@ -> Task -> InstalledMap -> m ()-singleBench runInBase beopts _lptb ac ee task installedMap =- withSingleContext runInBase ac ee task (Just "bench") $ \_package cabalfp pkgDir cabal announce console _mlogFile -> do- cache <- getConfigCache ee task $- case taskType task of- TTLocal lp -> concat- [ ["--enable-tests" | depsPresent installedMap $ lpTestDeps lp]- , ["--enable-benchmarks"]- ]- _ -> []+singleBench runInBase beopts _lptb ac ee task installedMap = do+ (allDepsMap, cache) <- getConfigCache ee task $+ case taskType task of+ TTLocal lp -> concat+ [ ["--enable-tests" | depsPresent installedMap $ lpTestDeps lp]+ , ["--enable-benchmarks"]+ ]+ _ -> []+ withSingleContext runInBase ac ee task (Just allDepsMap) (Just "bench") $ \_package cabalfp pkgDir cabal announce console _mlogFile -> do neededConfig <- ensureConfig cache pkgDir ee (announce "configure (benchmarks)") cabal cabalfp benchBuilt <- checkBenchBuilt pkgDir@@ -1140,7 +1206,7 @@ TTLocal lp -> writeBuildCache pkgDir $ lpNewBuildCache lp TTUpstream _ _ -> assert False $ return () config <- asks getConfig- extraOpts <- extraBuildOptions+ extraOpts <- extraBuildOptions (eeBuildOpts ee) cabal (console && configHideTHLoading config) ("build" : extraOpts) setBenchBuilt pkgDir let args = maybe []@@ -1231,7 +1297,88 @@ 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"]+-- Do not pass `-hpcdir` as GHC option if the coverage is not enabled.+-- This helps running stack-compiled programs with dynamic interpreters like `hint`.+-- Cfr: https://github.com/commercialhaskell/stack/issues/997+extraBuildOptions :: M env m => BuildOpts -> m [String]+extraBuildOptions bopts = do+ let ddumpOpts = " -ddump-hi -ddump-to-file"+ case toCoverage (boptsTestOpts bopts) of+ True -> do+ hpcIndexDir <- toFilePath . (</> dotHpc) <$> hpcRelativeDir+ return ["--ghc-options", "-hpcdir " ++ hpcIndexDir ++ ddumpOpts]+ False -> return ["--ghc-options", ddumpOpts]++-- | Take the given list of package dependencies and the contents of the global+-- package database, and construct a set of installed package IDs that:+--+-- * Excludes the Cabal library (it's added later)+--+-- * Includes all packages depended on by this package+--+-- * Includes all global packages, unless: (1) it's hidden, (2) it's shadowed+-- by a depended-on package, or (3) one of its dependencies is not met.+--+-- See:+--+-- * https://github.com/commercialhaskell/stack/issues/941+--+-- * https://github.com/commercialhaskell/stack/issues/944+--+-- * https://github.com/commercialhaskell/stack/issues/949+addGlobalPackages :: Map PackageIdentifier GhcPkgId -- ^ dependencies of the package+ -> [DumpPackage () ()] -- ^ global packages+ -> Set GhcPkgId+addGlobalPackages deps globals0 =+ res+ where+ -- Initial set of packages: the installed IDs of all dependencies+ res0 = Map.elems $ Map.filterWithKey (\ident _ -> not $ isCabal ident) deps++ -- First check on globals: it's not shadowed by a dep, it's not Cabal, and+ -- it's exposed+ goodGlobal1 dp = not (isDep dp)+ && not (isCabal $ dpPackageIdent dp)+ && dpIsExposed dp+ globals1 = filter goodGlobal1 globals0++ -- Create a Map of unique package names in the global database+ globals2 = Map.fromListWith chooseBest+ $ map (packageIdentifierName . dpPackageIdent &&& id) globals1++ -- Final result: add in globals that have their dependencies met+ res = loop id (Map.elems globals2) $ Set.fromList res0++ ----------------------------------+ -- Some auxiliary helper functions+ ----------------------------------++ -- Is the given package identifier for any version of Cabal+ isCabal (PackageIdentifier name _) = name == $(mkPackageName "Cabal")++ -- Is the given package name provided by the package dependencies?+ isDep dp = packageIdentifierName (dpPackageIdent dp) `Set.member` depNames+ depNames = Set.map packageIdentifierName $ Map.keysSet deps++ -- Choose the best of two competing global packages (the newest version)+ chooseBest dp1 dp2+ | getVer dp1 < getVer dp2 = dp2+ | otherwise = dp1+ where+ getVer = packageIdentifierVersion . dpPackageIdent++ -- Are all dependencies of the given package met by the given Set of+ -- installed packages+ depsMet dp gids = all (`Set.member` gids) (dpDepends dp)++ -- Find all globals that have all of their dependencies met+ loop front (dp:dps) gids+ -- This package has its deps met. Add it to the list of dependencies+ -- and then traverse the list from the beginning (this package may have+ -- been a dependency of an earlier one).+ | depsMet dp gids = loop id (front dps) (Set.insert (dpGhcPkgId dp) gids)+ -- Deps are not met, keep going+ | otherwise = loop (front . (dp:)) dps gids+ -- None of the packages we checked can be added, therefore drop them all+ -- and return our results+ loop _ [] gids = gids
src/Stack/Build/Haddock.hs view
@@ -67,19 +67,18 @@ -> Set (Path Abs Dir) -> m () copyDepHaddocks envOverride wc bco pkgDbs pkgId extraDestDirs = do- mpkgHtmlDir <- findGhcPkgHaddockHtml envOverride wc pkgDbs pkgId+ mpkgHtmlDir <- findGhcPkgHaddockHtml envOverride wc pkgDbs $ packageIdentifierString pkgId case mpkgHtmlDir of Nothing -> return ()- Just pkgHtmlDir -> do- depGhcIds <- findGhcPkgDepends envOverride wc pkgDbs pkgId- forM_ (map ghcPkgIdPackageIdentifier depGhcIds) $- copyDepWhenNeeded pkgHtmlDir+ Just (_pkgId, pkgHtmlDir) -> do+ depGhcIds <- findGhcPkgDepends envOverride wc pkgDbs $ packageIdentifierString pkgId+ forM_ depGhcIds $ copyDepWhenNeeded pkgHtmlDir where- copyDepWhenNeeded pkgHtmlDir depId = do- mDepOrigDir <- findGhcPkgHaddockHtml envOverride wc pkgDbs depId+ copyDepWhenNeeded pkgHtmlDir depGhcId = do+ mDepOrigDir <- findGhcPkgHaddockHtml envOverride wc pkgDbs $ ghcPkgIdString depGhcId case mDepOrigDir of Nothing -> return ()- Just depOrigDir -> do+ Just (depId, depOrigDir) -> do let extraDestDirs' = -- Parent test ensures we don't try to copy docs to global locations if bcoSnapInstallRoot bco `isParentOf` pkgHtmlDir ||
src/Stack/Build/Installed.hs view
@@ -11,6 +11,7 @@ ) where import Control.Applicative+import Control.Arrow ((&&&)) import Control.Monad import Control.Monad.Catch (MonadCatch, MonadMask) import Control.Monad.IO.Class@@ -26,8 +27,6 @@ import qualified Data.Map.Strict as M import qualified Data.Map.Strict as Map import Data.Maybe-import Data.Set (Set)-import qualified Data.Set as Set import Network.HTTP.Client.Conduit (HasHttpManager) import Path import Prelude hiding (FilePath, writeFile)@@ -63,7 +62,10 @@ => EnvOverride -> GetInstalledOpts -> Map PackageName pii -- ^ does not contain any installed information- -> m (InstalledMap, Set GhcPkgId)+ -> m ( InstalledMap+ , [DumpPackage () ()] -- globally installed+ , Map GhcPkgId PackageIdentifier -- locally installed+ ) getInstalled menv opts sourceMap = do snapDBPath <- packageDatabaseDeps localDBPath <- packageDatabaseLocal@@ -76,11 +78,12 @@ else return Nothing let loadDatabase' = loadDatabase menv opts mcache sourceMap- (installedLibs', localInstalled) <-- loadDatabase' Nothing [] >>=- loadDatabase' (Just (Snap, snapDBPath)) . fst >>=- loadDatabase' (Just (Local, localDBPath)) . fst- let installedLibs = M.fromList $ map lhPair installedLibs'+ (installedLibs0, globalInstalled) <- loadDatabase' Nothing []+ (installedLibs1, _snapInstalled) <-+ loadDatabase' (Just (Snap, snapDBPath)) installedLibs0+ (installedLibs2, localInstalled) <-+ loadDatabase' (Just (Local, localDBPath)) installedLibs1+ let installedLibs = M.fromList $ map lhPair installedLibs2 case mcache of Nothing -> return ()@@ -108,7 +111,10 @@ , installedLibs ] - return (installedMap, localInstalled)+ return ( installedMap+ , globalInstalled+ , Map.fromList $ map (dpGhcPkgId &&& dpPackageIdent) localInstalled+ ) -- | Outputs both the modified InstalledMap and the Set of all installed packages in this database --@@ -122,18 +128,18 @@ -> Map PackageName pii -- ^ to determine which installed things we should include -> Maybe (InstallLocation, Path Abs Dir) -- ^ package database, Nothing for global -> [LoadHelper] -- ^ from parent databases- -> m ([LoadHelper], Set GhcPkgId)+ -> m ([LoadHelper], [DumpPackage () ()]) loadDatabase menv opts mcache sourceMap mdb lhs0 = do wc <- getWhichCompiler- (lhs1, gids) <- ghcPkgDump menv wc (fmap snd mdb)+ (lhs1, dps) <- ghcPkgDump menv wc (fmap snd mdb) $ conduitDumpPackage =$ sink let lhs = pruneDeps- (packageIdentifierName . ghcPkgIdPackageIdentifier)+ id lhId lhDeps const (lhs0 ++ lhs1)- return (map (\lh -> lh { lhDeps = [] }) $ Map.elems lhs, Set.fromList gids)+ return (map (\lh -> lh { lhDeps = [] }) $ Map.elems lhs, dps) where conduitProfilingCache = case mcache of@@ -151,10 +157,9 @@ =$ conduitHaddockCache =$ CL.mapMaybe (isAllowed opts mcache sourceMap (fmap fst mdb)) =$ CL.consume- sinkGIDs = CL.map dpGhcPkgId =$ CL.consume sink = getZipSink $ (,) <$> ZipSink sinkDP- <*> ZipSink sinkGIDs+ <*> ZipSink CL.consume -- | Check if a can be included in the set of installed packages or not, based -- on the package selections made by the user. This does not perform any@@ -183,7 +188,7 @@ if name `HashSet.member` wiredInPackages then [] else dpDepends dp- , lhPair = (name, (version, fromMaybe Snap mloc, Library gid))+ , lhPair = (name, (version, fromMaybe Snap mloc, Library ident gid)) } | otherwise = Nothing where@@ -209,4 +214,4 @@ checkLocation Local = mloc == Just Local gid = dpGhcPkgId dp- PackageIdentifier name version = ghcPkgIdPackageIdentifier gid+ ident@(PackageIdentifier name version) = dpPackageIdent dp
src/Stack/Build/Source.hs view
@@ -14,6 +14,7 @@ , getLocalPackageViews , loadLocalPackage , parseTargetsFromBuildOpts+ , addUnlistedToBuildCache ) where @@ -218,13 +219,14 @@ go (Map.insert flag version extra) flags -- | Parse out the local package views for the current project-getLocalPackageViews :: (MonadThrow m, MonadIO m, MonadReader env m, HasEnvConfig env)+getLocalPackageViews :: (MonadThrow m, MonadIO m, MonadReader env m, HasEnvConfig env, MonadLogger m) => m (Map PackageName (LocalPackageView, GenericPackageDescription)) getLocalPackageViews = do econfig <- asks getEnvConfig locals <- forM (Map.toList $ envConfigPackages econfig) $ \(dir, validWanted) -> do cabalfp <- getCabalFileName dir- gpkg <- readPackageUnresolved cabalfp+ (warnings,gpkg) <- readPackageUnresolved cabalfp+ mapM_ (printCabalFileWarning cabalfp) warnings let cabalID = package $ packageDescription gpkg name = fromCabalPackageName $ pkgName $ cabalID checkCabalFileName name cabalfp@@ -333,12 +335,7 @@ testpkg = resolvePackage testconfig gpkg benchpkg = resolvePackage benchconfig gpkg mbuildCache <- tryGetBuildCache $ lpvRoot lpv- (_,modFiles,otherFiles,mainFiles,extraFiles) <- getPackageFiles (packageFiles pkg) (lpvCabalFP lpv)- let files =- mconcat (M.elems modFiles) <>- mconcat (M.elems otherFiles) <>- Set.map mainIsFile (mconcat (M.elems mainFiles)) <>- extraFiles+ (files,_) <- getPackageFilesSimple pkg (lpvCabalFP lpv) (isDirty, newBuildCache) <- checkBuildCache (fromMaybe Map.empty mbuildCache) (map toFilePath $ Set.toList files)@@ -481,27 +478,69 @@ return (True, newFci) return (Any isDirty, Map.singleton fp newFci) - getModTimeMaybe fp =- liftIO- (catch- (liftM- (Just . modTime)- (getModificationTime fp))- (\e ->- if isDoesNotExistError e- then return Nothing- else throwM e))+-- | Returns entries to add to the build cache for any newly found unlisted modules+addUnlistedToBuildCache+ :: (MonadIO m, MonadReader env m, MonadCatch m, MonadLogger m, HasEnvConfig env)+ => ModTime+ -> Package+ -> Path Abs File+ -> Map FilePath a+ -> m ([Map FilePath FileCacheInfo], [PackageWarning])+addUnlistedToBuildCache preBuildTime pkg cabalFP buildCache = do+ (files,warnings) <- getPackageFilesSimple pkg cabalFP+ let newFiles =+ Set.toList $+ Set.map toFilePath files `Set.difference` Map.keysSet buildCache+ addBuildCache <- mapM addFileToCache newFiles+ return (addBuildCache, warnings)+ where+ addFileToCache fp = do+ mmodTime <- getModTimeMaybe fp+ case mmodTime of+ Nothing -> return Map.empty+ Just modTime' ->+ if modTime' < preBuildTime+ then do+ newFci <- calcFci modTime' fp+ return (Map.singleton fp newFci)+ else return Map.empty - calcFci modTime' fp =- withBinaryFile fp ReadMode $ \h -> do- (size, digest) <- CB.sourceHandle h $$ getZipSink- ((,)- <$> ZipSink (CL.fold- (\x y -> x + fromIntegral (S.length y))- 0)- <*> ZipSink sinkHash)- return FileCacheInfo- { fciModTime = modTime'- , fciSize = size- , fciHash = toBytes (digest :: Digest SHA256)- }+-- | Gets list of Paths for files in a package+getPackageFilesSimple+ :: (MonadIO m, MonadReader env m, MonadCatch m, MonadLogger m, HasEnvConfig env)+ => Package -> Path Abs File -> m (Set (Path Abs File), [PackageWarning])+getPackageFilesSimple pkg cabalFP = do+ (_,compFiles,cabalFiles,warnings) <-+ getPackageFiles (packageFiles pkg) cabalFP+ return+ ( Set.map dotCabalGetPath (mconcat (M.elems compFiles)) <> cabalFiles+ , warnings)++-- | Get file modification time, if it exists.+getModTimeMaybe :: MonadIO m => FilePath -> m (Maybe ModTime)+getModTimeMaybe fp =+ liftIO+ (catch+ (liftM+ (Just . modTime)+ (getModificationTime fp))+ (\e ->+ if isDoesNotExistError e+ then return Nothing+ else throwM e))++-- | Create FileCacheInfo for a file.+calcFci :: MonadIO m => ModTime -> FilePath -> m FileCacheInfo+calcFci modTime' fp = liftIO $+ withBinaryFile fp ReadMode $ \h -> do+ (size, digest) <- CB.sourceHandle h $$ getZipSink+ ((,)+ <$> ZipSink (CL.fold+ (\x y -> x + fromIntegral (S.length y))+ 0)+ <*> ZipSink sinkHash)+ return FileCacheInfo+ { fciModTime = modTime'+ , fciSize = size+ , fciHash = toBytes (digest :: Digest SHA256)+ }
src/Stack/BuildPlan.hs view
@@ -275,7 +275,7 @@ )]) res <- forM (Map.toList byIndex) $ \(indexName', pkgs) -> withCabalFiles indexName' pkgs $ \ident flags cabalBS -> do- gpd <- readPackageUnresolvedBS Nothing cabalBS+ (_warnings,gpd) <- readPackageUnresolvedBS Nothing cabalBS let packageConfig = PackageConfig { packageConfigEnableTests = False , packageConfigEnableBenchmarks = False@@ -429,7 +429,7 @@ -- | Load up a 'MiniBuildPlan', preferably from cache loadMiniBuildPlan- :: (MonadIO m, MonadThrow m, MonadLogger m, MonadReader env m, HasHttpManager env, HasConfig env, MonadBaseControl IO m, MonadCatch m)+ :: (MonadIO m, MonadThrow m, MonadLogger m, MonadReader env m, HasHttpManager env, HasConfig env, HasGHCVariant env, MonadBaseControl IO m, MonadCatch m) => SnapName -> m MiniBuildPlan loadMiniBuildPlan name = do@@ -587,7 +587,7 @@ -- | Find a snapshot and set of flags that is compatible with the given -- 'GenericPackageDescription'. Returns 'Nothing' if no such snapshot is found.-findBuildPlan :: (MonadIO m, MonadCatch m, MonadLogger m, MonadReader env m, HasHttpManager env, HasConfig env, MonadBaseControl IO m)+findBuildPlan :: (MonadIO m, MonadCatch m, MonadLogger m, MonadReader env m, HasHttpManager env, HasConfig env, HasGHCVariant env, MonadBaseControl IO m) => [GenericPackageDescription] -> [SnapName] -> m (Maybe (SnapName, Map PackageName (Map FlagName Bool)))
src/Stack/Config.hs view
@@ -21,7 +21,9 @@ -- 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- (loadConfig+ (MiniConfig+ ,loadConfig+ ,loadMiniConfig ,packagesParser ,resolvePackageEntry ) where@@ -35,7 +37,7 @@ 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, asks, runReaderT)+import Control.Monad.Reader (MonadReader, ask, runReaderT) import Control.Monad.Trans.Control (MonadBaseControl) import qualified Crypto.Hash.SHA256 as SHA256 import Data.Aeson.Extended@@ -46,7 +48,8 @@ import Data.Maybe import Data.Monoid import qualified Data.Text as T-import Data.Text.Encoding (encodeUtf8, decodeUtf8)+import Data.Text.Encoding (encodeUtf8, decodeUtf8, decodeUtf8With)+import Data.Text.Encoding.Error (lenientDecode) import qualified Data.Yaml as Yaml import Distribution.System (OS (..), Platform (..), buildPlatform) import qualified Distribution.Text@@ -58,6 +61,7 @@ import Path import Path.IO import qualified Paths_stack as Meta+import Safe (headMay) import Stack.BuildPlan import Stack.Constants import qualified Stack.Docker as Docker@@ -115,7 +119,9 @@ }] configMonoidPackageIndices - configSystemGHC = fromMaybe True configMonoidSystemGHC+ configGHCVariant0 = configMonoidGHCVariant++ configSystemGHC = fromMaybe (isNothing configGHCVariant0) configMonoidSystemGHC configInstallGHC = fromMaybe False configMonoidInstallGHC configSkipGHCCheck = fromMaybe False configMonoidSkipGHCCheck configSkipMsys = fromMaybe False configMonoidSkipMsys@@ -147,14 +153,16 @@ $ map (T.pack *** T.pack) rawEnv let configEnvOverride _ = return origEnv - platform <- runReaderT platformRelDir configPlatform-+ platformOnlyDir <- runReaderT platformOnlyRelDir configPlatform configLocalPrograms <-- case configPlatform of- Platform _ Windows -> do- progsDir <- getWindowsProgsDir configStackRoot origEnv- return $ progsDir </> $(mkRelDir stackProgName) </> platform- _ -> return $ configStackRoot </> $(mkRelDir "programs") </> platform+ case configPlatform of+ Platform _ Windows -> do+ progsDir <- getWindowsProgsDir configStackRoot origEnv+ return $ progsDir </> $(mkRelDir stackProgName) </> platformOnlyDir+ _ ->+ return $+ configStackRoot </> $(mkRelDir "programs") </>+ platformOnlyDir configLocalBin <- case configMonoidLocalBinPath of@@ -176,9 +184,31 @@ let configTemplateParams = configMonoidTemplateParameters configScmInit = configMonoidScmInit configGhcOptions = configMonoidGhcOptions+ configSetupInfoLocations = configMonoidSetupInfoLocations+ configPvpBounds = fromMaybe PvpBoundsNone configMonoidPvpBounds return Config {..} +-- | Get the default 'GHCVariant'. On older Linux systems with libgmp4, returns 'GHCGMP4'.+getDefaultGHCVariant+ :: (MonadIO m, MonadBaseControl IO m, MonadCatch m, MonadLogger m)+ => EnvOverride -> Platform -> m GHCVariant+getDefaultGHCVariant menv (Platform _ Linux) = do+ executablePath <- liftIO getExecutablePath+ elddOut <- tryProcessStdout Nothing menv "ldd" [executablePath]+ return $+ case elddOut of+ Left _ -> GHCStandard+ Right lddOut ->+ if hasLineWithFirstWord "libgmp.so.3" lddOut+ then GHCGMP4+ else GHCStandard+ where+ hasLineWithFirstWord w =+ elem (Just w) .+ map (headMay . T.words) . T.lines . decodeUtf8With lenientDecode+getDefaultGHCVariant _ _ = return GHCStandard+ -- | Get the directory on Windows where we should install extra programs. For -- more information, see discussion at: -- https://github.com/fpco/minghc/issues/43#issuecomment-99737383@@ -193,14 +223,30 @@ return $ lad </> $(mkRelDir "Programs") Nothing -> return $ stackRoot </> $(mkRelDir "Programs") -data MiniConfig = MiniConfig Manager Config+-- | An environment with a subset of BuildConfig used for setup.+data MiniConfig = MiniConfig Manager GHCVariant Config instance HasConfig MiniConfig where- getConfig (MiniConfig _ c) = c+ getConfig (MiniConfig _ _ c) = c instance HasStackRoot MiniConfig instance HasHttpManager MiniConfig where- getHttpManager (MiniConfig man _) = man+ getHttpManager (MiniConfig man _ _) = man instance HasPlatform MiniConfig+instance HasGHCVariant MiniConfig where+ getGHCVariant (MiniConfig _ v _) = v +-- | Load the 'MiniConfig'.+loadMiniConfig+ :: (MonadIO m, HasHttpManager a, MonadReader a m, MonadBaseControl IO m, MonadCatch m, MonadLogger m)+ => Config -> m MiniConfig+loadMiniConfig config = do+ menv <- liftIO $ (configEnvOverride config) minimalEnvSettings+ manager <- getHttpManager <$> ask+ ghcVariant <-+ case configGHCVariant0 config of+ Just ghcVariant -> return ghcVariant+ Nothing -> getDefaultGHCVariant menv (configPlatform config)+ return (MiniConfig manager ghcVariant config)+ -- | Load the configuration, using current directory, environment variables, -- and defaults as necessary. loadConfig :: (MonadLogger m,MonadIO m,MonadCatch m,MonadThrow m,MonadBaseControl IO m,MonadReader env m,HasHttpManager env,HasTerminal env)@@ -235,7 +281,8 @@ -> m BuildConfig loadBuildConfig mproject config stackRoot mresolver = do env <- ask- let miniConfig = MiniConfig (getHttpManager env) config+ miniConfig <- loadMiniConfig config+ (project', stackYamlFP) <- case mproject of Just (project, fp, _) -> return (project, fp) Nothing -> do@@ -283,10 +330,7 @@ case mresolver of Nothing -> return $ projectResolver project' Just aresolver -> do- manager <- asks getHttpManager- runReaderT- (makeConcreteResolver aresolver)- (MiniConfig manager config)+ runReaderT (makeConcreteResolver aresolver) miniConfig let project = project' { projectResolver = resolver } wantedCompiler <-@@ -308,6 +352,7 @@ , bcStackYaml = stackYamlFP , bcFlags = projectFlags project , bcImplicitGlobal = isNothing mproject+ , bcGHCVariant = getGHCVariant miniConfig } -- | Resolve a PackageEntry into a list of paths, downloading and cloning as@@ -327,7 +372,7 @@ subs -> mapM (resolveDir entryRoot) subs case peValidWanted pe of Nothing -> return ()- Just _ -> $logWarn "Warning: you are using the deprecated valid-wanted field. You should instead use extra-dep. See: https://github.com/commercialhaskell/stack/wiki/stack.yaml#packages"+ Just _ -> $logWarn "Warning: you are using the deprecated valid-wanted field. You should instead use extra-dep. See: https://github.com/commercialhaskell/stack/blob/master/doc/yaml_configuration.md#packages" return $ map (, not $ peExtraDep pe) paths -- | Resolve a PackageLocation into a path, downloading and cloning as
src/Stack/Constants.hs view
@@ -200,7 +200,7 @@ => m (Path Rel Dir) distRelativeDir = do cabalPkgVer <- asks (envConfigCabalVersion . getEnvConfig)- platform <- platformRelDir+ platform <- platformVariantRelDir cabal <- parseRelDir $ packageIdentifierString
src/Stack/Docker.hs view
@@ -570,7 +570,7 @@ "docker" (concat [["login"]- ,maybe [] (\u -> ["--username=" ++ u]) (dockerRegistryUsername docker)+ ,maybe [] (\n -> ["--username=" ++ n]) (dockerRegistryUsername docker) ,maybe [] (\p -> ["--password=" ++ p]) (dockerRegistryPassword docker) ,[takeWhile (/= '/') image]])) e <- try (callProcess Nothing envOverride "docker" ["pull",image])
src/Stack/Dot.hs view
@@ -92,7 +92,7 @@ (_,_,locals,_,sourceMap) <- loadSourceMap NeedTargets defaultBuildOpts let graph = Map.fromList (localDependencies dotOpts locals) menv <- getMinimalEnvOverride- installedMap <- fmap thrd . fst <$> getInstalled menv+ installedMap <- fmap thrd . fst3 <$> getInstalled menv (GetInstalledOpts False False) sourceMap withLoadPackage menv (\loader -> do@@ -108,11 +108,12 @@ thrd :: (a,b,c) -> c thrd (_,_,x) = x + fst3 :: (a,b,c) -> a+ fst3 (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 (Library (PackageIdentifier _ v) _) = Just v libVersionFromInstalled (Executable _) = Nothing listDependencies :: (HasEnvConfig env
src/Stack/FileWatch.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE TupleSections #-} module Stack.FileWatch ( fileWatch+ , fileWatchPoll , printExceptionStderr ) where @@ -11,7 +12,7 @@ import Control.Concurrent.STM import Control.Exception (Exception) import Control.Exception.Enclosed (tryAny)-import Control.Monad (forever, unless)+import Control.Monad (forever, unless, when) import qualified Data.ByteString.Lazy as L import qualified Data.Map.Strict as Map import Data.Monoid ((<>))@@ -29,14 +30,26 @@ printExceptionStderr e = L.hPut stderr $ toLazyByteString $ fromShow e <> copyByteString "\n" +fileWatch :: IO (Path Abs Dir)+ -> ((Set (Path Abs File) -> IO ()) -> IO ())+ -> IO ()+fileWatch = fileWatchConf defaultConfig++fileWatchPoll :: IO (Path Abs Dir)+ -> ((Set (Path Abs File) -> IO ()) -> IO ())+ -> IO ()+fileWatchPoll = fileWatchConf $ defaultConfig { confUsePolling = True }+ -- | Run an action, watching for file changes -- -- The action provided takes a callback that is used to set the files to be -- watched. When any of those files are changed, we rerun the action again.-fileWatch :: IO (Path Abs Dir)- -> ((Set (Path Abs File) -> IO ()) -> IO ())- -> IO ()-fileWatch getProjectRoot inner = withManager $ \manager -> do+fileWatchConf :: WatchConfig+ -> IO (Path Abs Dir)+ -> ((Set (Path Abs File) -> IO ()) -> IO ())+ -> IO ()+fileWatchConf cfg getProjectRoot inner = withManagerConf cfg $ \manager -> do+ allFiles <- newTVarIO Set.empty dirtyVar <- newTVarIO True watchVar <- newTVarIO Map.empty projRoot <- getProjectRoot@@ -48,10 +61,13 @@ return $ FileIgnoredChecker (const False) Right chk -> return chk - let onChange = atomically $ writeTVar dirtyVar True+ let onChange event = atomically $ do+ files <- readTVar allFiles+ when (eventPath event `Set.member` files) (writeTVar dirtyVar True) setWatched :: Set (Path Abs File) -> IO () setWatched files = do+ atomically $ writeTVar allFiles $ Set.map toFilePath files watch0 <- readTVarIO watchVar let actions = Map.mergeWithKey keepListening@@ -77,7 +93,7 @@ return Nothing startListening = Map.mapWithKey $ \dir () -> do let dir' = fromString $ toFilePath dir- listen <- watchDir manager dir' (not . isFileIgnored . eventPath) (const onChange)+ listen <- watchDir manager dir' (not . isFileIgnored . eventPath) onChange return $ Just listen let watchInput = do@@ -90,7 +106,7 @@ putStrLn "quit: exit" putStrLn "build: force a rebuild" putStrLn "watched: display watched directories"- "build" -> onChange+ "build" -> atomically $ writeTVar dirtyVar True "watched" -> do watch <- readTVarIO watchVar mapM_ (putStrLn . toFilePath) (Map.keys watch)
src/Stack/GhcPkg.hs view
@@ -1,14 +1,17 @@+-- FIXME See how much of this module can be deleted. {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-} {-# OPTIONS -fno-warn-unused-do-bind #-} -- | Functions for the GHC package database. module Stack.GhcPkg (findGhcPkgId+ ,findGhcPkgKey ,getGlobalDB ,EnvOverride ,envHelper@@ -19,9 +22,11 @@ ,findGhcPkgDepends ,findTransitiveGhcPkgDepends ,listGhcPkgDbs- ,ghcPkgExeName)+ ,ghcPkgExeName+ ,mkGhcPackagePath) where +import Control.Applicative import Control.Monad import Control.Monad.Catch import Control.Monad.IO.Class@@ -30,6 +35,7 @@ import qualified Data.ByteString.Char8 as S8 import Data.Either import Data.List+import qualified Data.Map as Map import Data.Maybe import Data.Set (Set) import qualified Data.Set as Set@@ -42,6 +48,7 @@ import Stack.Constants import Stack.Types import System.Directory (canonicalizePath, doesDirectoryExist)+import System.FilePath (FilePath, searchPathSeparator, dropTrailingPathSeparator) import System.Process.Read -- | Get the global package database@@ -109,7 +116,7 @@ => EnvOverride -> WhichCompiler -> [Path Abs Dir] -- ^ package databases- -> Text+ -> String -- ^ package identifier, or GhcPkgId -> Text -> m (Maybe Text) findGhcPkgField menv wc pkgDbs name field = do@@ -118,7 +125,7 @@ menv wc pkgDbs- ["field", "--simple-output", T.unpack name, T.unpack field]+ ["field", "--simple-output", name, T.unpack field] return $ case result of Left{} -> Nothing@@ -135,28 +142,59 @@ -> PackageName -> m (Maybe GhcPkgId) findGhcPkgId menv wc pkgDbs name = do- mpid <- findGhcPkgField menv wc pkgDbs (packageNameText name) "id"+ mpid <- findGhcPkgField menv wc pkgDbs (packageNameString name) "id" case mpid of Just !pid -> return (parseGhcPkgId (T.encodeUtf8 pid)) _ -> return Nothing +-- | Get the package key e.g. @foo_9bTCpMF7G4UFWJJvtDrIdB@.+--+-- NOTE: GHC > 7.10 only! Will always yield 'Nothing' otherwise.+findGhcPkgKey :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadThrow m)+ => EnvOverride+ -> WhichCompiler+ -> [Path Abs Dir] -- ^ package databases+ -> PackageName+ -> m (Maybe Text)+findGhcPkgKey menv wc pkgDbs name =+ findGhcPkgField menv wc pkgDbs (packageNameString name) "key"++-- | Get the version of the package+findGhcPkgVersion :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadThrow m)+ => EnvOverride+ -> WhichCompiler+ -> [Path Abs Dir] -- ^ package databases+ -> PackageName+ -> m (Maybe Version)+findGhcPkgVersion menv wc pkgDbs name = do+ mv <- findGhcPkgField menv wc pkgDbs (packageNameString name) "version"+ case mv of+ Just !v -> return (parseVersion (T.encodeUtf8 v))+ _ -> return Nothing+ -- | Get the Haddock HTML documentation path of the package. findGhcPkgHaddockHtml :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadThrow m) => EnvOverride -> WhichCompiler -> [Path Abs Dir] -- ^ package databases- -> PackageIdentifier- -> m (Maybe (Path Abs Dir))-findGhcPkgHaddockHtml menv wc pkgDbs pkgId = do- mpath <- findGhcPkgField menv wc pkgDbs (packageIdentifierText pkgId) "haddock-html"- case mpath of- Just !path0 -> do+ -> String -- ^ PackageIdentifier or GhcPkgId+ -> m (Maybe (PackageIdentifier, Path Abs Dir))+findGhcPkgHaddockHtml menv wc pkgDbs ghcPkgId = do+ mpath <- findGhcPkgField menv wc pkgDbs ghcPkgId "haddock-html"+ mid <- findGhcPkgField menv wc pkgDbs ghcPkgId "id"+ mversion <- findGhcPkgField menv wc pkgDbs ghcPkgId "version"+ let mpkgId = PackageIdentifier+ <$> (mid >>= parsePackageName . T.encodeUtf8)+ <*> (mversion >>= parseVersion . T.encodeUtf8)+ case (,) <$> mpath <*> mpkgId of+ Just (path0, pkgId) -> do let path = T.unpack path0 exists <- liftIO $ doesDirectoryExist path path' <- if exists then liftIO $ canonicalizePath path else return path- return (parseAbsDir path')++ return $ fmap (pkgId,) (parseAbsDir path') _ -> return Nothing -- | Finds dependencies of package, and all their dependencies, etc.@@ -168,28 +206,38 @@ -> PackageIdentifier -> m (Set PackageIdentifier) findTransitiveGhcPkgDepends menv wc pkgDbs pkgId0 =- go pkgId0 Set.empty+ liftM (Set.fromList . Map.elems)+ (go (packageIdentifierString pkgId0) Map.empty) where go pkgId res = do deps <- findGhcPkgDepends menv wc pkgDbs pkgId- loop (map ghcPkgIdPackageIdentifier deps) res+ loop deps res loop [] res = return res loop (dep:deps) res = do- if Set.member dep res+ if Map.member dep res then loop deps res else do- res' <- go dep (Set.insert dep res)- loop deps (Set.union res res')+ let pkgId = ghcPkgIdString dep+ mname <- findGhcPkgField menv wc pkgDbs pkgId "name"+ mversion <- findGhcPkgField menv wc pkgDbs pkgId "version"+ let mident = do+ name <- mname >>= parsePackageName . T.encodeUtf8+ version <- mversion >>= parseVersion . T.encodeUtf8+ Just $ PackageIdentifier name version+ res' = maybe id (Map.insert dep) mident res+ res'' <- go pkgId res'+ -- FIXME is the Map.union actually necessary?+ loop deps (Map.union res res'') -- | Get the dependencies of the package. findGhcPkgDepends :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadThrow m) => EnvOverride -> WhichCompiler -> [Path Abs Dir] -- ^ package databases- -> PackageIdentifier+ -> String -- ^ package identifier or GhcPkgId -> m [GhcPkgId] findGhcPkgDepends menv wc pkgDbs pkgId = do- mdeps <- findGhcPkgField menv wc pkgDbs (packageIdentifierText pkgId) "depends"+ mdeps <- findGhcPkgField menv wc pkgDbs pkgId "depends" case mdeps of Just !deps -> return (mapMaybe (parseGhcPkgId . T.encodeUtf8) (T.words deps)) _ -> return []@@ -197,30 +245,34 @@ unregisterGhcPkgId :: (MonadIO m, MonadLogger m, MonadThrow m, MonadCatch m, MonadBaseControl IO m) => EnvOverride -> WhichCompiler+ -> CompilerVersion -> Path Abs Dir -- ^ package database -> GhcPkgId+ -> PackageIdentifier -> m ()-unregisterGhcPkgId menv wc pkgDb gid = do+unregisterGhcPkgId menv wc cv pkgDb gid ident = do eres <- ghcPkg menv wc [pkgDb] args case eres of Left e -> $logWarn $ T.pack $ show e Right _ -> return () where -- TODO ideally we'd tell ghc-pkg a GhcPkgId instead- args = ["unregister", "--user", "--force", packageIdentifierString $ ghcPkgIdPackageIdentifier gid]+ args = "unregister" : "--user" : "--force" :+ (case cv of+ GhcVersion v | v < $(mkVersion "7.9") ->+ [packageIdentifierString ident]+ _ -> ["--ipid", ghcPkgIdString gid]) -- | Get the version of Cabal from the global package database. getCabalPkgVer :: (MonadThrow m, MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) => EnvOverride -> WhichCompiler -> m Version getCabalPkgVer menv wc =- findGhcPkgId+ findGhcPkgVersion menv wc [] -- global DB cabalPackageName >>=- maybe- (throwM $ Couldn'tFindPkgId cabalPackageName)- (return . packageIdentifierVersion . ghcPkgIdPackageIdentifier)+ maybe (throwM $ Couldn'tFindPkgId cabalPackageName) return listGhcPkgDbs :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadThrow m)@@ -236,3 +288,16 @@ case result of Left{} -> [] Right lbs -> mapMaybe parsePackageIdentifier (S8.words lbs)++-- | Get the value for GHC_PACKAGE_PATH+mkGhcPackagePath :: Bool -> Path Abs Dir -> Path Abs Dir -> Path Abs Dir -> Text+mkGhcPackagePath locals localdb deps globaldb =+ T.pack $ intercalate [searchPathSeparator] $ concat+ [ [toFilePathNoTrailingSlash localdb | locals]+ , [toFilePathNoTrailingSlash deps]+ , [toFilePathNoTrailingSlash globaldb]+ ]++-- TODO: dedupe with copy in Stack.Setup+toFilePathNoTrailingSlash :: Path loc Dir -> FilePath+toFilePathNoTrailingSlash = dropTrailingPathSeparator . toFilePath
src/Stack/Ghci.hs view
@@ -246,11 +246,10 @@ , packageConfigCompilerVersion = envConfigCompilerVersion econfig , packageConfigPlatform = configPlatform (getConfig bconfig) }- pkg <- readPackage config cabalfp- (componentsOpts,generalOpts) <-+ (warnings,pkg) <- readPackage config cabalfp+ mapM_ (printCabalFileWarning cabalfp) warnings+ (componentsModules,componentFiles,componentsOpts,generalOpts) <- getPackageOpts (packageOpts pkg) sourceMap locals cabalfp- (componentsModules,componentModFiles,_,mainIsFiles,_) <-- getPackageFiles (packageFiles pkg) cabalfp let filterWithinWantedComponents m = M.elems (M.filterWithKey@@ -270,10 +269,12 @@ , ghciPkgModules = mconcat (filterWithinWantedComponents componentsModules) , ghciPkgModFiles = mconcat- (filterWithinWantedComponents componentModFiles)- , ghciPkgMainIs = M.map (S.map mainIsFile) mainIsFiles+ (filterWithinWantedComponents+ (M.map (setMapMaybe dotCabalModulePath) componentFiles))+ , ghciPkgMainIs = M.map (setMapMaybe dotCabalMainPath) componentFiles } where badForGhci :: String -> Bool badForGhci x = isPrefixOf "-O" x || elem x (words "-debug -threaded -ticky")+ setMapMaybe f = S.fromList . mapMaybe f . S.toList
src/Stack/Init.hs view
@@ -19,7 +19,11 @@ import Control.Monad.Logger import Control.Monad.Reader (MonadReader, asks) import Control.Monad.Trans.Control (MonadBaseControl)+import qualified Data.ByteString.Builder as B+import qualified Data.ByteString.Lazy as L+import qualified Data.HashMap.Strict as HM import qualified Data.IntMap as IntMap+import qualified Data.Foldable as F import Data.List (isSuffixOf,sort) import Data.List.Extra (nubOrd) import Data.Map (Map)@@ -59,7 +63,7 @@ ] -- | Generate stack.yaml-initProject :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, MonadBaseControl IO m)+initProject :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpManager env, HasGHCVariant env, MonadLogger m, MonadBaseControl IO m) => Path Abs Dir -> InitOpts -> m ()@@ -79,7 +83,8 @@ $logInfo "" when (null cabalfps) $ error "In order to init, you should have an existing .cabal file. Please try \"stack new\" instead"- gpds <- mapM readPackageUnresolved cabalfps+ (warnings,gpds) <- fmap unzip (mapM readPackageUnresolved cabalfps)+ sequence_ (zipWith (mapM_ . printCabalFileWarning) cabalfps warnings) (r, flags, extraDeps) <- getDefaultResolver cabalfps gpds initOpts let p = Project@@ -101,9 +106,55 @@ , peSubdirs = [] } $logInfo $ "Selected resolver: " <> resolverName r- liftIO $ Yaml.encodeFile dest' p+ liftIO $ L.writeFile dest' $ B.toLazyByteString $ renderStackYaml p $logInfo $ "Wrote project config to: " <> T.pack dest' +-- | Render a stack.yaml file with comments, see:+-- https://github.com/commercialhaskell/stack/issues/226+renderStackYaml :: Project -> B.Builder+renderStackYaml p =+ case Yaml.toJSON p of+ Yaml.Object o -> renderObject o+ _ -> assert False $ B.byteString $ Yaml.encode p+ where+ renderObject o =+ B.byteString "# For more information, see: https://github.com/commercialhaskell/stack/blob/master/doc/yaml_configuration.md\n\n" <>+ F.foldMap (goComment o) comments <>+ goOthers (o `HM.difference` HM.fromList comments) <>+ B.byteString+ "# Control whether we use the GHC we find on the path\n\+ \# system-ghc: true\n\n\+ \# Require a specific version of stack, using version ranges\n\+ \# require-stack-version: -any # Default\n\+ \# require-stack-version: >= 0.1.4.0\n\n\+ \# Override the architecture used by stack, especially useful on Windows\n\+ \# arch: i386\n\+ \# arch: x86_64\n\n\+ \# Extra directories used by stack for building\n\+ \# extra-include-dirs: [/path/to/dir]\n\+ \# extra-lib-dirs: [/path/to/dir]\n"++ comments =+ [ ("resolver", "Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2)")+ , ("packages", "Local packages, usually specified by relative directory name")+ , ("extra-deps", "Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3)")+ , ("flags", "Override default flag values for local packages and extra-deps")+ ]++ goComment o (name, comment) =+ case HM.lookup name o of+ Nothing -> assert False mempty+ Just v ->+ B.byteString "# " <>+ B.byteString comment <>+ B.byteString "\n" <>+ B.byteString (Yaml.encode $ Yaml.object [(name, v)]) <>+ B.byteString "\n"++ goOthers o+ | HM.null o = mempty+ | otherwise = assert False $ B.byteString $ Yaml.encode o+ getSnapshots' :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, MonadBaseControl IO m) => m (Maybe Snapshots) getSnapshots' =@@ -119,13 +170,13 @@ $logError "" $logError "You can try again, or create your stack.yaml file by hand. See:" $logError ""- $logError " https://github.com/commercialhaskell/stack/wiki/stack.yaml"+ $logError " https://github.com/commercialhaskell/stack/blob/master/doc/yaml_configuration.md" $logError "" $logError $ "Exception was: " <> T.pack (show e) return Nothing -- | Get the default resolver value-getDefaultResolver :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, MonadBaseControl IO m)+getDefaultResolver :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpManager env, HasGHCVariant env, MonadLogger m, MonadBaseControl IO m) => [Path Abs File] -- ^ cabal files -> [C.GenericPackageDescription] -- ^ cabal descriptions -> InitOpts@@ -162,7 +213,7 @@ , fmap fst extraDeps ) -getRecommendedSnapshots :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, MonadBaseControl IO m)+getRecommendedSnapshots :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpManager env, HasGHCVariant env, MonadLogger m, MonadBaseControl IO m) => Snapshots -> SnapPref -> m [SnapName]
src/Stack/Options.hs view
@@ -17,6 +17,7 @@ ,abstractResolverOptsParser ,solverOptsParser ,testOptsParser+ ,pvpBoundsOption ) where import Control.Monad.Logger (LogLevel(..))@@ -77,16 +78,12 @@ 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 <*> onlyConfigure- where optimize =- maybeBoolFlags "optimizations" "DEPRECATED: This flag is no longer used, and has no effect. Please use --ghc-options=-O?" idm- target =+ haddock <*> haddockDeps <*> dryRun <*> ghcOpts <*>+ flags <*> copyBins <*> preFetch <*> buildSubset <*>+ fileWatch' <*> keepGoing <*> forceDirty <*> tests <*>+ testOptsParser <*> benches <*> benchOptsParser <*>+ many exec <*> onlyConfigure <*> reconfigure <*> cabalVerbose+ where target = many (textArgument (metavar "TARGET" <> help "If none specified, use all packages"))@@ -98,7 +95,7 @@ exeProfiling = boolFlags False "executable-profiling"- "library profiling for TARGETs and all its dependencies"+ "executable profiling for TARGETs and all its dependencies" idm haddock = boolFlags (cmd == Haddock)@@ -106,13 +103,10 @@ "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-+ maybeBoolFlags+ "haddock-deps"+ "building Haddocks for dependencies"+ idm copyBins = boolFlags (cmd == Install) "copy-bins" "copying binaries to the local-bin-path (see 'stack path')"@@ -152,9 +146,14 @@ help "A synonym for --only-dependencies") <|> pure BSAll - fileWatch' = flag False True- (long "file-watch" <>- help "Watch for changes in local files and automatically rebuild. Ignores files in VCS boring/ignore file")+ fileWatch' =+ flag' FileWatch+ (long "file-watch" <>+ help "Watch for changes in local files and automatically rebuild. Ignores files in VCS boring/ignore file")+ <|> flag' FileWatchPoll+ (long "file-watch-poll" <>+ help "Like --file-watch, but polling the filesystem instead of using events")+ <|> pure NoFileWatch keepGoing = maybeBoolFlags "keep-going"@@ -165,7 +164,6 @@ (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"@@ -185,6 +183,14 @@ (long "only-configure" <> help "Only perform the configure step, not any builds. Intended for tool usage, may break when used on multiple packages at once!") + reconfigure = flag False True+ (long "reconfigure" <>+ help "Perform the configure step even if unnecessary. Useful in some corner cases with custom Setup.hs files")++ cabalVerbose = flag False True+ (long "cabal-verbose" <>+ help "Ask Cabal to be verbose in its output")+ -- | Parser for package:[-]flag readFlag :: ReadM (Map (Maybe PackageName) (Map FlagName Bool)) readFlag = do@@ -211,13 +217,14 @@ -- | Command-line arguments parser for configuration. configOptsParser :: Bool -> Parser ConfigMonoid configOptsParser docker =- (\opts systemGHC installGHC arch os jobs includes libs skipGHCCheck skipMsys localBin -> mempty+ (\opts systemGHC installGHC arch os ghcVariant jobs includes libs skipGHCCheck skipMsys localBin -> mempty { configMonoidDockerOpts = opts , configMonoidSystemGHC = systemGHC , configMonoidInstallGHC = installGHC , configMonoidSkipGHCCheck = skipGHCCheck , configMonoidArch = arch , configMonoidOS = os+ , configMonoidGHCVariant = ghcVariant , configMonoidJobs = jobs , configMonoidExtraIncludeDirs = includes , configMonoidExtraLibDirs = libs@@ -243,6 +250,7 @@ <> metavar "OS" <> help "Operating system, e.g. linux, windows" ))+ <*> optional ghcVariantParser <*> optional (option auto ( long "jobs" <> short 'j'@@ -445,18 +453,19 @@ -> Parser ExecOpts execOptsParser mcmd = ExecOpts- <$> maybe eoCmdParser pure mcmd+ <$> 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)"))+ eoArgsParser = many (strArgument (metavar meta))+ where+ meta =+ (maybe ("CMD ") (const "") mcmd) +++ "-- ARGS (e.g. stack ghc -- X.hs -o x)" eoEnvSettingsParser :: Parser EnvSettings eoEnvSettingsParser = EnvSettings@@ -589,6 +598,21 @@ Left e -> readerError $ show e Right x -> return $ ARResolver x +-- | GHC variant parser+ghcVariantParser :: Parser GHCVariant+ghcVariantParser =+ option+ readGHCVariant+ (long "ghc-variant" <> metavar "VARIANT" <>+ help+ "Specialized GHC variant, e.g. integersimple (implies --no-system-ghc)")+ where+ readGHCVariant = do+ s <- readerAsk+ case parseGHCVariant s of+ Left e -> readerError (show e)+ Right v -> return v+ -- | Parser for @solverCmd@ solverOptsParser :: Parser Bool solverOptsParser = boolFlags False@@ -636,3 +660,17 @@ help "Parameter for the template in the format key:value"))) <* abortOption ShowHelpText (long "help" <> help "Show help text.")++pvpBoundsOption :: Parser PvpBounds+pvpBoundsOption =+ option+ readPvpBounds+ (long "pvp-bounds" <> metavar "PVP-BOUNDS" <>+ help+ "How PVP version bounds should be added to .cabal file: none, lower, upper, both")+ where+ readPvpBounds = do+ s <- readerAsk+ case parsePvpBounds $ T.pack s of+ Left e -> readerError e+ Right v -> return v
src/Stack/Package.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-}@@ -31,7 +32,8 @@ ,packageDependencies ,packageIdentifier ,autogenDir- ,checkCabalFileName)+ ,checkCabalFileName+ ,printCabalFileWarning) where import Control.Exception hiding (try,catch)@@ -63,6 +65,7 @@ import Distribution.Package hiding (Package,PackageName,packageName,packageVersion,PackageIdentifier) import Distribution.PackageDescription hiding (FlagName) import Distribution.PackageDescription.Parse+import Distribution.ParseUtils import Distribution.Simple.Utils import Distribution.System (OS (..), Arch, Platform (..)) import Distribution.Text (display, simpleParse)@@ -75,7 +78,7 @@ import Stack.Types import qualified Stack.Types.PackageIdentifier import System.Directory (doesFileExist, getDirectoryContents)-import System.FilePath (splitExtensions)+import System.FilePath (splitExtensions, replaceExtension) import qualified System.FilePath as FilePath import System.IO.Error @@ -88,7 +91,7 @@ -- | Read the raw, unresolved package information. readPackageUnresolved :: (MonadIO m, MonadThrow m) => Path Abs File- -> m GenericPackageDescription+ -> m ([PWarning],GenericPackageDescription) readPackageUnresolved cabalfp = liftIO (BS.readFile (FL.toFilePath cabalfp)) >>= readPackageUnresolvedBS (Just cabalfp)@@ -97,12 +100,12 @@ readPackageUnresolvedBS :: (MonadThrow m) => Maybe (Path Abs File) -> BS.ByteString- -> m GenericPackageDescription+ -> m ([PWarning],GenericPackageDescription) readPackageUnresolvedBS mcabalfp bs = case parsePackageDescription chars of ParseFailed per -> throwM (PackageInvalidCabalFile mcabalfp per)- ParseOk _ gpkg -> return gpkg+ ParseOk warnings gpkg -> return (warnings,gpkg) where chars = T.unpack (dropBOM (decodeUtf8With lenientDecode bs)) @@ -113,30 +116,49 @@ readPackage :: (MonadLogger m, MonadIO m, MonadThrow m, MonadCatch m) => PackageConfig -> Path Abs File- -> m Package+ -> m ([PWarning],Package) readPackage packageConfig cabalfp =- resolvePackage packageConfig `liftM` readPackageUnresolved cabalfp+ do (warnings,gpkg) <- readPackageUnresolved cabalfp+ return (warnings,resolvePackage packageConfig gpkg) -- | Reads and exposes the package information, from a ByteString readPackageBS :: (MonadThrow m) => PackageConfig -> BS.ByteString- -> m Package+ -> m ([PWarning],Package) readPackageBS packageConfig bs =- resolvePackage packageConfig `liftM` readPackageUnresolvedBS Nothing bs+ do (warnings,gpkg) <- readPackageUnresolvedBS Nothing bs+ return (warnings,resolvePackage packageConfig gpkg) -- | Convenience wrapper around @readPackage@ that first finds the cabal file -- in the given directory. readPackageDir :: (MonadLogger m, MonadIO m, MonadThrow m, MonadCatch m) => PackageConfig -> Path Abs Dir- -> m (Path Abs File, Package)+ -> m (Path Abs File, [PWarning], Package) readPackageDir packageConfig dir = do cabalfp <- getCabalFileName dir- pkg <- readPackage packageConfig cabalfp+ (warnings,pkg) <- readPackage packageConfig cabalfp checkCabalFileName (packageName pkg) cabalfp+ return (cabalfp, warnings, pkg) - return (cabalfp, pkg)+-- | Print cabal file warnings.+printCabalFileWarning+ :: (MonadLogger m)+ => Path Abs File -> PWarning -> m ()+printCabalFileWarning cabalfp =+ \case+ (PWarning x) ->+ $logWarn+ ("Cabal file warning in " <> T.pack (toFilePath cabalfp) <>+ ": " <>+ T.pack x)+ (UTFWarning line msg) ->+ $logWarn+ ("Cabal file warning in " <> T.pack (toFilePath cabalfp) <> ":" <>+ T.pack (show line) <>+ ": " <>+ T.pack msg) -- | Check if the given name in the @Package@ matches the name of the .cabal file checkCabalFileName :: MonadThrow m => PackageName -> Path Abs File -> m ()@@ -157,19 +179,7 @@ { packageName = name , packageVersion = fromCabalVersion (pkgVersion pkgId) , packageDeps = deps- , packageFiles = GetPackageFiles $- \cabalfp ->- do distDir <- distDirFromDir (parent cabalfp)- (modules,moduleFiles,files,mains,extra) <-- runReaderT- (packageDescModulesAndFiles pkg)- (cabalfp, buildDir distDir)- return- ( modules- , moduleFiles- , files- , mains- , S.singleton cabalfp <> extra)+ , packageFiles = pkgFiles , packageTools = packageDescTools pkg , packageFlags = packageConfigFlags packageConfig , packageAllDeps = S.fromList (M.keys deps)@@ -185,7 +195,10 @@ , buildable (buildInfo b)] , packageOpts = GetPackageOpts $ \sourceMap locals cabalfp ->- generatePkgDescOpts sourceMap locals cabalfp pkg+ do (componentsModules,componentFiles,_,_) <- getPackageFiles pkgFiles cabalfp+ (componentsOpts,generalOpts) <-+ generatePkgDescOpts sourceMap locals cabalfp pkg componentFiles+ return (componentsModules,componentFiles,componentsOpts,generalOpts) , packageHasExposedModules = maybe False (not . null . exposedModules)@@ -195,6 +208,14 @@ map (fromCabalFlagName . flagName) $ genPackageFlags gpkg } where+ pkgFiles = GetPackageFiles $+ \cabalfp ->+ do distDir <- distDirFromDir (parent cabalfp)+ (componentModules,componentFiles,cabalFiles,warnings) <-+ runReaderT+ (packageDescModulesAndFiles pkg)+ (cabalfp, buildDir distDir)+ return (componentModules, componentFiles, cabalFiles, warnings) pkgId = package (packageDescription gpkg) name = fromCabalPackageName (pkgName pkgId) pkg = resolvePackageDescription packageConfig gpkg@@ -209,8 +230,9 @@ -> [PackageName] -> Path Abs File -> PackageDescription+ -> Map NamedComponent (Set DotCabalPath) -> m (Map NamedComponent [String],[String])-generatePkgDescOpts sourceMap locals cabalfp pkg = do+generatePkgDescOpts sourceMap locals cabalfp pkg componentPaths = do distDir <- distDirFromDir cabalDir let cabalmacros = autogenDir distDir </> $(mkRelFile "cabal_macros.h") exists <- fileExists cabalmacros@@ -218,34 +240,41 @@ if exists then Just cabalmacros else Nothing- let generate =- generateBuildInfoOpts- sourceMap- mcabalmacros- cabalDir- distDir- locals+ let generate namedComponent binfo =+ ( namedComponent+ , generateBuildInfoOpts+ sourceMap+ mcabalmacros+ cabalDir+ distDir+ locals+ binfo+ (fromMaybe mempty (M.lookup namedComponent componentPaths))+ namedComponent) return ( M.fromList (concat [ maybe []- (return . (CLib, ) . generate . libBuildInfo)+ (return . generate CLib . libBuildInfo) (library pkg) , map (\exe ->- ( CExe (T.pack (exeName exe))- , generate (buildInfo exe)))+ (generate+ (CExe (T.pack (exeName exe)))+ (buildInfo exe))) (executables pkg) , map (\bench ->- ( CBench (T.pack (benchmarkName bench))- , generate (benchmarkBuildInfo bench)))+ (generate+ (CBench (T.pack (benchmarkName bench)))+ (benchmarkBuildInfo bench))) (benchmarks pkg) , map (\test ->- ( CBench (T.pack (testName test))- , generate (testBuildInfo test)))+ (generate+ (CBench (T.pack (testName test)))+ (testBuildInfo test))) (testSuites pkg)]) , ["-hide-all-packages"]) where@@ -259,10 +288,17 @@ -> Path Abs Dir -> [PackageName] -> BuildInfo+ -> Set DotCabalPath+ -> NamedComponent -> [String]-generateBuildInfoOpts sourceMap mcabalmacros cabalDir distDir locals b =- nubOrd (concat [ghcOpts b, extOpts b, srcOpts, includeOpts, macros, deps, extra b, extraDirs, fworks b])+generateBuildInfoOpts sourceMap mcabalmacros cabalDir distDir locals b dotCabalPaths componentName =+ nubOrd (concat [ghcOpts b, extOpts b, srcOpts, includeOpts, macros, deps, extra b, extraDirs, fworks b, cObjectFiles]) where+ cObjectFiles =+ mapMaybe (fmap toFilePath .+ makeObjectFilePathFromC cabalDir componentName distDir)+ cfiles+ cfiles = mapMaybe dotCabalCFilePath (S.toList dotCabalPaths) deps = concat [ ["-package=" <> display name <>@@ -312,6 +348,56 @@ ] fworks = map (\fwk -> "-framework=" <> fwk) . frameworks +-- | Make the .o path from the .c file path for a component. Example:+--+-- @+-- executable FOO+-- c-sources: cbits/text_search.c+-- @+--+-- Produces+--+-- <dist-dir>/build/FOO/FOO-tmp/cbits/text_search.o+--+-- Example:+--+-- λ> makeObjectFilePathFromC+-- $(mkAbsDir "/Users/chris/Repos/hoogle")+-- CLib+-- $(mkAbsDir "/Users/chris/Repos/hoogle/.stack-work/Cabal-x.x.x/dist")+-- $(mkAbsFile "/Users/chris/Repos/hoogle/cbits/text_search.c")+-- Just "/Users/chris/Repos/hoogle/.stack-work/Cabal-x.x.x/dist/build/cbits/text_search.o"+-- λ> makeObjectFilePathFromC+-- $(mkAbsDir "/Users/chris/Repos/hoogle")+-- (CExe "hoogle")+-- $(mkAbsDir "/Users/chris/Repos/hoogle/.stack-work/Cabal-x.x.x/dist")+-- $(mkAbsFile "/Users/chris/Repos/hoogle/cbits/text_search.c")+-- Just "/Users/chris/Repos/hoogle/.stack-work/Cabal-x.x.x/dist/build/hoogle/hoogle-tmp/cbits/text_search.o"+-- λ>+makeObjectFilePathFromC+ :: MonadThrow m+ => Path Abs Dir -- ^ The cabal directory.+ -> NamedComponent -- ^ The name of the component.+ -> Path Abs Dir -- ^ Dist directory.+ -> Path Abs File -- ^ The path to the .c file.+ -> m (Path Abs File) -- ^ The path to the .o file for the component.+makeObjectFilePathFromC cabalDir namedComponent distDir cFilePath = do+ relCFilePath <- stripDir cabalDir cFilePath+ relOFilePath <-+ parseRelFile (replaceExtension (toFilePath relCFilePath) "o")+ addComponentPrefix <- fromComponentName+ return (addComponentPrefix (buildDir distDir) </> relOFilePath)+ where+ fromComponentName =+ case namedComponent of+ CLib -> return id+ CExe name -> makeTmp name+ CTest name -> makeTmp name+ CBench name -> makeTmp name+ makeTmp name = do+ prefix <- parseRelDir (T.unpack name <> "/" <> T.unpack name <> "-tmp")+ return (</> prefix)+ -- | Make the autogen dir. autogenDir :: Path Abs Dir -> Path Abs Dir autogenDir distDir = buildDir distDir </> $(mkRelDir "autogen")@@ -368,52 +454,45 @@ packageDescModulesAndFiles :: (MonadLogger m, MonadIO m, MonadThrow m, MonadReader (Path Abs File, Path Abs Dir) m, MonadCatch m) => PackageDescription- -> m (Map NamedComponent (Set ModuleName), Map NamedComponent (Set (Path Abs File)), Map NamedComponent (Set (Path Abs File)), Map NamedComponent (Set MainIs), Set (Path Abs File))+ -> m (Map NamedComponent (Set ModuleName), Map NamedComponent (Set DotCabalPath), Set (Path Abs File), [PackageWarning]) packageDescModulesAndFiles pkg = do- (libraryMods,libModFiles,libOtherFiles,_) <-+ (libraryMods,libDotCabalFiles,libWarnings) <- maybe- (return (M.empty, M.empty, M.empty, M.empty))+ (return (M.empty, M.empty, [])) (asModuleAndFileMap libComponent libraryFiles) (library pkg)- (executableMods,exeModFiles,exeOtherFiles,exeMainIs) <-+ (executableMods,exeDotCabalFiles,exeWarnings) <- liftM- foldTriples+ foldTuples (mapM (asModuleAndFileMap exeComponent executableFiles) (executables pkg))- (testMods,testModFps,testOtherFps,testMainIs) <-+ (testMods,testDotCabalFiles,testWarnings) <- liftM- foldTriples+ foldTuples (mapM (asModuleAndFileMap testComponent testFiles) (testSuites pkg))- (benchModules,benchModFiles,benchOtherFiles,benchMainIs) <-+ (benchModules,benchDotCabalPaths,benchWarnings) <- liftM- foldTriples+ foldTuples (mapM (asModuleAndFileMap benchComponent benchmarkFiles) (benchmarks pkg))- dfiles <- resolveGlobFiles (map (dataDir pkg FilePath.</>) (dataFiles pkg))+ (dfiles) <- resolveGlobFiles (map (dataDir pkg FilePath.</>) (dataFiles pkg)) let modules = libraryMods <> executableMods <> testMods <> benchModules- moduleFiles = libModFiles <> exeModFiles <> testModFps <> benchModFiles- otherFiles = libOtherFiles <> exeOtherFiles <> testOtherFps <> benchOtherFiles- mains = exeMainIs <> benchMainIs <> testMainIs- return (modules, moduleFiles, otherFiles, mains, dfiles)+ files =+ libDotCabalFiles <> exeDotCabalFiles <> testDotCabalFiles <>+ benchDotCabalPaths+ warnings = libWarnings <> exeWarnings <> testWarnings <> benchWarnings+ return (modules, files, dfiles, warnings) where libComponent = const CLib exeComponent = CExe . T.pack . exeName testComponent = CTest . T.pack . testName benchComponent = CBench . T.pack . benchmarkName asModuleAndFileMap label f lib = do- (a,b,c, d) <- f lib- return- ( M.singleton (label lib) a- , M.singleton (label lib) b- , M.singleton (label lib) c- , M.singleton (label lib) d)- foldTriples =- foldl'- (\(a,b,c,d) (x,y,z,k) ->- (a <> x, b <> y, c <> z, d <> k))- (M.empty, M.empty, M.empty, M.empty)+ (a,b,c) <- f lib+ return (M.singleton (label lib) a, M.singleton (label lib) b, c)+ foldTuples = foldl' (<>) (M.empty, M.empty, []) -- | Resolve globbing of files (e.g. data files) to absolute paths. resolveGlobFiles :: (MonadLogger m,MonadIO m,MonadThrow m,MonadReader (Path Abs File, Path Abs Dir) m,MonadCatch m)@@ -478,97 +557,114 @@ matches -> return matches -- | Get all files referenced by the benchmark.-benchmarkFiles :: (MonadLogger m, MonadIO m, MonadThrow m, MonadReader (Path Abs File, Path Abs Dir) m)- => Benchmark -> m (Set ModuleName,Set (Path Abs File),Set (Path Abs File),Set MainIs)+benchmarkFiles+ :: (MonadLogger m, MonadIO m, MonadThrow m, MonadReader (Path Abs File, Path Abs Dir) m)+ => Benchmark -> m (Set ModuleName, Set DotCabalPath, [PackageWarning]) benchmarkFiles bench = do dirs <- mapMaybeM resolveDirOrWarn (hsSourceDirs build) dir <- asks (parent . fst)- (rmodules,modFiles,thFiles) <-+ (modules,files,warnings) <- resolveFilesAndDeps (Just $ benchmarkName bench) (dirs ++ [dir])- bnames+ (bnames <> exposed) haskellModuleExts- mainFiles <- resolveFiles (dirs ++ [dir]) exposed haskellModuleExts- cfiles <- buildCSources build- return (rmodules, modFiles, cfiles <> thFiles, S.map MainIs (S.fromList mainFiles))+ cfiles <- buildOtherSources build+ return (modules, files <> cfiles, warnings) where exposed = case benchmarkInterface bench of- BenchmarkExeV10 _ fp -> [Right fp]+ BenchmarkExeV10 _ fp -> [DotCabalMain fp] BenchmarkUnsupported _ -> []- bnames = map Left (otherModules build)+ bnames = map DotCabalModule (otherModules build) build = benchmarkBuildInfo bench -- | Get all files referenced by the test. testFiles :: (MonadLogger m, MonadIO m, MonadThrow m, MonadReader (Path Abs File, Path Abs Dir) m) => TestSuite- -> m (Set ModuleName, Set (Path Abs File), Set (Path Abs File), Set MainIs)+ -> m (Set ModuleName, Set DotCabalPath, [PackageWarning]) testFiles test = do dirs <- mapMaybeM resolveDirOrWarn (hsSourceDirs build) dir <- asks (parent . fst)- (modules,modFiles,thFiles) <-+ (modules,files,warnings) <- resolveFilesAndDeps (Just $ testName test) (dirs ++ [dir])- bnames+ (bnames <> exposed) haskellModuleExts- mainFiles <- resolveFiles (dirs ++ [dir]) exposed haskellModuleExts- cfiles <- buildCSources build- return (modules, modFiles, cfiles <> thFiles, S.map MainIs (S.fromList mainFiles))+ cfiles <- buildOtherSources build+ return (modules, files <> cfiles, warnings) where exposed = case testInterface test of- TestSuiteExeV10 _ fp -> [Right fp]- TestSuiteLibV09 _ mn -> [Left mn]+ TestSuiteExeV10 _ fp -> [DotCabalMain fp]+ TestSuiteLibV09 _ mn -> [DotCabalModule mn] TestSuiteUnsupported _ -> []- bnames = map Left (otherModules build)+ bnames = map DotCabalModule (otherModules build) build = testBuildInfo test -- | Get all files referenced by the executable. executableFiles :: (MonadLogger m, MonadIO m, MonadThrow m, MonadReader (Path Abs File, Path Abs Dir) m) => Executable- -> m (Set ModuleName, Set (Path Abs File), Set (Path Abs File), Set MainIs)+ -> m (Set ModuleName, Set DotCabalPath, [PackageWarning]) executableFiles exe = do dirs <- mapMaybeM resolveDirOrWarn (hsSourceDirs build) dir <- asks (parent . fst)- (modules,modFiles,thFiles) <-+ (modules,files,warnings) <- resolveFilesAndDeps (Just $ exeName exe) (dirs ++ [dir])- (map Left (otherModules build))+ (map DotCabalModule (otherModules build) +++ [DotCabalMain (modulePath exe)]) haskellModuleExts- mainFiles <-- resolveFiles (dirs ++ [dir]) [Right (modulePath exe)] haskellModuleExts- cfiles <- buildCSources build- return (modules, modFiles, cfiles <> thFiles, S.map MainIs (S.fromList mainFiles))+ cfiles <- buildOtherSources build+ return (modules, files <> cfiles, warnings) where build = buildInfo exe -- | Get all files referenced by the library.-libraryFiles :: (MonadLogger m,MonadIO m,MonadThrow m,MonadReader (Path Abs File, Path Abs Dir) m)- => Library -> m (Set ModuleName,Set (Path Abs File),Set (Path Abs File), Set MainIs)+libraryFiles+ :: (MonadLogger m, MonadIO m, MonadThrow m, MonadReader (Path Abs File, Path Abs Dir) m)+ => Library -> m (Set ModuleName, Set DotCabalPath, [PackageWarning]) libraryFiles lib = do dirs <- mapMaybeM resolveDirOrWarn (hsSourceDirs build) dir <- asks (parent . fst)- (modules,modFiles,thFiles) <-- resolveFilesAndDeps Nothing (dirs ++ [dir]) names haskellModuleExts- cfiles <- buildCSources build- return (modules, modFiles, cfiles <> thFiles, mempty)+ (modules,files,warnings) <-+ resolveFilesAndDeps+ Nothing+ (dirs ++ [dir])+ (names <> exposed)+ haskellModuleExts+ cfiles <- buildOtherSources build+ return (modules, files <> cfiles, warnings) where names = concat [bnames, exposed]- exposed = map Left (exposedModules lib)- bnames = map Left (otherModules build)+ exposed = map DotCabalModule (exposedModules lib)+ bnames = map DotCabalModule (otherModules build) build = libBuildInfo lib --- | 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 C sources and extra source files in a build.+buildOtherSources :: (MonadLogger m,MonadIO m,MonadThrow m,MonadReader (Path Abs File, Path Abs Dir) m)+ => BuildInfo -> m (Set DotCabalPath)+buildOtherSources build =+ do csources <- liftM+ (S.map DotCabalCFilePath . S.fromList)+ (mapMaybeM resolveFileOrWarn (cSources build))+ jsources <- liftM+ (S.map DotCabalFilePath . S.fromList)+ (mapMaybeM resolveFileOrWarn (targetJsSources build))+ return (csources <> jsources) +-- | Get the target's JS sources.+targetJsSources :: BuildInfo -> [FilePath]+#if MIN_VERSION_Cabal(1, 22, 0)+targetJsSources = jsSources+#else+targetJsSources = const []+#endif+ -- | Get all dependencies of a package, including library, -- executables, tests, benchmarks. resolvePackageDescription :: PackageConfig@@ -634,7 +730,7 @@ mkResolveConditions compilerVersion (Platform arch os) flags = ResolveConditions { rcFlags = flags , rcCompilerVersion = compilerVersion- , rcOS = if isWindows os then Windows else os+ , rcOS = os , rcArch = arch } @@ -701,75 +797,74 @@ :: (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.+ -> [DotCabalDescriptor] -- ^ Base names. -> [Text] -- ^ Extentions.- -> m (Set ModuleName,Set (Path Abs File),Set (Path Abs File))+ -> m (Set ModuleName,Set DotCabalPath,[PackageWarning]) resolveFilesAndDeps component dirs names0 exts = do- (moduleFiles,thFiles,foundModules) <- loop names0 S.empty- warnUnlisted component (lefts names0) foundModules- return (foundModules, moduleFiles, S.fromList thFiles)+ (dotCabalPaths,foundModules) <- loop names0 S.empty+ warnings <- warnUnlisted foundModules+ return (foundModules, dotCabalPaths, warnings) where- loop [] doneModules = return (S.empty, [], doneModules)+ loop [] doneModules = return (S.empty, doneModules) loop names doneModules0 = do resolvedFiles <- resolveFiles dirs names exts pairs <- mapM (getDependencies component) resolvedFiles- let doneModules' = S.union doneModules0 (S.fromList (lefts names))+ let doneModules' =+ S.union+ doneModules0+ (S.fromList (mapMaybe dotCabalModule 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'+ (resolvedFiles',doneModules'') <-+ loop (map DotCabalModule (S.toList modulesRemaining)) doneModules' return- ( S.union (S.fromList resolvedFiles) moduleDepFiles'- , thDepFiles ++ thDepFiles'+ ( S.union+ (S.fromList+ (resolvedFiles <> map DotCabalFilePath thDepFiles))+ resolvedFiles' , doneModules'')---- | Warn about modules which are used but not listed in the cabal--- file.-warnUnlisted- :: (MonadLogger m, MonadReader (Path Abs File, void) m)- => Maybe String -> [ModuleName] -> Set ModuleName -> m ()-warnUnlisted component names0 foundModules = do- cabalfp <- asks fst- 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))- where- unlistedModules =- foundModules `S.difference` (S.fromList names0)+ warnUnlisted foundModules = do+ let unlistedModules =+ foundModules `S.difference`+ (S.fromList $ mapMaybe dotCabalModule names0)+ cabalfp <- asks fst+ return $+ if S.null unlistedModules+ then []+ else [ UnlistedModulesWarning+ cabalfp+ component+ (S.toList unlistedModules)] -- | Get the dependencies of a Haskell module file. getDependencies :: (MonadReader (Path Abs File, Path Abs Dir) m, MonadIO m)- => Maybe String -> Path Abs File -> m (Set ModuleName, [Path Abs File])-getDependencies component 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, [])- where getDumpHIDir = do- bld <- asks snd- return $ maybe bld (bld </>) (getBuildComponentDir component)+ => Maybe String -> DotCabalPath -> m (Set ModuleName, [Path Abs File])+getDependencies component dotCabalPath =+ case dotCabalPath of+ DotCabalModulePath resolvedFile -> readResolvedHi resolvedFile+ DotCabalMainPath resolvedFile -> readResolvedHi resolvedFile+ DotCabalFilePath{} -> return (S.empty, [])+ DotCabalCFilePath{} -> return (S.empty, [])+ where+ readResolvedHi resolvedFile = do+ dumpHIDir <- getDumpHIDir+ dir <- asks (parent . fst)+ 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, [])+ getDumpHIDir = do+ bld <- asks snd+ return $ maybe bld (bld </>) (getBuildComponentDir component) -- | Parse a .dump-hi file into a set of modules and files. parseDumpHI@@ -809,9 +904,9 @@ 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.+ -> [DotCabalDescriptor] -- ^ Base names. -> [Text] -- ^ Extentions.- -> m [Path Abs File]+ -> m [DotCabalPath] resolveFiles dirs names exts = do liftM catMaybes (forM names (findCandidate dirs exts)) @@ -821,34 +916,41 @@ :: (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))+ -> DotCabalDescriptor+ -> m (Maybe DotCabalPath) findCandidate dirs exts name = do pkg <- asks fst >>= parsePackageNameFromFilePath candidates <- liftIO makeNameCandidates case candidates of- [candidate] -> return (Just candidate)+ [candidate] -> return (Just (cons candidate)) [] -> do case name of- Left mn+ DotCabalModule mn | not (display mn == paths_pkg pkg) -> do logPossibilities dirs mn _ -> return () return Nothing (candidate:rest) -> do warnMultiple name candidate rest- return (Just candidate)+ return (Just (cons candidate)) where+ cons =+ case name of+ DotCabalModule{} -> DotCabalModulePath+ DotCabalMain{} -> DotCabalMainPath+ DotCabalFile{} -> DotCabalFilePath+ DotCabalCFile{} -> DotCabalCFilePath 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 :: Path Abs Dir+ -> IO [Either ResolveException (Path Abs File)] makeDirCandidates dir = case name of- Right fp -> liftM return (try (resolveFile' dir fp))- Left mn ->+ DotCabalMain fp -> liftM return (try (resolveFile' dir fp))+ DotCabalFile fp -> liftM return (try (resolveFile' dir fp))+ DotCabalCFile fp -> liftM return (try (resolveFile' dir fp))+ DotCabalModule mn -> mapM (\ext -> try@@ -856,7 +958,9 @@ dir (Cabal.toFilePath mn ++ "." ++ ext))) (map T.unpack exts)- resolveFile' :: (MonadIO m, MonadThrow m) => Path Abs Dir -> FilePath.FilePath -> m (Path Abs File)+ resolveFile'+ :: (MonadIO m, MonadThrow m)+ => Path Abs Dir -> FilePath.FilePath -> m (Path Abs File) resolveFile' x y = do p <- parseCollapsedAbsFile (toFilePath x FilePath.</> y) exists <- fileExists p@@ -868,7 +972,7 @@ -- entry, but that we picked one anyway and continued. warnMultiple :: MonadLogger m- => Either ModuleName String -> Path b t -> [Path b t] -> m ()+ => DotCabalDescriptor -> Path b t -> [Path b t] -> m () warnMultiple name candidate rest = $logWarn ("There were multiple candidates for the Cabal entry \"" <>@@ -877,8 +981,10 @@ 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+ where showName (DotCabalModule name') = T.pack (display name')+ showName (DotCabalMain fp) = T.pack fp+ showName (DotCabalFile fp) = T.pack fp+ showName (DotCabalCFile fp) = T.pack fp -- | Log that we couldn't find a candidate, but there are -- possibilities for custom preprocessor extensions.
src/Stack/PackageDump.hs view
@@ -25,8 +25,9 @@ ) where import Control.Applicative+import Control.Arrow ((&&&)) import Control.Exception.Enclosed (tryIO)-import Control.Monad (when, liftM)+import Control.Monad (liftM) import Control.Monad.Catch import Control.Monad.IO.Class import Control.Monad.Logger (MonadLogger)@@ -61,19 +62,19 @@ -- | Cached information on whether package have profiling libraries and haddocks. newtype InstalledCache = InstalledCache (IORef InstalledCacheInner) newtype InstalledCacheInner = InstalledCacheInner (Map GhcPkgId InstalledCacheEntry)- deriving (Binary, NFData)-instance BinarySchema InstalledCacheInner where- -- Don't forget to update this if you change the datatype in any way!- binarySchema _ = 1+ deriving (Binary, NFData, Generic)+instance HasStructuralInfo InstalledCacheInner+instance HasSemanticVersion InstalledCacheInner -- | Cached information on whether a package has profiling libraries and haddocks. data InstalledCacheEntry = InstalledCacheEntry { installedCacheProfiling :: !Bool- , installedCacheHaddock :: !Bool }+ , installedCacheHaddock :: !Bool+ , installedCacheIdent :: !PackageIdentifier } deriving (Eq, Generic) instance Binary InstalledCacheEntry-instance NFData InstalledCacheEntry where- rnf = genericRnf+instance HasStructuralInfo InstalledCacheEntry+instance NFData InstalledCacheEntry -- | Call ghc-pkg dump with appropriate flags and stream to the given @Sink@, for a single database ghcPkgDump@@ -162,23 +163,21 @@ m (Map PackageName (DumpPackage Bool Bool)) sinkMatching reqProfiling reqHaddock allowed = do- dps <- CL.filter (\dp -> isAllowed (dpGhcPkgId dp) &&+ dps <- CL.filter (\dp -> isAllowed (dpPackageIdent dp) && (not reqProfiling || dpProfiling dp) && (not reqHaddock || dpHaddock dp)) =$= CL.consume- return $ pruneDeps- (packageIdentifierName . ghcPkgIdPackageIdentifier)+ return $ Map.fromList $ map (packageIdentifierName . dpPackageIdent &&& id) $ Map.elems $ pruneDeps+ id dpGhcPkgId dpDepends const -- Could consider a better comparison in the future dps where- isAllowed gid =+ isAllowed (PackageIdentifier name version) = case Map.lookup name allowed of Just version' | version /= version' -> False _ -> True- where- PackageIdentifier name version = ghcPkgIdPackageIdentifier gid -- | Add profiling information to the stream of @DumpPackage@s addProfiling :: MonadIO m@@ -231,7 +230,7 @@ Nothing -> do let loop [] = return False loop (ifc:ifcs) = do- exists <- doesFileExist (S8.unpack ifc)+ exists <- doesFileExist ifc if exists then return True else loop ifcs@@ -241,19 +240,20 @@ -- | Dump information for a single package data DumpPackage profiling haddock = DumpPackage { dpGhcPkgId :: !GhcPkgId+ , dpPackageIdent :: !PackageIdentifier , dpLibDirs :: ![FilePath] , dpLibraries :: ![ByteString] , dpHasExposedModules :: !Bool , dpDepends :: ![GhcPkgId]- , dpHaddockInterfaces :: ![ByteString]+ , dpHaddockInterfaces :: ![FilePath] , dpProfiling :: !profiling , dpHaddock :: !haddock+ , dpIsExposed :: !Bool } deriving (Show, Eq, Ord) data PackageDumpException = MissingSingleField ByteString (Map ByteString [Line])- | MismatchedId PackageName Version GhcPkgId | Couldn'tParseField ByteString [Line] deriving Typeable instance Exception PackageDumpException@@ -266,9 +266,6 @@ ] , map (\(k, v) -> " " ++ show (k, v)) (Map.toList values) ]- show (MismatchedId name version gid) =- "Invalid id/name/version in ghc-pkg dump output: " ++- show (name, version, gid) show (Couldn'tParseField name ls) = "Couldn't parse the field " ++ show name ++ " from lines: " ++ show ls @@ -307,31 +304,34 @@ name <- parseS "name" >>= parsePackageName version <- parseS "version" >>= parseVersion ghcPkgId <- parseS "id" >>= parseGhcPkgId- when (PackageIdentifier name version /= ghcPkgIdPackageIdentifier ghcPkgId)- $ throwM $ MismatchedId name version ghcPkgId -- if a package has no modules, these won't exist let libDirKey = "library-dirs"- libDirs = parseM libDirKey libraries = parseM "hs-libraries" exposedModules = parseM "exposed-modules"- haddockInterfaces = parseM "haddock-interfaces"+ exposed = parseM "exposed" depends <- mapM parseDepend $ parseM "depends" - libDirPaths <-- case mapM (P.parseOnly (argsParser NoEscaping) . T.decodeUtf8) libDirs of- Left{} -> throwM (Couldn'tParseField libDirKey libDirs)- Right dirs -> return (concat dirs)+ let parseQuoted key =+ case mapM (P.parseOnly (argsParser NoEscaping) . T.decodeUtf8) val of+ Left{} -> throwM (Couldn'tParseField key val)+ Right dirs -> return (concat dirs)+ where+ val = parseM key+ libDirPaths <- parseQuoted libDirKey+ haddockInterfaces <- parseQuoted "haddock-interfaces" return $ Just DumpPackage { dpGhcPkgId = ghcPkgId+ , dpPackageIdent = PackageIdentifier name version , 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+ , dpHaddockInterfaces = haddockInterfaces , dpProfiling = () , dpHaddock = ()+ , dpIsExposed = exposed == ["True"] } stripPrefixBS :: ByteString -> ByteString -> Maybe ByteString
src/Stack/PackageIndex.hs view
@@ -88,16 +88,17 @@ -- ^ size in bytes of the .cabal file , pcDownload :: !(Maybe PackageDownload) }- deriving Generic-instance Binary.Binary PackageCache-instance NFData PackageCache where- rnf = genericRnf+ deriving (Generic) +instance Binary PackageCache+instance NFData PackageCache+instance HasStructuralInfo PackageCache+ newtype PackageCacheMap = PackageCacheMap (Map PackageIdentifier PackageCache)- deriving (Binary.Binary, NFData)-instance BinarySchema PackageCacheMap where- -- Don't forget to update this if you change the datatype in any way!- binarySchema _ = 1+ deriving (Generic, Binary, NFData)+instance HasStructuralInfo PackageCacheMap+instance HasSemanticVersion PackageCacheMap+ -- | Populate the package index caches and return them. populateCache :: (MonadIO m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, MonadBaseControl IO m, MonadCatch m)@@ -363,8 +364,8 @@ } deriving (Show, Generic) instance Binary.Binary PackageDownload-instance NFData PackageDownload where- rnf = genericRnf+instance HasStructuralInfo PackageDownload+instance NFData PackageDownload instance FromJSON PackageDownload where parseJSON = withObject "Package" $ \o -> do hashes <- o .: "package-hashes"
src/Stack/SDist.hs view
@@ -1,7 +1,9 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ViewPatterns #-} -- Create a source distribution tarball module Stack.SDist ( getSDistTarball@@ -13,24 +15,34 @@ import Control.Applicative import Control.Concurrent.Execute (ActionContext(..)) import Control.Monad (when, void)-import Control.Monad.Catch (MonadCatch, MonadMask)+import Control.Monad.Catch (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 qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L+import Data.Data (Data, Typeable, cast, gmapT) import Data.Either (partitionEithers) import Data.List import qualified Data.Map.Strict as Map+import Data.Maybe (fromMaybe) import Data.Monoid ((<>)) import qualified Data.Set as Set import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Encoding as TLE+import Distribution.Package (Dependency (..))+import Distribution.PackageDescription.PrettyPrint (showGenericPackageDescription)+import Distribution.Version (simplifyVersionRange, orLaterVersion, earlierVersion)+import Distribution.Version.Extra import Network.HTTP.Client.Conduit (HasHttpManager) import Path import Prelude -- Fix redundant import warnings import Stack.Build (mkBaseConfigOpts) import Stack.Build.Execute+import Stack.Build.Installed import Stack.Build.Source (loadSourceMap, localFlags) import Stack.Build.Target import Stack.Constants@@ -40,7 +52,7 @@ 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)+type M env m = (MonadIO m,MonadReader env m,HasHttpManager env,MonadLogger m,MonadBaseControl IO m,MonadMask m,HasLogLevel env,HasEnvConfig env,HasTerminal env) -- | Given the path to a local package, creates its source -- distribution tarball.@@ -48,28 +60,95 @@ -- 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+getSDistTarball :: M env m+ => Maybe PvpBounds -- ^ override Config value+ -> Path Abs Dir+ -> m (FilePath, L.ByteString)+getSDistTarball mpvpBounds pkgDir = do+ config <- asks getConfig+ let pvpBounds = fromMaybe (configPvpBounds config) mpvpBounds+ tweakCabal = pvpBounds /= PvpBoundsNone+ pkgFp = toFilePath pkgDir lp <- readLocalPackage pkgDir $logInfo $ "Getting file list for " <> T.pack pkgFp- fileList <- getSDistFileList lp+ (fileList, cabalfp) <- 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)))+ -- 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 tarPath isDir fp = either error id+ (Tar.toTarPath isDir (pkgId FP.</> fp))+ packWith f isDir fp =+ liftIO $ f (pkgFp FP.</> fp)+ (tarPath isDir fp)+ packDir = packWith Tar.packDirectoryEntry True+ packFile fp+ | tweakCabal && isCabalFp fp = do+ lbs <- getCabalLbs pvpBounds $ toFilePath cabalfp+ return $ Tar.fileEntry (tarPath False fp) lbs+ | otherwise = packWith Tar.packFileEntry False fp+ isCabalFp fp = toFilePath pkgDir FP.</> fp == toFilePath cabalfp+ tarName = pkgId FP.<.> "tar.gz"+ pkgId = packageIdentifierString (packageIdentifier (lpPackage lp))+ dirEntries <- mapM packDir (dirsFromFiles files)+ fileEntries <- mapM packFile files+ return (tarName, GZip.compress (Tar.write (dirEntries ++ fileEntries))) +-- | Get the PVP bounds-enabled version of the given cabal file+getCabalLbs :: M env m => PvpBounds -> FilePath -> m L.ByteString+getCabalLbs pvpBounds fp = do+ bs <- liftIO $ S.readFile fp+ (_warnings, gpd) <- readPackageUnresolvedBS Nothing bs+ (_, _, _, _, sourceMap) <- loadSourceMap AllowNoTargets defaultBuildOpts+ menv <- getMinimalEnvOverride+ (installedMap, _, _) <- getInstalled menv GetInstalledOpts+ { getInstalledProfiling = False+ , getInstalledHaddock = False+ }+ sourceMap+ let gpd' = gtraverseT (addBounds sourceMap installedMap) gpd+ return $ TLE.encodeUtf8 $ TL.pack $ showGenericPackageDescription gpd'+ where+ addBounds :: SourceMap -> InstalledMap -> Dependency -> Dependency+ addBounds sourceMap installedMap dep@(Dependency cname range) =+ case lookupVersion (fromCabalPackageName cname) of+ Nothing -> dep+ Just version -> Dependency cname $ simplifyVersionRange+ $ (if toAddUpper && not (hasUpper range) then addUpper version else id)+ $ (if toAddLower && not (hasLower range) then addLower version else id)+ range+ where+ lookupVersion name =+ case Map.lookup name sourceMap of+ Just (PSLocal lp) -> Just $ packageVersion $ lpPackage lp+ Just (PSUpstream version _ _) -> Just version+ Nothing ->+ case Map.lookup name installedMap of+ Just (version, _, _) -> Just version+ Nothing -> Nothing+++ addUpper version = intersectVersionRanges+ (earlierVersion $ toCabalVersion $ nextMajorVersion version)+ addLower version = intersectVersionRanges+ (orLaterVersion (toCabalVersion version))++ (toAddLower, toAddUpper) =+ case pvpBounds of+ PvpBoundsNone -> (False, False)+ PvpBoundsUpper -> (False, True)+ PvpBoundsLower -> (True, False)+ PvpBoundsBoth -> (True, True)++-- | Traverse a data type.+gtraverseT :: (Data a,Typeable b) => (Typeable b => b -> b) -> a -> a+gtraverseT f =+ gmapT (\x -> case cast x of+ Nothing -> gtraverseT f x+ Just b -> fromMaybe x (cast (f b)))+ -- Read in a 'LocalPackage' config. This makes some default decisions -- about 'LocalPackage' fields that might not be appropriate for other -- usecases.@@ -88,7 +167,8 @@ , packageConfigCompilerVersion = envConfigCompilerVersion econfig , packageConfigPlatform = configPlatform $ getConfig bconfig }- package <- readPackage config cabalfp+ (warnings,package) <- readPackage config cabalfp+ mapM_ (printCabalFileWarning cabalfp) warnings return LocalPackage { lpPackage = package , lpExeComponents = Nothing -- HACK: makes it so that sdist output goes to a log instead of a file.@@ -105,7 +185,8 @@ , lpComponents = Set.empty } -getSDistFileList :: M env m => LocalPackage -> m String+-- | Returns a newline-separate list of paths, and the absolute path to the .cabal file.+getSDistFileList :: M env m => LocalPackage -> m (String, Path Abs File) getSDistFileList lp = withSystemTempDirectory (stackProgName <> "-sdist") $ \tmpdir -> do menv <- getMinimalEnvOverride@@ -113,11 +194,14 @@ baseConfigOpts <- mkBaseConfigOpts bopts (_, _mbp, locals, _extraToBuild, sourceMap) <- loadSourceMap NeedTargets bopts runInBase <- liftBaseWith $ \run -> return (void . run)- withExecuteEnv menv bopts baseConfigOpts locals sourceMap $ \ee -> do- withSingleContext runInBase ac ee task (Just "sdist") $ \_package _cabalfp _pkgDir cabal _announce _console _mlogFile -> do+ withExecuteEnv menv bopts baseConfigOpts locals+ [] -- provide empty list of globals. This is a hack around custom Setup.hs files+ sourceMap $ \ee -> do+ withSingleContext runInBase ac ee task Nothing (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)+ contents <- liftIO (readFile outFile)+ return (contents, cabalfp) where package = lpPackage lp ac = ActionContext Set.empty@@ -128,7 +212,7 @@ { tcoMissing = Set.empty , tcoOpts = \_ -> ConfigureOpts [] [] }- , taskPresent = Set.empty+ , taskPresent = Map.empty } normalizeTarballPaths :: M env m => [FilePath] -> m [FilePath]
src/Stack/Setup.hs view
@@ -6,6 +6,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TupleSections #-}@@ -14,6 +15,7 @@ ( setupEnv , ensureGHC , SetupOpts (..)+ , defaultStackSetupYaml ) where import Control.Applicative@@ -27,7 +29,6 @@ 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)@@ -60,15 +61,16 @@ import Path import Path.IO import Prelude hiding (concat, elem) -- Fix AMP warning-import Safe (headMay, readMay)+import Safe (readMay) import Stack.Types.Build import Stack.Config (resolvePackageEntry) import Stack.Constants (distRelativeDir) import Stack.Fetch-import Stack.GhcPkg (createDatabase, getCabalPkgVer, getGlobalDB)+import Stack.GhcPkg (createDatabase, getCabalPkgVer, getGlobalDB, mkGhcPackagePath) import Stack.Solver (getCompilerVersion) import Stack.Types import Stack.Types.StackT+import qualified System.Directory as D import System.Environment (getExecutablePath) import System.Exit (ExitCode (ExitSuccess)) import System.FilePath (searchPathSeparator)@@ -77,8 +79,14 @@ import System.Process (rawSystem) import System.Process.Read import System.Process.Run (runIn)+import System.IO.Temp (withTempDirectory) import Text.Printf (printf) +-- | Default location of the stack-setup.yaml file+defaultStackSetupYaml :: String+defaultStackSetupYaml =+ "https://raw.githubusercontent.com/fpco/stackage-content/master/stack/stack-setup-2.yaml"+ data SetupOpts = SetupOpts { soptsInstallIfMissing :: !Bool , soptsUseSystem :: !Bool@@ -98,6 +106,10 @@ -- version. Only works reliably with a stack-managed installation. , soptsResolveMissingGHC :: !(Maybe Text) -- ^ Message shown to user for how to resolve the missing GHC+ , soptsStackSetupYaml :: !String+ -- ^ Location of the main stack-setup.yaml file+ , soptsGHCBindistURL :: !(Maybe String)+ -- ^ Alternate GHC binary distribution (requires custom GHCVariant) } deriving Show data SetupException = UnsupportedSetupCombo OS Arch@@ -105,6 +117,10 @@ | UnknownCompilerVersion Text CompilerVersion (Set Version) | UnknownOSKey Text | GHCSanityCheckCompileFailed ReadProcessException (Path Abs File)+ | WantedMustBeGHC+ | RequireCustomGHCVariant+ | ProblemWhileDecompressing (Path Abs File)+ | SetupInfoMissingSevenz deriving Typeable instance Exception SetupException instance Show SetupException where@@ -129,13 +145,21 @@ [ "The GHC located at " , toFilePath ghc , " failed to compile a sanity check. Please see:\n\n"- , " https://github.com/commercialhaskell/stack/wiki/Downloads\n\n"+ , " https://github.com/commercialhaskell/stack/blob/master/doc/install_and_upgrade.md\n\n" , "for more information. Exception was:\n" , show e ]+ show WantedMustBeGHC =+ "The wanted compiler must be GHC"+ show RequireCustomGHCVariant =+ "A custom --ghc-variant must be specified to use --ghc-bindist"+ show (ProblemWhileDecompressing archive) =+ "Problem while decompressing " ++ toFilePath archive+ show SetupInfoMissingSevenz =+ "SetupInfo missing Sevenz EXE/DLL" -- | Modify the environment variables (like PATH) appropriately, possibly doing installation too-setupEnv :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasBuildConfig env, HasHttpManager env, MonadBaseControl IO m)+setupEnv :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasBuildConfig env, HasHttpManager env, HasGHCVariant env, MonadBaseControl IO m) => Maybe Text -- ^ Message to give user when necessary GHC is not available -> m EnvConfig setupEnv mResolveMissingGHC = do@@ -154,6 +178,8 @@ , soptsSkipMsys = configSkipMsys $ bcConfig bconfig , soptsUpgradeCabal = False , soptsResolveMissingGHC = mResolveMissingGHC+ , soptsStackSetupYaml = defaultStackSetupYaml+ , soptsGHCBindistURL = Nothing } mghcBin <- ensureGHC sopts@@ -162,7 +188,7 @@ -- is being used menv0 <- getMinimalEnvOverride let env = removeHaskellEnvVars- $ augmentPathMap (fromMaybe [] mghcBin)+ $ augmentPathMap (maybe [] edBins mghcBin) $ unEnvOverride menv0 menv <- mkEnvOverride platform env@@ -189,12 +215,8 @@ createDatabase menv wc deps localdb <- runReaderT packageDatabaseLocal envConfig0 createDatabase menv wc localdb- globalDB <- getGlobalDB menv wc- let mkGPP locals = T.pack $ intercalate [searchPathSeparator] $ concat- [ [toFilePathNoTrailingSlash localdb | locals]- , [toFilePathNoTrailingSlash deps]- , [toFilePathNoTrailingSlash globalDB]- ]+ globaldb <- getGlobalDB menv wc+ let mkGPP locals = mkGhcPackagePath locals localdb deps globaldb distDir <- runReaderT distRelativeDir envConfig0 @@ -211,7 +233,9 @@ eo <- mkEnvOverride platform $ Map.insert "PATH" (if esIncludeLocals es then localsPath else depsPath) $ (if esIncludeGhcPackagePath es- then Map.insert "GHC_PACKAGE_PATH" (mkGPP (esIncludeLocals es))+ then Map.insert+ (case wc of { Ghc -> "GHC_PACKAGE_PATH"; Ghcjs -> "GHCJS_PACKAGE_PATH" })+ (mkGPP (esIncludeLocals es)) else id) $ (if esStackExe es@@ -243,23 +267,45 @@ return EnvConfig { envConfigBuildConfig = bconfig- { bcConfig = (bcConfig bconfig) { configEnvOverride = getEnvOverride' }+ { bcConfig = maybe id addIncludeLib mghcBin+ (bcConfig bconfig)+ { configEnvOverride = getEnvOverride' } } , envConfigCabalVersion = cabalVer , envConfigCompilerVersion = compilerVer , envConfigPackages = envConfigPackages envConfig0 } +-- | Add the include and lib paths to the given Config+addIncludeLib :: ExtraDirs -> Config -> Config+addIncludeLib (ExtraDirs _bins includes libs) config = config+ { configExtraIncludeDirs = Set.union+ (configExtraIncludeDirs config)+ (Set.fromList $ map T.pack includes)+ , configExtraLibDirs = Set.union+ (configExtraLibDirs config)+ (Set.fromList $ map T.pack libs)+ }++data ExtraDirs = ExtraDirs+ { edBins :: ![FilePath]+ , edInclude :: ![FilePath]+ , edLib :: ![FilePath]+ }+instance Monoid ExtraDirs where+ mempty = ExtraDirs [] [] []+ mappend (ExtraDirs a b c) (ExtraDirs x y z) = ExtraDirs+ (a ++ x)+ (b ++ y)+ (c ++ z)+ -- | Ensure GHC is installed and provide the PATHs to add if necessary-ensureGHC :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m)+ensureGHC :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, HasGHCVariant env, MonadBaseControl IO m) => SetupOpts- -> m (Maybe [FilePath])+ -> m (Maybe ExtraDirs) ensureGHC sopts = do let wc = whichCompiler (soptsWantedCompiler sopts)- ghcVersion = case soptsWantedCompiler sopts of- GhcVersion v -> v- GhcjsVersion _ v -> v- when (ghcVersion < $(mkVersion "7.8")) $ do+ when (getGhcVersion (soptsWantedCompiler sopts) < $(mkVersion "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"@@ -286,57 +332,69 @@ -- If we need to install a GHC, try to do so mpaths <- if needLocal then do- getSetupInfo' <- runOnce (getSetupInfo =<< asks getHttpManager)+ getSetupInfo' <- runOnce (getSetupInfo sopts =<< asks getHttpManager) - config <- asks getConfig- installed <- runReaderT listInstalled config+ installed <- listInstalled -- Install GHC- ghcIdent <- case getInstalledTool installed $(mkPackageName "ghc") (isWanted . GhcVersion) of+ ghcVariant <- asks getGHCVariant+ config <- asks getConfig+ ghcPkgName <- parsePackageNameFromString ("ghc" ++ ghcVariantSuffix ghcVariant)+ ghcIdent <- case getInstalledTool installed ghcPkgName (isWanted . GhcVersion) of Just ident -> return ident Nothing | soptsInstallIfMissing sopts -> do si <- getSetupInfo'- downloadAndInstallGHC menv0 si (soptsWantedCompiler sopts) (soptsCompilerCheck sopts)+ downloadAndInstallGHC+ si+ (soptsWantedCompiler sopts)+ (soptsCompilerCheck sopts)+ (soptsGHCBindistURL sopts) | otherwise -> do- Platform arch _ <- asks getPlatform throwM $ CompilerVersionMismatch msystem- (soptsWantedCompiler sopts, arch)+ (soptsWantedCompiler sopts, expectedArch)+ ghcVariant (soptsCompilerCheck sopts) (soptsStackYaml sopts) (fromMaybe- "Try running stack setup to locally install the correct GHC"+ ("Try running \"stack setup\" to install the correct GHC into "+ <> T.pack (toFilePath (configLocalPrograms config))) $ soptsResolveMissingGHC sopts) - -- Install git on windows, if necessary- mgitIdent <- case configPlatform config of- Platform _ os | isWindows os && not (soptsSkipMsys sopts) ->- case getInstalledTool installed $(mkPackageName "git") (const True) of+ -- Install msys2 on windows, if necessary+ platform <- asks getPlatform+ mmsys2Ident <- case platform of+ Platform _ Cabal.Windows | not (soptsSkipMsys sopts) ->+ case getInstalledTool installed $(mkPackageName "msys2") (const True) of Just ident -> return (Just ident) Nothing | soptsInstallIfMissing sopts -> do si <- getSetupInfo'- let VersionedDownloadInfo version info = siPortableGit si- Just <$> downloadAndInstallTool si info $(mkPackageName "git") version installGitWindows+ osKey <- getOSKey+ VersionedDownloadInfo version info <-+ case Map.lookup osKey $ siMsys2 si of+ Just x -> return x+ Nothing -> error $ "MSYS2 not found for " ++ T.unpack osKey+ Just <$> downloadAndInstallTool si info $(mkPackageName "msys2") version (installMsys2Windows osKey) | otherwise -> do- $logWarn "Continuing despite missing tool: git"+ $logWarn "Continuing despite missing tool: msys2" return Nothing _ -> return Nothing - let idents = catMaybes [Just ghcIdent, mgitIdent]- paths <- runReaderT (mapM binDirs idents) config- return $ Just $ map toFilePathNoTrailingSlash $ concat paths+ let idents = catMaybes [Just ghcIdent, mmsys2Ident]+ paths <- mapM extraDirs idents+ return $ Just $ mconcat paths else return Nothing menv <- case mpaths of Nothing -> return menv0- Just paths -> do+ Just ed -> do config <- asks getConfig let m0 = unEnvOverride menv0 path0 = Map.lookup "PATH" m0- path = augmentPath paths path0+ path = augmentPath (edBins ed) path0 m = Map.insert "PATH" path m0 mkEnvOverride (configPlatform config) (removeHaskellEnvVars m) @@ -397,7 +455,11 @@ Just dir -> return dir runIn dir (compilerExeName wc) menv ["Setup.hs"] Nothing- let setupExe = toFilePath $ dir </> $(mkRelFile "Setup")+ platform <- asks getPlatform+ let setupExe = toFilePath $ dir </>+ (case platform of+ Platform _ Cabal.Windows -> $(mkRelFile "Setup.exe")+ _ -> $(mkRelFile "Setup")) dirArgument name' = concat [ "--" , name'@@ -439,67 +501,39 @@ (_, Nothing) -> return Nothing else return Nothing -data DownloadInfo = DownloadInfo- { downloadInfoUrl :: Text- , downloadInfoContentLength :: Int- , downloadInfoSha1 :: Maybe ByteString- }- deriving Show--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 :: DownloadInfo- , siSevenzDll :: DownloadInfo- , siPortableGit :: VersionedDownloadInfo- , siGHCs :: Map Text (Map Version DownloadInfo)- }- deriving Show-instance FromJSON SetupInfo where- parseJSON = withObject "SetupInfo" $ \o -> SetupInfo- <$> o .: "sevenzexe-info"- <*> o .: "sevenzdll-info"- <*> o .: "portable-git"- <*> o .: "ghc"- -- | Download the most recent SetupInfo-getSetupInfo :: (MonadIO m, MonadThrow m) => Manager -> m SetupInfo-getSetupInfo manager = do- bss <- liftIO $ flip runReaderT manager- $ withResponse req $ \res -> responseBody res $$ CL.consume- let bs = S8.concat bss- either throwM return $ Yaml.decodeEither' bs+getSetupInfo+ :: (MonadIO m, MonadThrow m, MonadLogger m, MonadReader env m, HasConfig env)+ => SetupOpts -> Manager -> m SetupInfo+getSetupInfo sopts manager = do+ config <- asks getConfig+ setupInfos <-+ mapM+ loadSetupInfo+ (SetupInfoFileOrURL (soptsStackSetupYaml sopts) :+ configSetupInfoLocations config)+ return+ (mconcat setupInfos) where- req = "https://raw.githubusercontent.com/fpco/stackage-content/master/stack/stack-setup-2.yaml"+ loadSetupInfo (SetupInfoInline si) = return si+ loadSetupInfo (SetupInfoFileOrURL urlOrFile) = do+ bs <-+ case parseUrl urlOrFile of+ Just req -> do+ bss <-+ liftIO $+ flip runReaderT manager $+ withResponse req $+ \res ->+ responseBody res $$ CL.consume+ return $ S8.concat bss+ Nothing -> liftIO $ S.readFile urlOrFile+ (si,warnings) <- either throwM return (Yaml.decodeEither' bs)+ logJSONWarnings urlOrFile warnings+ return si markInstalled :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m)- => PackageIdentifier -- ^ e.g., ghc-7.8.4, git-2.4.0.1+ => PackageIdentifier -- ^ e.g., ghc-7.8.4, msys2-20150512 -> m () markInstalled ident = do dir <- asks $ configLocalPrograms . getConfig@@ -535,27 +569,43 @@ return $ configLocalPrograms config </> reldir -- | Binary directories for the given installed package-binDirs :: (MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m)- => PackageIdentifier- -> m [Path Abs Dir]-binDirs ident = do- config <- asks getConfig+extraDirs :: (MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m)+ => PackageIdentifier+ -> m ExtraDirs+extraDirs ident = do+ platform <- asks getPlatform dir <- installDir ident- case (configPlatform config, packageNameString $ packageIdentifierName ident) of- (Platform _ (isWindows -> True), "ghc") -> return- [ dir </> $(mkRelDir "bin")- , dir </> $(mkRelDir "mingw") </> $(mkRelDir "bin")- ]- (Platform _ (isWindows -> True), "git") -> return- [ dir </> $(mkRelDir "cmd")- , dir </> $(mkRelDir "usr") </> $(mkRelDir "bin")- ]- (_, "ghc") -> return- [ dir </> $(mkRelDir "bin")- ]+ case (platform, packageNameString $ packageIdentifierName ident) of+ (Platform _ Cabal.Windows, isGHC -> True) -> return mempty+ { edBins = goList+ [ dir </> $(mkRelDir "bin")+ , dir </> $(mkRelDir "mingw") </> $(mkRelDir "bin")+ ]+ }+ (Platform _ Cabal.Windows, "msys2") -> return mempty+ { edBins = goList+ [ dir </> $(mkRelDir "usr") </> $(mkRelDir "bin")+ ]+ , edInclude = goList+ [ dir </> $(mkRelDir "mingw64") </> $(mkRelDir "include")+ , dir </> $(mkRelDir "mingw32") </> $(mkRelDir "include")+ ]+ , edLib = goList+ [ dir </> $(mkRelDir "mingw64") </> $(mkRelDir "lib")+ , dir </> $(mkRelDir "mingw32") </> $(mkRelDir "lib")+ ]+ }+ (_, isGHC -> True) -> return mempty+ { edBins = goList+ [ dir </> $(mkRelDir "bin")+ ]+ } (Platform _ x, tool) -> do $logWarn $ "binDirs: unexpected OS/tool combo: " <> T.pack (show (x, tool))- return []+ return mempty+ where+ goList = map toFilePathNoTrailingSlash+ isGHC n = "ghc" == n || "ghc-" `isPrefixOf` n getInstalledTool :: [PackageIdentifier] -- ^ already installed -> PackageName -- ^ package to find@@ -587,64 +637,75 @@ markInstalled ident return ident -downloadAndInstallGHC :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m)- => EnvOverride- -> SetupInfo+downloadAndInstallGHC :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasGHCVariant env, HasHttpManager env, MonadBaseControl IO m)+ => SetupInfo -> CompilerVersion -> VersionCheck+ -> (Maybe String) -> m PackageIdentifier-downloadAndInstallGHC menv si wanted versionCheck = do- osKey <- getOSKey menv- pairs <-- case Map.lookup osKey $ siGHCs si of- Nothing -> throwM $ UnknownOSKey osKey- Just pairs -> return pairs- let mpair =- listToMaybe $- sortBy (flip (comparing fst)) $- filter (\(v, _) -> isWantedCompiler versionCheck wanted (GhcVersion v)) (Map.toList pairs)- (selectedVersion, downloadInfo) <-- case mpair of- Just pair -> return pair- Nothing -> throwM $ UnknownCompilerVersion osKey wanted (Map.keysSet pairs)- platform <- asks $ configPlatform . getConfig+downloadAndInstallGHC si wanted versionCheck mbindistURL = do+ ghcVariant <- asks getGHCVariant+ (selectedVersion, downloadInfo) <- case mbindistURL of+ Just bindistURL -> do+ case ghcVariant of+ GHCCustom _ -> return ()+ _ -> throwM RequireCustomGHCVariant+ case wanted of+ GhcVersion version ->+ return (version, DownloadInfo (T.pack bindistURL) Nothing Nothing)+ _ ->+ throwM WantedMustBeGHC+ _ -> do+ ghcKey <- getGhcKey+ pairs <-+ case Map.lookup ghcKey $ siGHCs si of+ Nothing -> throwM $ UnknownOSKey ghcKey+ Just pairs -> return pairs+ let mpair =+ listToMaybe $+ sortBy (flip (comparing fst)) $+ filter (\(v, _) -> isWantedCompiler versionCheck wanted (GhcVersion v)) (Map.toList pairs)+ case mpair of+ Just pair -> return pair+ Nothing -> throwM $ UnknownCompilerVersion ghcKey wanted (Map.keysSet pairs)+ platform <- asks getPlatform let installer = case platform of- Platform _ os | isWindows os -> installGHCWindows+ Platform _ Cabal.Windows -> installGHCWindows _ -> installGHCPosix- $logInfo "Preparing to install GHC to an isolated location."+ $logInfo $+ "Preparing to install GHC" <>+ (case ghcVariant of+ GHCStandard -> ""+ v -> " (" <> T.pack (ghcVariantName v) <> ")") <>+ " to an isolated location." $logInfo "This will not interfere with any system-level installation."- downloadAndInstallTool si downloadInfo $(mkPackageName "ghc") selectedVersion installer+ ghcPkgName <- parsePackageNameFromString ("ghc" ++ ghcVariantSuffix ghcVariant)+ downloadAndInstallTool si downloadInfo ghcPkgName selectedVersion installer -getOSKey :: (MonadReader env m, MonadThrow m, HasConfig env, MonadLogger m, MonadIO m, MonadCatch m, MonadBaseControl IO m)- => EnvOverride -> m Text-getOSKey menv = do- platform <- asks $ configPlatform . getConfig+getGhcKey :: (MonadReader env m, MonadThrow m, HasPlatform env, HasGHCVariant env, MonadLogger m, MonadIO m, MonadCatch m, MonadBaseControl IO m)+ => m Text+getGhcKey = do+ ghcVariant <- asks getGHCVariant+ osKey <- getOSKey+ return $ osKey <> T.pack (ghcVariantSuffix ghcVariant)++getOSKey :: (MonadReader env m, MonadThrow m, HasPlatform env, MonadLogger m, MonadIO m, MonadCatch m, MonadBaseControl IO m)+ => m Text+getOSKey = do+ platform <- asks getPlatform case platform of- Platform I386 Cabal.Linux -> ("linux32" <>) <$> getLinuxSuffix- Platform X86_64 Cabal.Linux -> ("linux64" <>) <$> getLinuxSuffix- Platform I386 Cabal.OSX -> return "macosx"- Platform X86_64 Cabal.OSX -> return "macosx"+ Platform I386 Cabal.Linux -> return "linux32"+ Platform X86_64 Cabal.Linux -> return "linux64"+ Platform I386 Cabal.OSX -> return "macosx"+ Platform X86_64 Cabal.OSX -> return "macosx" Platform I386 Cabal.FreeBSD -> return "freebsd32" Platform X86_64 Cabal.FreeBSD -> return "freebsd64" Platform I386 Cabal.OpenBSD -> return "openbsd32" Platform X86_64 Cabal.OpenBSD -> return "openbsd64" Platform I386 Cabal.Windows -> return "windows32" Platform X86_64 Cabal.Windows -> return "windows64"-- Platform I386 (Cabal.OtherOS "windowsintegersimple") -> return "windowsintegersimple32"- Platform X86_64 (Cabal.OtherOS "windowsintegersimple") -> return "windowsintegersimple64"- Platform arch os -> throwM $ UnsupportedSetupCombo os arch- where- getLinuxSuffix = do- executablePath <- liftIO getExecutablePath- elddOut <- tryProcessStdout Nothing menv "ldd" [executablePath]- return $ case elddOut of- Left _ -> ""- Right lddOut -> if hasLineWithFirstWord "libgmp.so.3" lddOut then "-gmp4" else ""- hasLineWithFirstWord w =- elem (Just w) . map (headMay . T.words) . T.lines . T.decodeUtf8With T.lenientDecode downloadFromInfo :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m) => DownloadInfo@@ -706,9 +767,12 @@ withSystemTempDirectory "stack-setup" $ \root' -> do root <- parseAbsDir root'- dir <- liftM (root Path.</>) $ parseRelDir $ packageIdentifierString ident+ dir <-+ liftM (root Path.</>) $+ parseRelDir $+ "ghc-" ++ versionString (packageIdentifierVersion ident) - $logSticky $ "Unpacking GHC ..."+ $logSticky $ T.concat ["Unpacking GHC into ", (T.pack . toFilePath $ root), " ..."] $logDebug $ "Unpacking " <> T.pack (toFilePath archiveFile) readInNull root tarTool menv ["xf", toFilePath archiveFile] Nothing @@ -763,7 +827,7 @@ -> Path Abs Dir -> PackageIdentifier -> m ()-installGHCWindows si archiveFile archiveType destDir _ = do+installGHCWindows si archiveFile archiveType destDir ident = do suffix <- case archiveType of TarXz -> return ".xz"@@ -774,9 +838,53 @@ Nothing -> error $ "Invalid GHC filename: " ++ show archiveFile Just x -> parseAbsFile $ T.unpack x - config <- asks getConfig- run7z <- setup7z si config+ run7z <- setup7z si + withTempDirectory (toFilePath $ parent destDir)+ ((FP.dropTrailingPathSeparator $ toFilePath $ dirname destDir) ++ "-tmp") $ \tmpDir0 -> do+ tmpDir <- parseAbsDir tmpDir0+ run7z (parent archiveFile) archiveFile+ run7z tmpDir tarFile+ removeFile tarFile `catchIO` \e ->+ $logWarn (T.concat+ [ "Exception when removing "+ , T.pack $ toFilePath tarFile+ , ": "+ , T.pack $ show e+ ])+ tarComponent <- parseRelDir $ "ghc-" ++ versionString (packageIdentifierVersion ident)+ renameDir (tmpDir </> tarComponent) destDir++ $logInfo $ "GHC installed to " <> T.pack (toFilePath destDir)++installMsys2Windows :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m)+ => Text -- ^ OS Key+ -> SetupInfo+ -> Path Abs File+ -> ArchiveType+ -> Path Abs Dir+ -> PackageIdentifier+ -> m ()+installMsys2Windows osKey si archiveFile archiveType destDir _ = do+ suffix <-+ case archiveType of+ TarXz -> return ".xz"+ TarBz2 -> return ".bz2"+ _ -> error $ "MSYS2 must be a .tar.xz archive"+ tarFile <-+ case T.stripSuffix suffix $ T.pack $ toFilePath archiveFile of+ Nothing -> error $ "Invalid MSYS2 filename: " ++ show archiveFile+ Just x -> parseAbsFile $ T.unpack x++ run7z <- setup7z si++ exists <- liftIO $ D.doesDirectoryExist $ toFilePath destDir+ when exists $ liftIO (D.removeDirectoryRecursive $ toFilePath destDir) `catchIO` \e -> do+ $logError $ T.pack $+ "Could not delete existing msys directory: " +++ toFilePath destDir+ throwM e+ run7z (parent archiveFile) archiveFile run7z (parent archiveFile) tarFile removeFile tarFile `catchIO` \e ->@@ -787,47 +895,51 @@ , T.pack $ show e ]) - $logInfo $ "GHC installed to " <> T.pack (toFilePath destDir)+ msys <- parseRelDir $ "msys" ++ T.unpack (fromMaybe "32" $ T.stripPrefix "windows" osKey)+ liftIO $ D.renameDirectory+ (toFilePath $ parent archiveFile </> msys)+ (toFilePath destDir) -installGitWindows :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m)- => SetupInfo- -> Path Abs File- -> ArchiveType- -> Path Abs Dir- -> PackageIdentifier- -> m ()-installGitWindows si archiveFile archiveType destDir _ = do- case archiveType of- SevenZ -> return ()- _ -> error $ "Git on Windows must be a 7z archive"+ platform <- asks getPlatform+ menv0 <- getMinimalEnvOverride+ let oldEnv = unEnvOverride menv0+ newEnv = augmentPathMap+ [toFilePath $ destDir </> $(mkRelDir "usr") </> $(mkRelDir "bin")]+ oldEnv+ menv <- mkEnvOverride platform newEnv - config <- asks getConfig- run7z <- setup7z si config- run7z destDir archiveFile+ -- I couldn't find this officially documented anywhere, but you need to run+ -- the shell once in order to initialize some pacman stuff. Once that run+ -- happens, you can just run commands as usual.+ runIn destDir "sh" menv ["--login", "-c", "true"] Nothing + -- Install git. We could install other useful things in the future too.+ runIn destDir "pacman" menv ["-Sy", "--noconfirm", "git"] Nothing+ -- | Download 7z as necessary, and get a function for unpacking things. -- -- Returned function takes an unpack directory and archive.-setup7z :: (MonadReader env m, HasHttpManager env, MonadThrow m, MonadIO m, MonadIO n, MonadLogger m, MonadBaseControl IO m)+setup7z :: (MonadReader env m, HasHttpManager env, HasConfig env, MonadThrow m, MonadIO m, MonadIO n, MonadLogger m, MonadBaseControl IO m) => SetupInfo- -> Config -> m (Path Abs Dir -> Path Abs File -> n ())-setup7z si config = do- chattyDownload "7z.dll" (siSevenzDll si) dll- chattyDownload "7z.exe" (siSevenzExe si) exe- return $ \outdir archive -> liftIO $ do- ec <- rawSystem (toFilePath exe)- [ "x"- , "-o" ++ toFilePath outdir- , "-y"- , toFilePath archive- ]- when (ec /= ExitSuccess)- $ error $ "Problem while decompressing " ++ toFilePath archive- where- dir = configLocalPrograms config </> $(mkRelDir "7z")- exe = dir </> $(mkRelFile "7z.exe")- dll = dir </> $(mkRelFile "7z.dll")+setup7z si = do+ dir <- asks $ configLocalPrograms . getConfig+ let exe = dir </> $(mkRelFile "7z.exe")+ dll = dir </> $(mkRelFile "7z.dll")+ case (siSevenzDll si, siSevenzExe si) of+ (Just sevenzDll, Just sevenzExe) -> do+ chattyDownload "7z.dll" sevenzDll dll+ chattyDownload "7z.exe" sevenzExe exe+ return $ \outdir archive -> liftIO $ do+ ec <- rawSystem (toFilePath exe)+ [ "x"+ , "-o" ++ toFilePath outdir+ , "-y"+ , toFilePath archive+ ]+ when (ec /= ExitSuccess)+ $ throwM (ProblemWhileDecompressing archive)+ _ -> throwM SetupInfoMissingSevenz chattyDownload :: (MonadReader env m, HasHttpManager env, MonadIO m, MonadLogger m, MonadThrow m, MonadBaseControl IO m) => Text -- ^ label@@ -866,7 +978,7 @@ let dReq = DownloadRequest { drRequest = req , drHashChecks = hashChecks- , drLengthCheck = Just totalSize+ , drLengthCheck = mtotalSize , drRetryPolicy = drRetryPolicyDefault } runInBase <- liftBaseWith $ \run -> return (void . run)@@ -875,7 +987,7 @@ then $logStickyDone ("Downloaded " <> label <> ".") else $logStickyDone "Already downloaded." where- totalSize = downloadInfoContentLength downloadInfo+ mtotalSize = downloadInfoContentLength downloadInfo chattyDownloadProgress runInBase _ = do _ <- liftIO $ runInBase $ $logSticky $ label <> ": download has begun"@@ -887,21 +999,15 @@ modify (+ size) totalSoFar <- get 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 mtotalSize of+ Nothing -> chattyProgressNoTotal totalSoFar+ Just 0 -> chattyProgressNoTotal totalSoFar+ Just totalSize -> chattyProgressWithTotal totalSoFar totalSize - -- 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: 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 =@@ -985,6 +1091,7 @@ -- Remove potentially confusing environment variables removeHaskellEnvVars :: Map Text Text -> Map Text Text removeHaskellEnvVars =+ Map.delete "GHCJS_PACKAGE_PATH" . Map.delete "GHC_PACKAGE_PATH" . Map.delete "HASKELL_PACKAGE_SANDBOX" . Map.delete "HASKELL_PACKAGE_SANDBOXES" .@@ -997,7 +1104,7 @@ => EnvOverride -> m (Map Text Text) getUtf8LocaleVars menv = do Platform _ os <- asks getPlatform- if isWindows os+ if os == Cabal.Windows then -- On Windows, locale is controlled by the code page, so we don't set any environment -- variables.
src/Stack/Solver.hs view
@@ -79,6 +79,7 @@ platform <- asks getPlatform menv' <- mkEnvOverride platform+ $ Map.delete "GHCJS_PACKAGE_PATH" $ Map.delete "GHC_PACKAGE_PATH" $ unEnvOverride menv bs <- readProcessStdout (Just tmpdir) menv' "cabal" args let ls = drop 1@@ -200,7 +201,8 @@ else ["flags" .= newFlags]) mapM_ $logInfo $ T.lines $ decodeUtf8 $ Yaml.encode o - when modStackYaml $ do+ if modStackYaml+ then do let fp = toFilePath $ bcStackYaml bconfig obj <- liftIO (Yaml.decodeFileEither fp) >>= either throwM return (ProjectAndConfigMonoid project _, warnings) <-@@ -215,3 +217,6 @@ obj liftIO $ Yaml.encodeFile fp obj' $logInfo $ T.pack $ "Updated " ++ fp+ else do+ $logInfo ""+ $logInfo "To automatically modify your stack.yaml file, rerun with '--modify-stack-yaml'"
src/Stack/Types/Build.hs view
@@ -25,6 +25,7 @@ ,Plan(..) ,TestOpts(..) ,BenchmarkOpts(..)+ ,FileWatchOpts(..) ,BuildOpts(..) ,BuildSubset(..) ,defaultBuildOpts@@ -75,7 +76,7 @@ import Stack.Types.PackageIdentifier import Stack.Types.PackageName import Stack.Types.Version-import System.Exit (ExitCode)+import System.Exit (ExitCode (ExitFailure)) import System.FilePath (dropTrailingPathSeparator, pathSeparator) ----------------------------------------------@@ -85,6 +86,7 @@ | CompilerVersionMismatch (Maybe (CompilerVersion, Arch)) (CompilerVersion, Arch)+ GHCVariant VersionCheck (Maybe (Path Abs File)) Text -- recommended resolution@@ -130,7 +132,7 @@ ", the package id couldn't be found " <> "(via ghc-pkg describe " <> packageNameString name <> "). This shouldn't happen, " <> "please report as a bug")- show (CompilerVersionMismatch mactual (expected, earch) check mstack resolution) = concat+ show (CompilerVersionMismatch mactual (expected, earch) ghcVariant check mstack resolution) = concat [ case mactual of Nothing -> "No compiler found, expected " Just (actual, arch) -> concat@@ -148,11 +150,12 @@ , T.unpack (compilerVersionName expected) , " (" , display earch+ , ghcVariantSuffix ghcVariant , ") (based on " , case mstack of Nothing -> "command line arguments" Just stack -> "resolver setting in " ++ toFilePath stack- , "). "+ , ").\n" , T.unpack resolution ] show (Couldn'tParseTargets targets) = unlines@@ -235,6 +238,9 @@ in "\n-- While building package " ++ dropQuotes (show taskProvides') ++ " using:\n" ++ " " ++ fullCmd ++ "\n" ++ " Process exited with code: " ++ show exitCode +++ (if exitCode == ExitFailure (-9)+ then " (THIS MAY INDICATE OUT OF MEMORY)"+ else "") ++ logLocations ++ (if S.null bs then ""@@ -404,7 +410,7 @@ ,boptsPreFetch :: !Bool -- ^ Fetch all packages immediately ,boptsBuildSubset :: !BuildSubset- ,boptsFileWatch :: !Bool+ ,boptsFileWatch :: !FileWatchOpts -- ^ Watch files for changes and automatically rebuild ,boptsKeepGoing :: !(Maybe Bool) -- ^ Keep building/running after failure@@ -424,6 +430,10 @@ -- ^ Commands (with arguments) to run after a successful build ,boptsOnlyConfigure :: !Bool -- ^ Only perform the configure step when building+ ,boptsReconfigure :: !Bool+ -- ^ Perform the configure step even if already configured+ ,boptsCabalVerbose :: !Bool+ -- ^ Ask Cabal to be verbose in its builds } deriving (Show) @@ -440,7 +450,7 @@ , boptsInstallExes = False , boptsPreFetch = False , boptsBuildSubset = BSAll- , boptsFileWatch = False+ , boptsFileWatch = NoFileWatch , boptsKeepGoing = Nothing , boptsForceDirty = False , boptsTests = False@@ -449,6 +459,8 @@ , boptsBenchmarkOpts = defaultBenchmarkOpts , boptsExec = [] , boptsOnlyConfigure = False+ , boptsReconfigure = False+ , boptsCabalVerbose = False } -- | Options for the 'FinalAction' 'DoTests'@@ -479,6 +491,12 @@ , beoDisableRun = False } +data FileWatchOpts+ = NoFileWatch+ | FileWatch+ | FileWatchPoll+ deriving (Show,Eq)+ -- | Package dependency oracle. newtype PkgDepsOracle = PkgDeps PackageName@@ -516,15 +534,16 @@ 4 <- getWord8 8 <- getWord8 fmap to gget-instance NFData ConfigCache where- rnf = genericRnf+instance NFData ConfigCache+instance HasStructuralInfo ConfigCache+instance HasSemanticVersion 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+ , taskPresent :: !(Map PackageIdentifier GhcPkgId) -- ^ GhcPkgIds of already-installed dependencies } deriving Show @@ -532,7 +551,7 @@ data TaskConfigOpts = TaskConfigOpts { tcoMissing :: !(Set PackageIdentifier) -- ^ Dependencies for which we don't yet have an GhcPkgId- , tcoOpts :: !(Set GhcPkgId -> ConfigureOpts)+ , tcoOpts :: !(Map PackageIdentifier GhcPkgId -> ConfigureOpts) -- ^ Produce the list of options given the missing @GhcPkgId@s } instance Show TaskConfigOpts where@@ -540,7 +559,7 @@ [ "Missing: " , show missing , ". Without those: "- , show $ f Set.empty+ , show $ f Map.empty ] -- | The type of a task, either building local code or something from the@@ -560,7 +579,7 @@ { planTasks :: !(Map PackageName Task) , planFinals :: !(Map PackageName (Task, LocalPackageTB)) -- ^ Final actions to be taken (test, benchmark, etc)- , planUnregisterLocal :: !(Map GhcPkgId Text)+ , planUnregisterLocal :: !(Map GhcPkgId (PackageIdentifier, Maybe Text)) -- ^ Text is reason we're unregistering, for display only , planInstallExes :: !(Map Text InstallLocation) -- ^ Executables that should be installed after successful building@@ -579,7 +598,7 @@ -- | Render a @BaseConfigOpts@ to an actual list of options configureOpts :: EnvConfig -> BaseConfigOpts- -> Set GhcPkgId -- ^ dependencies+ -> Map PackageIdentifier GhcPkgId -- ^ dependencies -> Bool -- ^ wanted? -> InstallLocation -> Package@@ -625,7 +644,7 @@ -- | Same as 'configureOpts', but does not include directory path options configureOptsNoDir :: EnvConfig -> BaseConfigOpts- -> Set GhcPkgId -- ^ dependencies+ -> Map PackageIdentifier GhcPkgId -- ^ dependencies -> Bool -- ^ wanted? -> Package -> [String]@@ -651,28 +670,28 @@ config = getConfig econfig bopts = bcoBuildOpts bco - depOptions = map toDepOption $ Set.toList deps+ depOptions = map (uncurry toDepOption) $ Map.toList deps where toDepOption = if envConfigCabalVersion econfig >= $(mkVersion "1.22") then toDepOption1_22 else toDepOption1_18 - toDepOption1_22 gid = concat+ toDepOption1_22 ident gid = concat [ "--dependency="- , packageNameString $ packageIdentifierName $ ghcPkgIdPackageIdentifier gid+ , packageNameString $ packageIdentifierName ident , "=" , ghcPkgIdString gid ] - toDepOption1_18 gid = concat+ toDepOption1_18 ident _gid = concat [ "--constraint=" , packageNameString name , "==" , versionString version ] where- PackageIdentifier name version = ghcPkgIdPackageIdentifier gid+ PackageIdentifier name version = ident ghcOptionsMap = configGhcOptions $ getConfig econfig allGhcOptions = concat@@ -696,7 +715,7 @@ , toRational (utctDayTime x)) -data Installed = Library GhcPkgId | Executable PackageIdentifier+data Installed = Library PackageIdentifier GhcPkgId | Executable PackageIdentifier deriving (Show, Eq, Ord) -- | Configure options to be sent to Setup.hs configure@@ -709,8 +728,8 @@ } deriving (Show, Eq, Generic) instance Binary ConfigureOpts-instance NFData ConfigureOpts where- rnf = genericRnf+instance HasStructuralInfo ConfigureOpts+instance NFData ConfigureOpts -- | Information on a compiled package: the library conf file (if relevant), -- and all of the executable paths.@@ -723,5 +742,6 @@ } deriving (Show, Eq, Generic) instance Binary PrecompiledCache-instance NFData PrecompiledCache where- rnf = genericRnf+instance HasSemanticVersion PrecompiledCache+instance HasStructuralInfo PrecompiledCache+instance NFData PrecompiledCache
src/Stack/Types/BuildPlan.hs view
@@ -22,7 +22,6 @@ , MiniPackageInfo (..) , renderSnapName , parseSnapName- , isWindows ) where import Control.Applicative@@ -250,8 +249,8 @@ -- | Name of an executable. newtype ExeName = ExeName { unExeName :: ByteString }- deriving (Show, Eq, Ord, Hashable, IsString, Generic, NFData)-instance Binary ExeName+ deriving (Show, Eq, Ord, Hashable, IsString, Generic, Binary, NFData)+instance HasStructuralInfo ExeName instance ToJSON ExeName where toJSON = toJSON . S8.unpack . unExeName instance FromJSON ExeName where@@ -375,11 +374,9 @@ } deriving (Generic, Show, Eq) 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 _ = 2+instance NFData MiniBuildPlan+instance HasStructuralInfo MiniBuildPlan+instance HasSemanticVersion MiniBuildPlan -- | Information on a single package for the 'MiniBuildPlan'. data MiniPackageInfo = MiniPackageInfo@@ -398,11 +395,5 @@ } deriving (Generic, Show, Eq) instance Binary MiniPackageInfo-instance NFData MiniPackageInfo where- rnf = genericRnf---isWindows :: OS -> Bool-isWindows Windows = True-isWindows (OtherOS "windowsintegersimple") = True-isWindows _ = False+instance HasStructuralInfo MiniPackageInfo+instance NFData MiniPackageInfo
src/Stack/Types/Compiler.hs view
@@ -5,9 +5,8 @@ module Stack.Types.Compiler where import Control.DeepSeq-import Control.DeepSeq.Generics (genericRnf) import Data.Aeson-import Data.Binary (Binary)+import Data.Binary.VersionTagged (Binary, HasStructuralInfo) import Data.Monoid ((<>)) import qualified Data.Text as T import GHC.Generics (Generic)@@ -34,8 +33,8 @@ {-# UNPACK #-} !Version -- GHC version deriving (Generic, Show, Eq, Ord) instance Binary CompilerVersion-instance NFData CompilerVersion where- rnf = genericRnf+instance HasStructuralInfo CompilerVersion+instance NFData CompilerVersion instance ToJSON CompilerVersion where toJSON = toJSON . compilerVersionName instance FromJSON CompilerVersion where@@ -71,6 +70,10 @@ isWantedCompiler check (GhcjsVersion wanted wantedGhc) (GhcjsVersion actual actualGhc) = checkVersion check wanted actual && checkVersion check wantedGhc actualGhc isWantedCompiler _ _ _ = False++getGhcVersion :: CompilerVersion -> Version+getGhcVersion (GhcVersion v) = v+getGhcVersion (GhcjsVersion _ v) = v compilerExeName :: WhichCompiler -> String compilerExeName Ghc = "ghc"
src/Stack/Types/Config.hs view
@@ -2,31 +2,36 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-} -- | The Config type. module Stack.Types.Config where import Control.Applicative+import Control.Arrow ((&&&)) import Control.Exception import Control.Monad (liftM, mzero, forM) 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),+ (ToJSON, toJSON, FromJSON, parseJSON, withText, object,+ (.=), (..:), (..:?), (..!=), Value(String, Object), withObjectWarnings, WarningParser, Object, jsonSubWarnings, JSONWarning,- jsonSubWarningsMT)+ jsonSubWarningsT, jsonSubWarningsTT, tellJSONField) import Data.Attoparsec.Args import Data.Binary (Binary) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as S8 import Data.Either (partitionEithers)+import Data.List (stripPrefix) import Data.Hashable (Hashable) import Data.Map (Map) import qualified Data.Map as Map@@ -73,6 +78,10 @@ -- console ,configPlatform :: !Platform -- ^ The platform we're building for, used in many directory names+ ,configGHCVariant0 :: !(Maybe GHCVariant)+ -- ^ The variant of GHC requested by the user.+ -- In most cases, use 'BuildConfig' or 'MiniConfig's version instead,+ -- which will have an auto-detected default. ,configLatestSnapshotUrl :: !Text -- ^ URL for a JSON file containing information on the latest -- snapshots available.@@ -125,6 +134,10 @@ ,configGhcOptions :: !(Map (Maybe PackageName) [Text]) -- ^ Additional GHC options to apply to either all packages (Nothing) -- or a specific package (Just).+ ,configSetupInfoLocations :: ![SetupInfoLocation]+ -- ^ Additional SetupInfo (inline or remote) to use to find tools.+ ,configPvpBounds :: !PvpBounds+ -- ^ How PVP upper bounds should be added to packages } -- | Information on a single package index@@ -196,7 +209,10 @@ deriving (Show, Eq, Ord) data ExecOpts = ExecOpts- { eoCmd :: !String+ { eoCmd :: !(Maybe String)+ -- ^ Usage of @Maybe@ here is nothing more than a hack, to avoid some weird+ -- bug in optparse-applicative. See:+ -- https://github.com/commercialhaskell/stack/issues/806 , eoArgs :: ![String] , eoExtra :: !ExecOptsExtra }@@ -260,6 +276,8 @@ , bcImplicitGlobal :: !Bool -- ^ Are we loading from the implicit global stack.yaml? This is useful -- for providing better error messages.+ , bcGHCVariant :: !GHCVariant+ -- ^ The variant of GHC used to select a GHC bindist. } -- | Directory containing the project's stack.yaml file@@ -280,8 +298,9 @@ getBuildConfig = envConfigBuildConfig instance HasConfig EnvConfig instance HasPlatform EnvConfig+instance HasGHCVariant EnvConfig instance HasStackRoot EnvConfig-class HasBuildConfig r => HasEnvConfig r where+class (HasBuildConfig r, HasGHCVariant r) => HasEnvConfig r where getEnvConfig :: r -> EnvConfig instance HasEnvConfig EnvConfig where getEnvConfig = id@@ -333,7 +352,7 @@ ] instance FromJSON (PackageEntry, [JSONWarning]) where parseJSON (String t) = do- loc <- parseJSON $ String t+ (loc, _::[JSONWarning]) <- parseJSON $ String t return (PackageEntry { peExtraDepMaybe = Nothing , peValidWanted = Nothing@@ -343,7 +362,7 @@ parseJSON v = withObjectWarnings "PackageEntry" (\o -> PackageEntry <$> o ..:? "extra-dep" <*> o ..:? "valid-wanted"- <*> o ..: "location"+ <*> jsonSubWarnings (o ..: "location") <*> o ..:? "subdirs" ..!= []) v data PackageLocation@@ -358,17 +377,17 @@ toJSON (PLFilePath fp) = toJSON fp toJSON (PLHttpTarball t) = toJSON t toJSON (PLGit x y) = toJSON $ T.unwords ["git", x, y]-instance FromJSON PackageLocation where- parseJSON v = git v <|> withText "PackageLocation" (\t -> http t <|> file t) v+instance FromJSON (PackageLocation, [JSONWarning]) where+ parseJSON v = ((,[]) <$> withText "PackageLocation" (\t -> http t <|> file t) v) <|> git v where file t = pure $ PLFilePath $ T.unpack t http t = case parseUrl $ T.unpack t of Left _ -> mzero Right _ -> return $ PLHttpTarball t- git = withObject "PackageGitLocation" $ \o -> PLGit- <$> o .: "git"- <*> o .: "commit"+ git = withObjectWarnings "PackageGitLocation" $ \o -> PLGit+ <$> o ..: "git"+ <*> o ..: "commit" -- | A project is a collection of packages. We can have multiple stack.yaml -- files, but only one of them may contain project information.@@ -415,13 +434,13 @@ , "location" .= location ] toJSON x = toJSON $ resolverName x-instance FromJSON Resolver where+instance FromJSON (Resolver,[JSONWarning]) where -- Strange structuring is to give consistent error messages- parseJSON v@(Object _) = withObject "Resolver" (\o -> ResolverCustom- <$> o .: "name"- <*> o .: "location") v+ parseJSON v@(Object _) = withObjectWarnings "Resolver" (\o -> ResolverCustom+ <$> o ..: "name"+ <*> o ..: "location") v - parseJSON (String t) = either (fail . show) return (parseResolverText t)+ parseJSON (String t) = either (fail . show) return ((,[]) <$> parseResolverText t) parseJSON _ = fail $ "Invalid Resolver, must be Object or String" @@ -455,6 +474,15 @@ instance HasPlatform Platform where getPlatform = id +-- | Class for environment values which have a GHCVariant+class HasGHCVariant env where+ getGHCVariant :: env -> GHCVariant+ default getGHCVariant :: HasBuildConfig env => env -> GHCVariant+ getGHCVariant = bcGHCVariant . getBuildConfig+ {-# INLINE getGHCVariant #-}+instance HasGHCVariant GHCVariant where+ getGHCVariant = id+ -- | Class for environment values that can provide a 'Config'. class (HasStackRoot env, HasPlatform env) => HasConfig env where getConfig :: env -> Config@@ -472,6 +500,7 @@ getBuildConfig :: env -> BuildConfig instance HasStackRoot BuildConfig instance HasPlatform BuildConfig+instance HasGHCVariant BuildConfig instance HasConfig BuildConfig instance HasBuildConfig BuildConfig where getBuildConfig = id@@ -507,6 +536,8 @@ -- ^ Used for overriding the platform ,configMonoidArch :: !(Maybe String) -- ^ Used for overriding the platform+ ,configMonoidGHCVariant :: !(Maybe GHCVariant)+ -- ^ Used for overriding the GHC variant ,configMonoidJobs :: !(Maybe Int) -- ^ See: 'configJobs' ,configMonoidExtraIncludeDirs :: !(Set Text)@@ -527,6 +558,10 @@ -- ^ See 'configGhcOptions' ,configMonoidExtraPath :: ![Path Abs Dir] -- ^ Additional paths to search for executables in+ ,configMonoidSetupInfoLocations :: ![SetupInfoLocation]+ -- ^ Additional setup info (inline or remote) to use for installing tools+ ,configMonoidPvpBounds :: !(Maybe PvpBounds)+ -- ^ See 'configPvpBounds' } deriving Show @@ -544,6 +579,7 @@ , configMonoidRequireStackVersion = anyVersion , configMonoidOS = Nothing , configMonoidArch = Nothing+ , configMonoidGHCVariant = Nothing , configMonoidJobs = Nothing , configMonoidExtraIncludeDirs = Set.empty , configMonoidExtraLibDirs = Set.empty@@ -555,6 +591,8 @@ , configMonoidCompilerCheck = Nothing , configMonoidGhcOptions = mempty , configMonoidExtraPath = []+ , configMonoidSetupInfoLocations = mempty+ , configMonoidPvpBounds = Nothing } mappend l r = ConfigMonoid { configMonoidDockerOpts = configMonoidDockerOpts l <> configMonoidDockerOpts r@@ -570,6 +608,7 @@ (configMonoidRequireStackVersion r) , configMonoidOS = configMonoidOS l <|> configMonoidOS r , configMonoidArch = configMonoidArch l <|> configMonoidArch r+ , configMonoidGHCVariant = configMonoidGHCVariant l <|> configMonoidGHCVariant r , configMonoidJobs = configMonoidJobs l <|> configMonoidJobs r , configMonoidExtraIncludeDirs = Set.union (configMonoidExtraIncludeDirs l) (configMonoidExtraIncludeDirs r) , configMonoidExtraLibDirs = Set.union (configMonoidExtraLibDirs l) (configMonoidExtraLibDirs r)@@ -581,6 +620,8 @@ , configMonoidCompilerCheck = configMonoidCompilerCheck l <|> configMonoidCompilerCheck r , configMonoidGhcOptions = Map.unionWith (++) (configMonoidGhcOptions l) (configMonoidGhcOptions r) , configMonoidExtraPath = configMonoidExtraPath l ++ configMonoidExtraPath r+ , configMonoidSetupInfoLocations = configMonoidSetupInfoLocations l ++ configMonoidSetupInfoLocations r+ , configMonoidPvpBounds = configMonoidPvpBounds l <|> configMonoidPvpBounds r } instance FromJSON (ConfigMonoid, [JSONWarning]) where@@ -595,7 +636,7 @@ configMonoidConnectionCount <- obj ..:? "connection-count" configMonoidHideTHLoading <- obj ..:? "hide-th-loading" configMonoidLatestSnapshotUrl <- obj ..:? "latest-snapshot-url"- configMonoidPackageIndices <- jsonSubWarningsMT (obj ..:? "package-indices")+ configMonoidPackageIndices <- jsonSubWarningsTT (obj ..:? "package-indices") configMonoidSystemGHC <- obj ..:? "system-ghc" configMonoidInstallGHC <- obj ..:? "install-ghc" configMonoidSkipGHCCheck <- obj ..:? "skip-ghc-check"@@ -605,6 +646,7 @@ ..!= VersionRangeJSON anyVersion configMonoidOS <- obj ..:? "os" configMonoidArch <- obj ..:? "arch"+ configMonoidGHCVariant <- obj ..:? "ghc-variant" configMonoidJobs <- obj ..:? "jobs" configMonoidExtraIncludeDirs <- obj ..:? "extra-include-dirs" ..!= Set.empty configMonoidExtraLibDirs <- obj ..:? "extra-lib-dirs" ..!= Set.empty@@ -631,6 +673,11 @@ configMonoidExtraPath <- forM extraPath $ either (fail . show) return . parseAbsDir . T.unpack + configMonoidSetupInfoLocations <-+ maybeToList <$> jsonSubWarningsT (obj ..:? "setup-info")++ configMonoidPvpBounds <- obj ..:? "pvp-bounds"+ return ConfigMonoid {..} where handleGhcOptions :: Monad m => (Text, Text) -> m (Maybe PackageName, [Text])@@ -664,6 +711,7 @@ | BadStackVersionException VersionRange | NoMatchingSnapshot [SnapName] | NoSuchDirectory FilePath+ | ParseGHCVariantException String deriving Typeable instance Show ConfigException where show (ParseConfigFileException configFile exception) = concat@@ -671,12 +719,12 @@ , toFilePath configFile , "':\n" , show exception- , "\nSee https://github.com/commercialhaskell/stack/wiki/stack.yaml."+ , "\nSee https://github.com/commercialhaskell/stack/blob/master/doc/yaml_configuration.md." ] show (ParseResolverException t) = concat [ "Invalid resolver value: " , T.unpack t- , ". Possible valid values include lts-2.12, nightly-YYYY-MM-DD, ghc-7.10.2, and ghcjs-0.1.0-ghc-7.10.2. "+ , ". Possible valid values include lts-2.12, nightly-YYYY-MM-DD, ghc-7.10.2, and ghcjs-0.1.0_ghc-7.10.2. " , "See https://www.stackage.org/snapshots for a complete list." ] show (NoProjectConfigFound dir mcmd) = concat@@ -709,7 +757,7 @@ (\name -> " stack init --resolver " ++ T.unpack (renderSnapName name)) names , "\nYou'll then need to add some extra-deps. See:\n\n"- , " https://github.com/commercialhaskell/stack/wiki/stack.yaml#extra-deps"+ , " https://github.com/commercialhaskell/stack/blob/master/doc/yaml_configuration.md#extra-deps" , "\n\nYou can also try falling back to a dependency solver with:\n\n" , " stack init --solver" ]@@ -717,6 +765,10 @@ ["No directory could be located matching the supplied path: " ,dir ]+ show (ParseGHCVariantException v) = concat+ [ "Invalid ghc-variant value: "+ , v+ ] instance Exception ConfigException -- | Helper function to ask the environment and apply getConfig@@ -769,9 +821,22 @@ configInstalledCache = liftM (</> $(mkRelFile "installed-cache.bin")) configProjectWorkDir -- | Relative directory for the platform identifier-platformRelDir :: (MonadReader env m, HasPlatform env, MonadThrow m) => m (Path Rel Dir)-platformRelDir = asks getPlatform >>= parseRelDir . Distribution.Text.display+platformOnlyRelDir+ :: (MonadReader env m, HasPlatform env, MonadThrow m)+ => m (Path Rel Dir)+platformOnlyRelDir = do+ platform <- asks getPlatform+ parseRelDir (Distribution.Text.display platform) +-- | Relative directory for the platform identifier+platformVariantRelDir+ :: (MonadReader env m, HasPlatform env, HasGHCVariant env, MonadThrow m)+ => m (Path Rel Dir)+platformVariantRelDir = do+ platform <- asks getPlatform+ ghcVariant <- asks getGHCVariant+ parseRelDir (Distribution.Text.display platform <> ghcVariantSuffix ghcVariant)+ -- | Path to .shake files. configShakeFilesDir :: (MonadReader env m, HasBuildConfig env) => m (Path Abs Dir) configShakeFilesDir = liftM (</> $(mkRelDir "shake")) configProjectWorkDir@@ -781,10 +846,10 @@ configLocalUnpackDir = liftM (</> $(mkRelDir "unpacked")) configProjectWorkDir -- | Directory containing snapshots-snapshotsDir :: (MonadReader env m, HasConfig env, MonadThrow m) => m (Path Abs Dir)+snapshotsDir :: (MonadReader env m, HasConfig env, HasGHCVariant env, MonadThrow m) => m (Path Abs Dir) snapshotsDir = do config <- asks getConfig- platform <- platformRelDir+ platform <- platformVariantRelDir return $ configStackRoot config </> $(mkRelDir "snapshots") </> platform -- | Installation root for dependencies@@ -802,7 +867,7 @@ bc <- asks getBuildConfig name <- parseRelDir $ T.unpack $ resolverName $ bcResolver bc ghc <- compilerVersionDir- platform <- platformRelDir+ platform <- platformVariantRelDir return $ configProjectWorkDir bc </> $(mkRelDir "install") </> platform </> name </> ghc compilerVersionDir :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Path Rel Dir)@@ -831,12 +896,12 @@ return $ root </> $(mkRelDir "flag-cache") -- | Where to store mini build plan caches-configMiniBuildPlanCache :: (MonadThrow m, MonadReader env m, HasStackRoot env, HasPlatform env)+configMiniBuildPlanCache :: (MonadThrow m, MonadReader env m, HasConfig env, HasGHCVariant env) => SnapName -> m (Path Abs File) configMiniBuildPlanCache name = do root <- asks getStackRoot- platform <- platformRelDir+ platform <- platformVariantRelDir file <- parseRelFile $ T.unpack (renderSnapName name) ++ ".cache" -- Yes, cached plans differ based on platform return (root </> $(mkRelDir "build-plan-cache") </> platform </> file)@@ -870,13 +935,17 @@ getMinimalEnvOverride :: (MonadReader env m, HasConfig env, MonadIO m) => m EnvOverride getMinimalEnvOverride = do config <- asks getConfig- liftIO $ configEnvOverride config EnvSettings- { esIncludeLocals = False- , esIncludeGhcPackagePath = False- , esStackExe = False- , esLocaleUtf8 = False- }+ liftIO $ configEnvOverride config minimalEnvSettings +minimalEnvSettings :: EnvSettings+minimalEnvSettings =+ EnvSettings+ { esIncludeLocals = False+ , esIncludeGhcPackagePath = False+ , esStackExe = False+ , esLocaleUtf8 = False+ }+ getWhichCompiler :: (MonadReader env m, HasEnvConfig env) => m WhichCompiler getWhichCompiler = asks (whichCompiler . envConfigCompilerVersion . getEnvConfig) @@ -885,7 +954,7 @@ instance (warnings ~ [JSONWarning]) => FromJSON (ProjectAndConfigMonoid, warnings) where parseJSON = withObjectWarnings "ProjectAndConfigMonoid" $ \o -> do- dirs <- jsonSubWarningsMT (o ..:? "packages") ..!= [packageEntryCurrDir]+ dirs <- jsonSubWarningsTT (o ..:? "packages") ..!= [packageEntryCurrDir] extraDeps' <- o ..:? "extra-deps" ..!= [] extraDeps <- case partitionEithers $ goDeps extraDeps' of@@ -893,7 +962,7 @@ (errs, _) -> fail $ unlines errs flags <- o ..:? "flags" ..!= mempty- resolver <- o ..: "resolver"+ resolver <- jsonSubWarnings (o ..: "resolver") config <- parseConfigMonoidJSON o let project = Project { projectPackages = dirs@@ -942,3 +1011,161 @@ instance ToJSON SCM where toJSON Git = toJSON ("git" :: Text)++-- | Specialized bariant of GHC (e.g. libgmp4 or integer-simple)+data GHCVariant+ = GHCStandard -- ^ Standard bindist+ | GHCGMP4 -- ^ Bindist that supports libgmp4 (centos66)+ | GHCArch -- ^ Bindist built on Arch Linux (bleeding-edge)+ | GHCIntegerSimple -- ^ Bindist that uses integer-simple+ | GHCCustom String -- ^ Other bindists+ deriving (Show)++instance FromJSON GHCVariant where+ -- Strange structuring is to give consistent error messages+ parseJSON =+ withText+ "GHCVariant"+ (either (fail . show) return . parseGHCVariant . T.unpack)++-- | Render a GHC variant to a String.+ghcVariantName :: GHCVariant -> String+ghcVariantName GHCStandard = "standard"+ghcVariantName GHCGMP4 = "gmp4"+ghcVariantName GHCArch = "arch"+ghcVariantName GHCIntegerSimple = "integersimple"+ghcVariantName (GHCCustom name) = "custom-" ++ name++-- | Render a GHC variant to a String suffix.+ghcVariantSuffix :: GHCVariant -> String+ghcVariantSuffix GHCStandard = ""+ghcVariantSuffix v = "-" ++ ghcVariantName v++-- | Parse GHC variant from a String.+parseGHCVariant :: (MonadThrow m) => String -> m GHCVariant+parseGHCVariant s =+ case stripPrefix "custom-" s of+ Just name -> return (GHCCustom name)+ Nothing+ | s == "" -> return GHCStandard+ | s == "standard" -> return GHCStandard+ | s == "gmp4" -> return GHCGMP4+ | s == "arch" -> return GHCArch+ | s == "integersimple" -> return GHCIntegerSimple+ | otherwise -> return (GHCCustom s)++-- | Information for a file to download.+data DownloadInfo = DownloadInfo+ { downloadInfoUrl :: Text+ , downloadInfoContentLength :: Maybe Int+ , downloadInfoSha1 :: Maybe ByteString+ } deriving (Show)++instance FromJSON (DownloadInfo, [JSONWarning]) where+ parseJSON = withObjectWarnings "DownloadInfo" parseDownloadInfoFromObject++-- | Parse JSON in existing object for 'DownloadInfo'+parseDownloadInfoFromObject :: Object -> WarningParser DownloadInfo+parseDownloadInfoFromObject o = do+ url <- o ..: "url"+ contentLength <- o ..:? "content-length"+ sha1TextMay <- o ..:? "sha1"+ -- Don't warn about 'version' field that is sometimes included+ tellJSONField "version"+ return+ DownloadInfo+ { downloadInfoUrl = url+ , downloadInfoContentLength = contentLength+ , downloadInfoSha1 = fmap encodeUtf8 sha1TextMay+ }++data VersionedDownloadInfo = VersionedDownloadInfo+ { vdiVersion :: Version+ , vdiDownloadInfo :: DownloadInfo+ }+ deriving Show++instance FromJSON (VersionedDownloadInfo, [JSONWarning]) where+ parseJSON = withObjectWarnings "VersionedDownloadInfo" $ \o -> do+ version <- o ..: "version"+ downloadInfo <- parseDownloadInfoFromObject o+ return VersionedDownloadInfo+ { vdiVersion = version+ , vdiDownloadInfo = downloadInfo+ }++data SetupInfo = SetupInfo+ { siSevenzExe :: Maybe DownloadInfo+ , siSevenzDll :: Maybe DownloadInfo+ , siMsys2 :: Map Text VersionedDownloadInfo+ , siGHCs :: Map Text (Map Version DownloadInfo)+ }+ deriving Show++instance FromJSON (SetupInfo, [JSONWarning]) where+ parseJSON = withObjectWarnings "SetupInfo" $ \o -> do+ siSevenzExe <- jsonSubWarningsT (o ..:? "sevenzexe-info")+ siSevenzDll <- jsonSubWarningsT (o ..:? "sevenzdll-info")+ siMsys2 <- jsonSubWarningsT (o ..:? "msys2" ..!= mempty)+ siGHCs <- jsonSubWarningsTT (o ..:? "ghc" ..!= mempty)+ -- Don't warn about 'portable-git' that is no-longer used+ tellJSONField "portable-git"+ return SetupInfo {..}++instance Monoid SetupInfo where+ mempty =+ SetupInfo+ { siSevenzExe = Nothing+ , siSevenzDll = Nothing+ , siMsys2 = Map.empty+ , siGHCs = Map.empty+ }+ mappend l r =+ SetupInfo+ { siSevenzExe = siSevenzExe l <|> siSevenzExe r+ , siSevenzDll = siSevenzDll l <|> siSevenzDll r+ , siMsys2 = siMsys2 l <> siMsys2 r+ , siGHCs = siGHCs l <> siGHCs r }++-- | Remote or inline 'SetupInfo'+data SetupInfoLocation+ = SetupInfoFileOrURL String+ | SetupInfoInline SetupInfo+ deriving (Show)++instance FromJSON (SetupInfoLocation, [JSONWarning]) where+ parseJSON v =+ ((, []) <$>+ withText "SetupInfoFileOrURL" (pure . SetupInfoFileOrURL . T.unpack) v) <|>+ inline+ where+ inline = do+ (si,w) <- parseJSON v+ return (SetupInfoInline si, w)++-- | How PVP bounds should be added to .cabal files+data PvpBounds+ = PvpBoundsNone+ | PvpBoundsUpper+ | PvpBoundsLower+ | PvpBoundsBoth+ deriving (Show, Read, Eq, Typeable, Ord, Enum, Bounded)++pvpBoundsText :: PvpBounds -> Text+pvpBoundsText PvpBoundsNone = "none"+pvpBoundsText PvpBoundsUpper = "upper"+pvpBoundsText PvpBoundsLower = "lower"+pvpBoundsText PvpBoundsBoth = "both"++parsePvpBounds :: Text -> Either String PvpBounds+parsePvpBounds t =+ case Map.lookup t m of+ Nothing -> Left $ "Invalid PVP bounds: " ++ T.unpack t+ Just x -> Right x+ where+ m = Map.fromList $ map (pvpBoundsText &&& id) [minBound..maxBound]++instance ToJSON PvpBounds where+ toJSON = toJSON . pvpBoundsText+instance FromJSON PvpBounds where+ parseJSON = withText "PvpBounds" (either fail return . parsePvpBounds)
src/Stack/Types/FlagName.hs view
@@ -55,6 +55,7 @@ newtype FlagName = FlagName ByteString deriving (Typeable,Data,Generic,Hashable,Binary,NFData)+instance HasStructuralInfo FlagName instance Eq FlagName where x == y = (compare x y) == EQ instance Ord FlagName where
src/Stack/Types/GhcPkgId.hs view
@@ -8,24 +8,22 @@ (GhcPkgId ,ghcPkgIdParser ,parseGhcPkgId- ,ghcPkgIdString- ,ghcPkgIdPackageIdentifier)+ ,ghcPkgIdString) where import Control.Applicative import Control.Monad.Catch import Data.Aeson.Extended-import Data.Attoparsec.ByteString.Char8+import Data.Attoparsec.ByteString.Char8 as A8+import Data.Binary (getWord8, putWord8) import Data.Binary.VersionTagged import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as S8-import Data.Char (isLetter) import Data.Data import Data.Hashable import Data.Text.Encoding (encodeUtf8) import GHC.Generics import Prelude -- Fix AMP warning-import Stack.Types.PackageIdentifier -- | A parse fail. data GhcPkgIdParseFail@@ -36,15 +34,26 @@ instance Exception GhcPkgIdParseFail -- | A ghc-pkg package identifier.-data GhcPkgId =- GhcPkgId !PackageIdentifier- !ByteString+newtype GhcPkgId = GhcPkgId ByteString deriving (Eq,Ord,Data,Typeable,Generic) instance Hashable GhcPkgId-instance Binary GhcPkgId-instance NFData GhcPkgId where- rnf = genericRnf+instance Binary GhcPkgId where+ put (GhcPkgId x) = do+ -- magic string+ putWord8 1+ putWord8 3+ putWord8 4+ putWord8 7+ put x+ get = do+ 1 <- getWord8+ 3 <- getWord8+ 4 <- getWord8+ 7 <- getWord8+ fmap GhcPkgId get+instance NFData GhcPkgId+instance HasStructuralInfo GhcPkgId instance Show GhcPkgId where show = show . ghcPkgIdString@@ -69,18 +78,16 @@ -- | A parser for a package-version-hash pair. ghcPkgIdParser :: Parser GhcPkgId ghcPkgIdParser =- do ident <- packageIdentifierParser- _ <- char8 '-'- h <- many1 (satisfy isAlphaNum)- let !bytes = S8.pack h- return (GhcPkgId ident bytes)- where isAlphaNum c = isLetter c || isDigit c+ fmap GhcPkgId (A8.takeWhile isValid)+ where+ isValid c =+ ('A' <= c && c <= 'Z') ||+ ('a' <= c && c <= 'z') ||+ ('0' <= c && c <= '9') ||+ c == '.' ||+ c == '-' ||+ c == '_' -- | Get a string representation of GHC package id. ghcPkgIdString :: GhcPkgId -> String-ghcPkgIdString (GhcPkgId ident x) =- packageIdentifierString ident ++ "-" ++ S8.unpack x---- | Get the package identifier of the GHC package id.-ghcPkgIdPackageIdentifier :: GhcPkgId -> PackageIdentifier-ghcPkgIdPackageIdentifier (GhcPkgId ident _) = ident+ghcPkgIdString (GhcPkgId x) = S8.unpack x
src/Stack/Types/Internal.hs view
@@ -22,6 +22,8 @@ getStackRoot = getStackRoot . envConfig instance HasPlatform config => HasPlatform (Env config) where getPlatform = getPlatform . envConfig+instance HasGHCVariant config => HasGHCVariant (Env config) where+ getGHCVariant = getGHCVariant . envConfig instance HasConfig config => HasConfig (Env config) where getConfig = getConfig . envConfig instance HasBuildConfig config => HasBuildConfig (Env config) where
src/Stack/Types/Package.hs view
@@ -29,6 +29,7 @@ import Distribution.ModuleName (ModuleName) import Distribution.Package hiding (Package,PackageName,packageName,packageVersion,PackageIdentifier) import Distribution.System (Platform (..))+import Distribution.Text (display) import GHC.Generics import Path as FL import Prelude@@ -95,11 +96,13 @@ -- | 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)+ { getPackageOpts :: forall env m. (MonadIO m,HasEnvConfig env, HasPlatform env, MonadThrow m, MonadReader env m, MonadLogger m, MonadCatch m) => SourceMap -> [PackageName] -> Path Abs File- -> m (Map NamedComponent [String],[String])+ -> m (Map NamedComponent (Set ModuleName)+ ,Map NamedComponent (Set DotCabalPath)+ ,Map NamedComponent [String],[String]) } instance Show GetPackageOpts where show _ = "<GetPackageOpts>"@@ -115,19 +118,36 @@ { getPackageFiles :: forall m env. (MonadIO m, MonadLogger m, MonadThrow m, MonadCatch m, MonadReader env m, HasPlatform env, HasEnvConfig env) => Path Abs File -> m (Map NamedComponent (Set ModuleName)- ,Map NamedComponent (Set (Path Abs File))- ,Map NamedComponent (Set (Path Abs File))- ,Map NamedComponent (Set MainIs)- ,Set (Path Abs File))+ ,Map NamedComponent (Set DotCabalPath)+ ,Set (Path Abs File)+ ,[PackageWarning]) } instance Show GetPackageFiles where show _ = "<GetPackageFiles>" --- | A file specified as @main-is@ in a .cabal file.-newtype MainIs = MainIs- { mainIsFile :: Path Abs File- }- deriving (Ord,Eq)+-- | Warning generated when reading a package+data PackageWarning+ = UnlistedModulesWarning (Path Abs File) (Maybe String) [ModuleName]+ -- ^ Modules found that are not listed in cabal file+instance Show PackageWarning where+ show (UnlistedModulesWarning cabalfp component [unlistedModule]) =+ concat+ [ "module not listed in "+ , toFilePath (filename cabalfp)+ , (case component of+ Nothing -> " for library"+ Just c -> " for '" ++ c ++ "'")+ , " component (add to other-modules): "+ , display unlistedModule]+ show (UnlistedModulesWarning cabalfp component unlistedModules) =+ concat+ [ "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 unlistedModules)] -- | Package build configuration data PackageConfig =@@ -236,9 +256,69 @@ } deriving (Generic, Show) instance Binary FileCacheInfo-instance NFData FileCacheInfo where- rnf = genericRnf+instance HasStructuralInfo FileCacheInfo+instance NFData FileCacheInfo -- | Used for storage and comparison. newtype ModTime = ModTime (Integer,Rational) deriving (Ord,Show,Generic,Eq,NFData,Binary)++instance HasStructuralInfo ModTime+instance HasSemanticVersion ModTime++-- | A descriptor from a .cabal file indicating one of the following:+--+-- exposed-modules: Foo+-- other-modules: Foo+-- or+-- main-is: Foo.hs+--+data DotCabalDescriptor+ = DotCabalModule !ModuleName+ | DotCabalMain !FilePath+ | DotCabalFile !FilePath+ | DotCabalCFile !FilePath+ deriving (Eq,Ord,Show)++-- | Maybe get the module name from the .cabal descriptor.+dotCabalModule :: DotCabalDescriptor -> Maybe ModuleName+dotCabalModule (DotCabalModule m) = Just m+dotCabalModule _ = Nothing++-- | Maybe get the main name from the .cabal descriptor.+dotCabalMain :: DotCabalDescriptor -> Maybe FilePath+dotCabalMain (DotCabalMain m) = Just m+dotCabalMain _ = Nothing++-- | A path resolved from the .cabal file, which is either main-is or+-- an exposed/internal/referenced module.+data DotCabalPath+ = DotCabalModulePath !(Path Abs File)+ | DotCabalMainPath !(Path Abs File)+ | DotCabalFilePath !(Path Abs File)+ | DotCabalCFilePath !(Path Abs File)+ deriving (Eq,Ord,Show)++-- | Get the module path.+dotCabalModulePath :: DotCabalPath -> Maybe (Path Abs File)+dotCabalModulePath (DotCabalModulePath fp) = Just fp+dotCabalModulePath _ = Nothing++-- | Get the main path.+dotCabalMainPath :: DotCabalPath -> Maybe (Path Abs File)+dotCabalMainPath (DotCabalMainPath fp) = Just fp+dotCabalMainPath _ = Nothing++-- | Get the c file path.+dotCabalCFilePath :: DotCabalPath -> Maybe (Path Abs File)+dotCabalCFilePath (DotCabalCFilePath fp) = Just fp+dotCabalCFilePath _ = Nothing++-- | Get the path.+dotCabalGetPath :: DotCabalPath -> Path Abs File+dotCabalGetPath dcp =+ case dcp of+ DotCabalModulePath fp -> fp+ DotCabalMainPath fp -> fp+ DotCabalFilePath fp -> fp+ DotCabalCFilePath fp -> fp
src/Stack/Types/PackageIdentifier.hs view
@@ -25,7 +25,7 @@ import Control.Monad.Catch (MonadThrow, throwM) import Data.Aeson.Extended import Data.Attoparsec.ByteString.Char8-import Data.Binary (Binary)+import Data.Binary.VersionTagged (Binary, HasStructuralInfo) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as S8 import Data.Data@@ -58,6 +58,7 @@ instance Hashable PackageIdentifier instance Binary PackageIdentifier+instance HasStructuralInfo PackageIdentifier instance Show PackageIdentifier where show = show . packageIdentifierString
src/Stack/Types/PackageName.hs view
@@ -31,7 +31,7 @@ import Data.Aeson.Extended import Data.Attoparsec.ByteString.Char8 import Data.Attoparsec.Combinators-import Data.Binary (Binary)+import Data.Binary.VersionTagged (Binary, HasStructuralInfo) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as S8 import Data.Char (isLetter)@@ -72,6 +72,8 @@ instance Show PackageName where show (PackageName n) = S8.unpack n++instance HasStructuralInfo PackageName instance ToJSON PackageName where toJSON = toJSON . packageNameText
src/Stack/Types/Version.hs view
@@ -24,7 +24,8 @@ ,withinRange ,Stack.Types.Version.intersectVersionRanges ,toMajorVersion- ,checkVersion)+ ,checkVersion+ ,nextMajorVersion) where import Control.Applicative@@ -32,7 +33,7 @@ import Control.Monad.Catch import Data.Aeson.Extended import Data.Attoparsec.ByteString.Char8-import Data.Binary (Binary)+import Data.Binary.VersionTagged (Binary, HasStructuralInfo) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as S8 import Data.Data@@ -66,7 +67,7 @@ newtype Version = Version {unVersion :: Vector Word} deriving (Eq,Ord,Typeable,Data,Generic,Binary,NFData)-+instance HasStructuralInfo Version instance Hashable Version where hashWithSalt i = hashWithSalt i . V.toList . unVersion@@ -174,6 +175,14 @@ 0 -> Version (V.fromList [0, 0]) 1 -> Version (V.fromList [V.head v, 0]) _ -> Version (V.fromList [V.head v, v V.! 1])++-- | Get the next major version number for the given version+nextMajorVersion :: Version -> Version+nextMajorVersion (Version v) =+ case V.length v of+ 0 -> Version (V.fromList [0, 1])+ 1 -> Version (V.fromList [V.head v, 1])+ _ -> Version (V.fromList [V.head v, (v V.! 1) + 1]) data VersionCheck = MatchMinor
src/Stack/Upgrade.hs view
@@ -14,6 +14,8 @@ import Data.Monoid ((<>)) import qualified Data.Monoid import qualified Data.Set as Set+import qualified Data.Text as T+import Development.GitRev (gitHash) import Network.HTTP.Client.Conduit (HasHttpManager, getHttpManager) import Path import qualified Paths_stack as Paths@@ -27,6 +29,7 @@ import Stack.Types.Internal import Stack.Types.StackT import System.IO.Temp (withSystemTempDirectory)+import System.Process (readProcess) import System.Process.Run upgrade :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, HasTerminal env, HasReExec env, HasLogLevel env, MonadBaseControl IO m)@@ -38,16 +41,21 @@ tmp <- parseAbsDir tmp' mdir <- case gitRepo of Just repo -> do- $logInfo "Cloning stack"- runIn tmp "git" menv- [ "clone"- , repo- , "stack"- , "--depth"- , "1"- ]- Nothing- return $ Just $ tmp </> $(mkRelDir "stack")+ remote <- liftIO $ readProcess "git" ["ls-remote", repo, "master"] []+ let latestCommit = head . words $ remote+ if (latestCommit == $gitHash) then do+ $logInfo "Already up-to-date, no upgrade required"+ return Nothing+ else do $logInfo "Cloning stack"+ runIn tmp "git" menv+ [ "clone"+ , repo+ , "stack"+ , "--depth"+ , "1"+ ]+ Nothing+ return $ Just $ tmp </> $(mkRelDir "stack") Nothing -> do updateAllIndices menv caches <- getPackageCaches menv@@ -77,18 +85,19 @@ logLevel <- asks getLogLevel terminal <- asks getTerminal reExec <- asks getReExec- configMonoid <- asks $ configConfigMonoid . getConfig+ config <- asks getConfig forM_ mdir $ \dir -> liftIO $ do bconfig <- runStackLoggingT manager logLevel terminal reExec $ do lc <- loadConfig- (configMonoid <> Data.Monoid.mempty+ (configConfigMonoid config <> Data.Monoid.mempty { configMonoidInstallGHC = Just True }) (Just $ dir </> $(mkRelFile "stack.yaml")) lcLoadBuildConfig lc mresolver- envConfig1 <- runStackT manager logLevel bconfig terminal reExec $ setupEnv $ Just- "Try rerunning with --install-ghc to install the appropriate GHC"+ envConfig1 <- runStackT manager logLevel bconfig terminal reExec $ setupEnv $ Just $+ "Try rerunning with --install-ghc to install the correct GHC into " <>+ T.pack (toFilePath (configLocalPrograms config)) runStackT manager logLevel envConfig1 terminal reExec $ build (const $ return ()) Nothing defaultBuildOpts { boptsTargets = ["stack"]
src/System/Process/Read.hs view
@@ -59,7 +59,7 @@ import qualified Data.Text.Lazy.Encoding as LT import qualified Data.Text.Lazy as LT import Data.Typeable (Typeable)-import Distribution.System (OS (Windows, OtherOS), Platform (Platform))+import Distribution.System (OS (Windows), Platform (Platform)) import Path (Path, Abs, Dir, toFilePath, File, parseAbsFile) import Path.IO (createTree, parseRelAsAbsFile) import Prelude -- Fix AMP warning@@ -111,7 +111,6 @@ isWindows = case platform of Platform _ Windows -> True- Platform _ (OtherOS "windowsintegersimple") -> True _ -> False -- | Helper conversion function
src/main/Main.hs view
@@ -16,9 +16,9 @@ import qualified Control.Monad.Catch as Catch import Control.Monad.IO.Class import Control.Monad.Logger-import Control.Monad.Reader (ask, asks)+import Control.Monad.Reader (ask, asks, runReaderT) import Control.Monad.Trans.Control (MonadBaseControl)-import Data.Attoparsec.Args (withInterpreterArgs)+import Data.Attoparsec.Args (withInterpreterArgs, parseArgs, EscapingMode (Escaping)) import qualified Data.ByteString.Lazy as L import Data.IORef import Data.List@@ -61,6 +61,7 @@ import Stack.Package (getCabalFileName) import qualified Stack.PackageIndex import Stack.Ghci+import Stack.GhcPkg (getGlobalDB, mkGhcPackagePath) import Stack.SDist (getSDistTarball) import Stack.Setup import Stack.Solver (solveExtraDeps)@@ -70,7 +71,7 @@ import Stack.Upgrade import qualified Stack.Upload as Upload import System.Directory (canonicalizePath, doesFileExist, doesDirectoryExist, createDirectoryIfMissing)-import System.Environment (getProgName)+import System.Environment (getEnvironment, getProgName) import System.Exit import System.FileLock (lockFile, tryLockFile, unlockFile, SharedExclusive(Exclusive), FileLock) import System.FilePath (dropTrailingPathSeparator, searchPathSeparator)@@ -154,7 +155,8 @@ [ [$(simpleVersion Meta.version)] -- Leave out number of commits for --depth=1 clone -- See https://github.com/commercialhaskell/stack/issues/792- , [" (" ++ $gitCommitCount ++ " commits)" | $gitCommitCount /= ("1"::String)]+ , [" (" ++ $gitCommitCount ++ " commits)" | $gitCommitCount /= ("1"::String) &&+ $gitCommitCount /= ("UNKNOWN" :: String)] , [" ", show buildArch] ] @@ -253,11 +255,15 @@ addCommand "upload" "Upload a package to Hackage" uploadCmd- (many $ strArgument $ metavar "TARBALL/DIR")+ ((,)+ <$> (many $ strArgument $ metavar "TARBALL/DIR")+ <*> optional pvpBoundsOption) addCommand "sdist" "Create source distribution tarballs" sdistCmd- (many $ strArgument $ metavar "DIR")+ ((,)+ <$> (many $ strArgument $ metavar "DIR")+ <*> optional pvpBoundsOption) addCommand "dot" "Visualize your project's dependency graph using Graphviz dot" dotCmd@@ -343,7 +349,7 @@ , " as a script interpreter, a\n'-- " , stackProgName , " [options] runghc [options]' comment is required."- , "\nSee https://github.com/commercialhaskell/stack/wiki/Script-interpreter" ]+ , "\nSee https://github.com/commercialhaskell/stack/blob/master/doc/GUIDE.md#ghcrunghc" ] throwIO exitCode Right (global,run) -> do when (globalLogLevel global == LevelDebug) $ hPutStrLn stderr versionString'@@ -371,6 +377,7 @@ menv <- getMinimalEnvOverride snap <- packageDatabaseDeps local <- packageDatabaseLocal+ global <- getGlobalDB menv =<< getWhichCompiler snaproot <- installationRootDeps localroot <- installationRootLocal distDir <- distRelativeDir@@ -390,6 +397,7 @@ menv snap local+ global snaproot localroot distDir))))@@ -400,6 +408,7 @@ ,piEnvOverride :: EnvOverride ,piSnapDb :: Path Abs Dir ,piLocalDb :: Path Abs Dir+ ,piGlobalDb :: Path Abs Dir ,piSnapRoot :: Path Abs Dir ,piLocalRoot :: Path Abs Dir ,piDistDir :: Path Rel Dir@@ -458,6 +467,13 @@ , "local-pkg-db" , \pi -> T.pack (toFilePathNoTrailing (piLocalDb pi)))+ , ( "Global package database"+ , "global-pkg-db"+ , \pi ->+ T.pack (toFilePathNoTrailing (piGlobalDb pi)))+ , ( "GHC_PACKAGE_PATH environment variable"+ , "ghc-package-path"+ , \pi -> mkGhcPackagePath True (piLocalDb pi) (piSnapDb pi) (piGlobalDb pi)) , ( "Snapshot installation root" , "snapshot-install-root" , \pi ->@@ -484,12 +500,14 @@ { scoCompilerVersion :: !(Maybe CompilerVersion) , scoForceReinstall :: !Bool , scoUpgradeCabal :: !Bool+ , scoStackSetupYaml :: !String+ , scoGHCBindistURL :: !(Maybe String) } setupParser :: Parser SetupCmdOpts setupParser = SetupCmdOpts <$> (optional $ argument readVersion- (metavar "GHC_MAJOR_VERSION" <>+ (metavar "GHC_VERSION" <> help ("Version of GHC to install, e.g. 7.10.2. " ++ "The default is to install the version implied by the resolver."))) <*> boolFlags False@@ -500,6 +518,17 @@ "upgrade-cabal" "installing the newest version of the Cabal library globally" idm+ <*> strOption+ ( long "stack-setup-yaml"+ <> help "Location of the main stack-setup.yaml file"+ <> value defaultStackSetupYaml+ <> showDefault+ )+ <*> (optional $ strOption+ (long "ghc-bindist"+ <> metavar "URL"+ <> help "Alternate GHC binary distribution (requires custom --ghc-variant)"+ )) where readVersion = do s <- readerAsk@@ -525,7 +554,8 @@ , configCompilerCheck (lcConfig lc) , Just $ bcStackYaml bc )- mpaths <- runStackTGlobal manager (lcConfig lc) go $+ miniConfig <- loadMiniConfig (lcConfig lc)+ mpaths <- runStackTGlobal manager miniConfig go $ ensureGHC SetupOpts { soptsInstallIfMissing = True , soptsUseSystem =@@ -540,6 +570,8 @@ , soptsSkipMsys = configSkipMsys $ lcConfig lc , soptsUpgradeCabal = scoUpgradeCabal , soptsResolveMissingGHC = Nothing+ , soptsStackSetupYaml = scoStackSetupYaml+ , soptsGHCBindistURL = scoGHCBindistURL } case mpaths of Nothing -> $logInfo "stack will use the GHC on your PATH"@@ -549,8 +581,13 @@ $logInfo "stack ghc, stack ghci, stack runghc, or stack exec" ) Nothing- (Just $ liftIO$ unlockFile lk)+ (Just $ munlockFile lk) +-- | Unlock a lock file, if the value is Just+munlockFile :: MonadIO m => Maybe FileLock -> m ()+munlockFile Nothing = return ()+munlockFile (Just lk) = liftIO $ unlockFile lk+ -- | Enforce mutual exclusion of every action running via this -- function, on this path, on this users account. --@@ -560,27 +597,32 @@ -- withUserFileLock :: (MonadBaseControl IO m, MonadIO m) => Path Abs Dir- -> (FileLock -> m a)+ -> (Maybe 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 $ hPutStrLn stderr $ "Failed to grab lock ("++show pth++- "); other stack instance running. Waiting..."- EL.bracket (liftIO $ lockFile (toFilePath pth) Exclusive)- (liftIO . unlockFile)- (\lk -> do- liftIO $ hPutStrLn stderr "Lock acquired, proceeding."- act lk))+ env <- liftIO getEnvironment+ let toLock = lookup "STACK_LOCK" env == Just "true"+ if toLock+ then 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 $ Just lk) (liftIO $ unlockFile lk)+ Nothing ->+ do liftIO $ hPutStrLn stderr $ "Failed to grab lock ("++show pth+++ "); other stack instance running. Waiting..."+ EL.bracket (liftIO $ lockFile (toFilePath pth) Exclusive)+ (liftIO . unlockFile)+ (\lk -> do+ liftIO $ hPutStrLn stderr "Lock acquired, proceeding."+ act $ Just lk))+ else act Nothing withConfigAndLock :: GlobalOpts -> StackT Config IO ()@@ -593,7 +635,7 @@ Nothing (runStackTGlobal manager (lcConfig lc) go inner) Nothing- (Just $ liftIO $ unlockFile lk)+ (Just $ munlockFile lk) -- For now the non-locking version just unlocks immediately. -- That is, there's still a serialization point.@@ -601,11 +643,11 @@ -> (StackT EnvConfig IO ()) -> IO () withBuildConfig go inner =- withBuildConfigAndLock go (\lk -> do liftIO $ unlockFile lk+ withBuildConfigAndLock go (\lk -> do munlockFile lk inner) withBuildConfigAndLock :: GlobalOpts- -> (FileLock -> StackT EnvConfig IO ())+ -> (Maybe FileLock -> StackT EnvConfig IO ()) -> IO () withBuildConfigAndLock go inner = withBuildConfigExt go Nothing inner Nothing@@ -617,7 +659,7 @@ -- 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 ())+ -> (Maybe 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 ())@@ -640,7 +682,7 @@ -- Hand-over-hand locking: withUserFileLock dir $ \lk2 -> do liftIO $ writeIORef curLk lk2- liftIO $ unlockFile lk+ liftIO $ munlockFile lk inner lk2 let inner'' lk = do@@ -660,26 +702,32 @@ Docker.reexecWithOptionalContainer (lcProjectRoot lc) mbefore (inner'' lk0) mafter (Just $ liftIO $ do lk' <- readIORef curLk- unlockFile lk')+ munlockFile lk') cleanCmd :: () -> GlobalOpts -> IO () cleanCmd () go = withBuildConfigAndLock go (\_ -> clean) -- | Helper for build and install commands buildCmd :: BuildOpts -> GlobalOpts -> IO ()-buildCmd opts go- | boptsFileWatch opts =- let getProjectRoot =- do (manager, lc) <- loadConfigWithOpts go- bconfig <-- runStackLoggingTGlobal manager go $- lcLoadBuildConfig lc (globalResolver go)- return (bcRoot bconfig)- in fileWatch getProjectRoot inner- | otherwise = inner $ const $ return ()+buildCmd opts go = do+ when (any (("-prof" `elem`) . either (const []) id . parseArgs Escaping) (boptsGhcOptions opts)) $ do+ hPutStrLn stderr "When building with stack, you should not use the -prof GHC option"+ hPutStrLn stderr "Instead, please use --enable-library-profiling and --enable-executable-profiling"+ hPutStrLn stderr "See: https://github.com/commercialhaskell/stack/issues/1015"+ error "-prof GHC option submitted"+ case boptsFileWatch opts of+ FileWatchPoll -> fileWatchPoll getProjectRoot inner+ FileWatch -> fileWatch getProjectRoot inner+ NoFileWatch -> inner $ const $ return () where inner setLocalFiles = withBuildConfigAndLock go $ \lk ->- globalFixCodePage go $ Stack.Build.build setLocalFiles (Just lk) opts+ globalFixCodePage go $ Stack.Build.build setLocalFiles lk opts+ getProjectRoot = do+ (manager, lc) <- loadConfigWithOpts go+ bconfig <-+ runStackLoggingTGlobal manager go $+ lcLoadBuildConfig lc (globalResolver go)+ return (bcRoot bconfig) globalFixCodePage :: (Catch.MonadMask m, MonadIO m, MonadLogger m) => GlobalOpts@@ -711,9 +759,9 @@ upgrade (if fromGit then Just repo else Nothing) (globalResolver go) -- | Upload to Hackage-uploadCmd :: [String] -> GlobalOpts -> IO ()-uploadCmd [] _ = error "To upload the current package, please run 'stack upload .'"-uploadCmd args go = do+uploadCmd :: ([String], Maybe PvpBounds) -> GlobalOpts -> IO ()+uploadCmd ([], _) _ = error "To upload the current package, please run 'stack upload .'"+uploadCmd (args, mpvpBounds) go = do let partitionM _ [] = return ([], []) partitionM f (x:xs) = do r <- f x@@ -741,18 +789,18 @@ liftIO $ forM_ files (canonicalizePath >=> Upload.upload uploader) forM_ dirs $ \dir -> do pkgDir <- parseAbsDir =<< liftIO (canonicalizePath dir)- (tarName, tarBytes) <- getSDistTarball pkgDir+ (tarName, tarBytes) <- getSDistTarball mpvpBounds pkgDir liftIO $ Upload.uploadBytes uploader tarName tarBytes -sdistCmd :: [String] -> GlobalOpts -> IO ()-sdistCmd dirs go =+sdistCmd :: ([String], Maybe PvpBounds) -> GlobalOpts -> IO ()+sdistCmd (dirs, mpvpBounds) 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+ (tarName, tarBytes) <- getSDistTarball mpvpBounds dir distDir <- distDirFromDir dir tarPath <- fmap (distDir </>) $ parseRelFile tarName liftIO $ createTree $ parent tarPath@@ -761,7 +809,12 @@ -- | Execute a command. execCmd :: ExecOpts -> GlobalOpts -> IO ()-execCmd ExecOpts {..} go@GlobalOpts{..} =+execCmd ExecOpts {..} go@GlobalOpts{..} = do+ (cmd, args) <-+ case (eoCmd, eoArgs) of+ (Just cmd, args) -> return (cmd, args)+ (Nothing, cmd:args) -> return (cmd, args)+ (Nothing, []) -> error "You must provide a command to exec, e.g. 'stack exec echo Hello World'" case eoExtra of ExecOptsPlain -> do (manager,lc) <- liftIO $ loadConfigWithOpts go@@ -769,22 +822,22 @@ runStackTGlobal manager (lcConfig lc) go $ Docker.execWithOptionalContainer (lcProjectRoot lc)- (return (eoCmd, eoArgs, [], id))+ (return (cmd, args, [], id)) -- Unlock before transferring control away, whether using docker or not:- (Just $ liftIO $ unlockFile lk)+ (Just $ munlockFile lk) (runStackTGlobal manager (lcConfig lc) go $ do- exec plainEnvSettings eoCmd eoArgs)+ exec plainEnvSettings cmd args) Nothing Nothing -- Unlocked already above. ExecOptsEmbellished {..} -> withBuildConfigAndLock go $ \lk -> do let targets = concatMap words eoPackages unless (null targets) $ globalFixCodePage go $- Stack.Build.build (const $ return ()) (Just lk) defaultBuildOpts+ Stack.Build.build (const $ return ()) lk defaultBuildOpts { boptsTargets = map T.pack targets }- liftIO $ unlockFile lk -- Unlock before transferring control away.- exec eoEnvSettings eoCmd eoArgs+ munlockFile lk -- Unlock before transferring control away.+ exec eoEnvSettings cmd args -- | Run GHCi in the context of a project. ghciCmd :: GhciOpts -> GlobalOpts -> IO ()@@ -792,10 +845,10 @@ withBuildConfigAndLock go $ \lk -> do let packageTargets = concatMap words (ghciAdditionalPackages ghciOpts) unless (null packageTargets) $ globalFixCodePage go $- Stack.Build.build (const $ return ()) (Just lk) defaultBuildOpts+ Stack.Build.build (const $ return ()) lk defaultBuildOpts { boptsTargets = map T.pack packageTargets }- liftIO $ unlockFile lk -- Don't hold the lock while in the GHCI.+ munlockFile lk -- Don't hold the lock while in the GHCI. ghci ghciOpts -- | Run ide-backend in the context of a project.@@ -853,7 +906,7 @@ do globalFixCodePage go $ Stack.Build.build (const (return ()))- (Just lk)+ lk defaultBuildOpts Image.stageContainerImageArtifacts) (Just Image.createContainerImageFromStage)@@ -880,14 +933,18 @@ initCmd initOpts go = withConfigAndLock go $ do pwd <- getWorkingDir- initProject pwd initOpts+ config <- asks getConfig+ miniConfig <- loadMiniConfig config+ runReaderT (initProject pwd initOpts) miniConfig -- | 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+ config <- asks getConfig+ miniConfig <- loadMiniConfig config+ runReaderT (initProject dir initOpts) miniConfig -- | List the available templates. templatesCmd :: () -> GlobalOpts -> IO ()
src/test/Stack/PackageDumpSpec.hs view
@@ -66,6 +66,7 @@ $$ conduitDumpPackage =$ CL.consume ghcPkgId <- parseGhcPkgId "haskell2010-1.1.2.0-05c8dd51009e08c6371c82972d40f55a"+ packageIdent <- parsePackageIdentifier "haskell2010-1.1.2.0" depends <- mapM parseGhcPkgId [ "array-0.5.0.0-470385a50d2b78598af85cfe9d988e1b" , "base-4.7.0.2-bfd89587617e381ae01b8dd7b6c7f1c1"@@ -73,6 +74,7 @@ ] haskell2010 `shouldBe` DumpPackage { dpGhcPkgId = ghcPkgId+ , dpPackageIdent = packageIdent , dpLibDirs = ["/opt/ghc/7.8.4/lib/ghc-7.8.4/haskell2010-1.1.2.0"] , dpDepends = depends , dpLibraries = ["HShaskell2010-1.1.2.0"]@@ -80,6 +82,7 @@ , dpHaddockInterfaces = ["/opt/ghc/7.8.4/share/doc/ghc/html/libraries/haskell2010-1.1.2.0/haskell2010.haddock"] , dpProfiling = () , dpHaddock = ()+ , dpIsExposed = False } it "ghc 7.10" $ do@@ -88,6 +91,7 @@ $$ conduitDumpPackage =$ CL.consume ghcPkgId <- parseGhcPkgId "ghc-7.10.1-325809317787a897b7a97d646ceaa3a3"+ pkgIdent <- parsePackageIdentifier "ghc-7.10.1" depends <- mapM parseGhcPkgId [ "array-0.5.1.0-e29cdbe82692341ebb7ce6e2798294f9" , "base-4.8.0.0-1b689eb8d72c4d4cc88f445839c1f01a"@@ -106,6 +110,7 @@ ] haskell2010 `shouldBe` DumpPackage { dpGhcPkgId = ghcPkgId+ , dpPackageIdent = pkgIdent , dpLibDirs = ["/opt/ghc/7.10.1/lib/ghc-7.10.1/ghc_EMlWrQ42XY0BNVbSrKixqY"] , dpHaddockInterfaces = ["/opt/ghc/7.10.1/share/doc/ghc/html/libraries/ghc-7.10.1/ghc.haddock"] , dpDepends = depends@@ -113,6 +118,7 @@ , dpHasExposedModules = True , dpProfiling = () , dpHaddock = ()+ , dpIsExposed = False } it "ghc 7.8.4 (osx)" $ do hmatrix:_ <- runResourceT@@ -120,6 +126,7 @@ $$ conduitDumpPackage =$ CL.consume ghcPkgId <- parseGhcPkgId "hmatrix-0.16.1.5-12d5d21f26aa98774cdd8edbc343fbfe"+ pkgId <- parsePackageIdentifier "hmatrix-0.16.1.5" depends <- mapM parseGhcPkgId [ "array-0.5.0.0-470385a50d2b78598af85cfe9d988e1b" , "base-4.7.0.2-918c7ac27f65a87103264a9f51652d63"@@ -132,6 +139,7 @@ , "vector-0.10.12.3-f4222db607fd5fdd7545d3e82419b307"] hmatrix `shouldBe` DumpPackage { dpGhcPkgId = ghcPkgId+ , dpPackageIdent = pkgId , dpLibDirs = [ "/Users/alexbiehl/.stack/snapshots/x86_64-osx/lts-2.13/7.8.4/lib/x86_64-osx-ghc-7.8.4/hmatrix-0.16.1.5" , "/opt/local/lib/"@@ -143,6 +151,7 @@ , dpHasExposedModules = True , dpProfiling = () , dpHaddock = ()+ , dpIsExposed = True } it "ghcPkgDump + addProfiling + addHaddock" $ (id :: IO () -> IO ()) $ runNoLoggingT $ do
stack.cabal view
@@ -1,5 +1,5 @@ name: stack-version: 0.1.4.1+version: 0.1.5.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@@ -101,6 +101,7 @@ Data.IORef.RunOnce Data.Maybe.Extra Data.Set.Monad+ Distribution.Version.Extra build-depends: Cabal >= 1.18.1.5 , aeson >= 0.8.0.2 , async >= 2.0.2@@ -110,6 +111,7 @@ , base64-bytestring , bifunctors >= 4.2.1 , binary >= 0.7+ , binary-tagged >= 0.1.1 , blaze-builder , byteable , bytestring@@ -119,7 +121,6 @@ , 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@@ -128,6 +129,7 @@ , filelock >= 0.1.0.1 , filepath >= 1.3.0.2 , fsnotify >= 0.2.1+ , gitrev >= 1.1 , hashable >= 1.2.3.2 , http-client >= 0.4.17 , http-client-tls >= 0.2.2@@ -168,7 +170,7 @@ , void >= 0.7 , yaml >= 0.8.10.1 , zlib >= 0.5.4.2- , deepseq+ , deepseq >= 1.3 , file-embed , word8 , hastache
stack.yaml view
@@ -1,6 +1,7 @@ resolver: lts-3.0 extra-deps: - ignore-0.1.1.0+- binary-tagged-0.1.1.0 flags: ignore: without-pcre: true