diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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: diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,6 +1,7 @@ ## The Haskell Tool Stack [![Build Status](https://travis-ci.org/commercialhaskell/stack.svg?branch=master)](https://travis-ci.org/commercialhaskell/stack) +[![Windows build status](https://ci.appveyor.com/api/projects/status/05y9unqcdav7p9xt?svg=true)](https://ci.appveyor.com/project/snoyberg/stack) [![Release](https://img.shields.io/github/release/commercialhaskell/stack.svg)](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 `. 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. + +
+ +## 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 diff --git a/src/Data/Aeson/Extended.hs b/src/Data/Aeson/Extended.hs --- a/src/Data/Aeson/Extended.hs +++ b/src/Data/Aeson/Extended.hs @@ -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] diff --git a/src/Data/Binary/VersionTagged.hs b/src/Data/Binary/VersionTagged.hs --- a/src/Data/Binary/VersionTagged.hs +++ b/src/Data/Binary/VersionTagged.hs @@ -1,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 diff --git a/src/Distribution/Version/Extra.hs b/src/Distribution/Version/Extra.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Version/Extra.hs @@ -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 diff --git a/src/Stack/Build.hs b/src/Stack/Build.hs --- a/src/Stack/Build.hs +++ b/src/Stack/Build.hs @@ -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 diff --git a/src/Stack/Build/Cache.hs b/src/Stack/Build/Cache.hs --- a/src/Stack/Build/Cache.hs +++ b/src/Stack/Build/Cache.hs @@ -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' } diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs --- a/src/Stack/Build/ConstructPlan.hs +++ b/src/Stack/Build/ConstructPlan.hs @@ -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 diff --git a/src/Stack/Build/Coverage.hs b/src/Stack/Build/Coverage.hs --- a/src/Stack/Build/Coverage.hs +++ b/src/Stack/Build/Coverage.hs @@ -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 () diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -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 diff --git a/src/Stack/Build/Haddock.hs b/src/Stack/Build/Haddock.hs --- a/src/Stack/Build/Haddock.hs +++ b/src/Stack/Build/Haddock.hs @@ -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 || diff --git a/src/Stack/Build/Installed.hs b/src/Stack/Build/Installed.hs --- a/src/Stack/Build/Installed.hs +++ b/src/Stack/Build/Installed.hs @@ -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 diff --git a/src/Stack/Build/Source.hs b/src/Stack/Build/Source.hs --- a/src/Stack/Build/Source.hs +++ b/src/Stack/Build/Source.hs @@ -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) + } diff --git a/src/Stack/BuildPlan.hs b/src/Stack/BuildPlan.hs --- a/src/Stack/BuildPlan.hs +++ b/src/Stack/BuildPlan.hs @@ -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))) diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -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 diff --git a/src/Stack/Constants.hs b/src/Stack/Constants.hs --- a/src/Stack/Constants.hs +++ b/src/Stack/Constants.hs @@ -200,7 +200,7 @@ => m (Path Rel Dir) distRelativeDir = do cabalPkgVer <- asks (envConfigCabalVersion . getEnvConfig) - platform <- platformRelDir + platform <- platformVariantRelDir cabal <- parseRelDir $ packageIdentifierString diff --git a/src/Stack/Docker.hs b/src/Stack/Docker.hs --- a/src/Stack/Docker.hs +++ b/src/Stack/Docker.hs @@ -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]) diff --git a/src/Stack/Dot.hs b/src/Stack/Dot.hs --- a/src/Stack/Dot.hs +++ b/src/Stack/Dot.hs @@ -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 diff --git a/src/Stack/FileWatch.hs b/src/Stack/FileWatch.hs --- a/src/Stack/FileWatch.hs +++ b/src/Stack/FileWatch.hs @@ -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) diff --git a/src/Stack/GhcPkg.hs b/src/Stack/GhcPkg.hs --- a/src/Stack/GhcPkg.hs +++ b/src/Stack/GhcPkg.hs @@ -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 diff --git a/src/Stack/Ghci.hs b/src/Stack/Ghci.hs --- a/src/Stack/Ghci.hs +++ b/src/Stack/Ghci.hs @@ -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 diff --git a/src/Stack/Init.hs b/src/Stack/Init.hs --- a/src/Stack/Init.hs +++ b/src/Stack/Init.hs @@ -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] diff --git a/src/Stack/Options.hs b/src/Stack/Options.hs --- a/src/Stack/Options.hs +++ b/src/Stack/Options.hs @@ -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 diff --git a/src/Stack/Package.hs b/src/Stack/Package.hs --- a/src/Stack/Package.hs +++ b/src/Stack/Package.hs @@ -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 +-- +-- /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. diff --git a/src/Stack/PackageDump.hs b/src/Stack/PackageDump.hs --- a/src/Stack/PackageDump.hs +++ b/src/Stack/PackageDump.hs @@ -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 diff --git a/src/Stack/PackageIndex.hs b/src/Stack/PackageIndex.hs --- a/src/Stack/PackageIndex.hs +++ b/src/Stack/PackageIndex.hs @@ -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" diff --git a/src/Stack/SDist.hs b/src/Stack/SDist.hs --- a/src/Stack/SDist.hs +++ b/src/Stack/SDist.hs @@ -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] diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs --- a/src/Stack/Setup.hs +++ b/src/Stack/Setup.hs @@ -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. diff --git a/src/Stack/Solver.hs b/src/Stack/Solver.hs --- a/src/Stack/Solver.hs +++ b/src/Stack/Solver.hs @@ -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'" diff --git a/src/Stack/Types/Build.hs b/src/Stack/Types/Build.hs --- a/src/Stack/Types/Build.hs +++ b/src/Stack/Types/Build.hs @@ -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 diff --git a/src/Stack/Types/BuildPlan.hs b/src/Stack/Types/BuildPlan.hs --- a/src/Stack/Types/BuildPlan.hs +++ b/src/Stack/Types/BuildPlan.hs @@ -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 diff --git a/src/Stack/Types/Compiler.hs b/src/Stack/Types/Compiler.hs --- a/src/Stack/Types/Compiler.hs +++ b/src/Stack/Types/Compiler.hs @@ -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" diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -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) diff --git a/src/Stack/Types/FlagName.hs b/src/Stack/Types/FlagName.hs --- a/src/Stack/Types/FlagName.hs +++ b/src/Stack/Types/FlagName.hs @@ -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 diff --git a/src/Stack/Types/GhcPkgId.hs b/src/Stack/Types/GhcPkgId.hs --- a/src/Stack/Types/GhcPkgId.hs +++ b/src/Stack/Types/GhcPkgId.hs @@ -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 diff --git a/src/Stack/Types/Internal.hs b/src/Stack/Types/Internal.hs --- a/src/Stack/Types/Internal.hs +++ b/src/Stack/Types/Internal.hs @@ -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 diff --git a/src/Stack/Types/Package.hs b/src/Stack/Types/Package.hs --- a/src/Stack/Types/Package.hs +++ b/src/Stack/Types/Package.hs @@ -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 _ = "" @@ -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 _ = "" --- | 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 diff --git a/src/Stack/Types/PackageIdentifier.hs b/src/Stack/Types/PackageIdentifier.hs --- a/src/Stack/Types/PackageIdentifier.hs +++ b/src/Stack/Types/PackageIdentifier.hs @@ -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 diff --git a/src/Stack/Types/PackageName.hs b/src/Stack/Types/PackageName.hs --- a/src/Stack/Types/PackageName.hs +++ b/src/Stack/Types/PackageName.hs @@ -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 diff --git a/src/Stack/Types/Version.hs b/src/Stack/Types/Version.hs --- a/src/Stack/Types/Version.hs +++ b/src/Stack/Types/Version.hs @@ -24,7 +24,8 @@ ,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 diff --git a/src/Stack/Upgrade.hs b/src/Stack/Upgrade.hs --- a/src/Stack/Upgrade.hs +++ b/src/Stack/Upgrade.hs @@ -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"] diff --git a/src/System/Process/Read.hs b/src/System/Process/Read.hs --- a/src/System/Process/Read.hs +++ b/src/System/Process/Read.hs @@ -59,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 diff --git a/src/main/Main.hs b/src/main/Main.hs --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -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 () diff --git a/src/test/Stack/PackageDumpSpec.hs b/src/test/Stack/PackageDumpSpec.hs --- a/src/test/Stack/PackageDumpSpec.hs +++ b/src/test/Stack/PackageDumpSpec.hs @@ -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 diff --git a/stack.cabal b/stack.cabal --- a/stack.cabal +++ b/stack.cabal @@ -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 diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -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