stack 0.1.2.0 → 0.1.3.0
raw patch · 75 files changed
+6518/−3152 lines, 75 filesdep +Win32dep +deepseq-genericsdep +extradep ~optparse-simple
Dependencies added: Win32, deepseq-generics, extra, filelock, hastache, project-template, retry
Dependency ranges changed: optparse-simple
Files
- ChangeLog.md +49/−0
- README.md +6/−1
- new-template/LICENSE +0/−30
- new-template/Setup.hs +0/−2
- new-template/app/Main.hs +0/−6
- new-template/new-template.cabal +0/−41
- new-template/src/Lib.hs +0/−6
- new-template/test/Spec.hs +0/−2
- src/Data/Aeson/Extended.hs +133/−5
- src/Data/Binary/VersionTagged.hs +43/−5
- src/Network/HTTP/Download.hs +4/−1
- src/Network/HTTP/Download/Verified.hs +25/−7
- src/Options/Applicative/Args.hs +11/−0
- src/Options/Applicative/Builder/Extra.hs +4/−0
- src/Path/IO.hs +97/−85
- src/Stack/Build.hs +33/−8
- src/Stack/Build/Cache.hs +82/−42
- src/Stack/Build/ConstructPlan.hs +111/−57
- src/Stack/Build/Coverage.hs +147/−0
- src/Stack/Build/Execute.hs +243/−204
- src/Stack/Build/Haddock.hs +125/−40
- src/Stack/Build/Installed.hs +1/−1
- src/Stack/Build/Source.hs +228/−220
- src/Stack/Build/Target.hs +319/−0
- src/Stack/Build/Types.hs +0/−544
- src/Stack/BuildPlan.hs +94/−19
- src/Stack/Config.hs +76/−110
- src/Stack/Constants.hs +73/−9
- src/Stack/Docker.hs +120/−164
- src/Stack/Docker/GlobalDB.hs +2/−2
- src/Stack/Dot.hs +128/−96
- src/Stack/Exec.hs +27/−23
- src/Stack/Fetch.hs +116/−67
- src/Stack/GhcPkg.hs +45/−8
- src/Stack/Ghci.hs +135/−0
- src/Stack/Ide.hs +47/−65
- src/Stack/Image.hs +217/−0
- src/Stack/Init.hs +46/−67
- src/Stack/New.hs +284/−35
- src/Stack/Options.hs +607/−0
- src/Stack/Package.hs +403/−272
- src/Stack/PackageDump.hs +11/−6
- src/Stack/PackageIndex.hs +28/−17
- src/Stack/Repl.hs +0/−82
- src/Stack/SDist.hs +156/−0
- src/Stack/Setup.hs +285/−74
- src/Stack/Solver.hs +25/−17
- src/Stack/Types.hs +3/−0
- src/Stack/Types/Build.hs +615/−0
- src/Stack/Types/BuildPlan.hs +8/−5
- src/Stack/Types/Config.hs +220/−87
- src/Stack/Types/Docker.hs +15/−26
- src/Stack/Types/FlagName.hs +2/−2
- src/Stack/Types/GhcPkgId.hs +3/−1
- src/Stack/Types/Image.hs +107/−0
- src/Stack/Types/Internal.hs +7/−0
- src/Stack/Types/Package.hs +231/−0
- src/Stack/Types/PackageName.hs +17/−1
- src/Stack/Types/StackT.hs +29/−7
- src/Stack/Types/TemplateName.hs +59/−0
- src/Stack/Types/Version.hs +6/−1
- src/Stack/Upgrade.hs +10/−8
- src/Stack/Upload.hs +18/−49
- src/System/Process/Read.hs +8/−3
- src/System/Process/Run.hs +28/−10
- src/main/Main.hs +435/−454
- src/test/Network/HTTP/Download/VerifiedSpec.hs +5/−3
- src/test/Stack/Build/ExecuteSpec.hs +1/−14
- src/test/Stack/Build/TargetSpec.hs +26/−0
- src/test/Stack/BuildPlanSpec.hs +4/−4
- src/test/Stack/ConfigSpec.hs +9/−8
- src/test/Stack/DotSpec.hs +24/−17
- src/test/Stack/PackageDumpSpec.hs +3/−0
- stack.cabal +30/−12
- stack.yaml +9/−0
ChangeLog.md view
@@ -1,3 +1,52 @@+## 0.1.3.0++Major changes:++* Detect when a module is compiled but not listed in the cabal file ([#32](https://github.com/commercialhaskell/stack/issues/32))+ * A warning is displayed for any modules that should be added to `other-modules` in the .cabal file+ * These modules are taken into account when determining whether a package needs to be built+* Respect TemplateHaskell addDependentFile dependency changes ([#105](https://github.com/commercialhaskell/stack/issues/105))+ * TH dependent files are taken into account when determining whether a package needs to be built.+* Overhauled target parsing, added `--test` and `--bench` options [#651](https://github.com/commercialhaskell/stack/issues/651)+ * For details, see [Build commands Wiki page](https://github.com/commercialhaskell/stack/wiki/Build-command)++Other enhancements:++* Set the `HASKELL_DIST_DIR` environment variable [#524](https://github.com/commercialhaskell/stack/pull/524)+* Track build status of tests and benchmarks [#525](https://github.com/commercialhaskell/stack/issues/525)+* `--no-run-tests` [#517](https://github.com/commercialhaskell/stack/pull/517)+* Targets outside of root dir don't build [#366](https://github.com/commercialhaskell/stack/issues/366)+* Upper limit on number of flag combinations to test [#543](https://github.com/commercialhaskell/stack/issues/543)+* Fuzzy matching support to give better error messages for close version numbers [#504](https://github.com/commercialhaskell/stack/issues/504)+* `--local-bin-path` global option. Use to change where binaries get placed on a `--copy-bins` [#342](https://github.com/commercialhaskell/stack/issues/342)+* Custom snapshots [#111](https://github.com/commercialhaskell/stack/issues/111)+* --force-dirty flag: Force treating all local packages as having dirty files (useful for cases where stack can't detect a file change)+* GHC error messages: display file paths as absolute instead of relative for better editor integration+* Add the `--copy-bins` option [#569](https://github.com/commercialhaskell/stack/issues/569)+* Give warnings on unexpected config keys [#48](https://github.com/commercialhaskell/stack/issues/48)+* Remove Docker `pass-host` option+* Don't require cabal-install to upload [#313](https://github.com/commercialhaskell/stack/issues/313)+* Generate indexes for all deps and all installed snapshot packages [#143](https://github.com/commercialhaskell/stack/issues/143)+* Provide `--resolver global` option [#645](https://github.com/commercialhaskell/stack/issues/645)+ * Also supports `--resolver nightly`, `--resolver lts`, and `--resolver lts-X`+* Make `stack build --flag` error when flag or package is unknown [#617](https://github.com/commercialhaskell/stack/issues/617)+* Preserve file permissions when unpacking sources [#666](https://github.com/commercialhaskell/stack/pull/666)+* `stack build` etc work outside of a project+* `list-dependencies` command [#638](https://github.com/commercialhaskell/stack/issues/638)+* `--upgrade-cabal` option to `stack setup` [#174](https://github.com/commercialhaskell/stack/issues/174)+* `--exec` option [#651](https://github.com/commercialhaskell/stack/issues/651)+* `--only-dependencies` implemented correctly [#387](https://github.com/commercialhaskell/stack/issues/387)++Bug fixes:++* Extensions from the `other-extensions` field no longer enabled by default [#449](https://github.com/commercialhaskell/stack/issues/449)+* Fix: haddock forces rebuild of empty packages [#452](https://github.com/commercialhaskell/stack/issues/452)+* Don't copy over executables excluded by component selection [#605](https://github.com/commercialhaskell/stack/issues/605)+* Fix: stack fails on Windows with git package in stack.yaml and no git binary on path [#712](https://github.com/commercialhaskell/stack/issues/712)+* Fixed GHCi issue: Specifying explicit package versions (#678)+* Fixed GHCi issue: Specifying -odir and -hidir as .stack-work/odir (#529)+* Fixed GHCi issue: Specifying A instead of A.ext for modules (#498) + ## 0.1.2.0 * Add `--prune` flag to `stack dot` [#487](https://github.com/commercialhaskell/stack/issues/487)
README.md view
@@ -1,7 +1,7 @@ ## The Haskell Tool Stack [](https://travis-ci.org/commercialhaskell/stack)-+[](https://github.com/commercialhaskell/stack/releases) `stack` is a cross-platform program for developing Haskell projects. It is aimed at Haskellers both new and experienced.@@ -23,6 +23,9 @@ * [Windows](https://github.com/commercialhaskell/stack/wiki/Downloads#windows) * [OS X](https://github.com/commercialhaskell/stack/wiki/Downloads#os-x) * [Ubuntu](https://github.com/commercialhaskell/stack/wiki/Downloads#ubuntu)+* [Debian](https://github.com/commercialhaskell/stack/wiki/Downloads#debian)+* [CentOS / Red Hat / Amazon Linux](https://github.com/commercialhaskell/stack/wiki/Downloads#centos--red-hat)+* [Fedora](https://github.com/commercialhaskell/stack/wiki/Downloads#fedora) * [Arch Linux](https://github.com/commercialhaskell/stack/wiki/Downloads#arch-linux) * [Linux (general)](https://github.com/commercialhaskell/stack/wiki/Downloads#linux) @@ -63,6 +66,8 @@ to [the stack mailing list](https://groups.google.com/d/forum/haskell-stack). * For bugs, issues, or requests please [open an issue](https://github.com/commercialhaskell/stack/issues/new).+* When using Stack Overflow, please use [the haskell-stack+ tag](http://stackoverflow.com/questions/tagged/haskell-stack). #### Why stack?
− new-template/LICENSE
@@ -1,30 +0,0 @@-Copyright (c) 2015--All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are met:-- * Redistributions of source code must retain the above copyright- notice, this list of conditions and the following disclaimer.-- * Redistributions in binary form must reproduce the above- copyright notice, this list of conditions and the following- disclaimer in the documentation and/or other materials provided- with the distribution.-- * Neither the name of Your name here nor the names of other- contributors may be used to endorse or promote products derived- from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
− new-template/Setup.hs
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
− new-template/app/Main.hs
@@ -1,6 +0,0 @@-module Main where--import Lib--main :: IO ()-main = someFunc
− new-template/new-template.cabal
@@ -1,41 +0,0 @@-name: new-template-version: 0.1.0.0-synopsis: Initial project template from stack-description: Please see README.md-homepage: http://github.com/name/project-license: BSD3-license-file: LICENSE-author: Your name here-maintainer: your.address@example.com--- copyright: -category: Web-build-type: Simple--- extra-source-files: -cabal-version: >=1.10--library- hs-source-dirs: src- exposed-modules: Lib- build-depends: base >= 4.7 && < 5- default-language: Haskell2010--executable new-template-exe- hs-source-dirs: app- main-is: Main.hs- ghc-options: -threaded -rtsopts -with-rtsopts=-N- build-depends: base- , new-template- default-language: Haskell2010--test-suite new-template-test- type: exitcode-stdio-1.0- hs-source-dirs: test- main-is: Spec.hs- build-depends: base- , new-template- ghc-options: -threaded -rtsopts -with-rtsopts=-N- default-language: Haskell2010--source-repository head- type: git- location: https://github.com/name/project
− new-template/src/Lib.hs
@@ -1,6 +0,0 @@-module Lib- ( someFunc- ) where--someFunc :: IO ()-someFunc = putStrLn "someFunc"
− new-template/test/Spec.hs
@@ -1,2 +0,0 @@-main :: IO ()-main = putStrLn "Test suite not yet implemented"
src/Data/Aeson/Extended.hs view
@@ -1,23 +1,151 @@--- | The purpose of this module is to provide better failure messages--- When parsing a key of an object, this makes sure the key itself will show up+{-# LANGUAGE OverloadedStrings, RecordWildCards, TemplateHaskell, TupleSections #-}++-- | Extensions to Aeson parsing of objects. module Data.Aeson.Extended ( module Export+ -- * Extended failure messages , (.:) , (.:?)+ -- * JSON Parser that emits warnings+ , WarningParser+ , JSONWarning (..)+ , withObjectWarnings+ , (..:)+ , (..:?)+ , (..!=)+ , jsonSubWarnings+ , jsonSubWarningsT+ , jsonSubWarningsMT+ , logJSONWarnings ) where +import Control.Monad.Logger (MonadLogger, logWarn)+import Control.Monad.Trans (lift)+import Control.Monad.Trans.Writer.Strict (WriterT, mapWriterT, runWriterT, tell) import Data.Aeson as Export hiding ((.:), (.:?)) import qualified Data.Aeson as A- import Data.Aeson.Types hiding ((.:), (.:?))-+import qualified Data.HashMap.Strict as HashMap+import Data.Monoid (Monoid (..), (<>))+import Data.Set (Set)+import qualified Data.Set as Set import Data.Text (unpack, Text)-import Data.Monoid ((<>))+import qualified Data.Text as T+import Data.Traversable (Traversable)+import qualified Data.Traversable as Traversable +-- | Extends @.:@ warning to include field name. (.:) :: FromJSON a => Object -> Text -> Parser a (.:) o p = modifyFailure (("failed to parse field '" <> unpack p <> "': ") <>) (o A..: p) {-# INLINE (.:) #-} +-- | Extends @.:?@ warning to include field name. (.:?) :: FromJSON a => Object -> Text -> Parser (Maybe a) (.:?) o p = modifyFailure (("failed to parse field '" <> unpack p <> "': ") <>) (o A..:? p) {-# INLINE (.:?) #-}++-- | 'WarningParser' version of @.:@.+(..:)+ :: FromJSON a+ => Object -> Text -> WarningParser a+o ..: k = tellField k >> lift (o .: k)++-- | 'WarningParser' version of @.:?@.+(..:?)+ :: FromJSON a+ => Object -> Text -> WarningParser (Maybe a)+o ..:? k = tellField k >> lift (o .:? k)++-- | 'WarningParser' version of @.!=@.+(..!=) :: WarningParser (Maybe a) -> a -> WarningParser a+wp ..!= d =+ flip mapWriterT wp $+ \p ->+ do a <- fmap snd p+ fmap (, a) (fmap fst p .!= d)++-- | Tell warning parser about about an expected field.+tellField :: Text -> WarningParser ()+tellField key = tell (mempty { wpmExpectedFields = Set.singleton key})++-- | 'MonadParser' version of 'withObject'.+withObjectWarnings :: String+ -> (Object -> WarningParser a)+ -> Value+ -> Parser (a, [JSONWarning])+withObjectWarnings expected f =+ withObject expected $+ \obj ->+ do (a,w) <- runWriterT (f obj)+ let unrecognizedFields =+ Set.toList+ (Set.difference+ (Set.fromList (HashMap.keys obj))+ (wpmExpectedFields w))+ return+ ( a+ , wpmWarnings w +++ case unrecognizedFields of+ [] -> []+ _ -> [JSONUnrecognizedFields expected unrecognizedFields])++-- | Log JSON warnings.+logJSONWarnings+ :: MonadLogger m+ => FilePath -> [JSONWarning] -> m ()+logJSONWarnings fp =+ mapM_ (\w -> $logWarn ("Warning: " <> T.pack fp <> ": " <> T.pack (show w)))++-- | Handle warnings in a sub-object.+jsonSubWarnings :: WarningParser (a, [JSONWarning]) -> WarningParser a+jsonSubWarnings f = do+ (result,warnings) <- f+ tell+ (mempty+ { wpmWarnings = warnings+ })+ return result++-- | Handle warnings in a @Traversable@ of sub-objects.+jsonSubWarningsT+ :: Traversable t+ => WarningParser (t (a, [JSONWarning])) -> WarningParser (t a)+jsonSubWarningsT f =+ Traversable.mapM (jsonSubWarnings . return) =<< f++-- | Handle warnings in a @Maybe Traversable@ of sub-objects.+jsonSubWarningsMT+ :: (Traversable t)+ => WarningParser (Maybe (t (a, [JSONWarning])))+ -> WarningParser (Maybe (t a))+jsonSubWarningsMT f = do+ ml <- f+ case ml of+ Nothing -> return Nothing+ Just l -> fmap Just (jsonSubWarningsT (return l))++-- | JSON parser that warns about unexpected fields in objects.+type WarningParser a = WriterT WarningParserMonoid Parser a++-- | Monoid used by 'MonadParser' to track expected fields and warnings.+data WarningParserMonoid = WarningParserMonoid+ { wpmExpectedFields :: !(Set Text)+ , wpmWarnings :: [JSONWarning]+ }+instance Monoid WarningParserMonoid where+ mempty = WarningParserMonoid Set.empty []+ mappend a b =+ WarningParserMonoid+ { wpmExpectedFields = Set.union+ (wpmExpectedFields a)+ (wpmExpectedFields b)+ , wpmWarnings = wpmWarnings a ++ wpmWarnings b+ }++-- | Warning output from 'WarningParser'.+data JSONWarning = JSONUnrecognizedFields String [Text]+instance Show JSONWarning where+ show (JSONUnrecognizedFields obj [field]) =+ "Unrecognized field in " <> obj <> ": " <> T.unpack field+ show (JSONUnrecognizedFields obj fields) =+ "Unrecognized fields in " <> obj <> ": " <> T.unpack (T.intercalate ", " fields)
src/Data/Binary/VersionTagged.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -- | Tag a Binary instance with the stack version number to ensure we're@@ -5,12 +7,22 @@ module Data.Binary.VersionTagged ( taggedDecodeOrLoad , taggedEncodeFile+ , Binary (..) , BinarySchema (..)+ , decodeFileOrFailDeep+ , encodeFile+ , NFData (..)+ , genericRnf ) where +import Control.DeepSeq.Generics (NFData (..), genericRnf)+import Control.Exception (Exception)+import Control.Monad.Catch (MonadThrow (..)) import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Binary (Binary (..), encodeFile, decodeFileOrFail, putWord8, getWord8)-import Control.Exception.Enclosed (tryIO)+import Data.Binary.Get (ByteOffset)+import Data.Typeable (Typeable)+import Control.Exception.Enclosed (tryAnyDeep) import System.FilePath (takeDirectory) import System.Directory (createDirectoryIfMissing) import qualified Data.ByteString as S@@ -22,10 +34,11 @@ magic = "stack" -- | A @Binary@ instance that also has a schema version-class Binary a => BinarySchema a where+class (Binary a, NFData a) => BinarySchema a where binarySchema :: Proxy a -> Int newtype WithTag a = WithTag a+ deriving NFData instance forall a. BinarySchema a => Binary (WithTag a) where get = do forM_ (S.unpack magic) $ \w -> do@@ -58,10 +71,35 @@ -> m a -> m a taggedDecodeOrLoad fp mx = do- eres <- liftIO $ tryIO $ decodeFileOrFail fp+ eres <- decodeFileOrFailDeep fp case eres of- Right (Right (WithTag x)) -> return x- _ -> do+ Left _ -> do x <- mx taggedEncodeFile fp x return x+ Right (WithTag x) -> return x++-- | Ensure that there are no lurking exceptions deep inside the parsed+-- value... because that happens unfortunately. See+-- https://github.com/commercialhaskell/stack/issues/554+decodeFileOrFailDeep :: (Binary a, NFData a, MonadIO m, MonadThrow n)+ => FilePath+ -> m (n a)+decodeFileOrFailDeep fp = liftIO $ fmap (either throwM return) $ tryAnyDeep $ do+ eres <- decodeFileOrFail fp+ case eres of+ Left (offset, str) -> throwM $ DecodeFileFailure fp offset str+ Right x -> return x++data DecodeFileFailure = DecodeFileFailure FilePath ByteOffset String+ deriving Typeable+instance Show DecodeFileFailure where+ show (DecodeFileFailure fp offset str) = concat+ [ "Decoding of "+ , fp+ , " failed at offset "+ , show offset+ , ": "+ , str+ ]+instance Exception DecodeFileFailure
src/Network/HTTP/Download.hs view
@@ -4,7 +4,9 @@ module Network.HTTP.Download ( verifiedDownload , DownloadRequest(..)+ , drRetryPolicyDefault , HashCheck(..)+ , DownloadException(..) , CheckHexDigest(..) , LengthCheck , VerifiedDownloadException(..)@@ -69,8 +71,9 @@ { drRequest = req , drHashChecks = [] , drLengthCheck = Nothing+ , drRetryPolicy = drRetryPolicyDefault }- let progressHook = return ()+ let progressHook _ = return () verifiedDownload downloadReq destpath progressHook -- | Same as 'download', but will download a file a second time if it is already present.
src/Network/HTTP/Download/Verified.hs view
@@ -9,6 +9,7 @@ module Network.HTTP.Download.Verified ( verifiedDownload , DownloadRequest(..)+ , drRetryPolicyDefault , HashCheck(..) , CheckHexDigest(..) , LengthCheck@@ -27,10 +28,12 @@ import Control.Monad.Catch import Control.Monad.IO.Class import Control.Monad.Reader+import Control.Retry (recovering,limitRetries,RetryPolicy,constantDelay) import Control.Applicative import Crypto.Hash import Crypto.Hash.Conduit (sinkHash) import Data.ByteString (ByteString)+import Data.ByteString.Char8 (readInteger) import Data.Conduit import Data.Conduit.Binary (sourceHandle, sinkHandle) import Data.Foldable (traverse_,for_)@@ -50,9 +53,14 @@ { drRequest :: Request , drHashChecks :: [HashCheck] , drLengthCheck :: Maybe LengthCheck+ , drRetryPolicy :: RetryPolicy }- deriving Show +-- | Default to retrying thrice with a short constant delay.+drRetryPolicyDefault :: RetryPolicy+drRetryPolicyDefault = limitRetries 3 <> constantDelay onehundredMilliseconds+ where onehundredMilliseconds = 100000+ data HashCheck = forall a. (Show a, HashAlgorithm a) => HashCheck { hashCheckAlgorithm :: a , hashCheckHexDigest :: CheckHexDigest@@ -178,22 +186,28 @@ -- * Verifies md5 if response includes content-md5 header -- * Verifies the expected hashes ----- Throws VerifiedDownloadException, and whatever else "download" throws.+-- Throws VerifiedDownloadException.+-- Throws IOExceptions related to file system operations.+-- Throws HttpException. verifiedDownload :: (MonadReader env m, HasHttpManager env, MonadIO m) => DownloadRequest -> Path Abs File -- ^ destination- -> Sink ByteString (ReaderT env IO) () -- ^ custom hook to observe progress+ -> (Maybe Integer -> Sink ByteString (ReaderT env IO) ()) -- ^ custom hook to observe progress -> m Bool -- ^ Whether a download was performed verifiedDownload DownloadRequest{..} destpath progressSink = do let req = drRequest env <- ask liftIO $ whenM' getShouldDownload $ do createDirectoryIfMissing True dir- withBinaryFile fptmp WriteMode $ \h ->- flip runReaderT env $- withResponse req (go h)+ withBinaryFile fptmp WriteMode $ \h -> do+ recovering drRetryPolicy [const $ Handler alwaysRetryHttp] $+ flip runReaderT env $+ withResponse req (go h) renameFile fptmp fp where+ alwaysRetryHttp :: Monad m => HttpException -> m Bool+ alwaysRetryHttp _ = return True+ whenM' mp m = do p <- mp if p then m >> return True else return False@@ -240,6 +254,10 @@ go h res = do let headers = responseHeaders res+ mcontentLength = do+ hLength <- List.lookup hContentLength headers+ (i,_) <- readInteger hLength+ return i for_ drLengthCheck $ checkContentLengthHeader headers let hashChecks = (case List.lookup hContentMD5 headers of Just md5BS ->@@ -257,4 +275,4 @@ ( hashChecksToZipSink drRequest hashChecks *> maybe (pure ()) (assertLengthSink drRequest) drLengthCheck *> ZipSink (sinkHandle h)- *> ZipSink progressSink)+ *> ZipSink (progressSink mcontentLength))
src/Options/Applicative/Args.hs view
@@ -5,6 +5,7 @@ module Options.Applicative.Args (argsArgument ,argsOption+ ,cmdOption ,parseArgsFromString) where @@ -26,6 +27,16 @@ O.option (do string <- O.str either O.readerError return (parseArgsFromString string))++-- | An option which accepts a command and a list of arguments e.g. @--exec "echo hello world"@+cmdOption :: O.Mod O.OptionFields (String, [String]) -> O.Parser (String, [String])+cmdOption =+ O.option+ (do string <- O.str+ xs <- either O.readerError return (parseArgsFromString string)+ case xs of+ [] -> O.readerError "Must provide a command"+ x:xs' -> return (x, xs')) -- | Parse from a string. parseArgsFromString :: String -> Either String [String]
src/Options/Applicative/Builder/Extra.hs view
@@ -36,6 +36,10 @@ -- | Enable/disable flags for any type, without a default (to allow chaining @<|>@s) enableDisableFlagsNoDefault :: a -> a -> String -> String -> Mod FlagFields a -> Parser a enableDisableFlagsNoDefault enabledValue disabledValue name helpSuffix mods =+ last <$> some (enableDisableFlagsNoDefault' enabledValue disabledValue name helpSuffix mods)++enableDisableFlagsNoDefault' :: a -> a -> String -> String -> Mod FlagFields a -> Parser a+enableDisableFlagsNoDefault' enabledValue disabledValue name helpSuffix mods = flag' enabledValue (long name <> help ("Enable " ++ helpSuffix) <>
src/Path/IO.hs view
@@ -4,23 +4,33 @@ module Path.IO (getWorkingDir+ ,parseRelAsAbsDir+ ,parseRelAsAbsFile ,listDirectory ,resolveDir ,resolveFile ,resolveDirMaybe ,resolveFileMaybe ,ResolveException(..)+ ,removeFile ,removeFileIfExists ,removeTree ,removeTreeIfExists- ,fileExists+ ,renameFile ,renameFileIfExists+ ,renameDir ,renameDirIfExists+ ,moveFile ,moveFileIfExists+ ,moveDir ,moveDirIfExists+ ,fileExists ,dirExists+ ,copyFile+ ,copyFileIfExists ,copyDirectoryRecursive- ,createTree)+ ,createTree+ ,dropRoot) where import Control.Exception hiding (catch)@@ -31,7 +41,8 @@ import Data.Maybe import Data.Typeable import Path-import System.Directory+import Path.Internal (Path(..))+import qualified System.Directory as D import qualified System.FilePath as FP import System.IO.Error @@ -47,8 +58,18 @@ -- | Get the current working directory. getWorkingDir :: (MonadIO m) => m (Path Abs Dir)-getWorkingDir = liftIO (canonicalizePath "." >>= parseAbsDir)+getWorkingDir = liftIO (D.canonicalizePath "." >>= parseAbsDir) +-- | Parse a directory path. If it's relative, then the absolute version+-- is yielded, based off the working directory.+parseRelAsAbsDir :: (MonadThrow m, MonadIO m) => FilePath -> m (Path Abs Dir)+parseRelAsAbsDir fp = parseAbsDir =<< liftIO (D.canonicalizePath fp)++-- | Parse a file path. If it's relative, then the absolute version is+-- yielded, based off the working directory.+parseRelAsAbsFile :: (MonadThrow m, MonadIO m) => FilePath -> m (Path Abs File)+parseRelAsAbsFile fp = parseAbsFile =<< liftIO (D.canonicalizePath fp)+ -- | Appends a stringly-typed relative path to an absolute path, and then -- canonicalizes it. resolveDir :: (MonadIO m, MonadThrow m) => Path Abs Dir -> FilePath -> m (Path Abs Dir)@@ -84,7 +105,7 @@ exists <- liftIO $ check fp if exists then do- canonic <- liftIO $ canonicalizePath fp+ canonic <- liftIO $ D.canonicalizePath fp liftM Just (parse canonic) else return Nothing @@ -93,23 +114,23 @@ -- be canonicalized, 'Nothing' is returned). resolveDirMaybe :: (MonadIO m,MonadThrow m) => Path Abs Dir -> FilePath -> m (Maybe (Path Abs Dir))-resolveDirMaybe = resolveCheckParse doesDirectoryExist parseAbsDir+resolveDirMaybe = resolveCheckParse D.doesDirectoryExist parseAbsDir -- | Appends a stringly-typed relative path to an absolute path, and then -- canonicalizes it. If the path doesn't exist (and therefore cannot -- be canonicalized, 'Nothing' is returned). resolveFileMaybe :: (MonadIO m,MonadThrow m) => Path Abs Dir -> FilePath -> m (Maybe (Path Abs File))-resolveFileMaybe = resolveCheckParse doesFileExist parseAbsFile+resolveFileMaybe = resolveCheckParse D.doesFileExist parseAbsFile -- | List objects in a directory, excluding "@.@" and "@..@". Entries are not sorted. listDirectory :: (MonadIO m,MonadThrow m) => Path Abs Dir -> m ([Path Abs Dir],[Path Abs File]) listDirectory dir =- do entriesFP <- liftIO (getDirectoryContents dirFP)+ do entriesFP <- liftIO (D.getDirectoryContents dirFP) maybeEntries <- forM (map (dirFP ++) entriesFP) (\entryFP ->- do isDir <- liftIO (doesDirectoryExist entryFP)+ do isDir <- liftIO (D.doesDirectoryExist entryFP) if isDir then case parseAbsDir entryFP of Nothing -> return Nothing@@ -124,98 +145,79 @@ return (lefts entries,rights entries) where dirFP = toFilePath dir --- | Remove the given file. Optimistically assumes it exists. If it--- doesn't, doesn't complain.+-- | Remove a file. Bails out if it doesn't exist.+removeFile :: MonadIO m => Path b File -> m ()+removeFile = liftIO . D.removeFile . toFilePath++-- | Remove a file. Optimistically assumes it exists. If it doesn't,+-- doesn't complain. removeFileIfExists :: MonadIO m => Path b File -> m ()-removeFileIfExists fp =- liftIO (catch- (removeFile- (toFilePath fp))- (\e ->- if isDoesNotExistError e- then return ()- else throwIO e))+removeFileIfExists = ignoreDoesNotExist . removeFile --- | Move the given file. Optimistically assumes it exists. If it--- doesn't, doesn't complain.-renameFileIfExists :: MonadIO m => Path b File -> Path b File -> m ()-renameFileIfExists from to =- liftIO- (catch- (renameFile (toFilePath from)- (toFilePath to))- (\e ->- if isDoesNotExistError e- then return ()- else throwIO e))+-- | Rename a file. Bails out if it doesn't exist.+renameFile :: MonadIO m => Path b1 File -> Path b2 File -> m ()+renameFile from to = liftIO (D.renameFile (toFilePath from) (toFilePath to)) --- | Rename the directory. Optimistically assumes it exists. If it+-- | Rename a file. Optimistically assumes it exists. If it doesn't,+-- doesn't complain.+renameFileIfExists :: MonadIO m => Path b1 File -> Path b2 File -> m ()+renameFileIfExists from to = ignoreDoesNotExist (renameFile from to)++renameDir :: MonadIO m => Path b1 Dir -> Path b2 Dir -> m ()+renameDir from to = liftIO (D.renameDirectory (toFilePath from) (toFilePath to))++-- | Rename a directory. Optimistically assumes it exists. If it -- doesn't, doesn't complain.-renameDirIfExists :: MonadIO m => Path b Dir -> Path b Dir -> m ()-renameDirIfExists from to =- liftIO- (catch- (renameDirectory (toFilePath from)- (toFilePath to))- (\e ->- if isDoesNotExistError e- then return ()- else throwIO e))+renameDirIfExists :: MonadIO m => Path b1 Dir -> Path b2 Dir -> m ()+renameDirIfExists from to = ignoreDoesNotExist (renameDir from to) -- | Make a directory tree, creating parents if needed. createTree :: MonadIO m => Path b Dir -> m ()-createTree = liftIO . createDirectoryIfMissing True . toFilePath+createTree = liftIO . D.createDirectoryIfMissing True . toFilePath --- | Move the given file. Optimistically assumes it exists. If it--- doesn't, doesn't complain.-moveFileIfExists :: MonadIO m => Path b File -> Path b Dir -> m ()-moveFileIfExists from to =- liftIO- (catch- (renameFile (toFilePath from)- (toFilePath (to </> filename from)))- (\e ->- if isDoesNotExistError e- then return ()- else throwIO e))+-- | Move a file. Bails out if it doesn't exist.+moveFile :: MonadIO m => Path b1 File -> Path b2 Dir -> m ()+moveFile from to = renameFile from (to </> filename from) --- | Move the given dir. Optimistically assumes it exists. If it--- doesn't, doesn't complain.-moveDirIfExists :: MonadIO m => Path b Dir -> Path b Dir -> m ()-moveDirIfExists from to =- liftIO- (catch- (renameDirectory- (toFilePath from)- (toFilePath (to </> dirname from)))- (\e ->- if isDoesNotExistError e- then return ()- else throwIO e))+-- | Move a file. Optimistically assumes it exists. If it doesn't,+-- doesn't complain.+moveFileIfExists :: MonadIO m => Path b1 File -> Path b2 Dir -> m ()+moveFileIfExists from to = ignoreDoesNotExist (moveFile from to) --- | Remove the given tree. Bails out if the directory doesn't exist.+-- | Move a dir. Bails out if it doesn't exist.+moveDir :: MonadIO m => Path b1 Dir -> Path b2 Dir -> m ()+moveDir from to = renameDir from (to </> dirname from)++-- | Move a dir. Optimistically assumes it exists. If it doesn't,+-- doesn't complain.+moveDirIfExists :: MonadIO m => Path b1 Dir -> Path b2 Dir -> m ()+moveDirIfExists from to = ignoreDoesNotExist (moveDir from to)++-- | Remove a tree. Bails out if it doesn't exist. removeTree :: MonadIO m => Path b Dir -> m ()-removeTree =- liftIO . removeDirectoryRecursive . toFilePath+removeTree = liftIO . D.removeDirectoryRecursive . toFilePath -- | Remove tree, don't complain about non-existent directories. removeTreeIfExists :: MonadIO m => Path b Dir -> m ()-removeTreeIfExists fp = do- liftIO (catch (removeTree fp)- (\e -> if isDoesNotExistError e- then return ()- else throwIO e))+removeTreeIfExists = ignoreDoesNotExist . removeTree --- | Does the given file exist?+-- | Does the file exist? fileExists :: MonadIO m => Path b File -> m Bool-fileExists =- liftIO . doesFileExist . toFilePath+fileExists = liftIO . D.doesFileExist . toFilePath --- | Does the given directory exist?+-- | Does the directory exist? dirExists :: MonadIO m => Path b Dir -> m Bool-dirExists =- liftIO . doesDirectoryExist . toFilePath+dirExists = liftIO . D.doesDirectoryExist . toFilePath +-- | Copies a file to another path. Bails out if it doesn't exist.+copyFile :: MonadIO m => Path b1 File -> Path b2 File -> m ()+copyFile from to = liftIO (D.copyFile (toFilePath from) (toFilePath to))++-- | Copies a file to another path. Optimistically assumes it exists. If+-- it doesn't, doesn't complain.+copyFileIfExists :: MonadIO m => Path b1 File -> Path b2 File -> m ()+copyFileIfExists from to = ignoreDoesNotExist (copyFile from to)+ -- | Copy a directory recursively. This just uses 'copyFile', so it is not smart about symbolic -- links or other special files. copyDirectoryRecursive :: (MonadIO m,MonadThrow m)@@ -223,16 +225,26 @@ -> Path Abs Dir -- ^ Destination directory -> m () copyDirectoryRecursive srcDir destDir =- do liftIO (createDirectoryIfMissing False (toFilePath destDir))+ do liftIO (D.createDirectoryIfMissing False (toFilePath destDir)) (srcSubDirs,srcFiles) <- listDirectory srcDir forM_ srcFiles (\srcFile -> case stripDir srcDir srcFile of Nothing -> return ()- Just relFile -> liftIO (copyFile (toFilePath srcFile)- (toFilePath (destDir </> relFile))))+ Just relFile -> copyFile srcFile (destDir </> relFile)) forM_ srcSubDirs (\srcSubDir -> case stripDir srcDir srcSubDir of Nothing -> return () Just relSubDir -> copyDirectoryRecursive srcSubDir (destDir </> relSubDir))+++-- | Drop the root (either @\/@ on POSIX or @C:\\@, @D:\\@, etc. on+-- Windows).+dropRoot :: Path Abs t -> Path Rel t+dropRoot (Path l) = Path (FP.dropDrive l)++-- Utility function for a common pattern of ignoring does-not-exist errors.+ignoreDoesNotExist :: MonadIO m => IO () -> m ()+ignoreDoesNotExist f =+ liftIO $ catch f $ \e -> unless (isDoesNotExistError e) (throwIO e)
src/Stack/Build.hs view
@@ -15,7 +15,8 @@ module Stack.Build (build ,clean- ,withLoadPackage)+ ,withLoadPackage+ ,mkBaseConfigOpts) where import Control.Monad@@ -25,8 +26,8 @@ import Control.Monad.Reader (MonadReader, asks) import Control.Monad.Trans.Resource import Data.Function-import Data.Map.Strict (Map) import qualified Data.Map as Map+import Data.Map.Strict (Map) import Data.Set (Set) import qualified Data.Set as Set import Network.HTTP.Client.Conduit (HasHttpManager)@@ -38,22 +39,28 @@ import Stack.Build.Haddock import Stack.Build.Installed import Stack.Build.Source-import Stack.Build.Types+import Stack.Types.Build import Stack.Constants import Stack.Fetch as Fetch import Stack.GhcPkg import Stack.Package import Stack.Types import Stack.Types.Internal+import System.FileLock (FileLock, unlockFile) type M env m = (MonadIO m,MonadReader env m,HasHttpManager env,HasBuildConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,MonadMask m,HasLogLevel env,HasEnvConfig env,HasTerminal env) --- | Build+-- | Build.+--+-- If a buildLock is passed there is an important contract here. That lock must+-- protect the snapshot, and it must be safe to unlock it if there are no further+-- modifications to the snapshot to be performed by this build. build :: M env m => (Set (Path Abs File) -> IO ()) -- ^ callback after discovering all local files+ -> Maybe FileLock -> BuildOpts -> m ()-build setLocalFiles bopts = do+build setLocalFiles mbuildLk bopts = do menv <- getMinimalEnvOverride (mbp, locals, extraToBuild, sourceMap) <- loadSourceMap bopts@@ -76,15 +83,33 @@ plan <- withLoadPackage menv $ \loadPackage -> constructPlan mbp baseConfigOpts locals extraToBuild locallyRegistered loadPackage sourceMap installedMap + -- If our work to do is all local, let someone else have a turn with the snapshot.+ -- They won't damage what's already in there.+ case (mbuildLk, allLocal plan) of+ -- NOTE: This policy is too conservative. In the future we should be able to+ -- schedule unlocking as an Action that happens after all non-local actions are+ -- complete.+ (Just lk,True) -> do $logDebug "All installs are local; releasing snapshot lock early."+ liftIO $ unlockFile lk+ _ -> return ()+ when (boptsPreFetch bopts) $ preFetch plan if boptsDryrun bopts- then printPlan (boptsFinalAction bopts) plan+ then printPlan plan else executePlan menv bopts baseConfigOpts locals sourceMap plan where profiling = boptsLibProfile bopts || boptsExeProfile bopts +-- | If all the tasks are local, they don't mutate anything outside of our local directory.+allLocal :: Plan -> Bool+allLocal =+ all (== Local) .+ map taskLocation .+ Map.elems .+ planTasks+ -- | Get the @BaseConfigOpts@ necessary for constructing configure options mkBaseConfigOpts :: (MonadIO m, MonadReader env m, HasEnvConfig env, MonadThrow m) => BuildOpts -> m BaseConfigOpts@@ -132,7 +157,7 @@ -- | Reset the build (remove Shake database and .gen files). clean :: (M env m) => m () clean = do- bconfig <- asks getBuildConfig+ econfig <- asks getEnvConfig forM_- (Map.keys (bcPackages bconfig))+ (Map.keys (envConfigPackages econfig)) (distDirFromDir >=> removeTreeIfExists)
src/Stack/Build/Cache.hs view
@@ -20,29 +20,28 @@ , setTestSuccess , unsetTestSuccess , checkTestSuccess+ , setTestBuilt+ , unsetTestBuilt+ , checkTestBuilt+ , setBenchBuilt+ , unsetBenchBuilt+ , checkBenchBuilt ) where -import Control.Exception.Enclosed (catchIO, handleIO, tryIO)-import Control.Monad.Catch (MonadThrow, catch, throwM)+import Control.Exception.Enclosed (handleIO)+import Control.Monad.Catch (MonadThrow) import Control.Monad.IO.Class import Control.Monad.Logger (MonadLogger) import Control.Monad.Reader-import Data.Binary (Binary)-import qualified Data.Binary as Binary-import qualified Data.ByteString as S-import qualified Data.ByteString.Lazy as L+import Data.Binary.VersionTagged import Data.Map (Map) import Data.Maybe (fromMaybe, mapMaybe) import GHC.Generics (Generic) import Path import Path.IO-import Stack.Build.Types+import Stack.Types.Build import Stack.Constants import Stack.Types-import System.Directory (createDirectoryIfMissing,- getDirectoryContents,- removeFile)-import System.IO.Error (isDoesNotExistError) -- | Directory containing files to mark an executable as installed exeInstalledDir :: (MonadReader env m, HasEnvConfig env, MonadThrow m)@@ -55,15 +54,15 @@ => InstallLocation -> m [PackageIdentifier] getInstalledExes loc = do dir <- exeInstalledDir loc- files <- liftIO $ handleIO (const $ return []) $ getDirectoryContents $ toFilePath dir- return $ mapMaybe parsePackageIdentifierFromString files+ (_, files) <- liftIO $ handleIO (const $ return ([], [])) $ listDirectory dir+ return $ mapMaybe (parsePackageIdentifierFromString . toFilePath . filename) files -- | Mark the given executable as installed markExeInstalled :: (MonadReader env m, HasEnvConfig env, MonadIO m, MonadThrow m) => InstallLocation -> PackageIdentifier -> m () markExeInstalled loc ident = do dir <- exeInstalledDir loc- liftIO $ createDirectoryIfMissing True $ toFilePath dir+ createTree dir ident' <- parseRelFile $ packageIdentifierString ident let fp = toFilePath $ dir </> ident' -- TODO consideration for the future: list all of the executables@@ -77,8 +76,7 @@ markExeNotInstalled loc ident = do dir <- exeInstalledDir loc ident' <- parseRelFile $ packageIdentifierString ident- let fp = toFilePath $ dir </> ident'- liftIO $ catchIO (removeFile fp) (\_ -> return ())+ removeFileIfExists (dir </> ident') -- | Stored on disk to know whether the flags have changed or any -- files have changed.@@ -88,6 +86,8 @@ } deriving (Generic) instance Binary BuildCache+instance NFData BuildCache where+ rnf = genericRnf -- | Try to read the dirtiness cache for the given package directory. tryGetBuildCache :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m, HasEnvConfig env)@@ -105,21 +105,11 @@ tryGetCabalMod = tryGetCache configCabalMod -- | Try to load a cache.-tryGetCache :: (MonadIO m, Binary a, MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m, HasEnvConfig env)+tryGetCache :: (MonadIO m, Binary a, NFData a) => (Path Abs Dir -> m (Path Abs File)) -> Path Abs Dir -> m (Maybe a)-tryGetCache get' dir = do- fp <- get' dir- liftIO- (catch- (fmap (decodeMaybe . L.fromStrict) (S.readFile (toFilePath fp)))- (\e -> if isDoesNotExistError e- then return Nothing- else throwM e))- where decodeMaybe =- either (const Nothing) (Just . thd) . Binary.decodeOrFail- where thd (_,_,x) = x+tryGetCache get' dir = get' dir >>= decodeFileOrFailDeep . toFilePath -- | Write the dirtiness cache for this package's files. writeBuildCache :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m, HasEnvConfig env)@@ -158,17 +148,14 @@ removeFileIfExists cfp -- | Write to a cache.-writeCache :: (Binary a, MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env, HasEnvConfig env)+writeCache :: (Binary a, MonadIO m) => Path Abs Dir -> (Path Abs Dir -> m (Path Abs File)) -> a -> m () writeCache dir get' content = do fp <- get' dir- liftIO- (L.writeFile- (toFilePath fp)- (Binary.encode content))+ liftIO $ encodeFile (toFilePath fp) content flagCacheFile :: (MonadIO m, MonadThrow m, MonadReader env m, HasEnvConfig env) => Installed@@ -185,12 +172,8 @@ tryGetFlagCache :: (MonadIO m, MonadThrow m, MonadReader env m, HasEnvConfig env) => Installed -> m (Maybe ConfigCache)-tryGetFlagCache gid = do- file <- flagCacheFile gid- eres <- liftIO $ tryIO $ Binary.decodeFileOrFail $ toFilePath file- case eres of- Right (Right x) -> return $ Just x- _ -> return Nothing+tryGetFlagCache gid =+ flagCacheFile gid >>= decodeFileOrFailDeep . toFilePath writeFlagCache :: (MonadIO m, MonadReader env m, HasEnvConfig env, MonadThrow m) => Installed@@ -199,9 +182,8 @@ writeFlagCache gid cache = do file <- flagCacheFile gid liftIO $ do- createDirectoryIfMissing True $ toFilePath $ parent file-- Binary.encodeFile (toFilePath file) cache+ createTree (parent file)+ encodeFile (toFilePath file) cache -- | Mark a test suite as having succeeded setTestSuccess :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env, HasEnvConfig env)@@ -231,3 +213,61 @@ liftM (fromMaybe False) (tryGetCache testSuccessFile dir)++-- | Mark a test suite as having built+setTestBuilt :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env, HasEnvConfig env)+ => Path Abs Dir+ -> m ()+setTestBuilt dir =+ writeCache+ dir+ testBuiltFile+ True++-- | Mark a test suite as not having built+unsetTestBuilt :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env, HasEnvConfig env)+ => Path Abs Dir+ -> m ()+unsetTestBuilt dir =+ writeCache+ dir+ testBuiltFile+ False++-- | Check if the test suite already built+checkTestBuilt :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env, HasEnvConfig env)+ => Path Abs Dir+ -> m Bool+checkTestBuilt dir =+ liftM+ (fromMaybe False)+ (tryGetCache testBuiltFile dir)++-- | Mark a bench suite as having built+setBenchBuilt :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env, HasEnvConfig env)+ => Path Abs Dir+ -> m ()+setBenchBuilt dir =+ writeCache+ dir+ benchBuiltFile+ True++-- | Mark a bench suite as not having built+unsetBenchBuilt :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env, HasEnvConfig env)+ => Path Abs Dir+ -> m ()+unsetBenchBuilt dir =+ writeCache+ dir+ benchBuiltFile+ False++-- | Check if the bench suite already built+checkBenchBuilt :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env, HasEnvConfig env)+ => Path Abs Dir+ -> m Bool+checkBenchBuilt dir =+ liftM+ (fromMaybe False)+ (tryGetCache benchBuiltFile dir)
src/Stack/Build/ConstructPlan.hs view
@@ -31,15 +31,14 @@ import Data.Text.Encoding (encodeUtf8, decodeUtf8With) import Data.Text.Encoding.Error (lenientDecode) import Distribution.Package (Dependency (..))-import Distribution.Version (anyVersion,- intersectVersionRanges)+import Distribution.Version (anyVersion) import Network.HTTP.Client.Conduit (HasHttpManager) import Prelude hiding (FilePath, pi, writeFile) import Stack.Build.Cache import Stack.Build.Haddock import Stack.Build.Installed import Stack.Build.Source-import Stack.Build.Types+import Stack.Types.Build import Stack.BuildPlan import Stack.Package@@ -75,12 +74,22 @@ | ADRFound InstallLocation Version Installed deriving Show +data W = W+ { wFinals :: !(Map PackageName (Either ConstructPlanException (Task, LocalPackageTB)))+ , wInstall :: !(Map Text InstallLocation)+ -- ^ executable to be installed, and location where the binary is placed+ , wDirty :: !(Map PackageName Text)+ -- ^ why a local package is considered dirty+ , wDeps :: !(Set PackageName)+ -- ^ Packages which count as dependencies+ }+instance Monoid W where+ mempty = W mempty mempty mempty mempty+ mappend (W a b c d) (W w x y z) = W (mappend a w) (mappend b x) (mappend c y) (mappend d z)+ type M = RWST Ctx- ( Map PackageName (Either ConstructPlanException Task) -- finals- , Map Text InstallLocation -- executable to be installed, and location where the binary is placed- , Map PackageName Text -- why a local package is considered dirty- )+ W (Map PackageName (Either ConstructPlanException AddDepRes)) IO @@ -122,14 +131,25 @@ let latest = Map.fromListWith max $ map toTuple $ Map.keys caches econfig <- asks getEnvConfig- let onWanted =- case boptsFinalAction $ bcoBuildOpts baseConfigOpts0 of- DoNothing -> void . addDep . packageName . lpPackage- _ -> addFinal+ let onWanted lp = do+ {-+ - Arguably this is the right thing to do. However, forcing the+ - library to rebuild causes the cabal_macros.h file to change,+ - which makes GHC rebuild everything...++ case lpExeComponents lp of+ Nothing -> return ()+ Just _ -> void $ addDep $ packageName $ lpPackage lp+ -}++ case lpTestBench lp of+ Just tb -> addFinal lp tb+ -- See comment above+ Nothing -> void $ addDep False $ packageName $ lpPackage lp let inner = do mapM_ onWanted $ filter lpWanted locals- mapM_ addDep $ Set.toList extraToBuild0- ((), m, (efinals, installExes, dirtyReason)) <- liftIO $ runRWST inner (ctx econfig latest) M.empty+ mapM_ (addDep False) $ Set.toList extraToBuild0+ ((), m, W efinals installExes dirtyReason deps) <- liftIO $ runRWST inner (ctx econfig latest) M.empty let toEither (_, Left e) = Left e toEither (k, Right v) = Right (k, v) (errlibs, adrs) = partitionEithers $ map toEither $ M.toList m@@ -140,11 +160,12 @@ let toTask (_, ADRFound _ _ _) = Nothing toTask (name, ADRToInstall task) = Just (name, task) tasks = M.fromList $ mapMaybe toTask adrs- maybeStripLocals- | boptsOnlySnapshot $ bcoBuildOpts baseConfigOpts0 =- stripLocals- | otherwise = id- return $ maybeStripLocals Plan+ takeSubset =+ case boptsBuildSubset $ bcoBuildOpts baseConfigOpts0 of+ BSAll -> id+ BSOnlySnapshot -> stripLocals+ BSOnlyDependencies -> stripNonDeps deps+ return $ takeSubset Plan { planTasks = tasks , planFinals = M.fromList finals , planUnregisterLocal = mkUnregisterLocal tasks dirtyReason locallyRegistered@@ -193,14 +214,14 @@ ident = ghcPkgIdPackageIdentifier gid name = packageIdentifierName ident -addFinal :: LocalPackage -> M ()-addFinal lp = do- depsRes <- addPackageDeps package+addFinal :: LocalPackage -> LocalPackageTB -> M ()+addFinal lp lptb = do+ depsRes <- addPackageDeps False package res <- case depsRes of Left e -> return $ Left e Right (missing, present, _minLoc) -> do ctx <- ask- return $ Right Task+ return $ Right (Task { taskProvides = PackageIdentifier (packageName package) (packageVersion package)@@ -215,32 +236,38 @@ package , taskPresent = present , taskType = TTLocal lp- }- tell (Map.singleton (packageName package) res, mempty, mempty)+ }, lptb)+ tell mempty { wFinals = Map.singleton (packageName package) res } where- package = lpPackageFinal lp+ package = lptbPackage lptb -addDep :: PackageName -> M (Either ConstructPlanException AddDepRes)-addDep name = do+addDep :: Bool -- ^ is this being used by a dependency?+ -> PackageName -> M (Either ConstructPlanException AddDepRes)+addDep treatAsDep' name = do+ ctx <- ask+ let treatAsDep = treatAsDep' || name `Set.notMember` wanted ctx+ when treatAsDep $ markAsDep name m <- get case Map.lookup name m of Just res -> return res Nothing -> do- res <- addDep' name+ res <- addDep' treatAsDep name modify $ Map.insert name res return res -addDep' :: PackageName -> M (Either ConstructPlanException AddDepRes)-addDep' name = do+addDep' :: Bool -- ^ is this being used by a dependency?+ -> PackageName -> M (Either ConstructPlanException AddDepRes)+addDep' treatAsDep name = do ctx <- ask if name `elem` callStack ctx then return $ Left $ DependencyCycleDetected $ name : callStack ctx else local (\ctx' -> ctx' { callStack = name : callStack ctx' }) $ do- (addDep'' name)+ (addDep'' treatAsDep name) -addDep'' :: PackageName -> M (Either ConstructPlanException AddDepRes)-addDep'' name = do+addDep'' :: Bool -- ^ is this being used by a dependency?+ -> PackageName -> M (Either ConstructPlanException AddDepRes)+addDep'' treatAsDep name = do ctx <- ask case Map.lookup name $ combinedMap ctx of -- TODO look up in the package index and see if there's a@@ -251,12 +278,12 @@ return $ Right $ ADRFound loc version installed Just (PIOnlySource ps) -> do tellExecutables name ps- installPackage name ps+ installPackage treatAsDep name ps Just (PIBoth ps installed) -> do tellExecutables name ps- needInstall <- checkNeedInstall name ps installed (wanted ctx)+ needInstall <- checkNeedInstall treatAsDep name ps installed (wanted ctx) if needInstall- then installPackage name ps+ then installPackage treatAsDep name ps else return $ Right $ ADRFound (piiLocation ps) (piiVersion ps) installed tellExecutables :: PackageName -> PackageSource -> M () -- TODO merge this with addFinal above?@@ -274,19 +301,39 @@ tellExecutablesPackage loc p tellExecutablesPackage :: InstallLocation -> Package -> M ()-tellExecutablesPackage loc p =- tell (Map.empty, m, Map.empty)+tellExecutablesPackage loc p = do+ cm <- asks combinedMap+ -- Determine which components are enabled so we know which ones to copy+ let myComps =+ case Map.lookup (packageName p) cm of+ Nothing -> assert False Set.empty+ Just (PIOnlyInstalled _ _ _) -> Set.empty+ Just (PIOnlySource ps) -> goSource ps+ Just (PIBoth ps _) -> goSource ps++ goSource (PSLocal lp) = fromMaybe Set.empty $ lpExeComponents lp+ goSource (PSUpstream _ _ _) = Set.empty++ tell mempty { wInstall = m myComps } where- m = Map.fromList $ map (, loc) $ Set.toList $ packageExes p+ m myComps = Map.fromList $ map (, loc) $ Set.toList+ $ filterComps myComps $ packageExes p + filterComps myComps x+ | Set.null myComps = x+ | otherwise = Set.intersection x $ Set.map toExe myComps++ toExe x = fromMaybe x $ T.stripPrefix "exe:" x+ -- TODO There are a lot of duplicated computations below. I've kept that for -- simplicity right now -installPackage :: PackageName -> PackageSource -> M (Either ConstructPlanException AddDepRes)-installPackage name ps = do+installPackage :: Bool -- ^ is this being used by a dependency?+ -> PackageName -> PackageSource -> M (Either ConstructPlanException AddDepRes)+installPackage treatAsDep name ps = do ctx <- ask package <- psPackage name ps- depsRes <- addPackageDeps package+ depsRes <- addPackageDeps treatAsDep package case depsRes of Left e -> return $ Left e Right (missing, present, minLoc) -> do@@ -313,29 +360,31 @@ PSUpstream _ loc _ -> TTUpstream package $ loc <> minLoc } -checkNeedInstall :: PackageName -> PackageSource -> Installed -> Set PackageName -> M Bool-checkNeedInstall name ps installed wanted = assert (piiLocation ps == Local) $ do+checkNeedInstall :: Bool+ -> PackageName -> PackageSource -> Installed -> Set PackageName -> M Bool+checkNeedInstall treatAsDep name ps installed wanted = assert (piiLocation ps == Local) $ do package <- psPackage name ps- depsRes <- addPackageDeps package+ depsRes <- addPackageDeps treatAsDep package case depsRes of Left _e -> return True -- installPackage will find the error again Right (missing, present, _loc) | Set.null missing -> checkDirtiness ps installed package present wanted | otherwise -> do- tell (Map.empty, Map.empty, Map.singleton name $+ tell mempty { wDirty = Map.singleton name $ let t = T.intercalate ", " $ map (T.pack . packageNameString . packageIdentifierName) (Set.toList missing) in T.append "missing dependencies: " $ if T.length t < 100 then t- else T.take 97 t <> "...")+ else T.take 97 t <> "..." } return True -addPackageDeps :: Package -> M (Either ConstructPlanException (Set PackageIdentifier, Set GhcPkgId, InstallLocation))-addPackageDeps package = do+addPackageDeps :: Bool -- ^ is this being used by a dependency?+ -> Package -> M (Either ConstructPlanException (Set PackageIdentifier, Set GhcPkgId, InstallLocation))+addPackageDeps treatAsDep package = do ctx <- ask deps' <- packageDepsWithTools package deps <- forM (Map.toList deps') $ \(depname, range) -> do- eres <- addDep depname+ eres <- addDep treatAsDep depname let mlatest = Map.lookup depname $ latestVersions ctx case eres of Left e ->@@ -385,7 +434,7 @@ , configCacheDeps = present , configCacheComponents = case ps of- PSLocal lp -> Set.map encodeUtf8 $ lpComponents lp+ PSLocal lp -> Set.map renderComponent $ lpComponents lp PSUpstream _ _ _ -> Set.empty , configCacheHaddock = shouldHaddockPackage buildOpts wanted (packageName package) ||@@ -402,7 +451,7 @@ case mreason of Nothing -> return False Just reason -> do- tell (Map.empty, Map.empty, Map.singleton (packageName package) reason)+ tell mempty { wDirty = Map.singleton (packageName package) reason } return True describeConfigDiff :: ConfigCache -> ConfigCache -> Text@@ -476,9 +525,14 @@ TTUpstream _ Local -> False TTUpstream _ Snap -> True -taskLocation :: Task -> InstallLocation-taskLocation =- go . taskType+stripNonDeps :: Set PackageName -> Plan -> Plan+stripNonDeps deps plan = plan+ { planTasks = Map.filter checkTask $ planTasks plan+ , planFinals = Map.empty+ , planInstallExes = Map.empty -- TODO maybe don't disable this?+ } where- go (TTLocal _) = Local- go (TTUpstream _ loc) = loc+ checkTask task = packageIdentifierName (taskProvides task) `Set.member` deps++markAsDep :: PackageName -> M ()+markAsDep name = tell mempty { wDeps = Set.singleton name }
+ src/Stack/Build/Coverage.hs view
@@ -0,0 +1,147 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+-- | Generate HPC (Haskell Program Coverage) reports+module Stack.Build.Coverage+ ( generateHpcReport+ , generateHpcMarkupIndex+ ) where++import Control.Applicative ((<$>))+import Control.Exception.Lifted+import Control.Monad (liftM)+import Control.Monad.Catch (MonadCatch)+import Control.Monad.IO.Class+import Control.Monad.Logger+import Control.Monad.Reader (MonadReader, asks)+import Control.Monad.Trans.Resource+import qualified Data.ByteString.Char8 as S8+import Data.Foldable (forM_)+import Data.Function+import Data.List+import qualified Data.Map.Strict as Map+import Data.Maybe+import Data.Monoid ((<>))+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.IO as T+import qualified Data.Text.Lazy as LT+import Data.Traversable (forM)+import Path+import Path.IO+import Prelude hiding (FilePath, writeFile)+import Stack.Constants+import Stack.Types+import System.Process.Read+import Text.Hastache (htmlEscape)++-- | Generates the HTML coverage report and shows a textual coverage+-- summary.+generateHpcReport :: (MonadIO m,MonadReader env m,HasConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,HasEnvConfig env)+ => Path Abs Dir -> Text -> Text -> Text -> m ()+generateHpcReport pkgDir pkgName pkgId testName = do+ let whichTest = pkgName <> "'s test-suite \"" <> testName <> "\""+ -- Compute destination directory.+ installDir <- installationRootLocal+ testNamePath <- parseRelDir (T.unpack testName)+ pkgIdPath <- parseRelDir (T.unpack pkgId)+ let destDir = installDir </> hpcDirSuffix </> pkgIdPath </> testNamePath+ -- Directories for .mix files.+ hpcDir <- hpcDirFromDir pkgDir+ hpcRelDir <- (</> dotHpc) <$> hpcRelativeDir+ -- Compute arguments used for both "hpc markup" and "hpc report".+ pkgDirs <- Map.keys . envConfigPackages <$> asks getEnvConfig+ let args =+ -- Use index files from all packages (allows cross-package+ -- coverage results).+ concatMap (\x -> ["--srcdir", toFilePath x]) pkgDirs +++ -- Look for index files in the correct dir (relative to+ -- each pkgdir).+ ["--hpcdir", toFilePath hpcRelDir, "--reset-hpcdirs"+ -- Restrict to just the current library code (see #634 -+ -- this will likely be customizable in the future)+ ,"--include", T.unpack (pkgId <> ":")]+ -- If a .tix file exists, generate an HPC report for it.+ tixFile <- parseRelFile (T.unpack testName ++ ".tix")+ let tixFileAbs = hpcDir </> tixFile+ tixFileExists <- fileExists tixFileAbs+ if not tixFileExists+ then $logError $ T.concat+ [ "Didn't find .tix coverage file for "+ , whichTest+ , " - expected to find it at "+ , T.pack (toFilePath tixFileAbs)+ , "."+ ]+ else (`onException` $logError ("Error occurred while producing coverage report for " <> whichTest)) $ do+ menv <- getMinimalEnvOverride+ $logInfo $ "Generating HTML coverage report for " <> whichTest+ _ <- readProcessStdout (Just hpcDir) menv "hpc"+ ("markup" : toFilePath tixFileAbs : ("--destdir=" ++ toFilePath destDir) : args)+ output <- readProcessStdout (Just hpcDir) menv "hpc"+ ("report" : toFilePath tixFileAbs : args)+ -- Print output, stripping @\r@ characters because+ -- Windows.+ forM_ (S8.lines output) ($logInfo . T.decodeUtf8 . S8.filter (not . (=='\r')))+ $logInfo+ ("The HTML coverage report for " <> whichTest <> " is available at " <>+ T.pack (toFilePath (destDir </> $(mkRelFile "hpc_index.html"))))++generateHpcMarkupIndex :: (MonadIO m,MonadReader env m,MonadLogger m,MonadCatch m,HasEnvConfig env)+ => m ()+generateHpcMarkupIndex = do+ installDir <- installationRootLocal+ let markupDir = installDir </> hpcDirSuffix+ outputFile = markupDir </> $(mkRelFile "index.html")+ (dirs, _) <- listDirectory markupDir+ rows <- liftM (catMaybes . concat) $ forM dirs $ \dir -> do+ (subdirs, _) <- listDirectory dir+ forM subdirs $ \subdir -> do+ let indexPath = subdir </> $(mkRelFile "hpc_index.html")+ exists <- fileExists indexPath+ if not exists then return Nothing else do+ relPath <- stripDir markupDir indexPath+ let package = dirname dir+ testsuite = dirname subdir+ return $ Just $ T.concat+ [ "<tr><td>"+ , pathToHtml package+ , "</td><td><a href=\""+ , pathToHtml relPath+ , "\">"+ , pathToHtml testsuite+ , "</a></td></tr>"+ ]+ liftIO $ T.writeFile (toFilePath outputFile) $ T.concat $+ [ "<html><head><meta http-equiv=\"Content-Type\" content=\"text/html; charset=UTF-8\">"+ -- Part of the css from HPC's output HTML+ , "<style type=\"text/css\">"+ , "table.dashboard { border-collapse: collapse; border: solid 1px black }"+ , ".dashboard td { border: solid 1px black }"+ , ".dashboard th { border: solid 1px black }"+ , "</style>"+ , "</head>"+ , "<body>"+ ] +++ (if null rows+ then+ [ "<b>No hpc_index.html files found in \""+ , pathToHtml markupDir+ , "\".</b>"+ ]+ else+ [ "<table class=\"dashboard\" width=\"100%\" boder=\"1\"><tbody>"+ , "<p><b>NOTE: This is merely a listing of the html files found in the coverage reports directory. Some of these reports may be old.</b></p>"+ , "<tr><th>Package</th><th>TestSuite</th></tr>"+ ] +++ rows +++ ["</tbody></table>"]) +++ ["</body></html>"]+ $logInfo $ "\nAn index of the generated HTML coverage reports is available at " <>+ T.pack (toFilePath outputFile)++pathToHtml :: Path b t -> Text+pathToHtml = T.dropWhileEnd (=='/') . LT.toStrict . htmlEscape . LT.pack . toFilePath
src/Stack/Build/Execute.hs view
@@ -4,59 +4,66 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-}--- Perform a build+-- | Perform a build module Stack.Build.Execute ( printPlan , preFetch , executePlan- -- TESTING- , compareTestsComponents+ -- * Running Setup.hs+ , ExecuteEnv+ , withExecuteEnv+ , withSingleContext ) where -import Control.Applicative ((<$>), (<*>))-import Control.Concurrent.Lifted (fork)+import Control.Applicative ((<$>)) import Control.Concurrent.Execute+import Control.Concurrent.Lifted (fork) import Control.Concurrent.MVar.Lifted import Control.Concurrent.STM+import Control.Exception.Enclosed (tryIO) import Control.Exception.Lifted-import Control.Monad+import Control.Monad (liftM, when, unless, void, join, guard) import Control.Monad.Catch (MonadCatch, MonadMask) import Control.Monad.IO.Class import Control.Monad.Logger import Control.Monad.Reader (MonadReader, asks) import Control.Monad.Trans.Control (liftBaseWith) import Control.Monad.Trans.Resource-import Control.Monad.Writer import qualified Data.ByteString as S+import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as S8 import Data.Conduit import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.List as CL+import Data.Foldable (forM_) import Data.Function import Data.List import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe+import Data.Monoid ((<>)) import Data.Set (Set) import qualified Data.Set as Set import Data.Streaming.Process hiding (callProcess, env) import qualified Data.Streaming.Process as Process+import Data.Traversable (forM) import Data.Text (Text) import qualified Data.Text as T-import qualified Data.Text.Encoding as T import Data.Text.Encoding (encodeUtf8)+import Data.Word8 (_colon) import Distribution.System (OS (Windows), Platform (Platform))-import Language.Haskell.TH (Loc(..))+import Language.Haskell.TH as TH (location) import Network.HTTP.Client.Conduit (HasHttpManager) import Path import Path.IO import Prelude hiding (FilePath, writeFile) import Stack.Build.Cache+import Stack.Build.Coverage import Stack.Build.Haddock import Stack.Build.Installed import Stack.Build.Source-import Stack.Build.Types+import Stack.Types.Build import Stack.Fetch as Fetch import Stack.GhcPkg import Stack.Package@@ -64,8 +71,7 @@ import Stack.Types import Stack.Types.StackT import Stack.Types.Internal-import System.Directory hiding (findExecutable,- findFiles)+import qualified System.Directory as D import System.Environment (getExecutablePath) import System.Exit (ExitCode (ExitSuccess)) import qualified System.FilePath as FP@@ -73,6 +79,7 @@ import System.IO.Temp (withSystemTempDirectory) import System.Process.Internals (createProcess_) import System.Process.Read+import System.Process.Run import System.Process.Log (showProcessArgDebug) type M env m = (MonadIO m,MonadReader env m,HasHttpManager env,HasBuildConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,MonadMask m,HasLogLevel env,HasEnvConfig env,HasTerminal env)@@ -97,12 +104,11 @@ (packageVersion package) printPlan :: M env m- => FinalAction- -> Plan+ => Plan -> m ()-printPlan finalAction plan = do+printPlan plan = do case Map.toList $ planUnregisterLocal plan of- [] -> $logInfo "Nothing to unregister"+ [] -> $logInfo "No packages would be unregistered." xs -> do $logInfo "Would unregister locally:" forM_ xs $ \(gid, reason) -> $logInfo $ T.concat@@ -115,31 +121,29 @@ $logInfo "" case Map.elems $ planTasks plan of- [] -> $logInfo "Nothing to build"+ [] -> $logInfo "Nothing to build." xs -> do $logInfo "Would build:" mapM_ ($logInfo . displayTask) xs - let mfinalLabel =- case finalAction of- DoNothing -> Nothing- DoBenchmarks -> Just "benchmark"- DoTests _ -> Just "test"- case mfinalLabel of- Nothing -> return ()- Just finalLabel -> do- $logInfo ""+ let hasTests = not . Set.null . lptbTests+ hasBenches = not . Set.null . lptbBenches+ tests = Map.elems $ fmap fst $ Map.filter (hasTests . snd) $ planFinals plan+ benches = Map.elems $ fmap fst $ Map.filter (hasBenches . snd) $ planFinals plan - case Map.toList $ planFinals plan of- [] -> $logInfo $ "Nothing to " <> finalLabel- xs -> do- $logInfo $ "Would " <> finalLabel <> ":"- forM_ xs $ \(name, _) -> $logInfo $ T.pack $ packageNameString name+ unless (null tests) $ do+ $logInfo ""+ $logInfo "Would test:"+ mapM_ ($logInfo . displayTask) tests+ unless (null benches) $ do+ $logInfo ""+ $logInfo "Would benchmark:"+ mapM_ ($logInfo . displayTask) benches $logInfo "" case Map.toList $ planInstallExes plan of- [] -> $logInfo "No executables to be installed"+ [] -> $logInfo "No executables to be installed." xs -> do $logInfo "Would install executables:" forM_ xs $ \(name, loc) -> $logInfo $ T.concat@@ -189,16 +193,15 @@ , eeGlobalDB :: !(Path Abs Dir) } --- | Perform the actual plan-executePlan :: M env m- => EnvOverride- -> BuildOpts- -> BaseConfigOpts- -> [LocalPackage]- -> SourceMap- -> Plan- -> m ()-executePlan menv bopts baseConfigOpts locals sourceMap plan = do+withExecuteEnv :: M env m+ => EnvOverride+ -> BuildOpts+ -> BaseConfigOpts+ -> [LocalPackage]+ -> SourceMap+ -> (ExecuteEnv -> m a)+ -> m a+withExecuteEnv menv bopts baseConfigOpts locals sourceMap inner = do withSystemTempDirectory stackProgName $ \tmpdir -> do tmpdir' <- parseAbsDir tmpdir configLock <- newMVar ()@@ -208,7 +211,7 @@ liftIO $ writeFile (toFilePath setupHs) "import Distribution.Simple\nmain = defaultMain" cabalPkgVer <- asks (envConfigCabalVersion . getEnvConfig) globalDB <- getGlobalDB menv- executePlan' plan ExecuteEnv+ inner ExecuteEnv { eeEnvOverride = menv , eeBuildOpts = bopts -- Uncertain as to why we cannot run configures in parallel. This appears@@ -229,13 +232,25 @@ , eeGlobalDB = globalDB } +-- | Perform the actual plan+executePlan :: M env m+ => EnvOverride+ -> BuildOpts+ -> BaseConfigOpts+ -> [LocalPackage]+ -> SourceMap+ -> Plan+ -> m ()+executePlan menv bopts baseConfigOpts locals sourceMap plan = do+ withExecuteEnv menv bopts baseConfigOpts locals sourceMap (executePlan' plan)+ unless (Map.null $ planInstallExes plan) $ do snapBin <- (</> bindirSuffix) `liftM` installationRootDeps localBin <- (</> bindirSuffix) `liftM` installationRootLocal destDir <- asks $ configLocalBin . getConfig- let destDir' = toFilePath destDir- liftIO $ createDirectoryIfMissing True destDir'+ createTree destDir + let destDir' = toFilePath destDir when (not $ any (FP.equalFilePath destDir') (envSearchPath menv)) $ $logWarn $ T.concat [ "Installation path "@@ -278,25 +293,29 @@ liftIO $ case platform of Platform _ Windows | FP.equalFilePath destFile currExe -> windowsRenameCopy (toFilePath file) destFile- _ -> copyFile (toFilePath file) destFile+ _ -> D.copyFile (toFilePath file) destFile return $ Just (destDir', [T.append name (T.pack ext)]) let destToInstalled = Map.fromListWith (++) (catMaybes installed) unless (Map.null destToInstalled) $ $logInfo "" forM_ (Map.toList destToInstalled) $ \(dest, executables) -> do $logInfo $ T.concat- [ "Installed executables to "+ [ "Copied executables to " , T.pack dest , ":"] forM_ executables $ \exe -> $logInfo $ T.append "- " exe + forM_ (boptsExec bopts) $ \(cmd, args) -> do+ $logProcessRun cmd args+ callProcess Nothing menv cmd args+ -- | Windows can't write over the current executable. Instead, we rename the -- current executable to something else and then do the copy. windowsRenameCopy :: FilePath -> FilePath -> IO () windowsRenameCopy src dest = do- copyFile src new- renameFile dest old- renameFile new dest+ D.copyFile src new+ D.renameFile dest old+ D.renameFile new dest where new = dest ++ ".new" old = dest ++ ".old"@@ -337,14 +356,14 @@ let keepGoing = case boptsKeepGoing eeBuildOpts of Just kg -> kg- Nothing ->- case boptsFinalAction eeBuildOpts of- DoNothing -> False- _ -> True+ Nothing -> boptsTests eeBuildOpts || boptsBenchmarks eeBuildOpts concurrentFinal =- case boptsFinalAction eeBuildOpts of- DoTests _ -> concurrentTests- _ -> True+ -- TODO it probably makes more sense to use a lock for test suites+ -- and just have the execution blocked. Turning off all concurrency+ -- on finals based on the --test option doesn't fit in well.+ if boptsTests eeBuildOpts+ then concurrentTests+ else True terminal <- asks getTerminal errs <- liftIO $ runActions threads keepGoing concurrentFinal actions $ \doneVar -> do let total = length actions@@ -363,13 +382,16 @@ then loop 0 else return () unless (null errs) $ throwM $ ExecutionFailure errs- when (boptsHaddock eeBuildOpts && not (null actions))- (generateHaddockIndex eeEnvOverride eeBaseConfigOpts eeLocals)+ when (boptsHaddock eeBuildOpts) $ do+ generateLocalHaddockIndex eeEnvOverride eeBaseConfigOpts eeLocals+ generateDepsHaddockIndex eeEnvOverride eeBaseConfigOpts eeLocals+ generateSnapHaddockIndex eeEnvOverride eeBaseConfigOpts eeGlobalDB+ when (toCoverage $ boptsTestOpts eeBuildOpts) generateHpcMarkupIndex toActions :: M env m => (m () -> IO ()) -> ExecuteEnv- -> (Maybe Task, Maybe Task) -- build and final+ -> (Maybe Task, Maybe (Task, LocalPackageTB)) -- build and final -> [Action] toActions runInBase ee (mbuild, mfinal) = abuild ++ afinal@@ -386,37 +408,29 @@ } ] afinal =- case (,) <$> mfinal <*> mfunc of- Just (task@Task {..}, (func, checkTask)) | checkTask task ->+ case mfinal of+ Nothing -> []+ Just (task@Task {..}, lptb) -> [ Action { actionId = ActionId taskProvides ATFinal , actionDeps = addBuild taskProvides $ (Set.map (\ident -> ActionId ident ATBuild) (tcoMissing taskConfigOpts))- , actionDo = \ac -> runInBase $ func ac ee task+ , actionDo = \ac -> runInBase $ do+ unless (Set.null $ lptbTests lptb) $ do+ singleTest topts lptb ac ee task+ unless (Set.null $ lptbBenches lptb) $ do+ singleBench beopts lptb ac ee task } ]- _ -> [] where addBuild ident = case mbuild of Nothing -> id Just _ -> Set.insert $ ActionId ident ATBuild - mfunc =- case boptsFinalAction $ eeBuildOpts ee of- DoNothing -> Nothing- DoTests rerunTests -> Just (singleTest rerunTests, checkTest)- DoBenchmarks -> Just (singleBench, checkBench)-- checkTest task =- case taskType task of- TTLocal lp -> not $ Set.null $ packageTests $ lpPackage lp- _ -> assert False False-- checkBench task =- case taskType task of- TTLocal lp -> not $ Set.null $ packageBenchmarks $ lpPackage lp- _ -> assert False False+ bopts = eeBuildOpts ee+ topts = boptsTestOpts bopts+ beopts = boptsBenchmarkOpts bopts -- | Ensure that the configuration for the package matches what is given ensureConfig :: M env m@@ -434,7 +448,7 @@ mOldConfigCache <- tryGetConfigCache pkgDir mOldCabalMod <- tryGetCabalMod pkgDir- newCabalMod <- liftIO (fmap modTime (getModificationTime (toFilePath cabalfp)))+ newCabalMod <- liftIO (fmap modTime (D.getModificationTime (toFilePath cabalfp))) idMap <- liftIO $ readTVarIO eeGhcPkgIds let getMissing ident =@@ -451,7 +465,7 @@ , configCacheDeps = allDeps , configCacheComponents = case taskType of- TTLocal lp -> Set.map encodeUtf8 $ lpComponents lp+ TTLocal lp -> Set.map renderComponent $ lpComponents lp TTUpstream _ _ -> Set.empty , configCacheHaddock = shouldHaddockPackage eeBuildOpts eeWanted (packageIdentifierName taskProvides)@@ -472,6 +486,7 @@ => ActionContext -> ExecuteEnv -> Task+ -> Maybe String -> ( Package -> Path Abs File -> Path Abs Dir@@ -481,7 +496,7 @@ -> Maybe (Path Abs File, Handle) -> m a) -> m a-withSingleContext ActionContext {..} ExecuteEnv {..} task@Task {..} inner0 =+withSingleContext ActionContext {..} ExecuteEnv {..} task@Task {..} msuffix inner0 = withPackage $ \package cabalfp pkgDir -> withLogFile package $ \mlogFile -> withCabal package pkgDir mlogFile $ \cabal ->@@ -520,8 +535,8 @@ withLogFile package inner | console = inner Nothing | otherwise = do- logPath <- buildLogPath package -- TODO give a difference suffix for test, bench, etc?- liftIO $ createDirectoryIfMissing True $ toFilePath $ parent logPath+ logPath <- buildLogPath package msuffix+ createTree (parent logPath) let fp = toFilePath logPath bracket (liftIO $ openBinaryFile fp WriteMode)@@ -537,14 +552,13 @@ } exeName <- liftIO $ join $ findExecutable menv "runhaskell" distRelativeDir' <- distRelativeDir- msetuphs <-+ setuphs <- -- Avoid broken Setup.hs files causing problems for simple build -- types, see: -- https://github.com/commercialhaskell/stack/issues/370 if packageSimpleType package- then return Nothing+ then return eeSetupHs else liftIO $ getSetupHs pkgDir- let setuphs = fromMaybe eeSetupHs msetuphs inner $ \stripTHLoading args -> do let fullArgs = ("-package=" ++@@ -578,7 +592,13 @@ cp = cp0 { cwd = Just $ toFilePath pkgDir , Process.env = envHelper menv- , std_in = CreatePipe+ -- Ideally we'd create a new pipe here and then close it+ -- below to avoid the child process from taking from our+ -- stdin. However, if we do this, the child process won't+ -- be able to get the codepage on Windows that we want.+ -- See:+ -- https://github.com/commercialhaskell/stack/issues/738+ -- , std_in = CreatePipe , std_out = case mlogFile of Nothing -> CreatePipe@@ -591,10 +611,12 @@ $logProcessRun (toFilePath exeName) fullArgs -- Use createProcess_ to avoid the log file being closed afterwards- (Just inH, moutH, merrH, ph) <- liftIO $ createProcess_ "singleBuild" cp- liftIO $ hClose inH- maybePrintBuildOutput stripTHLoading LevelInfo mlogFile moutH- maybePrintBuildOutput stripTHLoading LevelWarn mlogFile merrH+ (Nothing, moutH, merrH, ph) <- liftIO $ createProcess_ "singleBuild" cp++ let makeAbsolute = stripTHLoading -- If users want control, we should add a config option for this++ maybePrintBuildOutput stripTHLoading makeAbsolute LevelInfo mlogFile moutH+ maybePrintBuildOutput False makeAbsolute LevelWarn mlogFile merrH ec <- liftIO $ waitForProcess ph case ec of ExitSuccess -> return ()@@ -613,12 +635,12 @@ (fmap fst mlogFile) bs - maybePrintBuildOutput stripTHLoading level mlogFile mh =+ maybePrintBuildOutput stripTHLoading makeAbsolute level mlogFile mh = case mh of Just h -> case mlogFile of Just{} -> return ()- Nothing -> printBuildOutput stripTHLoading level h+ Nothing -> printBuildOutput stripTHLoading makeAbsolute level h Nothing -> return () singleBuild :: M env m@@ -627,7 +649,7 @@ -> Task -> m () singleBuild ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} =- withSingleContext ac ee task $ \package cabalfp pkgDir cabal announce console _mlogFile -> do+ withSingleContext ac ee task Nothing $ \package cabalfp pkgDir cabal announce console _mlogFile -> do (cache, _neededConfig) <- ensureConfig pkgDir ee task (announce "configure") cabal cabalfp [] markExeNotInstalled (taskLocation task) taskProvides@@ -637,10 +659,15 @@ announce "build" config <- asks getConfig+ extraOpts <- extraBuildOptions cabal (console && configHideTHLoading config) $- case taskType of- TTLocal lp -> "build" : map T.unpack (Set.toList $ lpComponents lp)- TTUpstream _ _ -> ["build"]+ (case taskType of+ TTLocal lp -> "build"+ -- Cabal... There doesn't seem to be a way to call out the library component...+ -- : "lib"+ : map (T.unpack . T.append "exe:")+ (maybe [] Set.toList $ lpExeComponents lp)+ TTUpstream _ _ -> ["build"]) ++ extraOpts let doHaddock = shouldHaddockPackage eeBuildOpts eeWanted (packageName package) && -- Works around haddock failing on bytestring-builder since it has no modules@@ -648,7 +675,10 @@ packageHasExposedModules package when doHaddock $ do announce "haddock"- hscolourExists <- doesExecutableExist eeEnvOverride "hscolour"+ hscolourExists <- doesExecutableExist eeEnvOverride "HsColour"+ unless hscolourExists $ $logWarn+ ("Warning: haddock not generating hyperlinked sources because 'HsColour' not\n" <>+ "found on PATH (use 'stack build hscolour --copy-bins' to install).") cabal False (concat [["haddock", "--html", "--hoogle", "--html-location=../$pkg-$version/"] ,["--hyperlink-source" | hscolourExists]]) @@ -676,63 +706,72 @@ liftIO $ atomically $ modifyTVar eeGhcPkgIds $ Map.insert taskProvides mpkgid' when (doHaddock && shouldHaddockDeps eeBuildOpts) $- copyDepHaddocks- eeEnvOverride- eeBaseConfigOpts- (pkgDbs ++ [eeGlobalDB])- (PackageIdentifier (packageName package) (packageVersion package))- Set.empty+ withMVar eeInstallLock $ \() ->+ copyDepHaddocks+ eeEnvOverride+ eeBaseConfigOpts+ (pkgDbs ++ [eeGlobalDB])+ (PackageIdentifier (packageName package) (packageVersion package))+ Set.empty singleTest :: M env m- => Bool -- ^ rerun tests?+ => TestOpts+ -> LocalPackageTB -> ActionContext -> ExecuteEnv -> Task -> m ()-singleTest rerunTests ac ee task =- withSingleContext ac ee task $ \package cabalfp pkgDir cabal announce console mlogFile -> do+singleTest topts lptb ac ee task =+ withSingleContext ac ee task (Just "test") $ \package cabalfp pkgDir cabal announce console mlogFile -> do (_cache, neededConfig) <- ensureConfig pkgDir ee task (announce "configure (test)") cabal cabalfp ["--enable-tests"] config <- asks getConfig + testBuilt <- checkTestBuilt pkgDir+ let needBuild = neededConfig || (case taskType task of TTLocal lp -> lpDirtyFiles lp- _ -> assert False True)- needHpc = boptsCoverage (eeBuildOpts ee)+ _ -> assert False True) ||+ not testBuilt - componentsRaw =- case taskType task of- TTLocal lp -> Set.toList $ lpComponents lp- TTUpstream _ _ -> assert False []- testsToRun = compareTestsComponents componentsRaw $ Set.toList $ packageTests package+ needHpc = toCoverage topts++ testsToRun = Set.toList $ lptbTests lptb components = map (T.unpack . T.append "test:") testsToRun when needBuild $ do announce "build (test)"+ unsetTestBuilt pkgDir unsetTestSuccess pkgDir case taskType task of TTLocal lp -> writeBuildCache pkgDir $ lpNewBuildCache lp TTUpstream _ _ -> assert False $ return ()- cabal (console && configHideTHLoading config) $ "build" : components+ extraOpts <- extraBuildOptions+ cabal (console && configHideTHLoading config) $+ "build" : (components ++ extraOpts)+ setTestBuilt pkgDir toRun <-- if rerunTests- then return True- else do- success <- checkTestSuccess pkgDir- if success- then do- unless (null testsToRun) $ announce "skipping already passed test"- return False- else return True+ if toDisableRun topts+ then do+ announce "Test running disabled by --no-run-tests flag."+ return False+ else if toRerunTests topts+ then return True+ else do+ success <- checkTestSuccess pkgDir+ if success+ then do+ unless (null testsToRun) $ announce "skipping already passed test"+ return False+ else return True when toRun $ do bconfig <- asks getBuildConfig buildDir <- distDirFromDir pkgDir hpcDir <- hpcDirFromDir pkgDir when needHpc (createTree hpcDir)- let dotHpcDir = pkgDir </> dotHpc- exeExtension =+ let exeExtension = case configPlatform $ getConfig bconfig of Platform _ Windows -> ".exe" _ -> ""@@ -757,11 +796,10 @@ $logWarn ("Removing HPC file " <> T.pack (toFilePath nameTix)) removeFileIfExists nameTix - let args = boptsTestArgs (eeBuildOpts ee)- argsDisplay =- case args of- [] -> ""- _ -> ", args: " <> T.intercalate " " (map showProcessArgDebug args)+ let args = toAdditionalArgs topts+ argsDisplay = case args of+ [] -> ""+ _ -> ", args: " <> T.intercalate " " (map showProcessArgDebug args) announce $ "test (suite: " <> testName <> argsDisplay <> ")" let cp = (proc (toFilePath exeName) args) { cwd = Just $ toFilePath pkgDir@@ -793,20 +831,15 @@ [ "Test suite " , testName , " executable not found for "- , T.pack $ packageNameString $ packageName package+ , packageNameText $ packageName package ] return $ Map.singleton testName Nothing- when needHpc $ do- createTree (hpcDir </> dotHpc)- exists <- dirExists dotHpcDir- when exists $ do- copyDirectoryRecursive dotHpcDir (hpcDir </> dotHpc)- removeTree dotHpcDir- (_,files) <- listDirectory hpcDir- let tixes =- filter (isSuffixOf ".tix" . toFilePath . filename) files- generateHpcReport pkgDir hpcDir (hpcDir </> dotHpc) tixes + when needHpc $ forM_ testsToRun $ \testName -> do+ let pkgName = packageNameText (packageName package)+ pkgId = packageIdentifierText (packageIdentifier package)+ generateHpcReport pkgDir pkgName pkgId testName+ bs <- liftIO $ case mlogFile of Nothing -> return ""@@ -822,79 +855,54 @@ setTestSuccess pkgDir --- | Determine the tests to be run based on the list of components.-compareTestsComponents :: [Text] -- ^ components- -> [Text] -- ^ all test names- -> [Text] -- ^ tests to be run-compareTestsComponents [] tests = tests -- no components -- all tests-compareTestsComponents comps tests2 =- Set.toList $ Set.intersection tests1 $ Set.fromList tests2- where- tests1 = Set.unions $ map toSet comps-- toSet x =- case T.break (== ':') x of- (y, "") -> assert (x == y) (Set.singleton x)- ("test", y) -> Set.singleton $ T.drop 1 y- _ -> Set.empty---- | Generate the HTML report and-generateHpcReport- :: M env m- => Path Abs Dir -> Path Abs Dir -> Path Abs Dir -> [Path Abs File] -> m ()-generateHpcReport _ _ _ [] = return ()-generateHpcReport pkgDir hpcDir dotHpcDir tixes = do- menv <- getMinimalEnvOverride- $logInfo "Generating HPC HTML ..."- subdir <- stripDir pkgDir dotHpcDir- _ <- readProcessStdout (Just hpcDir) menv "hpc" ("markup" : args subdir)- output <-- readProcessStdout (Just hpcDir) menv "hpc" ("report" : args subdir)- forM_ (S8.lines output) ($logInfo . T.decodeUtf8)- $logInfo- ("The HTML report is available at " <>- T.pack (toFilePath (hpcDir </> $(mkRelFile "hpc_index.html"))))- where- args subdir =- concat- [ map (toFilePath . filename) tixes- , ["--srcdir", toFilePath pkgDir]- , ["--hpcdir", toFilePath subdir]- , ["--reset-hpcdirs"]]- singleBench :: M env m- => ActionContext+ => BenchmarkOpts+ -> LocalPackageTB+ -> ActionContext -> ExecuteEnv -> Task -> m ()-singleBench ac ee task =- withSingleContext ac ee task $ \_package cabalfp pkgDir cabal announce console _mlogFile -> do+singleBench beopts _lptb ac ee task =+ withSingleContext ac ee task (Just "bench") $ \_package cabalfp pkgDir cabal announce console _mlogFile -> do (_cache, neededConfig) <- ensureConfig pkgDir ee task (announce "configure (benchmarks)") cabal cabalfp ["--enable-benchmarks"] + benchBuilt <- checkBenchBuilt pkgDir+ let needBuild = neededConfig || (case taskType task of TTLocal lp -> lpDirtyFiles lp- _ -> assert False True)+ _ -> assert False True) ||+ not benchBuilt when needBuild $ do announce "build (benchmarks)"+ unsetBenchBuilt pkgDir case taskType task of TTLocal lp -> writeBuildCache pkgDir $ lpNewBuildCache lp TTUpstream _ _ -> assert False $ return () config <- asks getConfig- cabal (console && configHideTHLoading config) ["build"]-+ extraOpts <- extraBuildOptions+ cabal (console && configHideTHLoading config) ("build" : extraOpts)+ setBenchBuilt pkgDir+ let args = maybe []+ ((:[]) . ("--benchmark-options=" <>))+ (beoAdditionalArgs beopts) announce "benchmarks"- cabal False ["bench"]+ cabal False ("bench" : args) -- | Grab all output from the given @Handle@ and print it to stdout, stripping -- Template Haskell "Loading package" lines. Does work in a separate thread. printBuildOutput :: (MonadIO m, MonadBaseControl IO m, MonadLogger m)- => Bool -> LogLevel -> Handle -> m ()-printBuildOutput excludeTHLoading level outH = void $ fork $+ => Bool -- ^ exclude TH loading?+ -> Bool -- ^ convert paths to absolute?+ -> LogLevel+ -> Handle -> m ()+printBuildOutput excludeTHLoading makeAbsolute level outH = void $ fork $ CB.sourceHandle outH $$ CB.lines+ =$ CL.map stripCarriageReturn =$ CL.filter (not . isTHLoading)- =$ CL.mapM_ (monadLoggerLog (Loc "<unknown>" "<unknown>" "<unknown>" (0,0) (0,0)) "" level)+ =$ CL.mapM toAbsolutePath+ =$ CL.mapM_ (monadLoggerLog $(TH.location >>= liftLoc) "" level) where -- | Is this line a Template Haskell "Loading package" line -- ByteString@@ -904,25 +912,56 @@ "Loading package " `S8.isPrefixOf` bs && ("done." `S8.isSuffixOf` bs || "done.\r" `S8.isSuffixOf` bs) -taskLocation :: Task -> InstallLocation-taskLocation task =- case taskType task of- TTLocal _ -> Local- TTUpstream _ loc -> loc+ -- | Convert GHC error lines with file paths to have absolute file paths+ toAbsolutePath bs | not makeAbsolute = return bs+ toAbsolutePath bs = do+ let (x, y) = S.break (== _colon) bs+ mabs <-+ if isValidSuffix y+ then do+ efp <- liftIO $ tryIO $ D.canonicalizePath $ S8.unpack x+ case efp of+ Left _ -> return Nothing+ Right fp -> return $ Just $ S8.pack fp+ else return Nothing+ case mabs of+ Nothing -> return bs+ Just fp -> return $ fp `S.append` y --- | Ensure Setup.hs exists in the given directory. Returns an action--- to remove it later.+ -- | Match the line:column format at the end of lines+ isValidSuffix bs0 = maybe False (const True) $ do+ guard $ not $ S.null bs0+ guard $ S.head bs0 == _colon+ (_, bs1) <- S8.readInt $ S.drop 1 bs0++ guard $ not $ S.null bs1+ guard $ S.head bs1 == _colon+ (_, bs2) <- S8.readInt $ S.drop 1 bs1++ guard $ bs2 == ":"++ -- | Strip @\r@ characters from the byte vector. Used because Windows.+ stripCarriageReturn :: ByteString -> ByteString+ stripCarriageReturn = S8.filter (not . (=='\r'))++-- | Find the Setup.hs or Setup.lhs in the given directory. If none exists,+-- throw an exception. getSetupHs :: Path Abs Dir -- ^ project directory- -> IO (Maybe (Path Abs File))+ -> IO (Path Abs File) getSetupHs dir = do exists1 <- fileExists fp1 if exists1- then return $ Just fp1+ then return fp1 else do exists2 <- fileExists fp2 if exists2- then return $ Just fp2- else return Nothing+ then return fp2+ else throwM $ NoSetupHsFound dir where fp1 = dir </> $(mkRelFile "Setup.hs") fp2 = dir </> $(mkRelFile "Setup.lhs")++extraBuildOptions :: M env m => m [String]+extraBuildOptions = do+ hpcIndexDir <- toFilePath . (</> dotHpc) <$> hpcRelativeDir+ return ["--ghc-options", "-hpcdir " ++ hpcIndexDir ++ " -ddump-hi -ddump-to-file"]
src/Stack/Build/Haddock.hs view
@@ -8,11 +8,14 @@ -- | Generate haddocks module Stack.Build.Haddock ( copyDepHaddocks- , generateHaddockIndex+ , generateLocalHaddockIndex+ , generateDepsHaddockIndex+ , generateSnapHaddockIndex , shouldHaddockPackage , shouldHaddockDeps ) where +import Control.Exception (tryJust) import Control.Monad import Control.Monad.Catch (MonadCatch) import Control.Monad.IO.Class@@ -24,17 +27,19 @@ import Data.Maybe import Data.Set (Set) import qualified Data.Set as Set+import Data.Text (Text) import qualified Data.Text as T import Path import Path.IO-import Prelude hiding (FilePath, writeFile)-import Stack.Build.Types+import Prelude+import Safe (maximumMay)+import Stack.Types.Build import Stack.GhcPkg import Stack.Package import Stack.Types-import System.Directory hiding (findExecutable,- findFiles)+import System.Directory (getModificationTime) import qualified System.FilePath as FP+import System.IO.Error (isDoesNotExistError) import System.Process.Read -- | Determine whether we should haddock for a package.@@ -76,8 +81,8 @@ Just depOrigDir -> do let extraDestDirs' = -- Parent test ensures we don't try to copy docs to global locations- if (bcoSnapInstallRoot bco) `isParentOf` pkgHtmlDir ||- (bcoLocalInstallRoot bco) `isParentOf` pkgHtmlDir+ if bcoSnapInstallRoot bco `isParentOf` pkgHtmlDir ||+ bcoLocalInstallRoot bco `isParentOf` pkgHtmlDir then Set.insert (parent pkgHtmlDir) extraDestDirs else extraDestDirs copyWhenNeeded extraDestDirs' depId depOrigDir@@ -106,44 +111,124 @@ origMod <- liftIO $ getModificationTime (toFilePath depOrigIndex) return (copyMod <= origMod) doCopy depOrigDir depCopyDir = do- depCopyDirExists <- dirExists depCopyDir- liftIO $ do- when depCopyDirExists $- removeDirectoryRecursive (toFilePath depCopyDir)- createDirectoryIfMissing True (toFilePath depCopyDir)+ removeTreeIfExists depCopyDir+ createTree depCopyDir copyDirectoryRecursive depOrigDir depCopyDir -- | Generate Haddock index and contents for local packages.-generateHaddockIndex :: (MonadIO m, MonadCatch m, MonadThrow m, MonadLogger m, MonadBaseControl IO m)- => EnvOverride- -> BaseConfigOpts- -> [LocalPackage]- -> m ()-generateHaddockIndex envOverride bco locals = do- $logInfo ("Generating Haddock index in\n" <>- T.pack (toFilePath (haddockIndexFile docDir)))- interfaceArgs <- mapM (\LocalPackage {lpPackage = Package {..}} ->- toInterfaceOpt (PackageIdentifier packageName packageVersion))- locals- readProcessNull- (Just docDir)+generateLocalHaddockIndex+ :: (MonadIO m, MonadCatch m, MonadThrow m, MonadLogger m, MonadBaseControl IO m)+ => EnvOverride -> BaseConfigOpts -> [LocalPackage] -> m ()+generateLocalHaddockIndex envOverride bco locals = do+ let packageIDs =+ map+ (\LocalPackage{lpPackage = Package{..}} ->+ PackageIdentifier packageName packageVersion)+ locals+ generateHaddockIndex+ "local packages" envOverride- "haddock"- (["--gen-contents", "--gen-index"] ++ concat interfaceArgs)+ packageIDs+ "."+ (localDocDir bco)++-- | Generate Haddock index and contents for local packages and their dependencies.+generateDepsHaddockIndex+ :: (MonadIO m, MonadCatch m, MonadThrow m, MonadLogger m, MonadBaseControl IO m)+ => EnvOverride -> BaseConfigOpts -> [LocalPackage] -> m ()+generateDepsHaddockIndex envOverride bco locals = do+ depSets <-+ mapM+ (\LocalPackage{lpPackage = Package{..}} ->+ findTransitiveGhcPkgDepends+ envOverride+ [bcoSnapDB bco, bcoLocalDB bco]+ (PackageIdentifier packageName packageVersion))+ locals+ generateHaddockIndex+ "local packages and dependencies"+ envOverride+ (Set.toList (Set.unions depSets))+ ".."+ (localDocDir bco </> $(mkRelDir "all"))++-- | Generate Haddock index and contents for all snapshot packages.+generateSnapHaddockIndex+ :: (MonadIO m, MonadCatch m, MonadThrow m, MonadLogger m, MonadBaseControl IO m)+ => EnvOverride -> BaseConfigOpts -> Path Abs Dir -> m ()+generateSnapHaddockIndex envOverride bco globalDB = do+ pkgIds <- listGhcPkgDbs envOverride [globalDB, bcoSnapDB bco]+ generateHaddockIndex+ "snapshot packages"+ envOverride+ pkgIds+ "."+ (snapDocDir bco)++-- | Generate Haddock index and contents for specified packages.+generateHaddockIndex+ :: (MonadIO m, MonadCatch m, MonadThrow m, MonadLogger m, MonadBaseControl IO m)+ => Text+ -> EnvOverride+ -> [PackageIdentifier]+ -> FilePath+ -> Path Abs Dir+ -> m ()+generateHaddockIndex descr envOverride packageIDs docRelDir destDir = do+ createTree destDir+ interfaceOpts <- liftIO $ fmap catMaybes (mapM toInterfaceOpt packageIDs)+ case maximumMay (map snd interfaceOpts) of+ Nothing -> return ()+ Just maxInterfaceModTime -> do+ eindexModTime <-+ liftIO $+ tryJust (guard . isDoesNotExistError) $+ getModificationTime (toFilePath (haddockIndexFile destDir))+ let needUpdate =+ case eindexModTime of+ Left _ -> True+ Right indexModTime ->+ indexModTime < maxInterfaceModTime+ when+ needUpdate $+ do $logInfo+ ("Updating Haddock index for " <> descr <> " in\n" <>+ T.pack (toFilePath (haddockIndexFile destDir)))+ readProcessNull+ (Just destDir)+ envOverride+ "haddock"+ (["--gen-contents", "--gen-index"] ++ concatMap fst interfaceOpts) where- docDir = bcoLocalInstallRoot bco </> docdirSuffix toInterfaceOpt pid@(PackageIdentifier name _) = do- interfaceRelFile <- parseRelFile (packageIdentifierString pid FP.</>- packageNameString name FP.<.>- "haddock")- interfaceExists <- fileExists (docDir </> interfaceRelFile)- return $ if interfaceExists- then [ "-i"- , concat- [ packageIdentifierString pid- , ","- , toFilePath interfaceRelFile ] ]- else []+ let interfaceRelFile =+ docRelDir FP.</> packageIdentifierString pid FP.</>+ packageNameString name FP.<.>+ "haddock"+ interfaceAbsFile = toFilePath destDir FP.</> interfaceRelFile+ einterfaceModTime <-+ tryJust (guard . isDoesNotExistError) $+ getModificationTime interfaceAbsFile+ return $+ case einterfaceModTime of+ Left _ -> Nothing+ Right interfaceModTime ->+ Just+ ( [ "-i"+ , concat+ [ docRelDir FP.</> packageIdentifierString pid+ , ","+ , interfaceRelFile]]+ , interfaceModTime) +-- | Path of haddock index file. haddockIndexFile :: Path Abs Dir -> Path Abs File-haddockIndexFile docDir = docDir </> $(mkRelFile "index.html")+haddockIndexFile destDir = destDir </> $(mkRelFile "index.html")++-- | Path of local packages documentation directory.+localDocDir :: BaseConfigOpts -> Path Abs Dir+localDocDir bco = bcoLocalInstallRoot bco </> docDirSuffix++-- | Path of snapshot packages documentation directory.+snapDocDir :: BaseConfigOpts -> Path Abs Dir+snapDocDir bco = bcoSnapInstallRoot bco </> docDirSuffix
src/Stack/Build/Installed.hs view
@@ -32,7 +32,7 @@ import Path import Prelude hiding (FilePath, writeFile) import Stack.Build.Cache-import Stack.Build.Types+import Stack.Types.Build import Stack.Constants import Stack.GhcPkg import Stack.PackageDump
src/Stack/Build/Source.hs view
@@ -10,67 +10,57 @@ , SourceMap , PackageSource (..) , localFlags- , loadLocals+ , getLocalPackageViews+ , loadLocalPackage ) where -import Network.HTTP.Client.Conduit (HasHttpManager)-import Control.Applicative ((<|>), (<$>), (<*>))-import Control.Exception (catch)+import Control.Applicative ((<$>), (<*>))+import Control.Arrow ((&&&))+import Control.Exception (assert, catch) import Control.Monad-import Control.Monad.Catch (MonadCatch)+import Control.Monad.Catch (MonadCatch) import Control.Monad.IO.Class import Control.Monad.Logger-import Control.Monad.Reader (MonadReader, asks)+import Control.Monad.Reader (MonadReader, asks) import Control.Monad.Trans.Resource-import Crypto.Hash (Digest, SHA256)-import Crypto.Hash.Conduit (sinkHash)-import Data.Byteable (toBytes)-import qualified Data.ByteString as S-import Data.Conduit (($$), ZipSink (..))-import qualified Data.Conduit.Binary as CB-import qualified Data.Conduit.List as CL+import Crypto.Hash (Digest, SHA256)+import Crypto.Hash.Conduit (sinkHash)+import qualified Data.ByteString as S+import Data.Byteable (toBytes)+import Data.Conduit (($$), ZipSink (..))+import qualified Data.Conduit.Binary as CB+import qualified Data.Conduit.List as CL import Data.Either-import qualified Data.Foldable as F import Data.Function-import qualified Data.HashSet as HashSet+import qualified Data.HashSet as HashSet import Data.List-import qualified Data.Map as Map-import Data.Map.Strict (Map)+import qualified Data.Map as Map+import Data.Map.Strict (Map) import Data.Maybe-import Data.Monoid ((<>), Any (..), mconcat)-import Data.Set (Set)-import qualified Data.Set as Set-import Data.Text (Text)-import qualified Data.Text as T+import Data.Monoid ((<>), Any (..), mconcat)+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as T+import Distribution.Package (pkgName, pkgVersion)+import Distribution.PackageDescription (GenericPackageDescription, package, packageDescription)+import qualified Distribution.PackageDescription as C+import Network.HTTP.Client.Conduit (HasHttpManager) import Path-import Prelude hiding (writeFile)+import Path.IO+import Prelude import Stack.Build.Cache-import Stack.Build.Types-import Stack.BuildPlan (loadMiniBuildPlan,- shadowMiniBuildPlan)-import Stack.Constants (wiredInPackages)+import Stack.Build.Target+import Stack.Types.Build+import Stack.BuildPlan (loadMiniBuildPlan, shadowMiniBuildPlan,+ parseCustomMiniBuildPlan)+import Stack.Constants (wiredInPackages) import Stack.Package import Stack.PackageIndex import Stack.Types-import System.Directory hiding (findExecutable, findFiles)-import System.IO (withBinaryFile, IOMode (ReadMode))-import System.IO.Error (isDoesNotExistError)--type SourceMap = Map PackageName PackageSource---- | Where the package's source is located: local directory or package index-data PackageSource- = PSLocal LocalPackage- | PSUpstream Version InstallLocation (Map FlagName Bool)- -- ^ Upstream packages could be installed in either local or snapshot- -- databases; this is what 'InstallLocation' specifies.- deriving Show-instance PackageInstallInfo PackageSource where- piiVersion (PSLocal lp) = packageVersion $ lpPackage lp- piiVersion (PSUpstream v _ _) = v-- piiLocation (PSLocal _) = Local- piiLocation (PSUpstream _ loc _) = loc+import System.Directory+import System.IO (withBinaryFile, IOMode (ReadMode))+import System.IO.Error (isDoesNotExistError) loadSourceMap :: (MonadIO m, MonadCatch m, MonadReader env m, HasBuildConfig env, MonadBaseControl IO m, HasHttpManager env, MonadLogger m, HasEnvConfig env) => BuildOpts@@ -89,30 +79,51 @@ { mbpGhcVersion = fromMajorVersion ghc , mbpPackages = Map.empty }+ ResolverCustom _ url -> do+ stackYamlFP <- asks $ bcStackYaml . getBuildConfig+ parseCustomMiniBuildPlan stackYamlFP url + rawLocals <- getLocalPackageViews+ workingDir <- getWorkingDir+ (cliExtraDeps, targets) <-+ parseTargets+ (bcImplicitGlobal bconfig)+ (boptsTests bopts)+ (boptsBenchmarks bopts)+ (mpiVersion <$> mbpPackages mbp0)+ (bcExtraDeps bconfig)+ (fst <$> rawLocals)+ workingDir+ (boptsTargets bopts)+ menv <- getMinimalEnvOverride caches <- getPackageCaches menv- let latestVersion = Map.fromList $ map toTuple $ Map.keys caches- (locals, extraNames, extraIdents) <- loadLocals bopts latestVersion+ let latestVersion = Map.fromListWith max $ map toTuple $ Map.keys caches + -- Extend extra-deps to encompass targets requested on the command line+ -- that are not in the snapshot.+ extraDeps0 <- extendExtraDeps+ (bcExtraDeps bconfig)+ cliExtraDeps+ (Map.keysSet $ Map.filter (== STUnknown) targets)+ latestVersion++ locals <- mapM (loadLocalPackage bopts targets) $ Map.toList rawLocals+ checkFlagsUsed bopts locals+ let -- loadLocals returns PackageName (foo) and PackageIdentifier (bar-1.2.3) targets separately; -- here we combine them into nonLocalTargets. This is one of the -- return values of this function. nonLocalTargets :: Set PackageName- nonLocalTargets = extraNames <> Set.map packageIdentifierName extraIdents-- -- Extend extra-deps to encompass targets requested on the command line- -- that are not in the snapshot.- extraDeps0 = extendExtraDeps- (bcExtraDeps bconfig)- mbp0- latestVersion- extraNames- extraIdents+ nonLocalTargets =+ Map.keysSet $ Map.filter (not . isLocal) targets+ where+ isLocal (STLocal _) = True+ isLocal STUnknown = False+ isLocal STNonLocal = False - let shadowed = Set.fromList (map (packageName . lpPackage) locals)- <> Map.keysSet extraDeps0+ shadowed = Map.keysSet rawLocals <> Map.keysSet extraDeps0 (mbp, extraDeps1) = shadowMiniBuildPlan mbp0 shadowed -- Add the extra deps from the stack.yaml file to the deps grabbed from@@ -135,152 +146,151 @@ (PSUpstream (mpiVersion mpi) Snap (mpiFlags mpi)) ] `Map.difference` Map.fromList (map (, ()) (HashSet.toList wiredInPackages)) - let unknown = Set.difference nonLocalTargets $ Map.keysSet sourceMap- unless (Set.null unknown) $ do- let toEither name =- case Map.lookup name latestVersion of- Nothing -> Left name- Just version -> Right (name, version)- eithers = map toEither $ Set.toList unknown- (unknown', notInIndex) = partitionEithers eithers- throwM $ UnknownTargets- (Set.fromList unknown')- (Map.fromList notInIndex)- (bcStackYaml bconfig)- return (mbp, locals, nonLocalTargets, sourceMap) --- | 'loadLocals' combines two pieces of information:------ 1. Targets, i.e. arguments passed to stack such as @foo@ and @bar@ in the @stack foo bar@ invocation------ 2. Local packages listed in @stack.yaml@------ It returns:------ 1. For every local package, a 'LocalPackage' structure------ 2. If a target does not correspond to a local package but is a valid--- 'PackageName' or 'PackageIdentifier', it is returned as such.------ NOTE: as the function is written right now, it may "drop" targets if--- they correspond to existing directories not listed in stack.yaml. This--- may be a bug.-loadLocals :: forall m env .- (MonadReader env m, HasBuildConfig env, MonadIO m, MonadLogger m, MonadThrow m, MonadCatch m,HasEnvConfig env)- => BuildOpts- -> Map PackageName Version- -> m ([LocalPackage], Set PackageName, Set PackageIdentifier)-loadLocals bopts latestVersion = do- targets <- mapM parseTarget $- case boptsTargets bopts of- [] -> ["."]- x -> x-- -- Group targets by their kind- (dirs, names, idents) <-- case partitionEithers targets of- ([], targets') -> return $ partitionTargetSpecs targets'- (bad, _) -> throwM $ Couldn'tParseTargets bad-+-- | Parse out the local package views for the current project+getLocalPackageViews :: (MonadThrow m, MonadIO m, MonadReader env m, HasEnvConfig env)+ => m (Map PackageName (LocalPackageView, GenericPackageDescription))+getLocalPackageViews = do econfig <- asks getEnvConfig- bconfig <- asks getBuildConfig- -- Iterate over local packages declared in stack.yaml and turn them- -- into LocalPackage structures. The targets affect whether these- -- packages will be marked as wanted.- lps <- forM (Map.toList $ bcPackages bconfig) $ \(dir, validWanted) -> do+ -- TODO ensure that there are no overlapping package names+ liftM Map.fromList $ forM (Map.toList $ envConfigPackages econfig) $ \(dir, validWanted) -> do cabalfp <- getCabalFileName dir+ gpkg <- readPackageUnresolved cabalfp+ let cabalID = package $ packageDescription gpkg name <- parsePackageNameFromFilePath cabalfp- let wanted = validWanted && isWanted dirs names dir name- config = PackageConfig- { packageConfigEnableTests = False- , packageConfigEnableBenchmarks = False- , packageConfigFlags = localFlags (boptsFlags bopts) bconfig name- , packageConfigGhcVersion = envConfigGhcVersion econfig- , packageConfigPlatform = configPlatform $ getConfig bconfig- }- configFinal = config- { packageConfigEnableTests =- case boptsFinalAction bopts of- DoTests _ -> wanted- _ -> False- , packageConfigEnableBenchmarks = wanted && boptsFinalAction bopts == DoBenchmarks+ when (fromCabalPackageName (pkgName $ cabalID) /= name)+ $ throwM $ MismatchedCabalName cabalfp name+ let lpv = LocalPackageView+ { lpvVersion = fromCabalVersion $ pkgVersion cabalID+ , lpvRoot = dir+ , lpvCabalFP = cabalfp+ , lpvExtraDep = not validWanted+ , lpvComponents = getNamedComponents gpkg }- pkg <- readPackage config cabalfp- pkgFinal <- readPackage configFinal cabalfp- when (packageName pkg /= name) $ throwM- $ MismatchedCabalName cabalfp (packageName pkg)- mbuildCache <- tryGetBuildCache dir- files <- getPackageFiles (packageFiles pkg) AllFiles cabalfp- (isDirty, newBuildCache) <- checkBuildCache- (fromMaybe Map.empty mbuildCache)- (map toFilePath $ Set.toList files)- return LocalPackage- { lpPackage = pkg- , lpPackageFinal = pkgFinal- , lpWanted = wanted- , lpFiles = files- , lpDirtyFiles = isDirty- , lpNewBuildCache = newBuildCache- , lpCabalFile = cabalfp- , lpDir = dir- , lpComponents = fromMaybe Set.empty $ Map.lookup name names+ return (name, (lpv, gpkg))+ where+ getNamedComponents gpkg = Set.fromList $ concat+ [ maybe [] (const [CLib]) (C.condLibrary gpkg)+ , go CExe C.condExecutables+ , go CTest C.condTestSuites+ , go CBench C.condBenchmarks+ ]+ where+ go wrapper f = map (wrapper . T.pack . fst) $ f gpkg++splitComponents :: [NamedComponent]+ -> (Set Text, Set Text, Set Text)+splitComponents =+ go id id id+ where+ go a b c [] = (Set.fromList $ a [], Set.fromList $ b [], Set.fromList $ c [])+ go a b c (CLib:xs) = go a b c xs+ go a b c (CExe x:xs) = go (a . (x:)) b c xs+ go a b c (CTest x:xs) = go a (b . (x:)) c xs+ go a b c (CBench x:xs) = go a b (c . (x:)) xs++-- | Upgrade the initial local package info to a full-blown @LocalPackage@+-- based on the selected components+loadLocalPackage+ :: forall m env.+ (MonadReader env m, HasEnvConfig env, MonadCatch m, MonadLogger m, MonadIO m)+ => BuildOpts+ -> Map PackageName SimpleTarget+ -> (PackageName, (LocalPackageView, GenericPackageDescription))+ -> m LocalPackage+loadLocalPackage bopts targets (name, (lpv, gpkg)) = do+ bconfig <- asks getBuildConfig+ econfig <- asks getEnvConfig++ let mtarget = Map.lookup name targets+ components =+ case mtarget of+ Just (STLocal comps) -> comps+ Just STNonLocal -> assert False Set.empty+ Just STUnknown -> assert False Set.empty+ Nothing -> Set.empty+ (exes, tests, benches) = splitComponents $ Set.toList components+ config = PackageConfig+ { packageConfigEnableTests = False+ , packageConfigEnableBenchmarks = False+ , packageConfigFlags = localFlags (boptsFlags bopts) bconfig name+ , packageConfigGhcVersion = envConfigGhcVersion econfig+ , packageConfigPlatform = configPlatform $ getConfig bconfig }+ btconfig = config+ { packageConfigEnableTests = not $ Set.null tests+ , packageConfigEnableBenchmarks = not $ Set.null benches+ }+ pkg = resolvePackage config gpkg+ btpkg+ | Set.null tests && Set.null benches = Nothing+ | otherwise = Just $ LocalPackageTB+ { lptbPackage = resolvePackage btconfig gpkg+ , lptbTests = tests+ , lptbBenches = benches+ }+ mbuildCache <- tryGetBuildCache $ lpvRoot lpv+ files <- getPackageFiles (packageFiles pkg) (lpvCabalFP lpv)+ (isDirty, newBuildCache) <- checkBuildCache+ (fromMaybe Map.empty mbuildCache)+ (map toFilePath $ Set.toList files) - let known = Set.fromList $ map (packageName . lpPackage) lps- unknown = Set.difference (Map.keysSet names) known+ return LocalPackage+ { lpPackage = pkg+ , lpExeComponents =+ case mtarget of+ Nothing -> Nothing+ Just _ -> Just exes+ , lpTestBench = btpkg+ , lpFiles = files+ , lpDirtyFiles = isDirty || boptsForceDirty bopts+ , lpNewBuildCache = newBuildCache+ , lpCabalFile = lpvCabalFP lpv+ , lpDir = lpvRoot lpv+ , lpComponents = components+ } - return (lps, unknown, idents)- where- -- Attempt to parse a TargetSpec based on its textual form and on- -- whether it is a name of an existing directory.- --- -- If a TargetSpec is not recognized, return it verbatim as Left.- parseTarget :: Text -> m (Either Text TargetSpec)- parseTarget t = do- let s = T.unpack t- isDir <- liftIO $ doesDirectoryExist s- if isDir- then liftM (Right . TSDir) $ liftIO (canonicalizePath s) >>= parseAbsDir- else return- $ maybe (Left t) Right- $ (flip TSName Set.empty <$> parsePackageNameFromString s)- <|> (TSIdent <$> parsePackageIdentifierFromString s)- <|> (do- t' <- T.stripSuffix ":latest" t- name <- parsePackageNameFromString $ T.unpack t'- version <- Map.lookup name latestVersion- Just $ TSIdent $ PackageIdentifier name version)- <|> (do- let (name', rest) = T.break (== ':') t- component <- T.stripPrefix ":" rest- name <- parsePackageNameFromString $ T.unpack name'- Just $ TSName name $ Set.singleton component)- isWanted dirs names dir name =- name `Map.member` names ||- any (`isParentOf` dir) dirs ||- any (== dir) dirs+-- | Ensure that the flags specified in the stack.yaml file and on the command+-- line are used.+checkFlagsUsed :: (MonadThrow m, MonadReader env m, HasBuildConfig env)+ => BuildOpts+ -> [LocalPackage]+ -> m ()+checkFlagsUsed bopts lps = do+ bconfig <- asks getBuildConfig -data TargetSpec- = TSName PackageName (Set Text)- | TSIdent PackageIdentifier- | TSDir (Path Abs Dir)+ -- Check if flags specified in stack.yaml and the command line are+ -- used, see https://github.com/commercialhaskell/stack/issues/617+ let flags = map (, FSCommandLine) [(k, v) | (Just k, v) <- Map.toList $ boptsFlags bopts]+ ++ map (, FSStackYaml) (Map.toList $ bcFlags bconfig) -partitionTargetSpecs :: [TargetSpec] -> ([Path Abs Dir], Map PackageName (Set Text), Set PackageIdentifier)-partitionTargetSpecs =- loop id Map.empty Set.empty- where- loop dirs names idents ts0 =- case ts0 of- [] -> (dirs [], names, idents)- TSName name comps:ts -> loop- dirs- (Map.insertWith Set.union name comps names)- idents- ts- TSIdent ident:ts -> loop dirs names (Set.insert ident idents) ts- TSDir dir:ts -> loop (dirs . (dir:)) names idents ts+ localNameMap = Map.fromList $ map (packageName . lpPackage &&& lpPackage) lps+ checkFlagUsed ((name, userFlags), source) =+ case Map.lookup name localNameMap of+ -- Package is not available locally+ Nothing ->+ case Map.lookup name $ bcExtraDeps bconfig of+ -- Also not in extra-deps, it's an error+ Nothing -> Just $ UFNoPackage source name+ -- We don't check for flag presence for extra deps+ Just _ -> Nothing+ -- Package exists locally, let's check if the flags are defined+ Just pkg ->+ let unused = Set.difference (Map.keysSet userFlags) (packageDefinedFlags pkg)+ in if Set.null unused+ -- All flags are defined, nothing to do+ then Nothing+ -- Error about the undefined flags+ else Just $ UFFlagsNotDefined source pkg unused + unusedFlags = mapMaybe checkFlagUsed flags++ unless (null unusedFlags)+ $ throwM+ $ InvalidFlagSpecification+ $ Set.fromList unusedFlags+ -- | All flags for a local package localFlags :: (Map (Maybe PackageName) (Map FlagName Bool)) -> BuildConfig@@ -294,36 +304,34 @@ -- | Add in necessary packages to extra dependencies ----- See https://github.com/commercialhaskell/stack/issues/272 for the requirements of this function-extendExtraDeps :: Map PackageName Version -- ^ original extra deps- -> MiniBuildPlan+-- Originally part of https://github.com/commercialhaskell/stack/issues/272,+-- this was then superseded by+-- https://github.com/commercialhaskell/stack/issues/651+extendExtraDeps :: (MonadThrow m, MonadReader env m, HasBuildConfig env)+ => Map PackageName Version -- ^ original extra deps+ -> Map PackageName Version -- ^ package identifiers from the command line+ -> Set PackageName -- ^ all packages added on the command line -> Map PackageName Version -- ^ latest versions in indices- -> Set PackageName -- ^ extra package names desired- -> Set PackageIdentifier -- ^ extra package identifiers desired- -> Map PackageName Version -- ^ new extradeps-extendExtraDeps extraDeps0 mbp latestVersion extraNames extraIdents =- F.foldl' addIdent- (F.foldl' addName extraDeps0 extraNames)- extraIdents+ -> m (Map PackageName Version) -- ^ new extradeps+extendExtraDeps extraDeps0 cliExtraDeps unknowns latestVersion+ | null errs = return $ Map.unions $ extraDeps1 : unknowns'+ | otherwise = do+ bconfig <- asks getBuildConfig+ throwM $ UnknownTargets+ (Set.fromList errs)+ Map.empty -- TODO check the cliExtraDeps for presence in index+ (bcStackYaml bconfig) where- snapshot = fmap mpiVersion $ mbpPackages mbp+ extraDeps1 = Map.union extraDeps0 cliExtraDeps - addName m name =- case Map.lookup name m <|> Map.lookup name snapshot of- -- alright exists in snapshot or extra-deps- Just _ -> m+ (errs, unknowns') = partitionEithers $ map addUnknown $ Set.toList unknowns+ addUnknown pn =+ case Map.lookup pn extraDeps1 of+ Just _ -> Right Map.empty Nothing ->- case Map.lookup name latestVersion of- -- use the latest version in the index- Just v -> Map.insert name v m- -- does not exist, will be reported as an error- Nothing -> m-- addIdent m (PackageIdentifier name version) =- case Map.lookup name snapshot of- -- the version matches what's in the snapshot, so just use the snapshot version- Just version' | version == version' -> m- _ -> Map.insert name version m+ case Map.lookup pn latestVersion of+ Just v -> Right $ Map.singleton pn v+ Nothing -> Left pn -- | Compare the current filesystem state to the cached information, and -- determine (1) if the files are dirty, and (2) the new cache values.
+ src/Stack/Build/Target.hs view
@@ -0,0 +1,319 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ViewPatterns #-}+-- | Parsing command line targets+module Stack.Build.Target+ ( -- * Types+ ComponentName+ , UnresolvedComponent (..)+ , RawTarget (..)+ , LocalPackageView (..)+ , SimpleTarget (..)+ -- * Parsers+ , parseRawTarget+ , parseTargets+ ) where++import Control.Applicative+import Control.Arrow (second)+import Control.Monad.Catch (MonadThrow, throwM)+import Control.Monad.IO.Class+import Data.Either (partitionEithers)+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe (mapMaybe)+import Data.Monoid (mconcat)+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as T+import Path+import Path.IO+import Stack.Types++-- | The name of a component, which applies to executables, test suites, and benchmarks+type ComponentName = Text++newtype RawInput = RawInput { unRawInput :: Text }++-- | Either a fully resolved component, or a component name that could be+-- either an executable, test, or benchmark+data UnresolvedComponent+ = ResolvedComponent !NamedComponent+ | UnresolvedComponent !ComponentName+ deriving (Show, Eq, Ord)++-- | Raw command line input, without checking against any databases or list of+-- locals. Does not deal with directories+data RawTarget (a :: RawTargetType) where+ RTPackageComponent :: !PackageName -> !UnresolvedComponent -> RawTarget a+ RTComponent :: !ComponentName -> RawTarget a+ RTPackage :: !PackageName -> RawTarget a+ RTPackageIdentifier :: !PackageIdentifier -> RawTarget HasIdents++deriving instance Show (RawTarget a)+deriving instance Eq (RawTarget a)+deriving instance Ord (RawTarget a)++data RawTargetType = HasIdents | NoIdents++-- | If this function returns @Nothing@, the input should be treated as a+-- directory.+parseRawTarget :: Text -> Maybe (RawTarget HasIdents)+parseRawTarget t =+ (RTPackageIdentifier <$> parsePackageIdentifierFromString s)+ <|> (RTPackage <$> parsePackageNameFromString s)+ <|> (RTComponent <$> T.stripPrefix ":" t)+ <|> parsePackageComponent+ where+ s = T.unpack t++ parsePackageComponent =+ case T.splitOn ":" t of+ [pname, "lib"]+ | Just pname' <- parsePackageNameFromString (T.unpack pname) ->+ Just $ RTPackageComponent pname' $ ResolvedComponent CLib+ [pname, cname]+ | Just pname' <- parsePackageNameFromString (T.unpack pname) ->+ Just $ RTPackageComponent pname' $ UnresolvedComponent cname+ [pname, typ, cname]+ | Just pname' <- parsePackageNameFromString (T.unpack pname)+ , Just wrapper <- parseCompType typ ->+ Just $ RTPackageComponent pname' $ ResolvedComponent $ wrapper cname+ _ -> Nothing++ parseCompType t' =+ case t' of+ "exe" -> Just CExe+ "test" -> Just CTest+ "bench" -> Just CBench+ _ -> Nothing++-- | A view of a local package needed for resolving components+data LocalPackageView = LocalPackageView+ { lpvVersion :: !Version+ , lpvRoot :: !(Path Abs Dir)+ , lpvCabalFP :: !(Path Abs File)+ , lpvComponents :: !(Set NamedComponent)+ , lpvExtraDep :: !Bool+ }++-- | Same as @parseRawTarget@, but also takes directories into account.+parseRawTargetDirs :: (MonadIO m, MonadThrow m)+ => Path Abs Dir -- ^ current directory+ -> Map PackageName LocalPackageView+ -> Text+ -> m (Either Text [(RawInput, RawTarget HasIdents)])+parseRawTargetDirs root locals t =+ case parseRawTarget t of+ Just rt -> return $ Right [(ri, rt)]+ Nothing -> do+ mdir <- resolveDirMaybe root $ T.unpack t+ case mdir of+ Nothing -> return $ Left $ "Directory not found: " `T.append` t+ Just dir ->+ case mapMaybe (childOf dir) $ Map.toList locals of+ [] -> return $ Left $+ "No local directories found as children of " `T.append`+ t+ names -> return $ Right $ map ((ri, ) . RTPackage) names+ where+ ri = RawInput t++ childOf dir (name, lpv) =+ if (dir == lpvRoot lpv || isParentOf dir (lpvRoot lpv)) && not (lpvExtraDep lpv)+ then Just name+ else Nothing++data TargetType+ = TTUnknown+ | TTNonLocal+ | TTLocalComp !NamedComponent+ | TTLocalAllComps !(Set NamedComponent)++data SimpleTarget+ = STUnknown+ | STNonLocal+ | STLocal !(Set NamedComponent)+ deriving (Show, Eq, Ord)++resolveIdents :: Map PackageName Version -- ^ snapshot+ -> Map PackageName Version -- ^ extra deps+ -> Map PackageName LocalPackageView+ -> (RawInput, RawTarget HasIdents)+ -> Either Text ((RawInput, RawTarget NoIdents), Map PackageName Version)+resolveIdents _ _ _ (ri, RTPackageComponent x y) = Right ((ri, RTPackageComponent x y), Map.empty)+resolveIdents _ _ _ (ri, RTComponent x) = Right ((ri, RTComponent x), Map.empty)+resolveIdents _ _ _ (ri, RTPackage x) = Right $ ((ri, RTPackage x), Map.empty)+resolveIdents snap extras locals (ri, RTPackageIdentifier (PackageIdentifier name version)) =+ case mfound of+ Just (foundPlace, foundVersion) | foundVersion /= version -> Left $ T.pack $ concat+ [ "Specified target version "+ , versionString version+ , " for package "+ , packageNameString name+ , " does not match "+ , foundPlace+ , " version "+ , versionString foundVersion+ ]+ _ -> Right+ ( (ri, RTPackage name)+ , case mfound of+ -- Add to extra deps since we didn't have it already+ Nothing -> Map.singleton name version+ -- Already had it, don't add to extra deps+ Just _ -> Map.empty+ )+ where+ mfound = mlocal <|> mextra <|> msnap++ mlocal = (("local", ) . lpvVersion) <$> Map.lookup name locals+ mextra = ("extra-deps", ) <$> Map.lookup name extras+ msnap = ("snapshot", ) <$> Map.lookup name snap++resolveRawTarget :: Map PackageName Version -- ^ snapshot+ -> Map PackageName Version -- ^ extra deps+ -> Map PackageName LocalPackageView+ -> (RawInput, RawTarget NoIdents)+ -> Either Text (PackageName, (RawInput, TargetType))+resolveRawTarget snap extras locals (ri, rt) =+ go rt+ where+ go (RTPackageComponent name ucomp) =+ case Map.lookup name locals of+ Nothing -> Left $ T.pack $ "Unknown local package: " ++ packageNameString name+ Just lpv ->+ case ucomp of+ ResolvedComponent comp+ | comp `Set.member` lpvComponents lpv ->+ Right (name, (ri, TTLocalComp comp))+ | otherwise -> Left $ T.pack $ concat+ [ "Component "+ , show comp+ , " does not exist in package "+ , packageNameString name+ ]+ UnresolvedComponent comp ->+ case filter (isCompNamed comp) $ Set.toList $ lpvComponents lpv of+ [] -> Left $ T.concat+ [ "Component "+ , comp+ , " does not exist in package "+ , T.pack $ packageNameString name+ ]+ [x] -> Right (name, (ri, TTLocalComp x))+ matches -> Left $ T.concat+ [ "Ambiguous component name "+ , comp+ , " for package "+ , T.pack $ packageNameString name+ , ": "+ , T.pack $ show matches+ ]+ go (RTComponent cname) =+ let allPairs = concatMap+ (\(name, lpv) -> map (name,) $ Set.toList $ lpvComponents lpv)+ (Map.toList locals)+ in case filter (isCompNamed cname . snd) allPairs of+ [] -> Left $ "Could not find a component named " `T.append` cname+ [(name, comp)] ->+ Right (name, (ri, TTLocalComp comp))+ matches -> Left $ T.concat+ [ "Ambiugous component name "+ , cname+ , ", matches: "+ , T.pack $ show matches+ ]++ go (RTPackage name) =+ case Map.lookup name locals of+ Just lpv -> Right (name, (ri, TTLocalAllComps $ lpvComponents lpv))+ Nothing ->+ case Map.lookup name extras of+ Just _ -> Right (name, (ri, TTNonLocal))+ Nothing ->+ case Map.lookup name snap of+ Just _ -> Right (name, (ri, TTNonLocal))+ Nothing -> Right (name, (ri, TTUnknown))++isCompNamed :: Text -> NamedComponent -> Bool+isCompNamed _ CLib = False+isCompNamed t1 (CExe t2) = t1 == t2+isCompNamed t1 (CTest t2) = t1 == t2+isCompNamed t1 (CBench t2) = t1 == t2++simplifyTargets :: Bool -- ^ include tests+ -> Bool -- ^ include benchmarks+ -> [(PackageName, (RawInput, TargetType))]+ -> ([Text], Map PackageName SimpleTarget)+simplifyTargets includeTests includeBenches =+ mconcat . map go . Map.toList . Map.fromListWith (++) . fmap (second return)+ where+ go :: (PackageName, [(RawInput, TargetType)])+ -> ([Text], Map PackageName SimpleTarget)+ go (_, []) = error "Stack.Build.Target.simplifyTargets: the impossible happened"+ go (name, [(_, tt)]) = ([], Map.singleton name $+ case tt of+ TTUnknown -> STUnknown+ TTNonLocal -> STNonLocal+ TTLocalComp comp -> STLocal $ Set.singleton comp+ TTLocalAllComps comps -> STLocal $ Set.filter keepComp comps+ )+ go (name, pairs) =+ case partitionEithers $ map (getLocalComp . snd) pairs of+ ([], comps) -> ([], Map.singleton name $ STLocal $ Set.fromList comps)+ _ ->+ let err = T.pack $ concat+ [ "Overlapping targets provided for package "+ , packageNameString name+ , ": "+ , show $ map (unRawInput . fst) pairs+ ]+ in ([err], Map.empty)++ keepComp CLib = True+ keepComp (CExe _) = True+ keepComp (CTest _) = includeTests+ keepComp (CBench _) = includeBenches++ getLocalComp (TTLocalComp comp) = Right comp+ getLocalComp _ = Left ()++parseTargets :: (MonadThrow m, MonadIO m)+ => Bool -- ^ using implicit global?+ -> Bool -- ^ include tests+ -> Bool -- ^ include benchmarks+ -> Map PackageName Version -- ^ snapshot+ -> Map PackageName Version -- ^ extra deps+ -> Map PackageName LocalPackageView+ -> Path Abs Dir -- ^ current directory+ -> [Text] -- ^ command line targets+ -> m (Map PackageName Version, Map PackageName SimpleTarget)+parseTargets implicitGlobal includeTests includeBenches snap extras locals currDir textTargets' = do+ let textTargets =+ if null textTargets'+ then map (T.pack . packageNameString) $ Map.keys $ Map.filter (not . lpvExtraDep) locals+ else textTargets'+ erawTargets <- mapM (parseRawTargetDirs currDir locals) textTargets++ let (errs1, rawTargets) = partitionEithers erawTargets+ (errs2, unzip -> (rawTargets', newExtras)) = partitionEithers $+ map (resolveIdents snap extras locals) $ concat rawTargets+ (errs3, targetTypes) = partitionEithers $+ map (resolveRawTarget snap extras locals) rawTargets'+ (errs4, targets) = simplifyTargets includeTests includeBenches targetTypes+ errs = concat [errs1, errs2, errs3, errs4]++ if null errs+ then if Map.null targets+ then throwM $ TargetParseException+ $ if implicitGlobal+ then ["The specified targets matched no packages.\nPerhaps you need to run 'stack init'?"]+ else ["The specified targets matched no packages"]+ else return (Map.unions newExtras, targets)+ else throwM $ TargetParseException errs
− src/Stack/Build/Types.hs
@@ -1,544 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE ViewPatterns #-}---- | All data types.--module Stack.Build.Types- (StackBuildException(..)- ,InstallLocation(..)- ,ModTime- ,modTime- ,Installed(..)- ,PackageInstallInfo(..)- ,Task(..)- ,LocalPackage(..)- ,BaseConfigOpts(..)- ,Plan(..)- ,FinalAction(..)- ,BuildOpts(..)- ,defaultBuildOpts- ,TaskType(..)- ,TaskConfigOpts(..)- ,ConfigCache(..)- ,ConstructPlanException(..)- ,configureOpts- ,BadDependency(..)- ,wantedLocalPackages- ,FileCacheInfo (..))- where--import Control.DeepSeq-import Control.Exception--import Data.Binary (Binary(..))-import qualified Data.ByteString as S-import Data.Char (isSpace)-import Data.Data-import Data.Hashable-import Data.List (dropWhileEnd, nub, intercalate)-import qualified Data.Map as Map-import Data.Map.Strict (Map)-import Data.Maybe-import Data.Monoid-import Data.Set (Set)-import qualified Data.Set as Set-import Data.Text (Text)-import qualified Data.Text as T-import Data.Text.Encoding (decodeUtf8With)-import Data.Text.Encoding.Error (lenientDecode)-import Data.Time.Calendar-import Data.Time.Clock-import Data.Word (Word64)-import Distribution.System (Arch)-import Distribution.Text (display)-import GHC.Generics-import Path (Path, Abs, File, Dir, mkRelDir, toFilePath, parseRelDir, (</>))-import Prelude-import Stack.Package-import Stack.Types-import System.Exit (ExitCode)-import System.FilePath (dropTrailingPathSeparator, pathSeparator)--------------------------------------------------- Exceptions-data StackBuildException- = Couldn'tFindPkgId PackageName- | GHCVersionMismatch (Maybe (Version, Arch)) (Version, Arch) (Maybe (Path Abs File))- -- ^ Path to the stack.yaml file- | Couldn'tParseTargets [Text]- | UnknownTargets- (Set PackageName) -- no known version- (Map PackageName Version) -- not in snapshot, here's the most recent version in the index- (Path Abs File) -- stack.yaml- | TestSuiteFailure PackageIdentifier (Map Text (Maybe ExitCode)) (Maybe (Path Abs File)) S.ByteString- | ConstructPlanExceptions- [ConstructPlanException]- (Path Abs File) -- stack.yaml- | CabalExitedUnsuccessfully- ExitCode- PackageIdentifier- (Path Abs File) -- cabal Executable- [String] -- cabal arguments- (Maybe (Path Abs File)) -- logfiles location- S.ByteString -- log contents- | ExecutionFailure [SomeException]- deriving Typeable--instance Show StackBuildException where- show (Couldn'tFindPkgId name) =- ("After installing " <> packageNameString name <>- ", the package id couldn't be found " <> "(via ghc-pkg describe " <>- packageNameString name <> "). This shouldn't happen, " <>- "please report as a bug")- show (GHCVersionMismatch mactual (expected, earch) mstack) = concat- [ case mactual of- Nothing -> "No GHC found, expected version "- Just (actual, arch) -> concat- [ "GHC version mismatched, found "- , versionString actual- , " ("- , display arch- , ")"- , ", but expected version "- ]- , versionString expected- , " ("- , display earch- , ") (based on "- , case mstack of- Nothing -> "command line arguments"- Just stack -> "resolver setting in " ++ toFilePath stack- , "). Try running stack setup"- ]- show (Couldn'tParseTargets targets) = unlines- $ "The following targets could not be parsed as package names or directories:"- : map T.unpack targets- show (UnknownTargets noKnown notInSnapshot stackYaml) =- unlines $ noKnown' ++ notInSnapshot'- where- noKnown'- | Set.null noKnown = []- | otherwise = return $- "The following target packages were not found: " ++- intercalate ", " (map packageNameString $ Set.toList noKnown)- notInSnapshot'- | Map.null notInSnapshot = []- | otherwise =- "The following packages are not in your snapshot, but exist"- : "in your package index. Recommended action: add them to your"- : ("extra-deps in " ++ toFilePath stackYaml)- : "(Note: these are the most recent versions,"- : "but there's no guarantee that they'll build together)."- : ""- : map- (\(name, version) -> "- " ++ packageIdentifierString- (PackageIdentifier name version))- (Map.toList notInSnapshot)- show (TestSuiteFailure ident codes mlogFile bs) = unlines $ concat- [ ["Test suite failure for package " ++ packageIdentifierString ident]- , flip map (Map.toList codes) $ \(name, mcode) -> concat- [ " "- , T.unpack name- , ": "- , case mcode of- Nothing -> " executable not found"- Just ec -> " exited with: " ++ show ec- ]- , return $ case mlogFile of- Nothing -> "Logs printed to console"- -- TODO Should we load up the full error output and print it here?- Just logFile -> "Full log available at " ++ toFilePath logFile- , if S.null bs- then []- else ["", "", doubleIndent $ T.unpack $ decodeUtf8With lenientDecode bs]- ]- where- indent = dropWhileEnd isSpace . unlines . fmap (\line -> " " ++ line) . lines- doubleIndent = indent . indent- show (ConstructPlanExceptions exceptions stackYaml) =- "While constructing the BuildPlan the following exceptions were encountered:" ++- appendExceptions exceptions' ++- if Map.null extras then "" else (unlines- $ ("\n\nRecommended action: try adding the following to your extra-deps in "- ++ toFilePath stackYaml)- : map (\(name, version) -> concat- [ "- "- , packageNameString name- , "-"- , versionString version- ]) (Map.toList extras)- ++ ["", "You may also want to try the 'stack solver' command"]- )- where- exceptions' = removeDuplicates exceptions- appendExceptions = foldr (\e -> (++) ("\n\n--" ++ show e)) ""- removeDuplicates = nub- extras = Map.unions $ map getExtras exceptions'-- getExtras (DependencyCycleDetected _) = Map.empty- getExtras (UnknownPackage _) = Map.empty- getExtras (DependencyPlanFailures _ m) =- Map.unions $ map go $ Map.toList m- where- go (name, (_range, Just version, NotInBuildPlan)) =- Map.singleton name version- go _ = Map.empty- -- Supressing duplicate output- show (CabalExitedUnsuccessfully exitCode taskProvides' execName fullArgs logFiles bs) =- let fullCmd = (dropQuotes (show execName) ++ " " ++ (unwords fullArgs))- logLocations = maybe "" (\fp -> "\n Logs have been written to: " ++ show fp) logFiles- in "\n-- While building package " ++ dropQuotes (show taskProvides') ++ " using:\n" ++- " " ++ fullCmd ++ "\n" ++- " Process exited with code: " ++ show exitCode ++- logLocations ++- (if S.null bs- then ""- else "\n\n" ++ doubleIndent (T.unpack $ decodeUtf8With lenientDecode bs))- where- -- appendLines = foldr (\pName-> (++) ("\n" ++ show pName)) ""- indent = dropWhileEnd isSpace . unlines . fmap (\line -> " " ++ line) . lines- dropQuotes = filter ('\"' /=)- doubleIndent = indent . indent- show (ExecutionFailure es) = intercalate "\n\n" $ map show es--instance Exception StackBuildException--data ConstructPlanException- = DependencyCycleDetected [PackageName]- | DependencyPlanFailures PackageIdentifier (Map PackageName (VersionRange, LatestVersion, BadDependency))- | UnknownPackage PackageName -- TODO perhaps this constructor will be removed, and BadDependency will handle it all- -- ^ Recommend adding to extra-deps, give a helpful version number?- deriving (Typeable, Eq)---- | For display purposes only, Nothing if package not found-type LatestVersion = Maybe Version---- | Reason why a dependency was not used-data BadDependency- = NotInBuildPlan- | Couldn'tResolveItsDependencies- | DependencyMismatch Version- deriving (Typeable, Eq)--instance Show ConstructPlanException where- show e =- let details = case e of- (DependencyCycleDetected pNames) ->- "While checking call stack,\n" ++- " dependency cycle detected in packages:" ++ indent (appendLines pNames)- (DependencyPlanFailures pIdent (Map.toList -> pDeps)) ->- "Failure when adding dependencies:" ++ doubleIndent (appendDeps pDeps) ++ "\n" ++- " needed for package: " ++ packageIdentifierString pIdent- (UnknownPackage pName) ->- "While attempting to add dependency,\n" ++- " Could not find package " ++ show pName ++ " in known packages"- in indent details- where- appendLines = foldr (\pName-> (++) ("\n" ++ show pName)) ""- indent = dropWhileEnd isSpace . unlines . fmap (\line -> " " ++ line) . lines- doubleIndent = indent . indent- appendDeps = foldr (\dep-> (++) ("\n" ++ showDep dep)) ""- showDep (name, (range, mlatest, badDep)) = concat- [ show name- , ": needed ("- , display range- , ")"- , case mlatest of- Nothing -> ""- Just latest -> ", latest is " ++ versionString latest- , ", but "- , case badDep of- NotInBuildPlan -> "not present in build plan"- Couldn'tResolveItsDependencies -> "couldn't resolve its dependencies"- DependencyMismatch version -> versionString version ++ " found"- ]- {- TODO Perhaps change the showDep function to look more like this:- dropQuotes = filter ((/=) '\"')- (VersionOutsideRange pName pIdentifier versionRange) ->- "Exception: Stack.Build.VersionOutsideRange\n" ++- " While adding dependency for package " ++ show pName ++ ",\n" ++- " " ++ dropQuotes (show pIdentifier) ++ " was found to be outside its allowed version range.\n" ++- " Allowed version range is " ++ display versionRange ++ ",\n" ++- " should you correct the version range for " ++ dropQuotes (show pIdentifier) ++ ", found in [extra-deps] in the project's stack.yaml?"- -}----------------------------------------------------- | Configuration for building.-data BuildOpts =- BuildOpts {boptsTargets :: ![Text]- ,boptsLibProfile :: !Bool- ,boptsExeProfile :: !Bool- ,boptsEnableOptimizations :: !(Maybe Bool)- ,boptsHaddock :: !Bool- -- ^ Build haddocks?- ,boptsHaddockDeps :: !(Maybe Bool)- -- ^ Build haddocks for dependencies?- ,boptsFinalAction :: !FinalAction- ,boptsDryrun :: !Bool- ,boptsGhcOptions :: ![Text]- ,boptsFlags :: !(Map (Maybe PackageName) (Map FlagName Bool))- ,boptsInstallExes :: !Bool- -- ^ Install executables to user path after building?- ,boptsPreFetch :: !Bool- -- ^ Fetch all packages immediately- ,boptsTestArgs :: ![String]- -- ^ Arguments to pass to the test suites if we're running them.- ,boptsOnlySnapshot :: !Bool- -- ^ Only install packages in the snapshot database, skipping- -- packages intended for the local database.- ,boptsCoverage :: !Bool- -- ^ Enable code coverage report generation for test- -- suites.- ,boptsFileWatch :: !Bool- -- ^ Watch files for changes and automatically rebuild- ,boptsKeepGoing :: !(Maybe Bool)- -- ^ Keep building/running after failure- }- deriving (Show)--defaultBuildOpts :: BuildOpts-defaultBuildOpts = BuildOpts- { boptsTargets = []- , boptsLibProfile = False- , boptsExeProfile = False- , boptsEnableOptimizations = Nothing- , boptsHaddock = False- , boptsHaddockDeps = Nothing- , boptsFinalAction = DoNothing- , boptsDryrun = False- , boptsGhcOptions = []- , boptsFlags = Map.empty- , boptsInstallExes = False- , boptsPreFetch = False- , boptsTestArgs = []- , boptsOnlySnapshot = False- , boptsCoverage = False- , boptsFileWatch = False- , boptsKeepGoing = Nothing- }---- | Run a Setup.hs action after building a package, before installing.-data FinalAction- = DoTests- Bool -- rerun tests which already passed?- | DoBenchmarks- | DoNothing- deriving (Eq,Show)---- | Package dependency oracle.-newtype PkgDepsOracle =- PkgDeps PackageName- deriving (Show,Typeable,Eq,Hashable,Binary,NFData)---- | A location to install a package into, either snapshot or local-data InstallLocation = Snap | Local- deriving (Show, Eq)-instance Monoid InstallLocation where- mempty = Snap- mappend Local _ = Local- mappend _ Local = Local- mappend Snap Snap = Snap---- | Datatype which tells how which version of a package to install and where--- to install it into-class PackageInstallInfo a where- piiVersion :: a -> Version- piiLocation :: a -> InstallLocation---- | Information on a locally available package of source code-data LocalPackage = LocalPackage- { lpPackage :: !Package -- ^ The @Package@ info itself, after resolution with package flags, not including any final actions- , lpPackageFinal :: !Package -- ^ Same as lpPackage, but with any test suites or benchmarks enabled as necessary- , lpWanted :: !Bool -- ^ Is this package a \"wanted\" target based on command line input- , lpDir :: !(Path Abs Dir) -- ^ Directory of the package.- , lpCabalFile :: !(Path Abs File) -- ^ The .cabal file- , lpDirtyFiles :: !Bool -- ^ are there files that have changed since the last build?- , lpNewBuildCache :: !(Map FilePath FileCacheInfo) -- ^ current state of the files- , lpFiles :: !(Set (Path Abs File)) -- ^ all files used by this package- , lpComponents :: !(Set Text) -- ^ components to build, passed directly to Setup.hs build- }- deriving Show---- | Stored on disk to know whether the flags have changed or any--- files have changed.-data ConfigCache = ConfigCache- { configCacheOpts :: ![S.ByteString]- -- ^ All options used for this package.- , configCacheDeps :: !(Set GhcPkgId)- -- ^ The GhcPkgIds of all of the dependencies. Since Cabal doesn't take- -- the complete GhcPkgId (only a PackageIdentifier) in the configure- -- options, just using the previous value is insufficient to know if- -- dependencies have changed.- , configCacheComponents :: !(Set S.ByteString)- -- ^ The components to be built. It's a bit of a hack to include this in- -- here, as it's not a configure option (just a build option), but this- -- is a convenient way to force compilation when the components change.- , configCacheHaddock :: !Bool- -- ^ Are haddocks to be built?- }- deriving (Generic,Eq,Show)-instance Binary ConfigCache---- | A task to perform when building-data Task = Task- { taskProvides :: !PackageIdentifier -- ^ the package/version to be built- , taskType :: !TaskType -- ^ the task type, telling us how to build this- , taskConfigOpts :: !TaskConfigOpts- , taskPresent :: !(Set GhcPkgId) -- ^ GhcPkgIds of already-installed dependencies- }- deriving Show---- | Given the IDs of any missing packages, produce the configure options-data TaskConfigOpts = TaskConfigOpts- { tcoMissing :: !(Set PackageIdentifier)- -- ^ Dependencies for which we don't yet have an GhcPkgId- , tcoOpts :: !(Set GhcPkgId -> [Text])- -- ^ Produce the list of options given the missing @GhcPkgId@s- }-instance Show TaskConfigOpts where- show (TaskConfigOpts missing f) = concat- [ "Missing: "- , show missing- , ". Without those: "- , show $ f Set.empty- ]---- | The type of a task, either building local code or something from the--- package index (upstream)-data TaskType = TTLocal LocalPackage- | TTUpstream Package InstallLocation- deriving Show---- | A complete plan of what needs to be built and how to do it-data Plan = Plan- { planTasks :: !(Map PackageName Task)- , planFinals :: !(Map PackageName Task)- -- ^ Final actions to be taken (test, benchmark, etc)- , planUnregisterLocal :: !(Map GhcPkgId Text)- -- ^ Text is reason we're unregistering, for display only- , planInstallExes :: !(Map Text InstallLocation)- -- ^ Executables that should be installed after successful building- }- deriving Show---- | Basic information used to calculate what the configure options are-data BaseConfigOpts = BaseConfigOpts- { bcoSnapDB :: !(Path Abs Dir)- , bcoLocalDB :: !(Path Abs Dir)- , bcoSnapInstallRoot :: !(Path Abs Dir)- , bcoLocalInstallRoot :: !(Path Abs Dir)- , bcoBuildOpts :: !BuildOpts- }---- | Render a @BaseConfigOpts@ to an actual list of options-configureOpts :: EnvConfig- -> BaseConfigOpts- -> Set GhcPkgId -- ^ dependencies- -> Bool -- ^ wanted?- -> InstallLocation- -> Package- -> [Text]-configureOpts econfig bco deps wanted loc package = map T.pack $ concat- [ ["--user", "--package-db=clear", "--package-db=global"]- , map (("--package-db=" ++) . toFilePath) $ case loc of- Snap -> [bcoSnapDB bco]- Local -> [bcoSnapDB bco, bcoLocalDB bco]- , depOptions- , [ "--libdir=" ++ toFilePathNoTrailingSlash (installRoot </> $(mkRelDir "lib"))- , "--bindir=" ++ toFilePathNoTrailingSlash (installRoot </> bindirSuffix)- , "--datadir=" ++ toFilePathNoTrailingSlash (installRoot </> $(mkRelDir "share"))- , "--docdir=" ++ toFilePathNoTrailingSlash docDir- , "--htmldir=" ++ toFilePathNoTrailingSlash docDir- , "--haddockdir=" ++ toFilePathNoTrailingSlash docDir]- , ["--enable-library-profiling" | boptsLibProfile bopts || boptsExeProfile bopts]- , ["--enable-executable-profiling" | boptsExeProfile bopts]- , map (\(name,enabled) ->- "-f" <>- (if enabled- then ""- else "-") <>- flagNameString name)- (Map.toList (packageFlags package))- -- FIXME Chris: where does this come from now? , ["--ghc-options=-O2" | gconfigOptimize gconfig]- , if wanted- then concatMap (\x -> ["--ghc-options", T.unpack x]) (boptsGhcOptions bopts)- else []- , map (("--extra-include-dirs=" ++) . T.unpack) (Set.toList (configExtraIncludeDirs config))- , map (("--extra-lib-dirs=" ++) . T.unpack) (Set.toList (configExtraLibDirs config))- ]- where- config = getConfig econfig- bopts = bcoBuildOpts bco- toFilePathNoTrailingSlash = dropTrailingPathSeparator . toFilePath- docDir =- case pkgVerDir of- Nothing -> installRoot </> docdirSuffix- Just dir -> installRoot </> docdirSuffix </> dir- installRoot =- case loc of- Snap -> bcoSnapInstallRoot bco- Local -> bcoLocalInstallRoot bco- pkgVerDir =- parseRelDir (packageIdentifierString (PackageIdentifier (packageName package)- (packageVersion package)) ++- [pathSeparator])-- depOptions = map toDepOption $ Set.toList deps- where- toDepOption =- if envConfigCabalVersion econfig >= $(mkVersion "1.22")- then toDepOption1_22- else toDepOption1_18-- toDepOption1_22 gid = concat- [ "--dependency="- , packageNameString $ packageIdentifierName $ ghcPkgIdPackageIdentifier gid- , "="- , ghcPkgIdString gid- ]-- toDepOption1_18 gid = concat- [ "--constraint="- , packageNameString name- , "=="- , versionString version- ]- where- PackageIdentifier name version = ghcPkgIdPackageIdentifier gid---- | Get set of wanted package names from locals.-wantedLocalPackages :: [LocalPackage] -> Set PackageName-wantedLocalPackages = Set.fromList . map (packageName . lpPackage) . filter lpWanted---- | Used for storage and comparison.-newtype ModTime = ModTime (Integer,Rational)- deriving (Ord,Show,Generic,Eq)-instance Binary ModTime---- | One-way conversion to serialized time.-modTime :: UTCTime -> ModTime-modTime x =- ModTime- ( toModifiedJulianDay- (utctDay x)- , toRational- (utctDayTime x))--data Installed = Library GhcPkgId | Executable PackageIdentifier- deriving (Show, Eq, Ord)--data FileCacheInfo = FileCacheInfo- { fciModTime :: !ModTime- , fciSize :: !Word64- , fciHash :: !S.ByteString- }- deriving (Generic, Show)-instance Binary FileCacheInfo
src/Stack/BuildPlan.hs view
@@ -22,6 +22,7 @@ , ToolMap , getToolMap , shadowMiniBuildPlan+ , parseCustomMiniBuildPlan ) where import Control.Applicative@@ -34,9 +35,12 @@ import Control.Monad.State.Strict (State, execState, get, modify, put) import Control.Monad.Trans.Control (MonadBaseControl)-import Data.Aeson.Extended (FromJSON (..), withObject, withText, (.:))+import qualified Crypto.Hash.SHA256 as SHA256+import Data.Aeson.Extended (FromJSON (..), withObject, withText, (.:), (.:?), (.!=)) import Data.Binary.VersionTagged (taggedDecodeOrLoad) import Data.ByteString (ByteString)+import qualified Data.ByteString.Base16 as B16+import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import Data.Either (partitionEithers) import qualified Data.Foldable as F@@ -46,15 +50,16 @@ import Data.List (intercalate) import Data.Map (Map) import qualified Data.Map as Map-import Data.Maybe (mapMaybe)+import Data.Maybe (fromMaybe, mapMaybe) import Data.Monoid ((<>), Monoid (..)) import Data.Set (Set) import qualified Data.Set as Set import qualified Data.Text as T+import Data.Text.Encoding (encodeUtf8) import Data.Time (Day) import qualified Data.Traversable as Tr import Data.Typeable (Typeable)-import Data.Yaml (decodeFileEither)+import Data.Yaml (decodeEither', decodeFileEither) import Distribution.PackageDescription (GenericPackageDescription, flagDefault, flagManual, flagName, genPackageFlags,@@ -67,6 +72,7 @@ import Network.HTTP.Types (Status(..)) import Network.HTTP.Client (checkStatus) import Path+import Path.IO import Prelude -- Fix AMP warning import Stack.Constants import Stack.Fetch@@ -75,8 +81,8 @@ import Stack.PackageIndex import Stack.Types import Stack.Types.StackT-import System.Directory (createDirectoryIfMissing)-import System.FilePath (takeDirectory)+import System.Directory (canonicalizePath)+import qualified System.FilePath as FP data BuildPlanException = UnknownPackages@@ -202,8 +208,11 @@ } toMiniBuildPlan :: (MonadIO m, MonadLogger m, MonadReader env m, HasHttpManager env, MonadThrow m, HasConfig env, MonadBaseControl IO m, MonadCatch m)- => BuildPlan -> m MiniBuildPlan-toMiniBuildPlan bp = do+ => Version -- ^ GHC version+ -> Map PackageName Version -- ^ cores+ -> Map PackageName (Version, Map FlagName Bool) -- ^ non-core packages+ -> m MiniBuildPlan+toMiniBuildPlan ghcVersion corePackages packages = do $logInfo "Caching build plan" -- Determine the dependencies of all of the packages in the build plan. We@@ -212,9 +221,9 @@ -- remove those from the list of dependencies, since there's no way we'll -- ever reinstall them anyway. (cores, missingCores) <- addDeps True ghcVersion- $ fmap (, Map.empty) (siCorePackages $ bpSystemInfo bp)+ $ fmap (, Map.empty) corePackages - (extras, missing) <- addDeps False ghcVersion $ fmap goPP $ bpPackages bp+ (extras, missing) <- addDeps False ghcVersion packages assert (Set.null missing) $ return MiniBuildPlan { mbpGhcVersion = ghcVersion@@ -225,7 +234,6 @@ ] } where- ghcVersion = siGhcVersion $ bpSystemInfo bp goCore (PackageIdentifier name version) = (name, MiniPackageInfo { mpiVersion = version , mpiFlags = Map.empty@@ -235,11 +243,6 @@ , mpiHasLibrary = True }) - goPP pp =- ( ppVersion pp- , pcFlagOverrides $ ppConstraints pp- )- removeMissingDeps cores mpi = mpi { mpiPackageDeps = Set.intersection cores (mpiPackageDeps mpi) }@@ -432,8 +435,17 @@ loadMiniBuildPlan name = do path <- configMiniBuildPlanCache name let fp = toFilePath path- taggedDecodeOrLoad fp $ liftM buildPlanFixes $- loadBuildPlan name >>= toMiniBuildPlan+ taggedDecodeOrLoad fp $ liftM buildPlanFixes $ do+ bp <- loadBuildPlan name+ toMiniBuildPlan+ (siGhcVersion $ bpSystemInfo bp)+ (siCorePackages $ bpSystemInfo bp)+ (fmap goPP $ bpPackages bp)+ where+ goPP pp =+ ( ppVersion pp+ , pcFlagOverrides $ ppConstraints pp+ ) -- | Some hard-coded fixes for build plans, hopefully to be irrelevant over -- time.@@ -467,7 +479,7 @@ Right bp -> return bp Left e -> do $logDebug $ "Decoding build plan from file failed: " <> T.pack (show e)- liftIO $ createDirectoryIfMissing True $ takeDirectory $ toFilePath fp+ createTree (parent fp) req <- parseUrl $ T.unpack url $logSticky $ "Downloading " <> renderSnapName name <> " build plan ..." $logDebug $ "Downloading build plan from: " <> url@@ -522,7 +534,11 @@ flagName' = fromCabalFlagName . flagName - flagOptions = map Map.fromList $ mapM getOptions $ genPackageFlags gpd+ -- Avoid exponential complexity in flag combinations making us sad pandas.+ -- See: https://github.com/commercialhaskell/stack/issues/543+ maxFlagOptions = 128++ flagOptions = take maxFlagOptions $ map Map.fromList $ mapM getOptions $ genPackageFlags gpd getOptions f | flagManual f = [(flagName' f, flagDefault f)] | flagDefault f =@@ -664,3 +680,62 @@ Just True -> Left Just False -> Right Nothing -> assert False Right++parseCustomMiniBuildPlan :: (MonadIO m, MonadCatch m, MonadLogger m, MonadReader env m, HasHttpManager env, HasConfig env, MonadBaseControl IO m)+ => Path Abs File -- ^ stack.yaml file location+ -> T.Text -> m MiniBuildPlan+parseCustomMiniBuildPlan stackYamlFP url0 = do+ yamlFP <- getYamlFP url0++ yamlBS <- liftIO $ S.readFile $ toFilePath yamlFP+ let yamlHash = S8.unpack $ B16.encode $ SHA256.hash yamlBS+ binaryFilename <- parseRelFile $ yamlHash ++ ".bin"+ customPlanDir <- getCustomPlanDir+ let binaryFP = customPlanDir </> $(mkRelDir "bin") </> binaryFilename++ taggedDecodeOrLoad (toFilePath binaryFP) $ do+ cs <- either throwM return $ decodeEither' yamlBS+ let addFlags :: PackageIdentifier -> (PackageName, (Version, Map FlagName Bool))+ addFlags (PackageIdentifier name ver) =+ (name, (ver, fromMaybe Map.empty $ Map.lookup name $ csFlags cs))+ toMiniBuildPlan+ (csGhcVersion cs)+ Map.empty+ (Map.fromList $ map addFlags $ Set.toList $ csPackages cs)+ where+ getCustomPlanDir = do+ root <- asks $ configStackRoot . getConfig+ return $ root </> $(mkRelDir "custom-plan")++ -- Get the path to the YAML file+ getYamlFP url =+ case parseUrl $ T.unpack url of+ Just req -> getYamlFPFromReq url req+ Nothing -> getYamlFPFromFile url++ getYamlFPFromReq url req = do+ let hashStr = S8.unpack $ B16.encode $ SHA256.hash $ encodeUtf8 url+ hashFP <- parseRelFile $ hashStr ++ ".yaml"+ customPlanDir <- getCustomPlanDir++ let cacheFP = customPlanDir </> $(mkRelDir "yaml") </> hashFP+ _ <- download req cacheFP+ return cacheFP++ getYamlFPFromFile url = do+ fp <- liftIO $ canonicalizePath $ toFilePath (parent stackYamlFP) FP.</> T.unpack (fromMaybe url $+ T.stripPrefix "file://" url <|> T.stripPrefix "file:" url)+ parseAbsFile fp++data CustomSnapshot = CustomSnapshot+ { csGhcVersion :: !Version+ , csPackages :: !(Set PackageIdentifier)+ , csFlags :: !(Map PackageName (Map FlagName Bool))+ }+instance FromJSON CustomSnapshot where+ parseJSON = withObject "CustomSnapshot" $ \o -> CustomSnapshot+ <$> ((o .: "compiler") >>= (\t -> maybe (fail $ "Invalid compiler: " ++ T.unpack t) return $ do+ t' <- T.stripPrefix "ghc-" t+ parseVersionFromString $ T.unpack t'))+ <*> o .: "packages"+ <*> o .:? "flags" .!= Map.empty
src/Stack/Config.hs view
@@ -21,19 +21,20 @@ -- probably default to behaving like cabal, possibly with spitting out -- a warning that "you should run `stk init` to make things better". module Stack.Config- ( configOptsParser- , loadConfig+ (loadConfig+ ,packagesParser+ ,resolvePackageEntry ) where import qualified Codec.Archive.Tar as Tar import qualified Codec.Compression.GZip as GZip import Control.Applicative-import Control.Concurrent (getNumCapabilities)+import Control.Exception (IOException) import Control.Monad-import Control.Monad.Catch+import Control.Monad.Catch (Handler(..), MonadCatch, MonadThrow, catches, throwM) import Control.Monad.IO.Class import Control.Monad.Logger hiding (Loc)-import Control.Monad.Reader (MonadReader, ask, runReaderT)+import Control.Monad.Reader (MonadReader, ask, asks, runReaderT) import Control.Monad.Trans.Control (MonadBaseControl) import qualified Crypto.Hash.SHA256 as SHA256 import Data.Aeson.Extended@@ -43,27 +44,27 @@ import qualified Data.Map as Map import Data.Maybe import Data.Monoid-import qualified Data.Set as S import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8, decodeUtf8) import qualified Data.Yaml as Yaml import Distribution.System (OS (..), Platform (..), buildPlatform) import qualified Distribution.Text import Distribution.Version (simplifyVersionRange)+import GHC.Conc (getNumProcessors) import Network.HTTP.Client.Conduit (HasHttpManager, getHttpManager, Manager, parseUrl) import Network.HTTP.Download (download)-import Options.Applicative (Parser, idm, strOption, long, short, metavar, help, option, auto)-import Options.Applicative.Builder.Extra (maybeBoolFlags)+import Options.Applicative (Parser, strOption, long, help) import Path import Path.IO import qualified Paths_stack as Meta import Stack.BuildPlan import Stack.Constants import qualified Stack.Docker as Docker+import qualified Stack.Image as Image import Stack.Init import Stack.Types import Stack.Types.Internal-import System.Directory+import System.Directory (getAppUserDataDirectory, createDirectoryIfMissing, canonicalizePath) import System.Environment import System.IO import System.Process.Read (getEnvOverride, EnvOverride, unEnvOverride, readInNull)@@ -134,6 +135,8 @@ configConfigMonoid = configMonoid + configImage = Image.imgOptsFromMonoid configMonoidImageOpts+ origEnv <- getEnvOverride configPlatform let configEnvOverride _ = return origEnv @@ -146,76 +149,28 @@ return $ progsDir </> $(mkRelDir stackProgName) </> platform _ -> return $ configStackRoot </> $(mkRelDir "programs") </> platform - configLocalBin <- do- localDir <- liftIO (getAppUserDataDirectory "local") >>= parseAbsDir- return $ localDir </> $(mkRelDir "bin")-+ configLocalBin <-+ case configMonoidLocalBinPath of+ Nothing -> do+ localDir <- liftIO (getAppUserDataDirectory "local") >>= parseAbsDir+ return $ localDir </> $(mkRelDir "bin")+ Just userPath ->+ (liftIO $ canonicalizePath userPath >>= parseAbsDir)+ `catches`+ [Handler (\(_ :: IOException) -> throwM $ NoSuchDirectory userPath)+ ,Handler (\(_ :: PathParseException) -> throwM $ NoSuchDirectory userPath)+ ] configJobs <- case configMonoidJobs of- Nothing -> liftIO getNumCapabilities+ Nothing -> liftIO getNumProcessors Just i -> return i let configConcurrentTests = fromMaybe True configMonoidConcurrentTests - return Config {..}+ let configAuthorEmail = configMonoidAuthorEmail+ configAuthorName = configMonoidAuthorName+ configScmInit = configMonoidScmInit --- | Command-line arguments parser for configuration.-configOptsParser :: Bool -> Parser ConfigMonoid-configOptsParser docker =- (\opts systemGHC installGHC arch os jobs includes libs skipGHCCheck skipMsys -> mempty- { configMonoidDockerOpts = opts- , configMonoidSystemGHC = systemGHC- , configMonoidInstallGHC = installGHC- , configMonoidSkipGHCCheck = skipGHCCheck- , configMonoidArch = arch- , configMonoidOS = os- , configMonoidJobs = jobs- , configMonoidExtraIncludeDirs = includes- , configMonoidExtraLibDirs = libs- , configMonoidSkipMsys = skipMsys- })- <$> Docker.dockerOptsParser docker- <*> maybeBoolFlags- "system-ghc"- "using the system installed GHC (on the PATH) if available and a matching version"- idm- <*> maybeBoolFlags- "install-ghc"- "downloading and installing GHC if necessary (can be done manually with stack setup)"- idm- <*> optional (strOption- ( long "arch"- <> metavar "ARCH"- <> help "System architecture, e.g. i386, x86_64"- ))- <*> optional (strOption- ( long "os"- <> metavar "OS"- <> help "Operating system, e.g. linux, windows"- ))- <*> optional (option auto- ( long "jobs"- <> short 'j'- <> metavar "JOBS"- <> help "Number of concurrent jobs to run"- ))- <*> fmap (S.fromList . map T.pack) (many $ strOption- ( long "extra-include-dirs"- <> metavar "DIR"- <> help "Extra directories to check for C header files"- ))- <*> fmap (S.fromList . map T.pack) (many $ strOption- ( long "extra-lib-dirs"- <> metavar "DIR"- <> help "Extra directories to check for libraries"- ))- <*> maybeBoolFlags- "skip-ghc-check"- "skipping the GHC version and architecture check"- idm- <*> maybeBoolFlags- "skip-msys"- "skipping the local MSYS installation (Windows only)"- idm+ return Config {..} -- | Get the directory on Windows where we should install extra programs. For -- more information, see discussion at:@@ -257,41 +212,33 @@ Just (_, _, projectConfig) -> configArgs : projectConfig : extraConfigs unless (fromCabalVersion Meta.version `withinRange` configRequireStackVersion config) (throwM (BadStackVersionException (configRequireStackVersion config)))- menv <- runReaderT getMinimalEnvOverride config return $ LoadConfig { lcConfig = config- , lcLoadBuildConfig = loadBuildConfig menv mproject config stackRoot+ , lcLoadBuildConfig = loadBuildConfig mproject config stackRoot , lcProjectRoot = fmap (\(_, fp, _) -> parent fp) mproject } -- | Load the build configuration, adds build-specific values to config loaded by @loadConfig@. -- values. loadBuildConfig :: (MonadLogger m, MonadIO m, MonadCatch m, MonadReader env m, HasHttpManager env, MonadBaseControl IO m, HasTerminal env)- => EnvOverride- -> Maybe (Project, Path Abs File, ConfigMonoid)+ => Maybe (Project, Path Abs File, ConfigMonoid) -> Config -> Path Abs Dir- -> Maybe Resolver -- override resolver- -> NoBuildConfigStrategy+ -> Maybe AbstractResolver -- override resolver -> m BuildConfig-loadBuildConfig menv mproject config stackRoot mresolver noConfigStrat = do+loadBuildConfig mproject config stackRoot mresolver = do env <- ask let miniConfig = MiniConfig (getHttpManager env) config (project', stackYamlFP) <- case mproject of Just (project, fp, _) -> return (project, fp)- Nothing -> case noConfigStrat of- ThrowException -> do- currDir <- getWorkingDir- cabalFiles <- findCabalFiles True currDir- throwM $ NoProjectConfigFound currDir- $ Just $ if null cabalFiles then "new" else "init"- ExecStrategy -> do+ Nothing -> do+ $logInfo "Run from outside a project, using implicit global config" let dest :: Path Abs File dest = destDir </> stackDotYaml destDir = implicitGlobalDir stackRoot dest' :: FilePath dest' = toFilePath dest- liftIO (createDirectoryIfMissing True (toFilePath destDir))+ createTree destDir exists <- fileExists dest if exists then do@@ -299,15 +246,22 @@ when (getTerminal env) $ case mresolver of Nothing ->- $logInfo ("Using resolver: " <> renderResolver (projectResolver project) <>+ $logInfo ("Using resolver: " <> resolverName (projectResolver project) <> " from global config file: " <> T.pack dest')- Just resolver ->- $logInfo ("Using resolver: " <> renderResolver resolver <>+ Just aresolver -> do+ let name =+ case aresolver of+ ARResolver resolver -> resolverName resolver+ ARLatestNightly -> "nightly"+ ARLatestLTS -> "lts"+ ARLatestLTSMajor x -> T.pack $ "lts-" ++ show x+ ARGlobal -> "global"+ $logInfo ("Using resolver: " <> name <> " specified on command line") return (project, dest) else do r <- runReaderT getLatestResolver miniConfig- $logInfo ("Using latest snapshot resolver: " <> renderResolver r)+ $logInfo ("Using latest snapshot resolver: " <> resolverName r) $logInfo ("Writing global (non-project-specific) config file to: " <> T.pack dest') $logInfo "Note: You can change the snapshot via the resolver field there." let p = Project@@ -318,9 +272,15 @@ } liftIO $ Yaml.encodeFile dest' p return (p, dest)- let project = project'- { projectResolver = fromMaybe (projectResolver project') mresolver- }+ resolver <-+ case mresolver of+ Nothing -> return $ projectResolver project'+ Just aresolver -> do+ manager <- asks getHttpManager+ runReaderT+ (makeConcreteResolver aresolver)+ (MiniConfig manager config)+ let project = project' { projectResolver = resolver } ghcVersion <- case projectResolver project of@@ -328,20 +288,19 @@ mbp <- runReaderT (loadMiniBuildPlan snapName) miniConfig return $ mbpGhcVersion mbp ResolverGhc m -> return $ fromMajorVersion m-- let root = parent stackYamlFP- packages' <- mapM (resolvePackageEntry menv root) (projectPackages project)- let packages = Map.fromList $ concat packages'+ ResolverCustom _name url -> do+ mbp <- runReaderT (parseCustomMiniBuildPlan stackYamlFP url) miniConfig+ return $ mbpGhcVersion mbp return BuildConfig { bcConfig = config , bcResolver = projectResolver project , bcGhcVersionExpected = ghcVersion- , bcPackages = packages+ , bcPackageEntries = projectPackages project , bcExtraDeps = projectExtraDeps project- , bcRoot = root , bcStackYaml = stackYamlFP , bcFlags = projectFlags project+ , bcImplicitGlobal = isNothing mproject } -- | Resolve a PackageEntry into a list of paths, downloading and cloning as@@ -384,7 +343,7 @@ dir = root </> dirRel dirTmp = root </> dirRelTmp - exists <- liftIO $ doesDirectoryExist $ toFilePath dir+ exists <- dirExists dir unless exists $ do req <- parseUrl $ T.unpack url _ <- download req file@@ -394,7 +353,7 @@ lbs <- L.hGetContents h let entries = Tar.read $ GZip.decompress lbs Tar.unpack (toFilePath dirTmp) entries- renameDirectory (toFilePath dirTmp) (toFilePath dir)+ renameDir dirTmp dir x <- listDirectory dir case x of@@ -412,10 +371,10 @@ let dir = root </> dirRel dirTmp = root </> dirRelTmp - exists <- liftIO $ doesDirectoryExist $ toFilePath dir+ exists <- dirExists dir unless exists $ do removeTreeIfExists dirTmp- liftIO $ createDirectoryIfMissing True $ toFilePath $ parent dirTmp+ createTree (parent dirTmp) readInNull (parent dirTmp) "git" menv [ "clone" , T.unpack url@@ -428,7 +387,7 @@ , T.unpack commit ] Nothing- liftIO $ renameDirectory (toFilePath dirTmp) (toFilePath dir)+ renameDir dirTmp dir return dir @@ -465,10 +424,14 @@ : maybe [] return (mstackGlobalConfig <|> defaultStackGlobalConfig) -- | Load and parse YAML from the given file.-loadYaml :: (FromJSON a,MonadIO m) => Path Abs File -> m a-loadYaml path =- liftIO $ Yaml.decodeFileEither (toFilePath path)- >>= either (throwM . ParseConfigFileException path) return+loadYaml :: (FromJSON (a, [JSONWarning]), MonadIO m, MonadLogger m) => Path Abs File -> m a+loadYaml path = do+ (result,warnings) <-+ liftIO $+ Yaml.decodeFileEither (toFilePath path) >>=+ either (throwM . ParseConfigFileException path) return+ logJSONWarnings (toFilePath path) warnings+ return result -- | Get the location of the project config file, if it exists. getProjectConfig :: (MonadIO m, MonadThrow m, MonadLogger m)@@ -526,3 +489,6 @@ load fp = do ProjectAndConfigMonoid project config <- loadYaml fp return $ Just (project, fp, config)++packagesParser :: Parser [String]+packagesParser = many (strOption (long "package" <> help "Additional packages that must be installed"))
src/Stack/Constants.hs view
@@ -10,7 +10,8 @@ ,defaultShakeThreads ,distDirFromDir ,distRelativeDir- ,haskellFileExts+ ,haskellModuleExts+ ,imageStagingDir ,projectDockerSandboxDir ,rawGithubUrl ,stackDotYaml@@ -20,18 +21,27 @@ ,configCabalMod ,buildCacheFile ,testSuccessFile+ ,testBuiltFile+ ,benchBuiltFile ,stackProgName ,wiredInPackages ,cabalPackageName ,implicitGlobalDir+ ,hpcRelativeDir ,hpcDirFromDir- ,dotHpc)+ ,dotHpc+ ,objectInterfaceDir+ ,templatesDir+ ,defaultAuthorEmail+ ,defaultAuthorName+ ,globalConfigPath+ ,authorEmailKey+ ,authorNameKey+ ,scmInitKey) where - import Control.Monad.Catch (MonadThrow) import Control.Monad.Reader- import Data.HashSet (HashSet) import qualified Data.HashSet as HashSet import Data.Text (Text)@@ -40,14 +50,20 @@ import Prelude import Stack.Types.Config import Stack.Types.PackageIdentifier- import Stack.Types.PackageName +-- | Extensions for anything that can be a Haskell module.+haskellModuleExts :: [Text]+haskellModuleExts = haskellFileExts ++ haskellPreprocessorExts --- | Extensions used for Haskell files.+-- | Extensions used for Haskell modules. Excludes preprocessor ones. haskellFileExts :: [Text]-haskellFileExts = ["hs","hsc","lhs"]+haskellFileExts = ["hs", "hsc", "lhs"] +-- | Extensions for modules that are preprocessed by common preprocessors.+haskellPreprocessorExts :: [Text]+haskellPreprocessorExts = ["gc", "chs", "hsc", "x", "y", "ly", "cpphs"]+ -- | The filename used for completed build indicators. builtFileFromDir :: (MonadThrow m, MonadReader env m, HasPlatform env,HasEnvConfig env) => Path Abs Dir@@ -100,6 +116,10 @@ userDocsDir :: Config -> Path Abs Dir userDocsDir config = configStackRoot config </> $(mkRelDir "doc/") +-- | Output .o/.hi directory.+objectInterfaceDir :: BuildConfig -> Path Abs Dir+objectInterfaceDir bconfig = bcWorkDir bconfig </> $(mkRelDir "odir/")+ -- | The filename used for dirtiness check of source files. buildCacheFile :: (MonadThrow m, MonadReader env m, HasPlatform env,HasEnvConfig env) => Path Abs Dir -- ^ Package directory.@@ -118,6 +138,24 @@ (</> $(mkRelFile "stack-test-success")) (distDirFromDir dir) +-- | The filename used to mark tests as having built+testBuiltFile :: (MonadThrow m, MonadReader env m, HasPlatform env,HasEnvConfig env)+ => Path Abs Dir -- ^ Package directory+ -> m (Path Abs File)+testBuiltFile dir =+ liftM+ (</> $(mkRelFile "stack-test-built"))+ (distDirFromDir dir)++-- | The filename used to mark benchmarks as having built+benchBuiltFile :: (MonadThrow m, MonadReader env m, HasPlatform env,HasEnvConfig env)+ => Path Abs Dir -- ^ Package directory+ -> m (Path Abs File)+benchBuiltFile dir =+ liftM+ (</> $(mkRelFile "stack-bench-built"))+ (distDirFromDir dir)+ -- | The filename used for dirtiness check of config. configCacheFile :: (MonadThrow m, MonadReader env m, HasPlatform env,HasEnvConfig env) => Path Abs Dir -- ^ Package directory.@@ -141,9 +179,15 @@ :: (MonadThrow m, MonadReader env m, HasPlatform env, HasEnvConfig env) => Path Abs Dir -- ^ Package directory. -> m (Path Abs Dir)-hpcDirFromDir dir = do- liftM (</> $(mkRelDir "hpc")) (distDirFromDir dir)+hpcDirFromDir fp =+ liftM (fp </>) hpcRelativeDir +-- | Relative location of directory for HPC work.+hpcRelativeDir :: (MonadThrow m, MonadReader env m, HasPlatform env, HasEnvConfig env)+ => m (Path Rel Dir)+hpcRelativeDir =+ liftM (</> $(mkRelDir "hpc")) distRelativeDir+ -- | Package's build artifacts directory. distDirFromDir :: (MonadThrow m, MonadReader env m, HasPlatform env, HasEnvConfig env) => Path Abs Dir@@ -151,6 +195,10 @@ distDirFromDir fp = liftM (fp </>) distRelativeDir +-- | Directory for project templates.+templatesDir :: Config -> Path Abs Dir+templatesDir config = configStackRoot config </> $(mkRelDir "templates")+ -- | Relative location of build artifacts. distRelativeDir :: (MonadThrow m, MonadReader env m, HasPlatform env, HasEnvConfig env) => m (Path Rel Dir)@@ -202,6 +250,10 @@ projectDockerSandboxDir :: Path Abs Dir -> Path Abs Dir projectDockerSandboxDir projectRoot = projectRoot </> workDirRel </> $(mkRelDir "docker/") +-- | Image staging dir from project root.+imageStagingDir :: Path Abs Dir -> Path Abs Dir+imageStagingDir p = p </> workDirRel </> $(mkRelDir "image/")+ -- | Name of the 'stack' program. stackProgName :: String stackProgName = "stack"@@ -247,3 +299,15 @@ -- | Where .mix files go. dotHpc :: Path Rel Dir dotHpc = $(mkRelDir ".hpc")++-- | Default author email.+defaultAuthorEmail :: Text+defaultAuthorEmail = "example@example.com"++-- | Default author name.+defaultAuthorName :: Text+defaultAuthorName = "Example Author Name"++-- | Global config path.+globalConfigPath :: Config -> Path Abs File+globalConfigPath = (</> $(mkRelFile "stack.yaml")) . configStackRoot
src/Stack/Docker.hs view
@@ -8,15 +8,14 @@ ,CleanupAction(..) ,dockerCleanupCmdName ,dockerCmdName- ,dockerOptsParser ,dockerOptsFromMonoid ,dockerPullCmdName ,execWithOptionalContainer- ,execWithRequiredContainer ,preventInContainer ,pull ,reexecWithOptionalContainer ,reset+ ,reExecArgName ) where import Control.Applicative@@ -29,94 +28,116 @@ import Control.Monad.Writer (execWriter,runWriter,tell) import Control.Monad.Trans.Control (MonadBaseControl) import Data.Aeson.Extended (FromJSON(..),(.:),(.:?),(.!=),eitherDecode)-import Data.Attoparsec.Args (EscapingMode (Escaping), parseArgs) import Data.ByteString.Builder (stringUtf8,charUtf8,toLazyByteString) import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as LBS import Data.Char (isSpace,toUpper,isAscii) import Data.List (dropWhileEnd,find,intercalate,intersperse,isPrefixOf,isInfixOf,foldl',sortBy)+import Data.List.Extra (trim) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe-import Data.Monoid import Data.Streaming.Process (ProcessExitedUnsuccessfully(..)) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T import Data.Time (UTCTime,LocalTime(..),diffDays,utcToLocalTime,getZonedTime,ZonedTime(..)) import Data.Typeable (Typeable)-import Options.Applicative.Builder.Extra (maybeBoolFlags)-import Options.Applicative (Parser,str,option,help,auto,metavar,long,value,hidden,internal,idm) import Path-import Path.IO (getWorkingDir,listDirectory)+import Path.IO (getWorkingDir,listDirectory,createTree,removeFile,removeTree,dirExists) import Stack.Constants (projectDockerSandboxDir,stackProgName,stackDotYaml,stackRootEnvVar)-import Stack.Exec import Stack.Types import Stack.Types.Internal import Stack.Docker.GlobalDB-import System.Directory (createDirectoryIfMissing,removeDirectoryRecursive,removeFile)-import System.Directory (doesDirectoryExist) import System.Environment (lookupEnv,getProgName,getArgs,getExecutablePath)+import System.Exit (exitSuccess, exitWith) import System.FilePath (dropTrailingPathSeparator,takeBaseName) import System.Info (arch,os) import System.IO (stderr,stdin,stdout,hIsTerminalDevice) import System.Process.PagerEditor (editByteString) import System.Process.Read import System.Process.Run+import System.Process (CreateProcess(delegate_ctlc)) import Text.Printf (printf) +#ifndef mingw32_HOST_OS+import Control.Monad.Trans.Control (liftBaseWith)+import System.Posix.Signals+#endif+ -- | If Docker is enabled, re-runs the currently running OS command in a Docker container. -- Otherwise, runs the inner action.+--+-- This takes an optional release action which should be taken IFF control is+-- transfering away from the current process to the intra-container one. The main use+-- for this is releasing a lock. After launching reexecution, the host process becomes+-- nothing but an manager for the call into docker and thus may not hold the lock. reexecWithOptionalContainer :: M env m => Maybe (Path Abs Dir)+ -> Maybe (m ()) -> IO ()+ -> Maybe (m ())+ -> Maybe (m ()) -> m () reexecWithOptionalContainer mprojectRoot = execWithOptionalContainer mprojectRoot getCmdArgs where getCmdArgs =- do args <- getArgs+ do args <- (("--" ++ reExecArgName) :) <$> getArgs if arch == "x86_64" && os == "linux" then do exePath <- getExecutablePath let mountPath = concat ["/opt/host/bin/",takeBaseName exePath] return (mountPath ,args+ ,[] ,\c -> c{configDocker=(configDocker c) {dockerMount=Mount exePath mountPath : dockerMount (configDocker c)}}) else do progName <- getProgName- return (takeBaseName progName,args,id)+ return (takeBaseName progName,args,[],id) -- | If Docker is enabled, re-runs the OS command returned by the second argument in a -- Docker container. Otherwise, runs the inner action.+--+-- This takes an optional release action just like `reexecWithOptionalContainer`. execWithOptionalContainer :: M env m => Maybe (Path Abs Dir)- -> IO (FilePath,[String],Config -> Config)+ -> IO (FilePath,[String],[(String,String)],Config -> Config)+ -> Maybe (m ()) -> IO ()+ -> Maybe (m ())+ -> Maybe (m ()) -> m ()-execWithOptionalContainer mprojectRoot getCmdArgs inner =+execWithOptionalContainer mprojectRoot getCmdArgs mbefore inner mafter mrelease = do config <- asks getConfig inContainer <- getInContainer- if inContainer || not (dockerEnable (configDocker config))- then liftIO inner- else do (cmd_,args,modConfig) <- liftIO getCmdArgs- runContainerAndExit modConfig mprojectRoot cmd_ args []---- | If Docker is enabled, re-runs the OS command returned by the second argument in a--- Docker container. Otherwise, throws 'DockerMustBeEnabledException'.-execWithRequiredContainer- :: M env m- => Maybe (Path Abs Dir)- -> IO (FilePath,[String],Config -> Config)- -> m ()-execWithRequiredContainer mprojectRoot getCmdArgs =- do config <- asks getConfig- unless (dockerEnable (configDocker config))- (throwM DockerMustBeEnabledException)- (cmd_,args,modConfig) <- liftIO getCmdArgs- runContainerAndExit modConfig mprojectRoot cmd_ args []+ isReExec <- asks getReExec+ if | inContainer && not isReExec && (isJust mbefore || isJust mafter) ->+ throwM OnlyOnHostException+ | inContainer ->+ liftIO (do inner+ exitSuccess)+ | not (dockerEnable (configDocker config)) ->+ do fromMaybeAction mbefore+ liftIO inner+ fromMaybeAction mafter+ liftIO exitSuccess+ | otherwise ->+ do (cmd_,args,envVars,modConfig) <- liftIO getCmdArgs+ fromMaybeAction mrelease+ runContainerAndExit+ modConfig+ mprojectRoot+ (fromMaybeAction mbefore)+ cmd_+ args+ envVars+ (fromMaybeAction mafter)+ where+ fromMaybeAction Nothing = return ()+ fromMaybeAction (Just hook) = hook -- | Error if running in a container. preventInContainer :: (MonadIO m,MonadThrow m) => m () -> m ()@@ -128,35 +149,36 @@ -- | 'True' if we are currently running inside a Docker container. getInContainer :: (MonadIO m) => m Bool-getInContainer =- do maybeEnvVar <- liftIO (lookupEnv inContainerEnvVar)- case maybeEnvVar of- Nothing -> return False- Just _ -> return True+getInContainer = liftIO (isJust <$> lookupEnv inContainerEnvVar) -- | Run a command in a new Docker container, then exit the process. runContainerAndExit :: M env m => (Config -> Config) -> Maybe (Path Abs Dir)+ -> m () -> FilePath -> [String] -> [(String, String)] -> m ()+ -> m () runContainerAndExit modConfig mprojectRoot+ before cmnd args- envVars =+ envVars+ after = do config <- fmap modConfig (asks getConfig) let docker = configDocker config envOverride <- getEnvOverride (configPlatform config) checkDockerVersion envOverride uidOut <- readProcessStdout Nothing envOverride "id" ["-u"] gidOut <- readProcessStdout Nothing envOverride "id" ["-g"]- (dockerHost,dockerCertPath,dockerTlsVerify) <-- liftIO ((,,) <$> lookupEnv "DOCKER_HOST"- <*> lookupEnv "DOCKER_CERT_PATH"- <*> lookupEnv "DOCKER_TLS_VERIFY")+ (dockerHost,dockerCertPath,bamboo,jenkins) <-+ liftIO ((,,,) <$> lookupEnv "DOCKER_HOST"+ <*> lookupEnv "DOCKER_CERT_PATH"+ <*> lookupEnv "bamboo_buildKey"+ <*> lookupEnv "JENKINS_HOME") isStdoutTerminal <- asks getTerminal (isStdinTerminal,isStderrTerminal) <- liftIO ((,) <$> hIsTerminalDevice stdin@@ -164,7 +186,7 @@ pwd <- getWorkingDir when (maybe False (isPrefixOf "tcp://") dockerHost && maybe False (isInfixOf "boot2docker") dockerCertPath)- ($logWarn "WARNING: Using boot2docker is NOT supported, and not likely to perform well.")+ ($logWarn "Warning: Using boot2docker is NOT supported, and not likely to perform well.") let image = dockerImage docker maybeImageInfo <- inspect envOverride image imageInfo <- case maybeImageInfo of@@ -180,20 +202,7 @@ let uid = dropWhileEnd isSpace (decodeUtf8 uidOut) gid = dropWhileEnd isSpace (decodeUtf8 gidOut) imageEnvVars = map (break (== '=')) (icEnv (iiConfig imageInfo))- (sandboxID,oldImage) =- case lookupImageEnv sandboxIDEnvVar imageEnvVars of- Just x -> (x,False)- Nothing ->- --EKB TODO: remove this and oldImage after lts-1.x images no longer in use- let sandboxName = maybe "default" id (lookupImageEnv "SANDBOX_NAME" imageEnvVars)- maybeImageCabalRemoteRepoName = lookupImageEnv "CABAL_REMOTE_REPO_NAME" imageEnvVars- maybeImageStackageSlug = lookupImageEnv "STACKAGE_SLUG" imageEnvVars- maybeImageStackageDate = lookupImageEnv "STACKAGE_DATE" imageEnvVars- in (case (maybeImageStackageSlug,maybeImageStackageDate) of- (Just stackageSlug,_) -> sandboxName ++ "_" ++ stackageSlug- (_,Just stackageDate) -> sandboxName ++ "_" ++ stackageDate- _ -> sandboxName ++ maybe "" ("_" ++) maybeImageCabalRemoteRepoName- ,True)+ sandboxID = fromMaybe "default" (lookupImageEnv sandboxIDEnvVar imageEnvVars) sandboxIDDir <- parseRelDir (sandboxID ++ "/") let stackRoot = configStackRoot config sandboxDir = projectDockerSandboxDir projectRoot@@ -202,22 +211,24 @@ sandboxRepoDir = sandboxDir </> sandboxIDDir sandboxSubdirs = map (\d -> sandboxRepoDir </> d) sandboxedHomeSubdirectories- isTerm = isStdinTerminal && isStdoutTerminal && isStderrTerminal+ isTerm = not (dockerDetach docker) &&+ isStdinTerminal &&+ isStdoutTerminal &&+ isStderrTerminal+ keepStdinOpen = not (dockerDetach docker) &&+ (isTerm || (isNothing bamboo && isNothing jenkins)) liftIO (do updateDockerImageLastUsed config (iiId imageInfo) (toFilePath projectRoot) - mapM_ (createDirectoryIfMissing True)- (concat [[toFilePath sandboxHomeDir- ,toFilePath sandboxSandboxDir- ,toFilePath stackRoot] ++- map toFilePath sandboxSubdirs]))- exec- plainEnvSettings- "docker"+ mapM_ createTree+ (concat [[sandboxHomeDir, sandboxSandboxDir, stackRoot] +++ sandboxSubdirs]))+ containerID <- (trim . decodeUtf8) <$> readDockerProcess+ envOverride (concat- [["run"+ [["create" ,"--net=host" ,"-e",inContainerEnvVar ++ "=1" ,"-e",stackRootEnvVar ++ "=" ++ toFPNoTrailingSep stackRoot@@ -232,39 +243,47 @@ ,"-v",toFPNoTrailingSep sandboxHomeDir ++ ":" ++ toFPNoTrailingSep sandboxRepoDir ,"-v",toFPNoTrailingSep stackRoot ++ ":" ++ toFPNoTrailingSep (sandboxRepoDir </> $(mkRelDir ("." ++ stackProgName ++ "/")))]- ,if oldImage- then ["-e",sandboxIDEnvVar ++ "=" ++ sandboxID- ,"--entrypoint=/root/entrypoint.sh"]- else []- ,case (dockerPassHost docker,dockerHost) of- (True,Just x@('u':'n':'i':'x':':':'/':'/':s)) -> ["-e","DOCKER_HOST=" ++ x- ,"-v",s ++ ":" ++ s]- (True,Just x) -> ["-e","DOCKER_HOST=" ++ x]- (True,Nothing) -> ["-v","/var/run/docker.sock:/var/run/docker.sock"]- (False,_) -> []- ,case (dockerPassHost docker,dockerCertPath) of- (True,Just x) -> ["-e","DOCKER_CERT_PATH=" ++ x- ,"-v",x ++ ":" ++ x]- _ -> []- ,case (dockerPassHost docker,dockerTlsVerify) of- (True,Just x )-> ["-e","DOCKER_TLS_VERIFY=" ++ x]- _ -> []+ ,concatMap (\(k,v) -> ["-e", k ++ "=" ++ v]) envVars ,concatMap sandboxSubdirArg sandboxSubdirs ,concatMap mountArg (dockerMount docker) ,case dockerContainerName docker of Just name -> ["--name=" ++ name] Nothing -> []- ,if dockerDetach docker- then ["-d"]- else concat [["--rm" | not (dockerPersist docker)]- ,["-t" | isTerm]- ,["-i"]]+ ,["-t" | isTerm]+ ,["-i" | keepStdinOpen] ,dockerRunArgs docker ,[image]- ,map (\(k,v) -> k ++ "=" ++ v) envVars ,[cmnd] ,args])-+ before+#ifndef mingw32_HOST_OS+ runInBase <- liftBaseWith $ \run -> return (void . run)+ oldHandlers <- forM (concat [[(sigINT,sigTERM) | not keepStdinOpen]+ ,[(sigTERM,sigTERM)]]) $ \(sigIn,sigOut) -> do+ let sigHandler = runInBase (readProcessNull Nothing envOverride "docker"+ ["kill","--signal=" ++ show sigOut,containerID])+ oldHandler <- liftIO $ installHandler sigIn (Catch sigHandler) Nothing+ return (sigIn, oldHandler)+#endif+ e <- try (callProcess'+ (if keepStdinOpen then id else (\cp -> cp { delegate_ctlc = False }))+ Nothing+ envOverride+ "docker"+ (concat [["start"]+ ,["-a" | not (dockerDetach docker)]+ ,["-i" | keepStdinOpen]+ ,[containerID]]))+#ifndef mingw32_HOST_OS+ forM_ oldHandlers $ \(sig,oldHandler) ->+ liftIO $ installHandler sig oldHandler Nothing+#endif+ unless (dockerPersist docker || dockerDetach docker)+ (readProcessNull Nothing envOverride "docker" ["rm","-f",containerID])+ case e of+ Left (ProcessExitedUnsuccessfully _ ec) -> liftIO (exitWith ec)+ Right () -> do after+ liftIO exitSuccess where lookupImageEnv name vars = case lookup name vars of@@ -537,7 +556,7 @@ pullImage envOverride docker (dockerImage docker) -- | Pull Docker image from registry.-pullImage :: (MonadLogger m,MonadIO m,MonadThrow m)+pullImage :: (MonadLogger m,MonadIO m,MonadThrow m,MonadBaseControl IO m) => EnvOverride -> DockerOpts -> String -> m () pullImage envOverride docker image = do $logInfo (concatT ["Pulling image from registry: '",image,"'"])@@ -552,7 +571,7 @@ ,maybe [] (\u -> ["--username=" ++ u]) (dockerRegistryUsername docker) ,maybe [] (\p -> ["--password=" ++ p]) (dockerRegistryPassword docker) ,[takeWhile (/= '/') image]]))- e <- liftIO (try (callProcess Nothing envOverride "docker" ["pull",image]))+ e <- try (callProcess Nothing envOverride "docker" ["pull",image]) case e of Left (ProcessExitedUnsuccessfully _ _) -> throwM (PullFailedException image) Right () -> return ()@@ -597,15 +616,15 @@ -> [Path Rel File] -- ^ Top-level file names to exclude from removal -> IO () removeDirectoryContents path excludeDirs excludeFiles =- do isRootDir <- doesDirectoryExist (toFilePath path)+ do isRootDir <- dirExists path when isRootDir (do (lsd,lsf) <- listDirectory path forM_ lsd (\d -> unless (dirname d `elem` excludeDirs)- (removeDirectoryRecursive (toFilePath d)))+ (removeTree d)) forM_ lsf (\f -> unless (filename f `elem` excludeFiles)- (removeFile (toFilePath f))))+ (removeFile f))) -- | Produce a strict 'S.ByteString' from the stdout of a -- process. Throws a 'ReadProcessException' exception if the@@ -627,72 +646,6 @@ homeDirName :: Path Rel Dir homeDirName = $(mkRelDir "_home/") --- | Options parser configuration for Docker.-dockerOptsParser :: Bool -> Parser DockerOptsMonoid-dockerOptsParser showOptions =- DockerOptsMonoid- <$> pure Nothing- <*> maybeBoolFlags dockerCmdName- "using a Docker container"- hide- <*> ((Just . DockerMonoidRepo) <$> option str (long (dockerOptName dockerRepoArgName) <>- hide <>- metavar "NAME" <>- help "Docker repository name") <|>- (Just . DockerMonoidImage) <$> option str (long (dockerOptName dockerImageArgName) <>- hide <>- metavar "IMAGE" <>- help "Exact Docker image ID (overrides docker-repo)") <|>- pure Nothing)- <*> maybeBoolFlags (dockerOptName dockerRegistryLoginArgName)- "registry requires login"- hide- <*> maybeStrOption (long (dockerOptName dockerRegistryUsernameArgName) <>- hide <>- metavar "USERNAME" <>- help "Docker registry username")- <*> maybeStrOption (long (dockerOptName dockerRegistryPasswordArgName) <>- hide <>- metavar "PASSWORD" <>- help "Docker registry password")- <*> maybeBoolFlags (dockerOptName dockerAutoPullArgName)- "automatic pulling latest version of image"- hide- <*> maybeBoolFlags (dockerOptName dockerDetachArgName)- "running a detached Docker container"- hide- <*> maybeBoolFlags (dockerOptName dockerPersistArgName)- "not deleting container after it exits"- hide- <*> maybeStrOption (long (dockerOptName dockerContainerNameArgName) <>- hide <>- metavar "NAME" <>- help "Docker container name")- <*> argsStrOption (long (dockerOptName dockerRunArgsArgName) <>- hide <>- value [] <>- metavar "'ARG1 [ARG2 ...]'" <>- help "Additional arguments to pass to 'docker run'")- <*> many (option auto (long (dockerOptName dockerMountArgName) <>- hide <>- metavar "(PATH | HOST-PATH:CONTAINER-PATH)" <>- help ("Mount volumes from host in container " ++- "(may specify mutliple times)")))- <*> maybeBoolFlags (dockerOptName dockerPassHostArgName)- "passing Docker daemon connection information into container"- hide- <*> maybeStrOption (long (dockerOptName dockerDatabasePathArgName) <>- hide <>- metavar "PATH" <>- help "Location of image usage tracking database")- where- dockerOptName optName = dockerCmdName ++ "-" ++ T.unpack optName- maybeStrOption = optional . option str- argsStrOption = option (fmap (either error id . parseArgs Escaping . T.pack) str)- hide = if showOptions- then idm- else internal <> hidden- -- | Interprets DockerOptsMonoid options. dockerOptsFromMonoid :: Maybe Project -> Path Abs Dir -> DockerOptsMonoid -> DockerOpts dockerOptsFromMonoid mproject stackRoot DockerOptsMonoid{..} = DockerOpts@@ -723,7 +676,6 @@ ,dockerContainerName = emptyToNothing dockerMonoidContainerName ,dockerRunArgs = dockerMonoidRunArgs ,dockerMount = dockerMonoidMount- ,dockerPassHost = fromMaybe False dockerMonoidPassHost ,dockerDatabasePath = case dockerMonoidDatabasePath of Nothing -> stackRoot </> $(mkRelFile "docker.db")@@ -767,6 +719,10 @@ dockerCleanupCmdName :: String dockerCleanupCmdName = "cleanup" +-- | Command-line option for @--internal-re-exec@.+reExecArgName :: String+reExecArgName = "internal-re-exec"+ -- | Options for 'cleanup'. data CleanupOpts = CleanupOpts { dcAction :: !CleanupAction@@ -936,4 +892,4 @@ concat ["Invalid database path: ",show ex] type M env m = (MonadIO m,MonadReader env m,MonadLogger m,MonadBaseControl IO m,MonadCatch m- ,HasConfig env,HasTerminal env)+ ,HasConfig env,HasTerminal env,HasReExec env)
src/Stack/Docker/GlobalDB.hs view
@@ -25,7 +25,7 @@ import Database.Persist.Sqlite import Database.Persist.TH import Path (toFilePath, parent)-import System.Directory (createDirectoryIfMissing)+import Path.IO (createTree) import Stack.Types.Config import Stack.Types.Docker @@ -75,7 +75,7 @@ withGlobalDB :: forall a. Config -> SqlPersistT (NoLoggingT (ResourceT IO)) a -> IO a withGlobalDB config action = do let db = dockerDatabasePath (configDocker config)- createDirectoryIfMissing True (toFilePath (parent db))+ createTree (parent db) runSqlite (T.pack (toFilePath db)) (do _ <- runMigrationSilent migrateTables action)
src/Stack/Dot.hs view
@@ -1,43 +1,43 @@-{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} module Stack.Dot (dot+ ,listDependencies ,DotOpts(..)- ,dotOptsParser ,resolveDependencies ,printGraph ,pruneGraph ) where -import Control.Monad (void)-import Control.Monad.Catch (MonadCatch)+import Control.Applicative+import Control.Arrow ((&&&))+import Control.Monad (liftM, void)+import Control.Monad.Catch (MonadCatch,MonadMask) import Control.Monad.IO.Class-import Control.Monad.Logger (MonadLogger, logInfo)+import Control.Monad.Logger (MonadLogger) import Control.Monad.Reader (MonadReader) import Control.Monad.Trans.Control (MonadBaseControl)-import Data.Char (isSpace) import qualified Data.Foldable as F import qualified Data.HashSet as HashSet-import Data.List.Split (splitOn) import Data.Map (Map) import qualified Data.Map as Map+import Data.Monoid ((<>)) import Data.Set (Set) import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as Text+import qualified Data.Text.IO as Text import qualified Data.Traversable as T import Network.HTTP.Client.Conduit (HasHttpManager)-import Options.Applicative-import Options.Applicative.Builder.Extra (boolFlags) import Stack.Build (withLoadPackage)+import Stack.Build.Installed (getInstalled, GetInstalledOpts(..)) import Stack.Build.Source-import Stack.Build.Types import Stack.Constants import Stack.Package import Stack.Types+import Stack.Types.Internal (HasLogLevel) --- | Options record for `stack dot`+-- | Options record for @stack dot@ data DotOpts = DotOpts { dotIncludeExternal :: Bool -- ^ Include external dependencies@@ -49,105 +49,130 @@ -- ^ Package names to prune from the graph } --- | Parser for arguments to `stack dot`-dotOptsParser :: Parser DotOpts-dotOptsParser = DotOpts- <$> includeExternal- <*> includeBase- <*> depthLimit- <*> fmap (maybe Set.empty Set.fromList . fmap splitNames) prunedPkgs- where includeExternal = boolFlags False- "external"- "inclusion of external dependencies"- idm- includeBase = boolFlags True- "include-base"- "inclusion of dependencies on base"- idm- depthLimit =- optional (option auto- (long "depth" <>- metavar "DEPTH" <>- help ("Limit the depth of dependency resolution " <>- "(Default: No limit)")))- prunedPkgs = optional (strOption- (long "prune" <>- metavar "PACKAGES" <>- help ("Prune each package name " <>- "from the comma separated list " <>- "of package names PACKAGES")))-- splitNames :: String -> [String]- splitNames = map (takeWhile (not . isSpace) . dropWhile isSpace) . splitOn ","- -- | Visualize the project's dependencies as a graphviz graph dot :: (HasEnvConfig env ,HasHttpManager env+ ,HasLogLevel env ,MonadBaseControl IO m ,MonadCatch m- ,MonadIO m ,MonadLogger m+ ,MonadIO m+ ,MonadMask m ,MonadReader env m ) => DotOpts -> m () dot dotOpts = do- (locals,_,_) <- loadLocals defaultBuildOpts Map.empty- (_,_,_,sourceMap) <- loadSourceMap defaultBuildOpts- let graph = Map.fromList (localDependencies dotOpts locals)- menv <- getMinimalEnvOverride- resultGraph <- withLoadPackage menv (\loader -> do- let depLoader = createDepLoader sourceMap (fmap3 packageAllDeps loader)- liftIO $ resolveDependencies (dotDependencyDepth dotOpts) graph depLoader)+ localNames <- liftM Map.keysSet getLocalPackageViews+ resultGraph <- createDependencyGraph dotOpts let pkgsToPrune = if dotIncludeBase dotOpts then dotPrune dotOpts else Set.insert "base" (dotPrune dotOpts)- localNames = Set.fromList (map (packageName . lpPackage) locals) prunedGraph = pruneGraph localNames pkgsToPrune resultGraph- printGraph dotOpts locals prunedGraph+ printGraph dotOpts localNames prunedGraph++-- | Create the dependency graph, the result is a map from a package+-- name to a tuple of dependencies and a version if available. This+-- function mainly gathers the required arguments for+-- @resolveDependencies@.+createDependencyGraph :: (HasEnvConfig env+ ,HasHttpManager env+ ,HasLogLevel env+ ,MonadLogger m+ ,MonadBaseControl IO m+ ,MonadCatch m+ ,MonadIO m+ ,MonadMask m+ ,MonadReader env m)+ => DotOpts+ -> m (Map PackageName (Set PackageName, Maybe Version))+createDependencyGraph dotOpts = do+ (_,locals,_,sourceMap) <- loadSourceMap defaultBuildOpts+ let graph = Map.fromList (localDependencies dotOpts locals)+ menv <- getMinimalEnvOverride+ installedMap <- fmap thrd . fst <$> getInstalled menv+ (GetInstalledOpts False False)+ sourceMap+ withLoadPackage menv (\loader -> do+ let depLoader =+ createDepLoader sourceMap+ installedMap+ (fmap3 (packageAllDeps &&& (Just . packageVersion)) loader)+ liftIO $ resolveDependencies (dotDependencyDepth dotOpts) graph depLoader) where -- fmap a function over the result of a function with 3 arguments fmap3 :: Functor f => (d -> e) -> (a -> b -> c -> f d) -> a -> b -> c -> f e fmap3 f g a b c = f <$> g a b c --- | `pruneGraph dontPrune toPrune graph` prunes all packages in--- `graph` with a name in `toPrune` and removes resulting orphans--- unless they are in `dontPrune`-pruneGraph :: (F.Foldable f, F.Foldable g)+ thrd :: (a,b,c) -> c+ thrd (_,_,x) = x++-- Given an 'Installed' try to get the 'Version'+libVersionFromInstalled :: Installed -> Maybe Version+libVersionFromInstalled (Library ghcPkgId) =+ case ghcPkgIdPackageIdentifier ghcPkgId of+ PackageIdentifier _ v -> Just v+libVersionFromInstalled (Executable _) = Nothing++listDependencies :: (HasEnvConfig env+ ,HasHttpManager env+ ,HasLogLevel env+ ,MonadBaseControl IO m+ ,MonadCatch m+ ,MonadLogger m+ ,MonadMask m+ ,MonadIO m+ ,MonadReader env m+ )+ => Text+ -> m ()+listDependencies sep = do+ let dotOpts = DotOpts True True Nothing Set.empty+ resultGraph <- createDependencyGraph dotOpts+ void (Map.traverseWithKey go (snd <$> resultGraph))+ where go name v = liftIO (Text.putStrLn $+ Text.pack (packageNameString name) <>+ sep <>+ maybe "<unknown>" (Text.pack . show) v)++-- | @pruneGraph dontPrune toPrune graph@ prunes all packages in+-- @graph@ with a name in @toPrune@ and removes resulting orphans+-- unless they are in @dontPrune@+pruneGraph :: (F.Foldable f, F.Foldable g, Eq a) => f PackageName -> g String- -> Map PackageName (Set PackageName)- -> Map PackageName (Set PackageName)+ -> Map PackageName (Set PackageName, a)+ -> Map PackageName (Set PackageName, a) pruneGraph dontPrune names =- pruneUnreachable dontPrune . Map.mapMaybeWithKey (\pkg pkgDeps ->+ pruneUnreachable dontPrune . Map.mapMaybeWithKey (\pkg (pkgDeps,x) -> if show pkg `F.elem` names then Nothing else let filtered = Set.filter (\n -> show n `F.notElem` names) pkgDeps in if Set.null filtered && not (Set.null pkgDeps) then Nothing- else Just filtered)+ else Just (filtered,x)) -- | Make sure that all unreachable nodes (orphans) are pruned-pruneUnreachable :: F.Foldable f+pruneUnreachable :: (Eq a, F.Foldable f) => f PackageName- -> Map PackageName (Set PackageName)- -> Map PackageName (Set PackageName)+ -> Map PackageName (Set PackageName, a)+ -> Map PackageName (Set PackageName, a) pruneUnreachable dontPrune = fixpoint prune where fixpoint :: Eq a => (a -> a) -> a -> a fixpoint f v = if f v == v then v else fixpoint f (f v) prune graph' = Map.filterWithKey (\k _ -> reachable k) graph' where reachable k = k `F.elem` dontPrune || k `Set.member` reachables- reachables = F.fold graph'+ reachables = F.fold (fst <$> graph') -- | Resolve the dependency graph up to (Just depth) or until fixpoint is reached resolveDependencies :: (Applicative m, Monad m) => Maybe Int- -> Map PackageName (Set PackageName)- -> (PackageName -> m (Set PackageName))- -> m (Map PackageName (Set PackageName))+ -> Map PackageName (Set PackageName,Maybe Version)+ -> (PackageName -> m (Set PackageName, Maybe Version))+ -> m (Map PackageName (Set PackageName,Maybe Version)) resolveDependencies (Just 0) graph _ = return graph resolveDependencies limit graph loadPackageDeps = do- let values = Set.unions (Map.elems graph)+ let values = Set.unions (fst <$> Map.elems graph) keys = Map.keysSet graph next = Set.difference values keys if Set.null next@@ -155,77 +180,84 @@ else do x <- T.traverse (\name -> (name,) <$> loadPackageDeps name) (F.toList next) resolveDependencies (subtract 1 <$> limit)- (Map.unionWith Set.union graph (Map.fromList x))+ (Map.unionWith unifier graph (Map.fromList x)) loadPackageDeps+ where unifier (pkgs1,v1) (pkgs2,_) = (Set.union pkgs1 pkgs2, v1) -- | Given a SourceMap and a dependency loader, load the set of dependencies for a package createDepLoader :: Applicative m => Map PackageName PackageSource- -> (PackageName -> Version -> Map FlagName Bool -> m (Set PackageName))+ -> Map PackageName Installed+ -> (PackageName -> Version -> Map FlagName Bool -> m (Set PackageName,Maybe Version)) -> PackageName- -> m (Set PackageName)-createDepLoader sourceMap loadPackageDeps pkgName =+ -> m (Set PackageName, Maybe Version)+createDepLoader sourceMap installed loadPackageDeps pkgName = case Map.lookup pkgName sourceMap of- Just (PSLocal lp) -> pure (packageAllDeps (lpPackage lp))+ Just (PSLocal lp) -> pure ((packageAllDeps &&& (Just . packageVersion)) (lpPackage lp)) Just (PSUpstream version _ flags) -> loadPackageDeps pkgName version flags- Nothing -> pure Set.empty+ Nothing -> pure (Set.empty, do m' <- T.traverse libVersionFromInstalled installed+ Map.lookup pkgName m') -- | Resolve the direct (depth 0) external dependencies of the given local packages-localDependencies :: DotOpts -> [LocalPackage] -> [(PackageName,Set PackageName)]-localDependencies dotOpts locals = map (\lp -> (packageName (lpPackage lp), deps lp)) locals+localDependencies :: DotOpts -> [LocalPackage] -> [(PackageName,(Set PackageName,Maybe Version))]+localDependencies dotOpts locals =+ map (\lp -> (packageName (lpPackage lp), (deps lp,Just (lpVersion lp)))) locals where deps lp = if dotIncludeExternal dotOpts then Set.delete (lpName lp) (packageAllDeps (lpPackage lp)) else Set.intersection localNames (packageAllDeps (lpPackage lp)) lpName lp = packageName (lpPackage lp) localNames = Set.fromList $ map (packageName . lpPackage) locals+ lpVersion lp = packageVersion (lpPackage lp) -- | Print a graphviz graph of the edges in the Map and highlight the given local packages-printGraph :: (Applicative m, MonadLogger m)+printGraph :: (Applicative m, MonadIO m) => DotOpts- -> [LocalPackage]- -> Map PackageName (Set PackageName)+ -> Set PackageName -- ^ all locals+ -> Map PackageName (Set PackageName, Maybe Version) -> m () printGraph dotOpts locals graph = do- $logInfo "strict digraph deps {"+ liftIO $ Text.putStrLn "strict digraph deps {" printLocalNodes dotOpts filteredLocals printLeaves graph- void (Map.traverseWithKey printEdges graph)- $logInfo "}"- where filteredLocals = filter (\local ->- show (packageName (lpPackage local)) `Set.notMember` dotPrune dotOpts) locals+ void (Map.traverseWithKey printEdges (fst <$> graph))+ liftIO $ Text.putStrLn "}"+ where filteredLocals = Set.filter (\local ->+ packageNameString local `Set.notMember` dotPrune dotOpts) locals -- | Print the local nodes with a different style depending on options-printLocalNodes :: (F.Foldable t, MonadLogger m)+printLocalNodes :: (F.Foldable t, MonadIO m) => DotOpts- -> t LocalPackage+ -> t PackageName -> m ()-printLocalNodes dotOpts locals = $logInfo (Text.intercalate "\n" lpNodes)+printLocalNodes dotOpts locals = liftIO $ Text.putStrLn (Text.intercalate "\n" lpNodes) where applyStyle :: Text -> Text applyStyle n = if dotIncludeExternal dotOpts then n <> " [style=dashed];" else n <> " [style=solid];" lpNodes :: [Text]- lpNodes = map (applyStyle . nodeName . packageName . lpPackage) (F.toList locals)+ lpNodes = map (applyStyle . nodeName) (F.toList locals) -- | Print nodes without dependencies-printLeaves :: (Applicative m, MonadLogger m) => Map PackageName (Set PackageName) -> m ()-printLeaves = F.traverse_ printLeaf . Map.keysSet . Map.filter Set.null+printLeaves :: (Applicative m, MonadIO m)+ => Map PackageName (Set PackageName,Maybe Version)+ -> m ()+printLeaves = F.traverse_ printLeaf . Map.keysSet . Map.filter Set.null . fmap fst --- | `printDedges p ps` prints an edge from p to every ps-printEdges :: (Applicative m, MonadLogger m) => PackageName -> Set PackageName -> m ()+-- | @printDedges p ps@ prints an edge from p to every ps+printEdges :: (Applicative m, MonadIO m) => PackageName -> Set PackageName -> m () printEdges package deps = F.for_ deps (printEdge package) -- | Print an edge between the two package names-printEdge :: MonadLogger m => PackageName -> PackageName -> m ()-printEdge from to = $logInfo (Text.concat [ nodeName from, " -> ", nodeName to, ";"])+printEdge :: MonadIO m => PackageName -> PackageName -> m ()+printEdge from to = liftIO $ Text.putStrLn (Text.concat [ nodeName from, " -> ", nodeName to, ";"]) -- | Convert a package name to a graph node name. nodeName :: PackageName -> Text nodeName name = "\"" <> Text.pack (packageNameString name) <> "\"" -- | Print a node with no dependencies-printLeaf :: MonadLogger m => PackageName -> m ()-printLeaf package = $logInfo . Text.concat $+printLeaf :: MonadIO m => PackageName -> m ()+printLeaf package = liftIO . Text.putStrLn . Text.concat $ if isWiredIn package then ["{rank=max; ", nodeName package, " [shape=box]; };"] else ["{rank=max; ", nodeName package, "; };"]
src/Stack/Exec.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} @@ -8,15 +10,20 @@ import Control.Monad.Reader import Control.Monad.Logger-import Control.Monad.Catch---import Path+import Control.Monad.Catch hiding (try)+import Control.Monad.Trans.Control (MonadBaseControl) import Stack.Types-import System.Directory (doesFileExist)+import System.Process.Log++#ifdef mingw32_HOST_OS+import Control.Exception.Lifted+import Data.Streaming.Process (ProcessExitedUnsuccessfully(..)) import System.Exit-import qualified System.Process as P-import System.Process.Read+import System.Process.Run (callProcess)+#else+import System.Process.Read (envHelper, preProcess)+import System.Posix.Process (executeFile)+#endif -- | Default @EnvSettings@ which includes locals and GHC_PACKAGE_PATH defaultEnvSettings :: EnvSettings@@ -35,21 +42,18 @@ } -- | Execute a process within the Stack configured environment.-exec :: (HasConfig r, MonadReader r m, MonadIO m, MonadLogger m, MonadThrow m)- => EnvSettings -> String -> [String] -> m b-exec envSettings cmd args = do+exec :: (HasConfig r, MonadReader r m, MonadIO m, MonadLogger m, MonadThrow m, MonadBaseControl IO m)+ => EnvSettings -> String -> [String] -> m b+exec envSettings cmd0 args = do config <- asks getConfig menv <- liftIO (configEnvOverride config envSettings)- exists <- liftIO $ doesFileExist cmd- cmd' <-- if exists- then return cmd- else liftM toFilePath $ join $ System.Process.Read.findExecutable menv cmd- let cp = (P.proc cmd' args)- { P.env = envHelper menv- , P.delegate_ctlc = True- }- $logProcessRun cmd' args- (Nothing, Nothing, Nothing, ph) <- liftIO (P.createProcess cp)- ec <- liftIO (P.waitForProcess ph)- liftIO (exitWith ec)+ $logProcessRun cmd0 args+#ifdef mingw32_HOST_OS+ e <- try (callProcess Nothing menv cmd0 args)+ liftIO $ case e of+ Left (ProcessExitedUnsuccessfully _ ec) -> exitWith ec+ Right () -> exitSuccess+#else+ cmd <- preProcess Nothing menv cmd0+ liftIO $ executeFile cmd True args (envHelper menv)+#endif
src/Stack/Fetch.hs view
@@ -22,57 +22,62 @@ , withCabalLoader ) where -import qualified Codec.Archive.Tar as Tar-import qualified Codec.Archive.Tar.Check as Tar-import Codec.Compression.GZip (decompress)+import qualified Codec.Archive.Tar as Tar+import qualified Codec.Archive.Tar.Check as Tar+import qualified Codec.Archive.Tar.Entry as Tar+import Codec.Compression.GZip (decompress) import Control.Applicative-import Control.Concurrent.Async (Concurrently (..))-import Control.Concurrent.MVar.Lifted (newMVar, modifyMVar)-import Control.Concurrent.STM (TVar, atomically, modifyTVar,- newTVarIO, readTVar,- readTVarIO, writeTVar)-import Control.Exception (assert)-import Control.Monad (liftM, when, join, unless, void)+import Control.Concurrent.Async (Concurrently (..))+import Control.Concurrent.MVar.Lifted (modifyMVar, newMVar)+import Control.Concurrent.STM (TVar, atomically, modifyTVar,+ newTVarIO, readTVar,+ readTVarIO, writeTVar)+import Control.Exception (assert)+import Control.Monad (join, liftM, unless, void,+ when) import Control.Monad.Catch import Control.Monad.IO.Class import Control.Monad.Logger-import Control.Monad.Reader (asks)-import Control.Monad.Reader (runReaderT)+import Control.Monad.Reader (asks)+import Control.Monad.Reader (runReaderT) import Control.Monad.Trans.Control-import Crypto.Hash (SHA512(..))-import Data.ByteString (ByteString)-import qualified Data.ByteString as S-import qualified Data.ByteString.Lazy as L-import Data.Either (partitionEithers)-import qualified Data.Foldable as F-import Data.Function (fix)-import Data.IORef (newIORef, readIORef, writeIORef)-import Data.List (intercalate)-import Data.Map (Map)-import qualified Data.Map as Map-import Data.Maybe (maybeToList)-import Data.Monoid ((<>))-import Data.Set (Set)-import qualified Data.Set as Set-import qualified Data.Text as T-import Data.Text.Encoding (decodeUtf8)-import Data.Typeable (Typeable)-import Data.Word (Word64)+import Crypto.Hash (SHA512 (..))+import Data.ByteString (ByteString)+import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L+import Data.Either (partitionEithers)+import qualified Data.Foldable as F+import Data.Function (fix)+import Data.IORef (newIORef, readIORef,+ writeIORef)+import Data.List (intercalate, intersperse)+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe (maybeToList, catMaybes)+import Data.Monoid ((<>))+import Data.Set (Set)+import qualified Data.Set as Set+import qualified Data.Text as T+import Data.Text.Encoding (decodeUtf8)+import Data.Typeable (Typeable)+import Data.Word (Word64) import Network.HTTP.Download import Path+import Path.IO (dirExists, createTree) import Prelude -- Fix AMP warning import Stack.GhcPkg import Stack.PackageIndex import Stack.Types-import System.Directory (canonicalizePath,- createDirectoryIfMissing,- doesDirectoryExist,- renameDirectory)-import System.FilePath ((<.>))-import qualified System.FilePath as FP-import System.IO (IOMode (ReadMode),- SeekMode (AbsoluteSeek),- hSeek, withBinaryFile)+import System.Directory (canonicalizePath,+ createDirectoryIfMissing,+ doesDirectoryExist,+ renameDirectory)+import System.FilePath ((<.>))+import qualified System.FilePath as FP+import System.IO (IOMode (ReadMode),+ SeekMode (AbsoluteSeek), hSeek,+ withBinaryFile)+import System.PosixCompat (setFileMode) data FetchException = Couldn'tReadIndexTarball FilePath Tar.FormatError@@ -170,12 +175,12 @@ return $ alreadyUnpacked <> nowUnpacked data ResolvedPackage = ResolvedPackage- { rpCache :: !PackageCache- , rpIndex :: !PackageIndex+ { rpCache :: !PackageCache+ , rpIndex :: !PackageIndex } -- | Resolve a set of package names and identifiers into @FetchPackage@ values.-resolvePackages :: (MonadIO m, MonadReader env m, HasHttpManager env, HasConfig env, MonadLogger m, MonadThrow m, MonadBaseControl IO m, MonadCatch m)+resolvePackages :: (MonadIO m, MonadReader env m, HasHttpManager env, HasConfig env, MonadLogger m, MonadBaseControl IO m, MonadCatch m) => EnvOverride -> Set PackageIdentifier -> Set PackageName@@ -274,39 +279,72 @@ runInBase <- liftBaseWith $ \run -> return (void . run) -- TODO in the future, keep all of the necessary @Handle@s open- let doLookup ident = do- eres <- doLookup' ident+ let doLookup :: PackageIdentifier+ -> IO ByteString+ doLookup ident = do+ cachesCurr <- liftIO $ readIORef icaches+ eres <- lookupPackageIdentifierExact ident env cachesCurr case eres of- Right bs -> return bs+ Just bs -> return bs -- Update the cache and try again- Left e -> join $ modifyMVar updateRef $ \toUpdate ->- if toUpdate- then do+ Nothing -> do+ let fuzzy = fuzzyLookupCandidates ident cachesCurr+ fuzzyCandidatesText = case fuzzy of+ Nothing -> ""+ Just cs -> "Possible candidates: "+ <> commaSeparatedIdents cs+ <> ". "+ join $ modifyMVar updateRef $ \toUpdate ->+ if toUpdate then do runInBase $ do $logInfo $ T.concat [ "Didn't see " , T.pack $ packageIdentifierString ident- , " in your package indices, updating and trying again"+ , " in your package indices. "+ , T.pack fuzzyCandidatesText+ , "Updating and trying again." ] updateAllIndices menv caches <- getPackageCaches menv liftIO $ writeIORef icaches caches return (False, doLookup ident)- else return (toUpdate, throwM e)+ else return (toUpdate, throwM (unknownIdent ident))+ inner doLookup+ where+ unknownIdent = UnknownPackageIdentifiers . Set.singleton+ commaSeparatedIdents = F.fold . intersperse ", " . map packageIdentifierString - doLookup' ident = do- caches <- liftIO $ readIORef icaches- case Map.lookup ident caches of- Nothing ->- return $ Left $ UnknownPackageIdentifiers $ Set.singleton ident- Just (index, cache) -> do- [bs] <- flip runReaderT env- $ withCabalFiles (indexName index) [(ident, cache, ())]- $ \_ _ bs -> return bs- return $ Right bs+type PackageCaches = Map PackageIdentifier (PackageIndex, PackageCache) - inner doLookup+lookupPackageIdentifierExact :: HasConfig env+ => PackageIdentifier -> env -> PackageCaches+ -> IO (Maybe ByteString)+lookupPackageIdentifierExact ident env caches = do+ case Map.lookup ident caches of+ Nothing -> return Nothing+ Just (index, cache) -> do+ [bs] <- flip runReaderT env+ $ withCabalFiles (indexName index) [(ident, cache, ())]+ $ \_ _ bs -> return bs+ return $ Just bs +-- TODO: use 'Maybe (NonEmpty PackageIdentifier)' return-type+fuzzyLookupCandidates :: PackageIdentifier -> PackageCaches+ -> Maybe [PackageIdentifier]+fuzzyLookupCandidates (PackageIdentifier name ver) caches =+ if null sameMajor then Nothing else Just (map fst sameMajor)+ where+ sameMajor = filter (\(PackageIdentifier _ v, _) ->+ getMajorVersion ver == getMajorVersion v)+ sameIdentCaches+ sameIdentCaches = maybe biggerFiltered+ (\z -> (zeroIdent, z) : biggerFiltered)+ zeroVer+ biggerFiltered = takeWhile (\(PackageIdentifier n _, _) -> name == n)+ (Map.toList bigger)+ zeroIdent = PackageIdentifier name (fromMajorVersion (MajorVersion 0 0))+ (_, zeroVer, bigger) = Map.splitLookup zeroIdent caches+ -- | Figure out where to fetch from. getToFetch :: (MonadThrow m, MonadIO m, MonadReader env m, HasConfig env) => Maybe (Path Abs Dir) -- ^ directory to unpack into, @Nothing@ means no unpack@@ -327,7 +365,7 @@ case mdestDir of Nothing -> return Nothing Just destDir -> do- exists <- liftIO $ doesDirectoryExist $ toFilePath destDir+ exists <- dirExists destDir return $ if exists then Just destDir else Nothing case mexists of Just destDir -> return $ Right (ident, destDir)@@ -396,8 +434,9 @@ { drRequest = req , drHashChecks = map toHashCheck $ maybeToList (tfSHA512 toFetch) , drLengthCheck = fmap fromIntegral $ tfSize toFetch+ , drRetryPolicy = drRetryPolicyDefault }- let progressSink = do+ let progressSink _ = do liftIO $ runInBase $ $logInfo $ packageIdentifierText ident <> ": download" _ <- verifiedDownload downloadReq destpath progressSink @@ -419,7 +458,19 @@ wrap :: Exception e => e -> FetchException wrap = Couldn'tReadPackageTarball fp . toException identStr = packageIdentifierString ident++ getPerms :: Tar.Entry -> (FilePath, Tar.Permissions)+ getPerms e = (dest FP.</> Tar.fromTarPath (Tar.entryTarPath e),+ Tar.entryPermissions e)++ filePerms :: [(FilePath, Tar.Permissions)]+ filePerms = catMaybes $ Tar.foldEntries (\e -> (:) (Just $ getPerms e))+ [] (const []) entries Tar.unpack dest entries+ -- Reset file permissions as they were in the tarball+ mapM_ (\(fp', perm) -> setFileMode+ (FP.dropTrailingPathSeparator fp')+ perm) filePerms case mdistDir of Nothing -> return ()@@ -435,9 +486,7 @@ -- https://github.com/commercialhaskell/stack/issues/216 -- -- Instead, use Path which is a bit more resilient- newDist' <- parseAbsDir newDist- createDirectoryIfMissing True- $ toFilePath $ parent newDist'+ createTree . parent =<< parseAbsDir newDist renameDirectory oldDist newDist let cabalFP =
src/Stack/GhcPkg.hs view
@@ -16,7 +16,9 @@ ,unregisterGhcPkgId ,getCabalPkgVer ,findGhcPkgHaddockHtml- ,findGhcPkgDepends)+ ,findGhcPkgDepends+ ,findTransitiveGhcPkgDepends+ ,listGhcPkgDbs) where import Control.Monad@@ -28,16 +30,17 @@ import Data.Either import Data.List import Data.Maybe+import Data.Set (Set)+import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T import Path (Path, Abs, Dir, toFilePath, parent, parseAbsDir)+import Path.IO (dirExists, createTree) import Prelude hiding (FilePath)-import Stack.Build.Types (StackBuildException (Couldn'tFindPkgId)) import Stack.Constants import Stack.Types-import System.Directory (createDirectoryIfMissing, doesDirectoryExist, canonicalizePath,- doesDirectoryExist)+import System.Directory (canonicalizePath, doesDirectoryExist) import System.Process.Read -- | Get the global package database@@ -78,14 +81,13 @@ createDatabase :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadThrow m) => EnvOverride -> Path Abs Dir -> m () createDatabase menv db = do- let db' = toFilePath db- exists <- liftIO $ doesDirectoryExist db'+ exists <- dirExists db unless exists $ do -- Creating the parent doesn't seem necessary, as ghc-pkg -- seems to be sufficiently smart. But I don't feel like -- finding out it isn't the hard way- liftIO $ createDirectoryIfMissing True $ toFilePath $ parent db- _ <- tryProcessStdout Nothing menv "ghc-pkg" ["init", db']+ createTree (parent db)+ _ <- tryProcessStdout Nothing menv "ghc-pkg" ["init", toFilePath db] return () -- | Get the necessary ghc-pkg flags for setting up the given package database@@ -146,6 +148,27 @@ return (parseAbsDir path') _ -> return Nothing +-- | Finds dependencies of package, and all their dependencies, etc.+findTransitiveGhcPkgDepends+ :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadThrow m)+ => EnvOverride+ -> [Path Abs Dir] -- ^ package databases+ -> PackageIdentifier+ -> m (Set PackageIdentifier)+findTransitiveGhcPkgDepends menv pkgDbs pkgId0 =+ go pkgId0 Set.empty+ where+ go pkgId res = do+ deps <- findGhcPkgDepends menv pkgDbs pkgId+ loop (map ghcPkgIdPackageIdentifier deps) res+ loop [] res = return res+ loop (dep:deps) res = do+ if Set.member dep res+ then loop deps res+ else do+ res' <- go dep (Set.insert dep res)+ loop deps (Set.union res res')+ -- | Get the dependencies of the package. findGhcPkgDepends :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadThrow m) => EnvOverride@@ -183,3 +206,17 @@ maybe (throwM $ Couldn'tFindPkgId cabalPackageName) (return . packageIdentifierVersion . ghcPkgIdPackageIdentifier)++listGhcPkgDbs+ :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadThrow m)+ => EnvOverride -> [Path Abs Dir] -> m [PackageIdentifier]+listGhcPkgDbs menv pkgDbs = do+ result <-+ ghcPkg+ menv+ pkgDbs+ ["list", "--simple-output"]+ return $+ case result of+ Left{} -> []+ Right lbs -> mapMaybe parsePackageIdentifier (S8.words lbs)
+ src/Stack/Ghci.hs view
@@ -0,0 +1,135 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE RecordWildCards #-}++-- | Run a GHCi configured with the user's project(s).++module Stack.Ghci where++import Control.Monad.Catch+import Control.Monad.IO.Class+import Control.Monad.Logger+import Control.Monad.Reader+import Control.Monad.Trans.Control (MonadBaseControl)+import Data.List+import qualified Data.Map.Strict as M+import Data.Maybe+import Data.Monoid+import Data.Set (Set)+import qualified Data.Set as S+import Data.Text (Text)+import qualified Data.Text as T+import Data.Typeable+import Distribution.ModuleName (ModuleName)+import Distribution.Text (display)+import Network.HTTP.Client.Conduit+import Path+import Path.IO+import Stack.Build.Source+import Stack.Constants+import Stack.Exec+import Stack.Package+import Stack.Types++data GhciOpts = GhciOpts+ {ghciTargets :: [Text]+ ,ghciArgs :: [String]+ ,ghciGhcCommand :: FilePath+ ,ghciNoLoadModules :: Bool+ ,ghciAdditionalPackages :: [String]+ } deriving (Show,Eq)++-- | Launch a GHCi session for the given local project targets with the+-- given options and configure it with the load paths and extensions+-- of those targets.+ghci :: (HasConfig r, HasBuildConfig r, HasHttpManager r, HasEnvConfig r, MonadReader r m, MonadIO m, MonadThrow m, MonadLogger m, MonadCatch m, MonadBaseControl IO m)+ => GhciOpts+ -> m ()+ghci GhciOpts{..} = do+ pkgs <- ghciSetup ghciTargets+ config <- asks getBuildConfig+ let pkgopts = concatMap ghciPkgOpts pkgs+ srcfiles+ | ghciNoLoadModules = []+ | otherwise = concatMap (map display . S.toList . ghciPkgModules) pkgs+ odir = ["-odir=" <> toFilePath (objectInterfaceDir config)+ ,"-hidir=" <> toFilePath (objectInterfaceDir config)]+ $logInfo+ ("Configuring GHCi with the following packages: " <>+ T.intercalate ", " (map (packageNameText . ghciPkgName) pkgs))+ exec+ defaultEnvSettings+ ghciGhcCommand+ ("--interactive" : odir <> pkgopts <> srcfiles <> ghciArgs)++data GhciPkgInfo = GhciPkgInfo+ { ghciPkgName :: PackageName+ , ghciPkgOpts :: [String]+ , ghciPkgDir :: Path Abs Dir+ , ghciPkgModules :: Set ModuleName+ }++ghciSetup+ :: (HasConfig r, HasHttpManager r, HasBuildConfig r, HasEnvConfig r, MonadReader r m, MonadIO m, MonadThrow m, MonadLogger m, MonadCatch m, MonadBaseControl IO m)+ => [Text] -> m [GhciPkgInfo]+ghciSetup targets = do+ econfig <- asks getEnvConfig+ bconfig <- asks getBuildConfig+ pwd <- getWorkingDir+ (_,_,_,sourceMap) <- loadSourceMap defaultBuildOpts+ locals <-+ liftM catMaybes $+ forM (M.toList (envConfigPackages econfig)) $+ \(dir,validWanted) ->+ do cabalfp <- getCabalFileName dir+ name <- parsePackageNameFromFilePath cabalfp+ if validWanted && wanted pwd cabalfp name+ then return (Just (name, cabalfp))+ else return Nothing+ let findTarget x = find ((x ==) . packageNameText . fst) locals+ unmetTargets = filter (isNothing . findTarget) targets+ when (not (null unmetTargets)) $ throwM (TargetsNotFound unmetTargets)+ forM locals $+ \(name,cabalfp) ->+ do let config =+ PackageConfig+ { packageConfigEnableTests = True+ , packageConfigEnableBenchmarks = True+ , packageConfigFlags = localFlags mempty bconfig name+ , packageConfigGhcVersion = envConfigGhcVersion econfig+ , packageConfigPlatform = configPlatform+ (getConfig bconfig)+ }+ pkg <- readPackage config cabalfp+ pkgOpts <-+ getPackageOpts (packageOpts pkg) sourceMap (map fst locals) cabalfp+ modules <- getPackageModules (packageModules pkg) cabalfp+ return+ GhciPkgInfo+ { ghciPkgName = packageName pkg+ , ghciPkgOpts = filter (not . badForGhci) pkgOpts+ , ghciPkgDir = parent cabalfp+ , ghciPkgModules = modules+ }+ where+ wanted pwd cabalfp name = isInWantedList || targetsEmptyAndInDir+ where+ isInWantedList = elem (packageNameText name) targets+ targetsEmptyAndInDir = null targets || isParentOf (parent cabalfp) pwd+ badForGhci :: String -> Bool+ badForGhci x =+ isPrefixOf "-O" x || elem x (words "-debug -threaded -ticky")++data GhciSetupException =+ TargetsNotFound [Text]+ deriving Typeable++instance Exception GhciSetupException+instance Show GhciSetupException where+ show (TargetsNotFound targets) = unlines+ [ "Couldn't find targets: " ++ T.unpack (T.unwords targets)+ , "(expecting package names)"+ ]
src/Stack/Ide.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ExtendedDefaultRules #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-}@@ -13,25 +14,29 @@ import Control.Monad.IO.Class import Control.Monad.Logger import Control.Monad.Reader+import Control.Monad.Trans.Control (MonadBaseControl) import Data.Aeson import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as L import Data.List-import qualified Data.Map.Strict as M import Data.Maybe import Data.Monoid import qualified Data.Set as S import Data.Text (Text)+import qualified Data.Text as T+import Distribution.Text (display)+import Network.HTTP.Client.Conduit import Path import Path.IO-import Stack.Build.Source import Stack.Constants import Stack.Exec (defaultEnvSettings)+import Stack.Ghci (GhciPkgInfo(..), ghciSetup) import Stack.Package import Stack.Types import System.Directory (doesFileExist)+import System.Environment (lookupEnv) import System.Exit import System.IO import qualified System.Process as P@@ -41,77 +46,54 @@ -- given options and configure it with the load paths and extensions -- of those targets. ide- :: (HasConfig r, HasBuildConfig r, HasEnvConfig r, MonadReader r m, MonadIO m, MonadThrow m, MonadLogger m, MonadCatch m)+ :: (HasConfig r, HasBuildConfig r, HasEnvConfig r, MonadReader r m, MonadIO m, MonadThrow m, MonadLogger m, MonadCatch m, MonadBaseControl IO m, HasHttpManager r) => [Text] -- ^ Targets. -> [String] -- ^ GHC options. -> m () ide targets useropts = do- econfig <- asks getEnvConfig- bconfig <- asks getBuildConfig+ pkgs <- ghciSetup targets pwd <- getWorkingDir- pkgs <-- liftM catMaybes $- forM (M.toList (bcPackages bconfig)) $- \(dir,validWanted) ->- do cabalfp <- getCabalFileName dir- name <- parsePackageNameFromFilePath cabalfp- let config =- PackageConfig- { packageConfigEnableTests = True- , packageConfigEnableBenchmarks = True- , packageConfigFlags = localFlags mempty bconfig name- , packageConfigGhcVersion = envConfigGhcVersion econfig- , packageConfigPlatform = configPlatform- (getConfig bconfig)- }- pkg <- readPackage config cabalfp- if validWanted && wanted pwd cabalfp pkg- then do- pkgOpts <- getPackageOpts (packageOpts pkg) cabalfp- srcfiles <-- getPackageFiles (packageFiles pkg) Modules cabalfp- dist <- distDirFromDir dir- autogen <- return (autogenDir dist)- paths_foo <-- liftM- (autogen </>)- (parseRelFile- ("Paths_" ++- packageNameString name ++ ".hs"))- paths_foo_exists <- fileExists paths_foo- return- (Just- ( packageName pkg- , ["--dist-dir=" <> toFilePath dist] ++- map ("--ghc-option=" ++) (filter (not . badForGhci) pkgOpts)- , mapMaybe- (stripDir pwd)- (S.toList srcfiles <>- if paths_foo_exists- then [paths_foo]- else [])))- else return Nothing+ (pkgopts,srcfiles) <-+ liftM mconcat $+ forM pkgs $+ \pkg ->+ do dist <- distDirFromDir (ghciPkgDir pkg)+ autogen <- return (autogenDir dist)+ paths_foo <-+ liftM+ (autogen </>)+ (parseRelFile+ ("Paths_" +++ packageNameString (ghciPkgName pkg) ++ ".hs"))+ paths_foo_exists <- fileExists paths_foo+ return+ ( ["--dist-dir=" <> toFilePath dist] +++ map ("--ghc-option=" ++) (ghciPkgOpts pkg)+ , (map display (S.toList (ghciPkgModules pkg)) <>+ (mapMaybe+ (fmap toFilePath . stripDir pwd)+ (if paths_foo_exists+ then [paths_foo]+ else [])))) localdb <- packageDatabaseLocal depsdb <- packageDatabaseDeps- let pkgopts = concat (map _2 pkgs)- srcfiles = concatMap (map toFilePath . _3) pkgs- pkgdbs =+ mpath <- liftIO $ lookupEnv "PATH"+ bindirs <- extraBinDirs `ap` return True {- include local bin -}+ let pkgdbs = ["--package-db=" <> toFilePath depsdb <> ":" <> toFilePath localdb]- exec- "stack-ide"- (["--local-work-dir="++toFilePath pwd] ++- map ("--ghc-option=" ++) (filter (not . badForGhci) useropts) <> pkgopts <> pkgdbs)- (encode (initialRequest srcfiles))- where- wanted pwd cabalfp pkg = isInWantedList || targetsEmptyAndInDir- where- isInWantedList = elem (packageNameText (packageName pkg)) targets- targetsEmptyAndInDir = null targets || isParentOf (parent cabalfp) pwd- badForGhci x =- isPrefixOf "-O" x || elem x (words "-debug -threaded -ticky")- _1 (x,_,_) = x- _2 (_,x,_) = x- _3 (_,_,x) = x+ paths =+ [ "--ide-backend-tools-path=" <>+ intercalate ":" (map toFilePath bindirs) <>+ (maybe "" (':' :) mpath)]+ args =+ ["--verbose"] <> ["--local-work-dir=" ++ toFilePath pwd] <>+ map ("--ghc-option=" ++) useropts <>+ paths <>+ pkgopts <>+ pkgdbs+ let initialStdin = encode (initialRequest srcfiles)+ $logDebug $ "Initial stack-ide request: " <> T.pack (show initialStdin)+ exec "stack-ide" args initialStdin -- | Make the initial request. initialRequest :: [FilePath] -> Value
+ src/Stack/Image.hs view
@@ -0,0 +1,217 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}++-- | This module builds Docker (OpenContainer) images.+module Stack.Image+ (stageContainerImageArtifacts, createContainerImageFromStage,+ imgCmdName, imgDockerCmdName, imgOptsFromMonoid,+ imgDockerOptsFromMonoid, imgOptsParser, imgDockerOptsParser)+ where++import Control.Applicative+import Control.Exception.Lifted hiding (finally)+import Control.Monad+import Control.Monad.Catch hiding (bracket)+import Control.Monad.IO.Class+import Control.Monad.Logger+import Control.Monad.Reader+import Control.Monad.Trans.Control+import Data.Char (toLower)+import qualified Data.Map.Strict as Map+import Data.Maybe+import Data.Monoid+import qualified Data.Text as T+import Data.Typeable+import Options.Applicative+import Path+import Path.IO+import Stack.Constants+import Stack.Types+import Stack.Types.Internal+import System.FilePath (dropTrailingPathSeparator)+import System.Process++type Build e m = (HasBuildConfig e, HasConfig e, HasEnvConfig e, HasTerminal e, MonadBaseControl IO m, MonadCatch m, MonadIO m, MonadLogger m, MonadReader e m)++type Assemble e m = (HasConfig e, HasTerminal e, MonadBaseControl IO m, MonadCatch m, MonadIO m, MonadLogger m, MonadMask m, MonadReader e m)++-- | Stages the executables & additional content in a staging+-- directory under '.stack-work'+stageContainerImageArtifacts :: Build e m+ => m ()+stageContainerImageArtifacts = do+ imageDir <- imageStagingDir <$> getWorkingDir+ createTree imageDir+ stageExesInDir imageDir+ syncAddContentToDir imageDir++-- | Builds a Docker (OpenContainer) image extending the `base` image+-- specified in the project's stack.yaml. Then new image will be+-- extended with an ENTRYPOINT specified for each `entrypoint` listed+-- in the config file.+createContainerImageFromStage :: Assemble e m+ => m ()+createContainerImageFromStage = do+ imageDir <- imageStagingDir <$> getWorkingDir+ createDockerImage imageDir+ extendDockerImageWithEntrypoint imageDir++-- | Stage all the Package executables in the usr/local/bin+-- subdirectory of a temp directory.+stageExesInDir :: Build e m => Path Abs Dir -> m ()+stageExesInDir dir = do+ srcBinPath <-+ (</> $(mkRelDir "bin")) <$>+ installationRootLocal+ let destBinPath = dir </>+ $(mkRelDir "usr/local/bin")+ createTree destBinPath+ copyDirectoryRecursive srcBinPath destBinPath++-- | Add any additional files into the temp directory, respecting the+-- (Source, Destination) mapping.+syncAddContentToDir :: Build e m => Path Abs Dir -> m ()+syncAddContentToDir dir = do+ config <- asks getConfig+ bconfig <- asks getBuildConfig+ let imgAdd = maybe Map.empty imgDockerAdd (imgDocker (configImage config))+ forM_+ (Map.toList imgAdd)+ (\(source,dest) ->+ do sourcePath <- parseRelDir source+ destPath <- parseAbsDir dest+ let destFullPath = dir </> dropRoot destPath+ createTree destFullPath+ copyDirectoryRecursive+ (bcRoot bconfig </> sourcePath)+ destFullPath)++-- | Derive an image name from the project directory.+imageName :: Path Abs Dir -> String+imageName = map toLower . dropTrailingPathSeparator . toFilePath . dirname++-- | Create a general purpose docker image from the temporary+-- directory of executables & static content.+createDockerImage :: Assemble e m => Path Abs Dir -> m ()+createDockerImage dir = do+ config <- asks getConfig+ let dockerConfig = imgDocker (configImage config)+ case imgDockerBase =<< dockerConfig of+ Nothing -> throwM StackImageDockerBaseUnspecifiedException+ Just base -> do+ liftIO+ (do writeFile+ (toFilePath+ (dir </>+ $(mkRelFile "Dockerfile")))+ (unlines ["FROM " ++ base, "ADD ./ /"])+ callProcess+ "docker"+ [ "build"+ , "-t"+ , fromMaybe+ (imageName (parent (parent dir)))+ (imgDockerImageName =<< dockerConfig)+ , toFilePath dir])++-- | Extend the general purpose docker image with entrypoints (if+-- specified).+extendDockerImageWithEntrypoint :: Assemble e m => Path Abs Dir -> m ()+extendDockerImageWithEntrypoint dir = do+ config <- asks getConfig+ let dockerConfig = imgDocker (configImage config)+ let dockerImageName = fromMaybe+ (imageName (parent (parent dir)))+ (imgDockerImageName =<< dockerConfig)+ let imgEntrypoints = maybe Nothing imgDockerEntrypoints dockerConfig+ case imgEntrypoints of+ Nothing -> return ()+ Just eps -> do+ forM_+ eps+ (\ep ->+ liftIO+ (do writeFile+ (toFilePath+ (dir </>+ $(mkRelFile "Dockerfile")))+ (unlines+ [ "FROM " ++ dockerImageName+ , "ENTRYPOINT [\"/usr/local/bin/" +++ ep ++ "\"]"+ , "CMD []"])+ callProcess+ "docker"+ [ "build"+ , "-t"+ , dockerImageName ++ "-" ++ ep+ , toFilePath dir]))++-- | The command name for dealing with images.+imgCmdName :: String+imgCmdName = "image"++-- | The command name for building a docker container.+imgDockerCmdName :: String+imgDockerCmdName = "container"++-- | A parser for ImageOptsMonoid.+imgOptsParser :: Parser ImageOptsMonoid+imgOptsParser = ImageOptsMonoid <$>+ optional+ (subparser+ (command+ imgDockerCmdName+ (info+ imgDockerOptsParser+ (progDesc "Create a container image (EXPERIMENTAL)"))))++-- | A parser for ImageDockerOptsMonoid.+imgDockerOptsParser :: Parser ImageDockerOptsMonoid+imgDockerOptsParser = ImageDockerOptsMonoid <$>+ optional+ (option+ str+ (long (imgDockerCmdName ++ "-" ++ T.unpack imgDockerBaseArgName) <>+ metavar "NAME" <>+ help "Docker base image name")) <*>+ pure Nothing <*>+ pure Nothing <*>+ pure Nothing++-- | Convert image opts monoid to image options.+imgOptsFromMonoid :: ImageOptsMonoid -> ImageOpts+imgOptsFromMonoid ImageOptsMonoid{..} = ImageOpts+ { imgDocker = imgDockerOptsFromMonoid <$> imgMonoidDocker+ }++-- | Convert Docker image opts monoid to Docker image options.+imgDockerOptsFromMonoid :: ImageDockerOptsMonoid -> ImageDockerOpts+imgDockerOptsFromMonoid ImageDockerOptsMonoid{..} = ImageDockerOpts+ { imgDockerBase = emptyToNothing imgDockerMonoidBase+ , imgDockerEntrypoints = emptyToNothing imgDockerMonoidEntrypoints+ , imgDockerAdd = fromMaybe Map.empty imgDockerMonoidAdd+ , imgDockerImageName = emptyToNothing imgDockerMonoidImageName+ }+ where emptyToNothing Nothing = Nothing+ emptyToNothing (Just s)+ | null s =+ Nothing+ | otherwise =+ Just s++-- | Stack image exceptions.+data StackImageException =+ StackImageDockerBaseUnspecifiedException+ deriving (Typeable)++instance Exception StackImageException++instance Show StackImageException where+ show StackImageDockerBaseUnspecifiedException = "You must specify a base docker image on which to place your haskell executables."
src/Stack/Init.hs view
@@ -6,21 +6,22 @@ ( findCabalFiles , initProject , InitOpts (..)- , initOptsParser- , readResolver+ , SnapPref (..)+ , Method (..)+ , makeConcreteResolver ) where import Control.Exception (assert) import Control.Exception.Enclosed (handleIO, catchAny) import Control.Monad (liftM, when)-import Control.Monad.Catch (MonadMask, throwM)+import Control.Monad.Catch (MonadMask, throwM, MonadThrow) import Control.Monad.IO.Class import Control.Monad.Logger-import Control.Monad.Reader (MonadReader)+import Control.Monad.Reader (MonadReader, asks) import Control.Monad.Trans.Control (MonadBaseControl) import qualified Data.IntMap as IntMap-import Data.List (sort)-import Data.List (isSuffixOf)+import Data.List (isSuffixOf,sort)+import Data.List.Extra (nubOrd) import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe (mapMaybe)@@ -31,8 +32,6 @@ import qualified Data.Yaml as Yaml import qualified Distribution.PackageDescription as C import Network.HTTP.Client.Conduit (HasHttpManager)-import Options.Applicative-import Options.Applicative.Types (readerAsk) import Path import Path.Find import Path.IO@@ -61,10 +60,10 @@ -- | Generate stack.yaml initProject :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, MonadBaseControl IO m)- => InitOpts+ => Path Abs Dir+ -> InitOpts -> m ()-initProject initOpts = do- currDir <- getWorkingDir+initProject currDir initOpts = do let dest = currDir </> stackDotYaml dest' = toFilePath dest exists <- fileExists dest@@ -101,7 +100,7 @@ Just rel -> toFilePath rel , peSubdirs = [] }- $logInfo $ "Selected resolver: " <> renderResolver r+ $logInfo $ "Selected resolver: " <> resolverName r liftIO $ Yaml.encodeFile dest' p $logInfo $ "Wrote project config to: " <> T.pack dest' @@ -144,17 +143,19 @@ Just (snap, flags) -> return (ResolverSnapshot snap, flags, Map.empty) Nothing -> throwM $ NoMatchingSnapshot names- MethodResolver resolver -> do+ MethodResolver aresolver -> do+ resolver <- makeConcreteResolver aresolver mpair <- case resolver of ResolverSnapshot name -> findBuildPlan gpds [name] ResolverGhc _ -> return Nothing+ ResolverCustom _ _ -> return Nothing case mpair of Just (snap, flags) -> return (ResolverSnapshot snap, flags, Map.empty) Nothing -> return (resolver, Map.empty, Map.empty) MethodSolver -> do- (ghcVersion, extraDeps) <- cabalSolver (map parent cabalfps) []+ (ghcVersion, extraDeps) <- cabalSolver (map parent cabalfps) Map.empty [] return ( ResolverGhc ghcVersion , Map.filter (not . Map.null) $ fmap snd extraDeps@@ -199,7 +200,7 @@ { ioMethod :: !Method -- ^ Preferred snapshots , forceOverwrite :: Bool- -- ^ Force overwrite of existing stack.yaml+ -- ^ Overwrite existing files , includeSubDirs :: Bool -- ^ If True, include all .cabal files found in any sub directories }@@ -207,56 +208,34 @@ data SnapPref = PrefNone | PrefLTS | PrefNightly -- | Method of initializing-data Method = MethodSnapshot SnapPref | MethodResolver Resolver | MethodSolver--initOptsParser :: Parser InitOpts-initOptsParser =- InitOpts <$> method <*> overwrite <*> fmap not ignoreSubDirs- where- ignoreSubDirs = flag False- True- (long "ignore-subdirs" <>- help "Do not search for .cabal files in sub directories")- overwrite = flag False- True- (long "force" <>- help "Force overwriting of an existing stack.yaml if it exists")- method = solver- <|> (MethodResolver <$> resolver)- <|> (MethodSnapshot <$> snapPref)-- solver =- flag' MethodSolver- (long "solver" <>- help "Use a dependency solver to determine dependencies")-- snapPref =- flag' PrefLTS- (long "prefer-lts" <>- help "Prefer LTS snapshots over Nightly snapshots") <|>- flag' PrefNightly- (long "prefer-nightly" <>- help "Prefer Nightly snapshots over LTS snapshots") <|>- pure PrefNone-- resolver = option readResolver- (long "resolver" <>- metavar "RESOLVER" <>- help "Use the given resolver, even if not all dependencies are met")--readResolver :: ReadM Resolver-readResolver = do- s <- readerAsk- case parseResolver $ T.pack s of- Left e -> readerError $ show e- Right x -> return x+data Method = MethodSnapshot SnapPref | MethodResolver AbstractResolver | MethodSolver --- | Same semantics as @nub@, but more efficient by using the @Ord@ constraint.-nubOrd :: Ord a => [a] -> [a]-nubOrd =- go Set.empty- where- go _ [] = []- go s (x:xs)- | x `Set.member` s = go s xs- | otherwise = x : go (Set.insert x s) xs+-- | Turn an 'AbstractResolver' into a 'Resolver'.+makeConcreteResolver :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m, HasHttpManager env, MonadLogger m)+ => AbstractResolver+ -> m Resolver+makeConcreteResolver (ARResolver r) = return r+makeConcreteResolver ar = do+ snapshots <- getSnapshots+ r <-+ case ar of+ ARResolver r -> assert False $ return r+ ARGlobal -> do+ stackRoot <- asks $ configStackRoot . getConfig+ let fp = implicitGlobalDir stackRoot </> stackDotYaml+ (ProjectAndConfigMonoid project _, _warnings) <-+ liftIO (Yaml.decodeFileEither $ toFilePath fp)+ >>= either throwM return+ return $ projectResolver project+ ARLatestNightly -> return $ ResolverSnapshot $ Nightly $ snapshotsNightly snapshots+ ARLatestLTSMajor x ->+ case IntMap.lookup x $ snapshotsLts snapshots of+ Nothing -> error $ "No LTS release found with major version " ++ show x+ Just y -> return $ ResolverSnapshot $ LTS x y+ ARLatestLTS+ | IntMap.null $ snapshotsLts snapshots -> error $ "No LTS releases found"+ | otherwise ->+ let (x, y) = IntMap.findMax $ snapshotsLts snapshots+ in return $ ResolverSnapshot $ LTS x y+ $logInfo $ "Selected resolver: " <> resolverName r+ return r
src/Stack/New.hs view
@@ -1,42 +1,291 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TemplateHaskell #-}++-- | Create new a new project directory populated with a basic working+-- project.+ module Stack.New- ( newProject- ) where+ ( new+ , NewOpts(..)+ , defaultTemplateName+ , templateNameArgument+ , getTemplates+ , TemplateName+ , listTemplates)+ where -import Control.Monad (filterM, forM_, unless)-import Control.Monad.IO.Class (MonadIO, liftIO)-import Control.Monad.Logger (MonadLogger, logInfo)-import Data.ByteString (ByteString)-import qualified Data.ByteString as S-import Data.FileEmbed (embedDir)-import Data.Map (Map)-import qualified Data.Map as Map-import qualified Data.Text as T-import System.Directory (createDirectoryIfMissing,- doesFileExist)-import System.FilePath (takeDirectory)+import Control.Monad+import Control.Monad.Catch+import Control.Monad.IO.Class+import Control.Monad.Logger+import Control.Monad.Reader+import Control.Monad.Trans.Writer.Strict+import Data.Aeson+import Data.Aeson.Types+import qualified Data.ByteString.Lazy as LB+import qualified Data.ByteString.Lazy.Char8 as L8+import Data.Conduit+import Data.List+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as M+import Data.Maybe+import Data.Monoid+import Data.Set (Set)+import qualified Data.Set as S+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.IO as T+import qualified Data.Text.Lazy as LT+import Data.Typeable+import Network.HTTP.Client.Conduit hiding (path)+import Network.HTTP.Download+import Network.HTTP.Types.Status+import Path+import Path.IO+import Stack.Constants+import Stack.Types+import Stack.Types.TemplateName+import System.Process.Run+import Text.Hastache+import Text.Hastache.Context+import Text.ProjectTemplate -newProject :: (MonadIO m, MonadLogger m)- => m ()-newProject = do- $logInfo "NOTE: Currently stack new functionality is very rudimentary"- $logInfo "There are plans to make this feature more useful in the future"- $logInfo "For more information, see: https://github.com/commercialhaskell/stack/issues/137"- $logInfo "For now, we'll just be generating a basic project structure in your current directory"+--------------------------------------------------------------------------------+-- Main project creation - exist <- filterM (liftIO . doesFileExist) (Map.keys files)- unless (null exist) $- error $ unlines- $ "The following files already exist, refusing to overwrite:"- : map ("- " ++) exist+-- | Options for creating a new project.+data NewOpts = NewOpts+ { newOptsProjectName :: PackageName -- ^ Name of the project to create.+ , newOptsTemplate :: TemplateName -- ^ Name of the template to use.+ } - $logInfo ""- forM_ (Map.toList files) $ \(fp, bs) -> do- $logInfo $ T.pack $ "Writing: " ++ fp- liftIO $ do- createDirectoryIfMissing True $ takeDirectory fp- S.writeFile fp bs+-- | Create a new project with the given options.+new+ :: (HasConfig r, MonadReader r m, MonadLogger m, MonadCatch m, MonadThrow m, MonadIO m, HasHttpManager r)+ => NewOpts -> m (Path Abs Dir)+new opts = do+ pwd <- getWorkingDir+ relDir <- parseRelDir (packageNameString (newOptsProjectName opts))+ absDir <- liftM (pwd </>) (return relDir)+ exists <- dirExists absDir+ if exists+ then throwM (AlreadyExists absDir)+ else do+ logUsing relDir+ templateText <- loadTemplate template+ files <- applyTemplate project absDir templateText+ writeTemplateFiles files+ runTemplateInits absDir+ return absDir+ where+ template = newOptsTemplate opts+ project = newOptsProjectName opts+ logUsing relDir =+ $logInfo+ ("Downloading template \"" <> templateName template <>+ "\" to create project \"" <>+ packageNameText project <>+ "\" in " <>+ T.pack (toFilePath relDir) <>+ " ...") -files :: Map FilePath ByteString-files = Map.fromList $(embedDir "new-template")+-- | Download and read in a template's text content.+loadTemplate+ :: (HasConfig r, HasHttpManager r, MonadReader r m, MonadIO m, MonadThrow m, MonadCatch m)+ => TemplateName -> m Text+loadTemplate name = do+ req <-+ parseUrl (defaultTemplateUrl <> "/" <> toFilePath (templatePath name))+ config <- asks getConfig+ let path = templatesDir config </> templatePath name+ _ <- catch (redownload req path) (throwM . FailedToDownloadTemplate name)+ exists <- fileExists path+ if exists+ then liftIO (T.readFile (toFilePath path))+ else throwM (FailedToLoadTemplate name path)++-- | Apply and unpack a template into a directory.+applyTemplate+ :: (MonadIO m, MonadThrow m, MonadReader r m, HasConfig r, MonadLogger m)+ => PackageName -> Path Abs Dir -> Text -> m (Map (Path Abs File) LB.ByteString)+applyTemplate project dir template = do+ config <- asks getConfig+ displayContext config+ applied <-+ hastacheStr+ defaultConfig+ template+ (mkStrContext (contextFunction config))+ files :: Map FilePath LB.ByteString <-+ execWriterT $+ yield (T.encodeUtf8 (LT.toStrict applied)) $$+ unpackTemplate receiveMem id+ liftM+ M.fromList+ (mapM+ (\(fp,bytes) ->+ do path <- parseRelFile fp+ return (dir </> path, bytes))+ (M.toList files))+ where+ context config =+ [ ("name", packageNameText project)+ , ( authorEmailKey+ , fromMaybe defaultAuthorEmail (configAuthorEmail config))+ , (authorNameKey, fromMaybe defaultAuthorName (configAuthorName config))]+ contextFunction :: Config -> String -> MuType m+ contextFunction config key =+ case lookup (T.pack key) (context config) of+ Nothing -> MuNothing+ Just value -> MuVariable value++-- | Display the context being used for the template.+displayContext :: MonadLogger m => Config -> m ()+displayContext config = do+ $logInfo "Using the following authorship configuration:"+ $logInfo+ (authorEmailKey <> ": " <>+ fromMaybe defaultAuthorEmail (configAuthorEmail config))+ $logInfo+ (authorNameKey <> ": " <>+ fromMaybe defaultAuthorName (configAuthorName config))+ $logInfo+ ("Copy these to " <> T.pack (toFilePath (globalConfigPath config)) <>+ " and edit to use different values.")++-- | Write files to the new project directory.+writeTemplateFiles+ :: MonadIO m+ => Map (Path Abs File) LB.ByteString -> m ()+writeTemplateFiles files = do+ forM_+ (M.toList files)+ (\(fp,bytes) ->+ do createTree (parent fp)+ liftIO (LB.writeFile (toFilePath fp) bytes))++-- | Run any initialization functions, such as Git.+runTemplateInits+ :: (MonadIO m, MonadReader r m, HasConfig r, MonadLogger m, MonadCatch m)+ => Path Abs Dir -> m ()+runTemplateInits dir = do+ menv <- getMinimalEnvOverride+ config <- asks getConfig+ case configScmInit config of+ Nothing -> return ()+ Just Git ->+ do catch+ (callProcess (Just dir) menv "git" ["init"])+ (\(_ :: ProcessExitedUnsuccessfully) ->+ $logInfo "git init failed to run, ignoring ...")++--------------------------------------------------------------------------------+-- Getting templates list++listTemplates+ :: (MonadIO m, MonadThrow m, MonadReader r m, HasHttpManager r, MonadCatch m, MonadLogger m)+ => m ()+listTemplates = do+ templates <- getTemplates+ mapM_ ($logInfo . templateName) (S.toList templates)++-- | Get the set of templates.+getTemplates+ :: (MonadIO m, MonadThrow m, MonadReader r m, HasHttpManager r, MonadCatch m)+ => m (Set TemplateName)+getTemplates = do+ req <- liftM addHeaders (parseUrl defaultTemplatesList)+ resp <- catch (httpLbs req) (throwM . FailedToDownloadTemplates)+ case statusCode (responseStatus resp) of+ 200 ->+ case eitherDecode (responseBody resp) >>=+ parseEither parseTemplateSet of+ Left err -> throwM (BadTemplatesJSON err (responseBody resp))+ Right value -> return value+ code -> throwM (BadTemplatesResponse code)+ where+ addHeaders req =+ req+ { requestHeaders = [ ("User-Agent", "The Haskell Stack")+ , ("Accept", "application/vnd.github.v3+json")] <>+ requestHeaders req+ }++-- | Parser the set of templates from the JSON.+parseTemplateSet :: Value -> Parser (Set TemplateName)+parseTemplateSet a = do+ xs <- parseJSON a+ fmap (S.fromList . catMaybes) (mapM parseTemplate xs)+ where+ parseTemplate v = do+ o <- parseJSON v+ name <- o .: "name"+ if isSuffixOf ".hsfiles" name+ then case parseTemplateNameFromString name of+ Left{} ->+ fail ("Unable to parse template name from " <> name)+ Right template -> return (Just template)+ else return Nothing++--------------------------------------------------------------------------------+-- Defaults++-- | The default template name you can use if you don't have one.+defaultTemplateName :: TemplateName+defaultTemplateName = $(mkTemplateName "new-template")++-- | Default web root URL to download from.+defaultTemplateUrl :: String+defaultTemplateUrl =+ "https://raw.githubusercontent.com/commercialhaskell/stack-templates/master"++-- | Default web URL to list the repo contents.+defaultTemplatesList :: String+defaultTemplatesList =+ "https://api.github.com/repos/commercialhaskell/stack-templates/contents/"++--------------------------------------------------------------------------------+-- Exceptions++-- | Exception that might occur when making a new project.+data NewException+ = FailedToLoadTemplate !TemplateName+ !(Path Abs File)+ | FailedToDownloadTemplate !TemplateName+ !DownloadException+ | FailedToDownloadTemplates !HttpException+ | BadTemplatesResponse !Int+ | BadTemplatesJSON !String !LB.ByteString+ | AlreadyExists !(Path Abs Dir)+ deriving (Typeable)++instance Exception NewException++instance Show NewException where+ show (FailedToLoadTemplate name path) =+ "Failed to load download template " <> T.unpack (templateName name) <>+ " from " <>+ toFilePath path+ show (FailedToDownloadTemplate name (RedownloadFailed _ _ resp)) =+ case statusCode (responseStatus resp) of+ 404 ->+ "That template doesn't exist. Run `stack templates' to see a list of available templates."+ code ->+ "Failed to download template " <> T.unpack (templateName name) <>+ ": unknown reason, status code was: " <>+ show code+ show (FailedToDownloadTemplate name _) =+ "Failed to download template " <> T.unpack (templateName name) <>+ ", reason unknown."+ show (AlreadyExists path) =+ "Directory " <> toFilePath path <> " already exists. Aborting."+ show (FailedToDownloadTemplates ex) =+ "Failed to download templates. The HTTP error was: " <> show ex+ show (BadTemplatesResponse code) =+ "Unexpected status code while retrieving templates list: " <> show code+ show (BadTemplatesJSON err bytes) =+ "Github returned some JSON that couldn't be parsed: " <> err <> "\n\n" <>+ L8.unpack bytes
+ src/Stack/Options.hs view
@@ -0,0 +1,607 @@+{-# LANGUAGE OverloadedStrings #-}++module Stack.Options+ (Command(..)+ ,benchOptsParser+ ,buildOptsParser+ ,configOptsParser+ ,dockerOptsParser+ ,dockerCleanupOptsParser+ ,dotOptsParser+ ,execOptsParser+ ,globalOptsParser+ ,initOptsParser+ ,newOptsParser+ ,logLevelOptsParser+ ,ghciOptsParser+ ,abstractResolverOptsParser+ ,solverOptsParser+ ,testOptsParser+ ) where++import Control.Monad.Logger (LogLevel(..))+import Data.Char (isSpace, toLower)+import Data.List.Split (splitOn)+import qualified Data.Map as Map+import Data.Map.Strict (Map)+import Data.Maybe+import Data.Monoid+import qualified Data.Set as Set+import qualified Data.Text as T+import Data.Text.Read (decimal)+import Options.Applicative.Args+import Options.Applicative.Builder.Extra+import Options.Applicative.Simple+import Options.Applicative.Types (readerAsk)+import Stack.Config (packagesParser)+import Stack.Docker+import qualified Stack.Docker as Docker+import Stack.Dot+import Stack.Ghci (GhciOpts(..))+import Stack.Init+import Stack.New+import Stack.Types++-- | Command sum type for conditional arguments.+data Command+ = Build+ | Test+ | Haddock+ | Bench+ | Install+ deriving (Eq)++-- | Parser for bench arguments.+benchOptsParser :: Parser BenchmarkOpts+benchOptsParser = BenchmarkOpts+ <$> optional (strOption (long "benchmark-arguments" <>+ metavar "BENCH_ARGS" <>+ help ("Forward BENCH_ARGS to the benchmark suite. " <>+ "Supports templates from `cabal bench`")))++addCoverageFlags :: BuildOpts -> BuildOpts+addCoverageFlags bopts+ | toCoverage $ boptsTestOpts bopts+ = bopts { boptsGhcOptions = "-fhpc" : boptsGhcOptions bopts }+ | otherwise = bopts++-- | Parser for build arguments.+buildOptsParser :: Command+ -> Parser BuildOpts+buildOptsParser cmd =+ fmap addCoverageFlags $+ BuildOpts <$> target <*> libProfiling <*> exeProfiling <*>+ optimize <*> haddock <*> haddockDeps <*> dryRun <*> ghcOpts <*>+ flags <*> copyBins <*> preFetch <*>+ buildSubset <*>+ fileWatch' <*> keepGoing <*> forceDirty <*>+ tests <*> testOptsParser <*>+ benches <*> benchOptsParser <*>+ many exec+ where optimize =+ maybeBoolFlags "optimizations" "optimizations for TARGETs and all its dependencies" idm+ target =+ fmap (map T.pack)+ (many (strArgument+ (metavar "TARGET" <>+ help "If none specified, use all packages")))+ libProfiling =+ boolFlags False+ "library-profiling"+ "library profiling for TARGETs and all its dependencies"+ idm+ exeProfiling =+ boolFlags False+ "executable-profiling"+ "library profiling for TARGETs and all its dependencies"+ idm+ haddock =+ boolFlags (cmd == Haddock)+ "haddock"+ "generating Haddocks the project(s) in this directory/configuration"+ idm+ haddockDeps =+ if cmd == Haddock+ then maybeBoolFlags+ "haddock-deps"+ "building Haddocks for dependencies"+ idm+ else pure Nothing++ copyBins = boolFlags (cmd == Install)+ "copy-bins"+ "copying binaries to the local-bin-path (see 'stack path')"+ idm++ dryRun = flag False True (long "dry-run" <>+ help "Don't build anything, just prepare to")+ ghcOpts = (++)+ <$> flag [] ["-Wall", "-Werror"]+ ( long "pedantic"+ <> help "Turn on -Wall and -Werror (note: option name may change in the future"+ )+ <*> many (fmap T.pack+ (strOption (long "ghc-options" <>+ metavar "OPTION" <>+ help "Additional options passed to GHC")))++ flags =+ fmap (Map.unionsWith Map.union) $ many+ (option readFlag+ ( long "flag"+ <> metavar "PACKAGE:[-]FLAG"+ <> help "Override flags set in stack.yaml (applies to local packages and extra-deps)"+ ))++ preFetch = flag False True+ (long "prefetch" <>+ help "Fetch packages necessary for the build immediately, useful with --dry-run")++ buildSubset =+ flag' BSOnlySnapshot+ (long "only-snapshot" <>+ help "Only build packages for the snapshot database, not the local database")+ <|> flag' BSOnlyDependencies+ (long "only-dependencies" <>+ help "Only build packages that are dependencies of targets on the command line")+ <|> pure BSAll++ fileWatch' = flag False True+ (long "file-watch" <>+ help "Watch for changes in local files and automatically rebuild")++ keepGoing = maybeBoolFlags+ "keep-going"+ "continue running after a step fails (default: false for build, true for test/bench)"+ idm++ forceDirty = flag False True+ (long "force-dirty" <>+ help "Force treating all local packages as having dirty files (useful for cases where stack can't detect a file change)")+++ tests = boolFlags (cmd == Test)+ "test"+ "testing the project(s) in this directory/configuration"+ idm++ benches = boolFlags (cmd == Bench)+ "bench"+ "benchmarking the project(s) in this directory/configuration"+ idm++ exec = cmdOption+ ( long "exec" <>+ metavar "CMD [ARGS]" <>+ help "Command and arguments to run after a successful build" )++-- | Parser for package:[-]flag+readFlag :: ReadM (Map (Maybe PackageName) (Map FlagName Bool))+readFlag = do+ s <- readerAsk+ case break (== ':') s of+ (pn, ':':mflag) -> do+ pn' <-+ case parsePackageNameFromString pn of+ Nothing+ | pn == "*" -> return Nothing+ | otherwise -> readerError $ "Invalid package name: " ++ pn+ Just x -> return $ Just x+ let (b, flagS) =+ case mflag of+ '-':x -> (False, x)+ _ -> (True, mflag)+ flagN <-+ case parseFlagNameFromString flagS of+ Nothing -> readerError $ "Invalid flag name: " ++ flagS+ Just x -> return x+ return $ Map.singleton pn' $ Map.singleton flagN b+ _ -> readerError "Must have a colon"++-- | Command-line arguments parser for configuration.+configOptsParser :: Bool -> Parser ConfigMonoid+configOptsParser docker =+ (\opts systemGHC installGHC arch os jobs includes libs skipGHCCheck skipMsys localBin -> mempty+ { configMonoidDockerOpts = opts+ , configMonoidSystemGHC = systemGHC+ , configMonoidInstallGHC = installGHC+ , configMonoidSkipGHCCheck = skipGHCCheck+ , configMonoidArch = arch+ , configMonoidOS = os+ , configMonoidJobs = jobs+ , configMonoidExtraIncludeDirs = includes+ , configMonoidExtraLibDirs = libs+ , configMonoidSkipMsys = skipMsys+ , configMonoidLocalBinPath = localBin+ })+ <$> dockerOptsParser docker+ <*> maybeBoolFlags+ "system-ghc"+ "using the system installed GHC (on the PATH) if available and a matching version"+ idm+ <*> maybeBoolFlags+ "install-ghc"+ "downloading and installing GHC if necessary (can be done manually with stack setup)"+ idm+ <*> optional (strOption+ ( long "arch"+ <> metavar "ARCH"+ <> help "System architecture, e.g. i386, x86_64"+ ))+ <*> optional (strOption+ ( long "os"+ <> metavar "OS"+ <> help "Operating system, e.g. linux, windows"+ ))+ <*> optional (option auto+ ( long "jobs"+ <> short 'j'+ <> metavar "JOBS"+ <> help "Number of concurrent jobs to run"+ ))+ <*> fmap (Set.fromList . map T.pack) (many $ strOption+ ( long "extra-include-dirs"+ <> metavar "DIR"+ <> help "Extra directories to check for C header files"+ ))+ <*> fmap (Set.fromList . map T.pack) (many $ strOption+ ( long "extra-lib-dirs"+ <> metavar "DIR"+ <> help "Extra directories to check for libraries"+ ))+ <*> maybeBoolFlags+ "skip-ghc-check"+ "skipping the GHC version and architecture check"+ idm+ <*> maybeBoolFlags+ "skip-msys"+ "skipping the local MSYS installation (Windows only)"+ idm+ <*> optional (strOption+ ( long "local-bin-path"+ <> metavar "DIR"+ <> help "Install binaries to DIR"+ ))++-- | Options parser configuration for Docker.+dockerOptsParser :: Bool -> Parser DockerOptsMonoid+dockerOptsParser showOptions =+ DockerOptsMonoid+ <$> pure Nothing+ <*> maybeBoolFlags dockerCmdName+ "using a Docker container"+ hide+ <*> ((Just . DockerMonoidRepo) <$> option str (long (dockerOptName dockerRepoArgName) <>+ hide <>+ metavar "NAME" <>+ help "Docker repository name") <|>+ (Just . DockerMonoidImage) <$> option str (long (dockerOptName dockerImageArgName) <>+ hide <>+ metavar "IMAGE" <>+ help "Exact Docker image ID (overrides docker-repo)") <|>+ pure Nothing)+ <*> maybeBoolFlags (dockerOptName dockerRegistryLoginArgName)+ "registry requires login"+ hide+ <*> maybeStrOption (long (dockerOptName dockerRegistryUsernameArgName) <>+ hide <>+ metavar "USERNAME" <>+ help "Docker registry username")+ <*> maybeStrOption (long (dockerOptName dockerRegistryPasswordArgName) <>+ hide <>+ metavar "PASSWORD" <>+ help "Docker registry password")+ <*> maybeBoolFlags (dockerOptName dockerAutoPullArgName)+ "automatic pulling latest version of image"+ hide+ <*> maybeBoolFlags (dockerOptName dockerDetachArgName)+ "running a detached Docker container"+ hide+ <*> maybeBoolFlags (dockerOptName dockerPersistArgName)+ "not deleting container after it exits"+ hide+ <*> maybeStrOption (long (dockerOptName dockerContainerNameArgName) <>+ hide <>+ metavar "NAME" <>+ help "Docker container name")+ <*> argsOption (long (dockerOptName dockerRunArgsArgName) <>+ hide <>+ value [] <>+ metavar "'ARG1 [ARG2 ...]'" <>+ help "Additional options to pass to 'docker run'")+ <*> many (option auto (long (dockerOptName dockerMountArgName) <>+ hide <>+ metavar "(PATH | HOST-PATH:CONTAINER-PATH)" <>+ help ("Mount volumes from host in container " +++ "(may specify mutliple times)")))+ <*> maybeStrOption (long (dockerOptName dockerDatabasePathArgName) <>+ hide <>+ metavar "PATH" <>+ help "Location of image usage tracking database")+ where+ dockerOptName optName = dockerCmdName ++ "-" ++ T.unpack optName+ maybeStrOption = optional . option str+ hide = if showOptions+ then idm+ else internal <> hidden++-- | Parser for docker cleanup arguments.+dockerCleanupOptsParser :: Parser Docker.CleanupOpts+dockerCleanupOptsParser =+ Docker.CleanupOpts <$>+ (flag' Docker.CleanupInteractive+ (short 'i' <>+ long "interactive" <>+ help "Show cleanup plan in editor and allow changes (default)") <|>+ flag' Docker.CleanupImmediate+ (short 'y' <>+ long "immediate" <>+ help "Immediately execute cleanup plan") <|>+ flag' Docker.CleanupDryRun+ (short 'n' <>+ long "dry-run" <>+ help "Display cleanup plan but do not execute") <|>+ pure Docker.CleanupInteractive) <*>+ opt (Just 14) "known-images" "LAST-USED" <*>+ opt Nothing "unknown-images" "CREATED" <*>+ opt (Just 0) "dangling-images" "CREATED" <*>+ opt Nothing "stopped-containers" "CREATED" <*>+ opt Nothing "running-containers" "CREATED"+ where opt def' name mv =+ fmap Just+ (option auto+ (long name <>+ metavar (mv ++ "-DAYS-AGO") <>+ help ("Remove " +++ toDescr name +++ " " +++ map toLower (toDescr mv) +++ " N days ago" +++ case def' of+ Just n -> " (default " ++ show n ++ ")"+ Nothing -> ""))) <|>+ flag' Nothing+ (long ("no-" ++ name) <>+ help ("Do not remove " +++ toDescr name +++ case def' of+ Just _ -> ""+ Nothing -> " (default)")) <|>+ pure def'+ toDescr = map (\c -> if c == '-' then ' ' else c)++-- | Parser for arguments to `stack dot`+dotOptsParser :: Parser DotOpts+dotOptsParser = DotOpts+ <$> includeExternal+ <*> includeBase+ <*> depthLimit+ <*> fmap (maybe Set.empty Set.fromList . fmap splitNames) prunedPkgs+ where includeExternal = boolFlags False+ "external"+ "inclusion of external dependencies"+ idm+ includeBase = boolFlags True+ "include-base"+ "inclusion of dependencies on base"+ idm+ depthLimit =+ optional (option auto+ (long "depth" <>+ metavar "DEPTH" <>+ help ("Limit the depth of dependency resolution " <>+ "(Default: No limit)")))+ prunedPkgs = optional (strOption+ (long "prune" <>+ metavar "PACKAGES" <>+ help ("Prune each package name " <>+ "from the comma separated list " <>+ "of package names PACKAGES")))++ splitNames :: String -> [String]+ splitNames = map (takeWhile (not . isSpace) . dropWhile isSpace) . splitOn ","++ghciOptsParser :: Parser GhciOpts+ghciOptsParser = GhciOpts+ <$> fmap (map T.pack)+ (many (strArgument+ (metavar "TARGET" <>+ help ("If none specified, " <>+ "use all packages defined in current directory"))))+ <*> fmap concat (many (argsOption (long "ghc-options" <>+ metavar "OPTION" <>+ help "Additional options passed to GHCi")))+ <*> strOption (long "with-ghc" <>+ metavar "GHC" <>+ help "Use this command for the GHC to run" <>+ value "ghc" <>+ showDefault)+ <*> flag False True (long "no-load" <>+ help "Don't load modules on start-up")+ <*> packagesParser+++-- | Parser for exec command+execOptsParser :: Maybe String -- ^ command+ -> Parser ExecOpts+execOptsParser mcmd =+ ExecOpts+ <$> maybe eoCmdParser pure mcmd+ <*> eoArgsParser+ <*> (eoPlainParser <|>+ ExecOptsEmbellished+ <$> eoEnvSettingsParser+ <*> eoPackagesParser)+ where+ eoCmdParser :: Parser String+ eoCmdParser = strArgument (metavar "CMD")++ eoArgsParser :: Parser [String]+ eoArgsParser = many (strArgument (metavar "-- ARGS (e.g. stack ghc -- X.hs -o x)"))++ eoEnvSettingsParser :: Parser EnvSettings+ eoEnvSettingsParser = EnvSettings+ <$> pure True+ <*> boolFlags True+ "ghc-package-path"+ "setting the GHC_PACKAGE_PATH variable for the subprocess"+ idm+ <*> boolFlags True+ "stack-exe"+ "setting the STACK_EXE environment variable to the path for the stack executable"+ idm++ eoPackagesParser :: Parser [String]+ eoPackagesParser = many (strOption (long "package" <> help "Additional packages that must be installed"))++ eoPlainParser :: Parser ExecOptsExtra+ eoPlainParser = flag' ExecOptsPlain+ (long "plain" <>+ help "Use an unmodified environment (only useful with Docker)")+++-- | Parser for global command-line options.+globalOptsParser :: Bool -> Parser GlobalOpts+globalOptsParser defaultTerminal =+ GlobalOpts <$>+ switch (long Docker.reExecArgName <>+ hidden <>+ internal) <*>+ logLevelOptsParser <*>+ configOptsParser False <*>+ optional abstractResolverOptsParser <*>+ flag+ defaultTerminal+ False+ (long "no-terminal" <>+ help+ "Override terminal detection in the case of running in a false terminal") <*>+ (optional (strOption+ (long "stack-yaml" <>+ metavar "STACK-YAML" <>+ help "Override project stack.yaml file (overrides any STACK_YAML environment variable)")))++initOptsParser :: Parser InitOpts+initOptsParser =+ InitOpts <$> method <*> overwrite <*> fmap not ignoreSubDirs+ where+ ignoreSubDirs = flag False+ True+ (long "ignore-subdirs" <>+ help "Do not search for .cabal files in sub directories")+ overwrite = flag False+ True+ (long "force" <>+ help "Force overwriting of an existing stack.yaml if it exists")+ method = solver+ <|> (MethodResolver <$> resolver)+ <|> (MethodSnapshot <$> snapPref)++ solver =+ flag' MethodSolver+ (long "solver" <>+ help "Use a dependency solver to determine dependencies")++ snapPref =+ flag' PrefLTS+ (long "prefer-lts" <>+ help "Prefer LTS snapshots over Nightly snapshots") <|>+ flag' PrefNightly+ (long "prefer-nightly" <>+ help "Prefer Nightly snapshots over LTS snapshots") <|>+ pure PrefNone++ resolver = option readAbstractResolver+ (long "resolver" <>+ metavar "RESOLVER" <>+ help "Use the given resolver, even if not all dependencies are met")++-- | Parse for a logging level.+logLevelOptsParser :: Parser LogLevel+logLevelOptsParser =+ fmap parse+ (strOption (long "verbosity" <>+ metavar "VERBOSITY" <>+ help "Verbosity: silent, error, warn, info, debug")) <|>+ flag defaultLogLevel+ verboseLevel+ (short 'v' <> long "verbose" <>+ help ("Enable verbose mode: verbosity level \"" <> showLevel verboseLevel <> "\""))+ where verboseLevel = LevelDebug+ showLevel l =+ case l of+ LevelDebug -> "debug"+ LevelInfo -> "info"+ LevelWarn -> "warn"+ LevelError -> "error"+ LevelOther x -> T.unpack x+ parse s =+ case s of+ "debug" -> LevelDebug+ "info" -> LevelInfo+ "warn" -> LevelWarn+ "error" -> LevelError+ _ -> LevelOther (T.pack s)++-- | Parser for the resolver+abstractResolverOptsParser :: Parser AbstractResolver+abstractResolverOptsParser =+ option readAbstractResolver+ (long "resolver" <>+ metavar "RESOLVER" <>+ help "Override resolver in project file")++readAbstractResolver :: ReadM AbstractResolver+readAbstractResolver = do+ s <- readerAsk+ case s of+ "global" -> return ARGlobal+ "nightly" -> return ARLatestNightly+ "lts" -> return ARLatestLTS+ 'l':'t':'s':'-':x | Right (x', "") <- decimal $ T.pack x ->+ return $ ARLatestLTSMajor x'+ _ ->+ case parseResolverText $ T.pack s of+ Left e -> readerError $ show e+ Right x -> return $ ARResolver x++-- | Parser for @solverCmd@+solverOptsParser :: Parser Bool+solverOptsParser = boolFlags False+ "modify-stack-yaml"+ "Automatically modify stack.yaml with the solver's recommendations"+ idm++-- | Parser for test arguments.+testOptsParser :: Parser TestOpts+testOptsParser = TestOpts+ <$> boolFlags True+ "rerun-tests"+ "running already successful tests"+ idm+ <*> fmap (fromMaybe [])+ (optional (argsOption(long "test-arguments" <>+ metavar "TEST_ARGS" <>+ help "Arguments passed in to the test suite program")))+ <*> flag False+ True+ (long "coverage" <>+ help "Generate a code coverage report")+ <*> flag False+ True+ (long "no-run-tests" <>+ help "Disable running of tests. (Tests will still be built.)")++-- | Parser for @stack new@.+newOptsParser :: Parser (NewOpts,InitOpts)+newOptsParser = (,) <$> newOpts <*> initOptsParser+ where+ newOpts =+ NewOpts <$>+ packageNameArgument+ (metavar "PACKAGE_NAME" <> help "A valid package name.") <*>+ templateNameArgument+ (metavar "TEMPLATE_NAME" <>+ help "Name of a template, for example: foo or foo.hsfiles" <>+ value defaultTemplateName) <*+ abortOption ShowHelpText (long "help" <> help "Show help text.")
src/Stack/Package.hs view
@@ -29,21 +29,22 @@ ,packageToolDependencies ,packageDependencies ,packageIdentifier- ,CabalFileType(..) ,autogenDir) where +import Control.Arrow ((***)) import Control.Exception hiding (try,catch) import Control.Monad import Control.Monad.Catch import Control.Monad.IO.Class import Control.Monad.Logger (MonadLogger,logWarn) import Control.Monad.Reader-import qualified Data.ByteString as S-import Data.Data+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as C8 import Data.Either import Data.Function import Data.List+import Data.List.Extra (nubOrd) import Data.Map.Strict (Map) import qualified Data.Map.Strict as M import Data.Maybe@@ -53,10 +54,9 @@ import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T-import Data.Text.Encoding (decodeUtf8With)+import Data.Text.Encoding (decodeUtf8, decodeUtf8With) import Data.Text.Encoding.Error (lenientDecode) import Distribution.Compiler-import Distribution.InstalledPackageInfo (PError) import Distribution.ModuleName (ModuleName) import qualified Distribution.ModuleName as Cabal import Distribution.Package hiding (Package,PackageName,packageName,packageVersion,PackageIdentifier)@@ -64,133 +64,38 @@ import Distribution.PackageDescription.Parse import Distribution.Simple.Utils import Distribution.System (OS (..), Arch, Platform (..))-import Distribution.Text (display)-import Distribution.Version (intersectVersionRanges)+import Distribution.Text (display, simpleParse) import Path as FL import Path.Find import Path.IO import Prelude hiding (FilePath)+import Safe (headDef, tailSafe) import Stack.Constants import Stack.Types import qualified Stack.Types.PackageIdentifier-import System.Directory (getDirectoryContents)+import System.Directory (doesFileExist, getDirectoryContents) import System.FilePath (splitExtensions) import qualified System.FilePath as FilePath import System.IO.Error --- | All exceptions thrown by the library.-data PackageException- = PackageInvalidCabalFile (Maybe (Path Abs File)) PError- | PackageNoCabalFileFound (Path Abs Dir)- | PackageMultipleCabalFilesFound (Path Abs Dir) [Path Abs File]- | MismatchedCabalName (Path Abs File) PackageName- deriving Typeable-instance Exception PackageException-instance Show PackageException where- show (PackageInvalidCabalFile mfile err) =- "Unable to parse cabal file" ++- (case mfile of- Nothing -> ""- Just file -> ' ' : toFilePath file) ++- ": " ++- show err- show (PackageNoCabalFileFound dir) =- "No .cabal file found in directory " ++- toFilePath dir- show (PackageMultipleCabalFilesFound dir files) =- "Multiple .cabal files found in directory " ++- toFilePath dir ++- ": " ++- intercalate ", " (map (toFilePath . filename) files)- show (MismatchedCabalName fp name) = concat- [ "cabal file "- , toFilePath fp- , " has a mismatched package name: "- , packageNameString name- ]---- | Some package info.-data Package =- Package {packageName :: !PackageName -- ^ Name of the package.- ,packageVersion :: !Version -- ^ Version of the package- ,packageFiles :: !GetPackageFiles- ,packageDeps :: !(Map PackageName VersionRange) -- ^ Packages that the package depends on.- ,packageTools :: ![Dependency] -- ^ A build tool name.- ,packageAllDeps :: !(Set PackageName) -- ^ Original dependencies (not sieved).- ,packageFlags :: !(Map FlagName Bool) -- ^ Flags used on package.- ,packageHasLibrary :: !Bool -- ^ does the package have a buildable library stanza?- ,packageTests :: !(Set Text) -- ^ names of test suites- ,packageBenchmarks :: !(Set Text) -- ^ names of benchmarks- ,packageExes :: !(Set Text) -- ^ names of executables- ,packageOpts :: !GetPackageOpts -- ^ Args to pass to GHC.- ,packageHasExposedModules :: !Bool -- ^ Does the package have exposed modules?- ,packageSimpleType :: !Bool -- ^ Does the package of build-type: Simple- }- deriving (Show,Typeable)---- | Files that the package depends on, relative to package directory.--- Argument is the location of the .cabal file-newtype GetPackageOpts = GetPackageOpts- { getPackageOpts :: forall env m. (MonadIO m,HasEnvConfig env, HasPlatform env, MonadThrow m, MonadReader env m)- => Path Abs File- -> m [String]- }-instance Show GetPackageOpts where- show _ = "<GetPackageOpts>"---- | Files that the package depends on, relative to package directory.--- Argument is the location of the .cabal file-newtype GetPackageFiles = GetPackageFiles- { getPackageFiles :: forall m. (MonadIO m, MonadLogger m, MonadThrow m, MonadCatch m)- => CabalFileType- -> Path Abs File- -> m (Set (Path Abs File))- }-instance Show GetPackageFiles where- show _ = "<GetPackageFiles>"---- | Get the identifier of the package. packageIdentifier :: Package -> Stack.Types.PackageIdentifier.PackageIdentifier packageIdentifier pkg = Stack.Types.PackageIdentifier.PackageIdentifier (packageName pkg) (packageVersion pkg) --- | Package build configuration-data PackageConfig =- PackageConfig {packageConfigEnableTests :: !Bool -- ^ Are tests enabled?- ,packageConfigEnableBenchmarks :: !Bool -- ^ Are benchmarks enabled?- ,packageConfigFlags :: !(Map FlagName Bool) -- ^ Package config flags.- ,packageConfigGhcVersion :: !Version -- ^ GHC version- ,packageConfigPlatform :: !Platform -- ^ host platform- }- deriving (Show,Typeable)---- | Files to get for a cabal package.-data CabalFileType- = AllFiles- | Modules---- | Compares the package name.-instance Ord Package where- compare = on compare packageName---- | Compares the package name.-instance Eq Package where- (==) = on (==) packageName- -- | Read the raw, unresolved package information. readPackageUnresolved :: (MonadIO m, MonadThrow m) => Path Abs File -> m GenericPackageDescription readPackageUnresolved cabalfp =- liftIO (S.readFile (FL.toFilePath cabalfp))+ liftIO (BS.readFile (FL.toFilePath cabalfp)) >>= readPackageUnresolvedBS (Just cabalfp) -- | Read the raw, unresolved package information from a ByteString. readPackageUnresolvedBS :: (MonadThrow m) => Maybe (Path Abs File)- -> S.ByteString+ -> BS.ByteString -> m GenericPackageDescription readPackageUnresolvedBS mcabalfp bs = case parsePackageDescription chars of@@ -214,7 +119,7 @@ -- | Reads and exposes the package information, from a ByteString readPackageBS :: (MonadThrow m) => PackageConfig- -> S.ByteString+ -> BS.ByteString -> m Package readPackageBS packageConfig bs = resolvePackage packageConfig `liftM` readPackageUnresolvedBS Nothing bs@@ -241,12 +146,17 @@ { packageName = name , packageVersion = fromCabalVersion (pkgVersion pkgId) , packageDeps = deps- , packageFiles = GetPackageFiles $ \ty cabalfp -> do- files <- runReaderT (packageDescFiles ty pkg) cabalfp- return $ S.fromList $- case ty of- Modules -> files- AllFiles -> cabalfp : files+ , packageFiles = GetPackageFiles $ \cabalfp -> do+ distDir <- distDirFromDir (parent cabalfp)+ (_,files) <- runReaderT (packageDescModulesAndFiles pkg)+ (cabalfp, buildDir distDir)+ return $ S.insert cabalfp files++ , packageModules = GetPackageModules $ \cabalfp -> do+ distDir <- distDirFromDir (parent cabalfp)+ (modules,_) <- runReaderT (packageDescModulesAndFiles pkg)+ (cabalfp, buildDir distDir)+ return modules , packageTools = packageDescTools pkg , packageFlags = packageConfigFlags packageConfig , packageAllDeps = S.fromList (M.keys deps)@@ -254,10 +164,11 @@ , packageTests = S.fromList $ [ T.pack (testName t) | t <- testSuites pkg, buildable (testBuildInfo t)] , packageBenchmarks = S.fromList $ [ T.pack (benchmarkName b) | b <- benchmarks pkg, buildable (benchmarkBuildInfo b)] , packageExes = S.fromList $ [ T.pack (exeName b) | b <- executables pkg, buildable (buildInfo b)]- , packageOpts = GetPackageOpts $ \cabalfp ->- generatePkgDescOpts cabalfp pkg+ , packageOpts = GetPackageOpts $ \sourceMap locals cabalfp ->+ generatePkgDescOpts sourceMap locals cabalfp pkg , packageHasExposedModules = maybe False (not . null . exposedModules) (library pkg) , packageSimpleType = buildType (packageDescription gpkg) == Just Simple+ , packageDefinedFlags = S.fromList $ map (fromCabalFlagName . flagName) $ genPackageFlags gpkg } where@@ -267,9 +178,14 @@ deps = M.filterWithKey (const . (/= name)) (packageDependencies pkg) -- | Generate GHC options for the package.-generatePkgDescOpts :: (HasEnvConfig env, HasPlatform env, MonadThrow m, MonadReader env m, MonadIO m)- => Path Abs File -> PackageDescription -> m [String]-generatePkgDescOpts cabalfp pkg = do+generatePkgDescOpts+ :: (HasEnvConfig env, HasPlatform env, MonadThrow m, MonadReader env m, MonadIO m)+ => SourceMap+ -> [PackageName]+ -> Path Abs File+ -> PackageDescription+ -> m [String]+generatePkgDescOpts sourceMap locals cabalfp pkg = do distDir <- distDirFromDir cabalDir let cabalmacros = autogenDir distDir </> $(mkRelFile "cabal_macros.h") exists <- fileExists cabalmacros@@ -278,11 +194,11 @@ then Just cabalmacros else Nothing return- (nub+ (nubOrd (["-hide-all-packages"] ++ concatMap (concatMap- (generateBuildInfoOpts mcabalmacros cabalDir distDir))+ (generateBuildInfoOpts sourceMap mcabalmacros cabalDir distDir locals)) [ maybe [] (return . libBuildInfo) (library pkg) , map buildInfo (executables pkg) , map benchmarkBuildInfo (benchmarks pkg)@@ -291,14 +207,28 @@ cabalDir = parent cabalfp -- | Generate GHC options for the target.-generateBuildInfoOpts :: Maybe (Path Abs File) -> Path Abs Dir -> Path Abs Dir -> BuildInfo -> [String]-generateBuildInfoOpts mcabalmacros cabalDir distDir b =- nub (concat [ghcOpts b, extOpts b, srcOpts, includeOpts b, macros, deps])+generateBuildInfoOpts+ :: SourceMap+ -> Maybe (Path Abs File)+ -> Path Abs Dir+ -> Path Abs Dir+ -> [PackageName]+ -> BuildInfo+ -> [String]+generateBuildInfoOpts sourceMap mcabalmacros cabalDir distDir locals b =+ nubOrd (concat [ghcOpts b, extOpts b, srcOpts, includeOpts, macros, deps, extra b, extraDirs, fworks b]) where deps = concat- [ ["-package=" <> display name]- | Dependency name _ <- targetBuildDepends b]+ [ ["-package=" <> display name <>+ maybe "" -- This empty case applies to e.g. base.+ ((("-" <>) . versionString) . sourceVersion)+ (M.lookup (fromCabalPackageName name) sourceMap)]+ | Dependency name _ <- targetBuildDepends b+ , not (elem name (map toCabalPackageName locals))]+ -- Generates: -package=base -package=base16-bytestring-0.1.1.6 ...+ sourceVersion (PSUpstream ver _ _) = ver+ sourceVersion (PSLocal localPkg) = packageVersion (lpPackage localPkg) macros = case mcabalmacros of Nothing -> []@@ -308,22 +238,48 @@ where isGhc GHC = True isGhc _ = False- extOpts = map (("-X" ++) . display) . allExtensions+ extOpts = map (("-X" ++) . display) . usedExtensions srcOpts = map (("-i" <>) . toFilePath) (cabalDir : map (cabalDir </>) (mapMaybe parseRelDir (hsSourceDirs b)) <>- [autogenDir distDir])- includeOpts- = map (("-I" <>) . toFilePath . (cabalDir </>))- . mapMaybe parseRelDir- . includeDirs+ [autogenDir distDir,buildDir distDir]) +++ ["-stubdir=" ++ toFilePath (buildDir distDir)]+ includeOpts =+ [ "-I" <> toFilePath absDir+ | dir <- includeDirs b+ , absDir <- case (parseAbsDir dir, parseRelDir dir) of+ (Just ab, _ ) -> [ab]+ (_ , Just rel) -> [cabalDir </> rel]+ (Nothing, Nothing ) -> []+ ]+ extra+ = map ("-l" <>)+ . extraLibs+ extraDirs =+ [ "-L" <> toFilePath absDir+ | dir <- extraLibDirs b+ , absDir <- case (parseAbsDir dir, parseRelDir dir) of+ (Just ab, _ ) -> [ab]+ (_ , Just rel) -> [cabalDir </> rel]+ (Nothing, Nothing ) -> []+ ]+ fworks = map (\fwk -> "-framework=" <> fwk) . frameworks -- | Make the autogen dir. autogenDir :: Path Abs Dir -> Path Abs Dir-autogenDir distDir = distDir </> $(mkRelDir "build/autogen")+autogenDir distDir = buildDir distDir </> $(mkRelDir "autogen") +-- | Make the build dir.+buildDir :: Path Abs Dir -> Path Abs Dir+buildDir distDir = distDir </> $(mkRelDir "build")++-- | Make the component-specific subdirectory of the build directory.+getBuildComponentDir :: Maybe String -> Maybe (Path Rel Dir)+getBuildComponentDir Nothing = Nothing+getBuildComponentDir (Just name) = parseRelDir (name FilePath.</> (name ++ "-tmp"))+ -- | Get all dependencies of the package (buildable targets only). packageDependencies :: PackageDescription -> Map PackageName VersionRange packageDependencies =@@ -333,7 +289,7 @@ allBuildInfo' -- | Get all build tool dependencies of the package (buildable targets only).-packageToolDependencies :: PackageDescription -> Map S.ByteString VersionRange+packageToolDependencies :: PackageDescription -> Map BS.ByteString VersionRange packageToolDependencies = M.fromList . concatMap (map (\dep -> ((packageNameByteString $ depName dep),depRange dep)) .@@ -364,41 +320,42 @@ , benchmarkEnabled tst ] -- | Get all files referenced by the package.-packageDescFiles- :: (MonadLogger m, MonadIO m, MonadThrow m, MonadReader (Path Abs File) m, MonadCatch m)- => CabalFileType -> PackageDescription -> m [Path Abs File]-packageDescFiles ty pkg = do+packageDescModulesAndFiles+ :: (MonadLogger m, MonadIO m, MonadThrow m, MonadReader (Path Abs File, Path Abs Dir) m, MonadCatch m)+ => PackageDescription -> m (Set ModuleName,Set (Path Abs File))+packageDescModulesAndFiles pkg = do libfiles <-- liftM concat (mapM (libraryFiles ty) (maybe [] return (library pkg)))- exefiles <- liftM concat (mapM (executableFiles ty) (executables pkg))- benchfiles <- liftM concat (mapM (benchmarkFiles ty) (benchmarks pkg))- testfiles <- liftM concat (mapM (testFiles ty) (testSuites pkg))- dfiles <- resolveGlobFiles (map (dataDir pkg FilePath.</>) (dataFiles pkg))- srcfiles <- resolveGlobFiles (extraSrcFiles pkg)+ liftM concat2 (mapM libraryFiles (maybe [] return (library pkg)))+ exefiles <- liftM concat2 (mapM executableFiles (executables pkg))+ benchfiles <- liftM concat2 (mapM benchmarkFiles (benchmarks pkg))+ testfiles <- liftM concat2 (mapM testFiles (testSuites pkg))+ dfiles <-+ liftM+ (mempty, )+ (resolveGlobFiles (map (dataDir pkg FilePath.</>) (dataFiles pkg)))+ srcfiles <- liftM (mempty, ) (resolveGlobFiles (extraSrcFiles pkg)) -- extraTmpFiles purposely not included here, as those are files generated -- by the build script. Another possible implementation: include them, but -- don't error out if not present- docfiles <- resolveGlobFiles (extraDocFiles pkg)- case ty of- Modules ->- return (nub (concat [libfiles, exefiles, testfiles, benchfiles]))- AllFiles ->- return- (nub- (concat- [ libfiles- , exefiles- , dfiles- , srcfiles- , docfiles- , benchfiles- , testfiles]))+ docfiles <- liftM (mempty, ) (resolveGlobFiles (extraDocFiles pkg))+ return+ (concat2+ [ libfiles+ , exefiles+ , dfiles+ , srcfiles+ , docfiles+ , benchfiles+ , testfiles])+ where+ concat2 :: (Ord a,Ord b) => [(Set a, Set b)] -> (Set a, Set b)+ concat2 = (mconcat *** mconcat) . unzip -- | Resolve globbing of files (e.g. data files) to absolute paths.-resolveGlobFiles :: (MonadLogger m,MonadIO m,MonadThrow m,MonadReader (Path Abs File) m,MonadCatch m)- => [String] -> m [Path Abs File]+resolveGlobFiles :: (MonadLogger m,MonadIO m,MonadThrow m,MonadReader (Path Abs File, Path Abs Dir) m,MonadCatch m)+ => [String] -> m (Set (Path Abs File)) resolveGlobFiles =- liftM (catMaybes . concat) .+ liftM (S.fromList . catMaybes . concat) . mapM resolve where resolve name =@@ -406,7 +363,7 @@ then explode name else liftM return (resolveFileOrWarn name) explode name = do- dir <- asks parent+ dir <- asks (parent . fst) names <- matchDirFileGlob' (FL.toFilePath dir)@@ -457,98 +414,102 @@ matches -> return matches -- | Get all files referenced by the benchmark.-benchmarkFiles :: (MonadLogger m, MonadIO m, MonadThrow m, MonadReader (Path Abs File) m)- => CabalFileType -> Benchmark -> m [Path Abs File]-benchmarkFiles ty bench = do+benchmarkFiles :: (MonadLogger m, MonadIO m, MonadThrow m, MonadReader (Path Abs File, Path Abs Dir) m)+ => Benchmark -> m (Set ModuleName,Set (Path Abs File))+benchmarkFiles bench = do dirs <- mapMaybeM resolveDirOrWarn (hsSourceDirs build)- dir <- asks parent- exposed <-- resolveFiles- (dirs ++ [dir])- (case benchmarkInterface bench of- BenchmarkExeV10 _ fp ->- [Right fp]- BenchmarkUnsupported _ ->- [])- haskellFileExts- bfiles <- buildFiles ty dir build- case ty of- AllFiles -> return (concat [bfiles,exposed])- Modules -> return (concat [bfiles])+ dir <- asks (parent . fst)+ (rmodules,rfiles) <- resolveFilesAndDeps+ (Just $ benchmarkName bench)+ (dirs ++ [dir])+ names+ haskellModuleExts+ cfiles <- buildCSources build+ return (rmodules,rfiles <> cfiles) where+ names =+ concat [bnames,exposed]+ exposed =+ case benchmarkInterface bench of+ BenchmarkExeV10 _ fp ->+ [Right fp]+ BenchmarkUnsupported _ ->+ []+ bnames = map Left (otherModules build) build = benchmarkBuildInfo bench -- | Get all files referenced by the test.-testFiles :: (MonadLogger m, MonadIO m, MonadThrow m, MonadReader (Path Abs File) m)- => CabalFileType -> TestSuite -> m [Path Abs File]-testFiles ty test = do+testFiles :: (MonadLogger m, MonadIO m, MonadThrow m, MonadReader (Path Abs File, Path Abs Dir) m)+ => TestSuite -> m (Set ModuleName,Set (Path Abs File))+testFiles test = do dirs <- mapMaybeM resolveDirOrWarn (hsSourceDirs build)- dir <- asks parent- exposed <-- resolveFiles- (dirs ++ [dir])- (case testInterface test of- TestSuiteExeV10 _ fp ->- [Right fp]- TestSuiteLibV09 _ mn ->- [Left mn]- TestSuiteUnsupported _ ->- [])- haskellFileExts- bfiles <- buildFiles ty dir build- case ty of- AllFiles -> return (concat [bfiles,exposed])- Modules -> return (concat [bfiles])+ dir <- asks (parent . fst)+ (modules,rfiles) <- resolveFilesAndDeps+ (Just $ testName test)+ (dirs ++ [dir])+ names+ haskellModuleExts+ cfiles <- buildCSources build+ return (modules,rfiles <> cfiles) where+ names =+ concat [bnames,exposed]+ exposed =+ case testInterface test of+ TestSuiteExeV10 _ fp ->+ [Right fp]+ TestSuiteLibV09 _ mn ->+ [Left mn]+ TestSuiteUnsupported _ ->+ []+ bnames = map Left (otherModules build) build = testBuildInfo test -- | Get all files referenced by the executable.-executableFiles :: (MonadLogger m,MonadIO m,MonadThrow m,MonadReader (Path Abs File) m)- => CabalFileType -> Executable -> m [Path Abs File]-executableFiles ty exe =+executableFiles :: (MonadLogger m,MonadIO m,MonadThrow m,MonadReader (Path Abs File, Path Abs Dir) m)+ => Executable -> m (Set ModuleName,Set (Path Abs File))+executableFiles exe = do dirs <- mapMaybeM resolveDirOrWarn (hsSourceDirs build)- dir <- asks parent- exposed <-- resolveFiles+ dir <- asks (parent . fst)+ (modules,rfiles) <- resolveFilesAndDeps+ (Just $ exeName exe) (dirs ++ [dir])- [Right (modulePath exe)]- haskellFileExts- bfiles <- buildFiles ty dir build- case ty of- AllFiles -> return (concat [bfiles,exposed])- Modules -> return (concat [bfiles])- where build = buildInfo exe+ names+ haskellModuleExts+ cfiles <- buildCSources build+ return (modules,rfiles <> cfiles)+ where+ names =+ concat [bnames,exposed]+ bnames = map Left (otherModules build)+ exposed = [Right (modulePath exe)]+ build = buildInfo exe -- | Get all files referenced by the library.-libraryFiles :: (MonadLogger m,MonadIO m,MonadThrow m,MonadReader (Path Abs File) m)- => CabalFileType -> Library -> m [Path Abs File]-libraryFiles ty lib =+libraryFiles :: (MonadLogger m,MonadIO m,MonadThrow m,MonadReader (Path Abs File, Path Abs Dir) m)+ => Library -> m (Set ModuleName,Set (Path Abs File))+libraryFiles lib = do dirs <- mapMaybeM resolveDirOrWarn (hsSourceDirs build)- dir <- asks parent- exposed <- resolveFiles- (dirs ++ [dir])- (map Left (exposedModules lib))- haskellFileExts- bfiles <- buildFiles ty dir build- case ty of- AllFiles -> return (concat [bfiles,exposed])- Modules -> return (concat [bfiles,exposed])- where build = libBuildInfo lib+ dir <- asks (parent . fst)+ (modules,rfiles) <- resolveFilesAndDeps+ Nothing+ (dirs ++ [dir])+ names+ haskellModuleExts+ cfiles <- buildCSources build+ return (modules,rfiles <> cfiles)+ where+ names =+ concat [bnames,exposed]+ exposed = map Left (exposedModules lib)+ bnames = map Left (otherModules build)+ build = libBuildInfo lib --- | Get all files in a build.-buildFiles :: (MonadLogger m,MonadIO m,MonadThrow m,MonadReader (Path Abs File) m)- => CabalFileType -> Path Abs Dir -> BuildInfo -> m [Path Abs File]-buildFiles ty dir build = do- dirs <- mapMaybeM resolveDirOrWarn (hsSourceDirs build)- other <-- resolveFiles- (dirs ++ [dir])- (map Left (otherModules build))- haskellFileExts- cSources' <- mapMaybeM resolveFileOrWarn (cSources build)- case ty of- Modules -> return other- AllFiles -> return (other ++ cSources')+-- | Get all C sources in a build.+buildCSources :: (MonadLogger m,MonadIO m,MonadThrow m,MonadReader (Path Abs File, Path Abs Dir) m)+ => BuildInfo -> m (Set (Path Abs File))+buildCSources build =+ liftM S.fromList (mapMaybeM resolveFileOrWarn (cSources build)) -- | Get all dependencies of a package, including library, -- executables, tests, benchmarks.@@ -668,30 +629,203 @@ -- | Try to resolve the list of base names in the given directory by -- looking for unique instances of base names applied with the given+-- extensions, plus find any of their module and TemplateHaskell+-- dependencies.+resolveFilesAndDeps+ :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader (Path Abs File, Path Abs Dir) m)+ => Maybe (String) -- ^ Package component name+ -> [Path Abs Dir] -- ^ Directories to look in.+ -> [Either ModuleName String] -- ^ Base names.+ -> [Text] -- ^ Extentions.+ -> m (Set ModuleName,Set (Path Abs File))+resolveFilesAndDeps component dirs names0 exts = do+ (moduleFiles,thFiles,foundModules) <- loop names0 S.empty+ cabalfp <- asks fst+ let unlistedModules =+ foundModules `S.difference` (S.fromList (lefts names0))+ unless (S.null unlistedModules) $+ $(logWarn) $+ T.pack $+ "Warning: " +++ (if S.size unlistedModules == 1+ then "module"+ else "modules") +++ " not listed in " +++ toFilePath (filename cabalfp) +++ (case component of+ Nothing -> " for library"+ Just c -> " for '" ++ c ++ "'") +++ " component (add to other-modules):\n " +++ intercalate "\n " (map display (S.toList unlistedModules))+ return (foundModules,moduleFiles <> S.fromList thFiles)+ where+ loop [] doneModules = return (S.empty, [], doneModules)+ loop names doneModules0 = do+ resolvedFiles <- resolveFiles dirs names exts+ pairs <- mapM getDependencies resolvedFiles+ let doneModules' = S.union doneModules0 (S.fromList (lefts names))+ moduleDeps = S.unions (map fst pairs)+ thDepFiles = concatMap snd pairs+ modulesRemaining = S.difference moduleDeps doneModules'+ (moduleDepFiles',thDepFiles',doneModules'') <-+ loop (map Left (S.toList modulesRemaining)) doneModules'+ return+ ( S.union (S.fromList resolvedFiles) moduleDepFiles'+ , thDepFiles ++ thDepFiles'+ , doneModules'')+ getDependencies resolvedFile = do+ dir <- asks (parent . fst)+ dumpHIDir <- getDumpHIDir+ case stripDir dir resolvedFile of+ Nothing -> return (S.empty, [])+ Just fileRel -> do+ let dumpHIPath =+ FilePath.replaceExtension+ (toFilePath (dumpHIDir </> fileRel))+ ".dump-hi"+ dumpHIExists <- liftIO $ doesFileExist dumpHIPath+ if dumpHIExists+ then parseDumpHI dumpHIPath+ else return (S.empty, [])+ parseDumpHI dumpHIPath = do+ dir <- asks (parent . fst)+ dumpHI <- liftIO $ fmap C8.lines (C8.readFile dumpHIPath)+ let startModuleDeps =+ dropWhile+ (not . ("module dependencies:" `C8.isPrefixOf`))+ dumpHI+ moduleDeps =+ S.fromList $+ mapMaybe (simpleParse . T.unpack . decodeUtf8) $+ C8.words $+ C8.concat $+ C8.dropWhile (/= ' ') (headDef "" startModuleDeps) :+ takeWhile (" " `C8.isPrefixOf`) (tailSafe startModuleDeps)+ thDeps =+ -- The dependent file path is surrounded by quotes but is not escaped.+ -- It can be an absolute or relative path.+ mapMaybe+ (parseAbsOrRelFile dir <=<+ (fmap T.unpack .+ (T.stripSuffix "\"" <=< T.stripPrefix "\"") .+ T.dropWhileEnd (== '\r') .+ decodeUtf8 . C8.dropWhile (/= '"'))) $+ filter ("addDependentFile \"" `C8.isPrefixOf`) dumpHI+ return+ (moduleDeps, thDeps)+ getDumpHIDir = do+ bld <- asks snd+ return $ maybe bld (bld </>) (getBuildComponentDir component)+ parseAbsOrRelFile dir fp =+ case parseRelFile fp of+ Just rel -> Just (dir </> rel)+ Nothing -> parseAbsFile fp++-- | Try to resolve the list of base names in the given directory by+-- looking for unique instances of base names applied with the given -- extensions.-resolveFiles :: MonadIO m- => [Path Abs Dir] -- ^ Directories to look in.- -> [Either ModuleName String] -- ^ Base names.- -> [Text] -- ^ Extentions.- -> m [Path Abs File]-resolveFiles dirs names exts =- liftM catMaybes (forM names (liftIO . makeNameCandidates))- where makeNameCandidates name =- fmap (listToMaybe . rights . concat)- (mapM (makeDirCandidates name) dirs)- makeDirCandidates :: Either ModuleName String- -> Path Abs Dir- -> IO [Either ResolveException (Path Abs File)]- makeDirCandidates name dir =- mapM (\ext ->- try (case name of- Left mn ->- resolveFile dir- (Cabal.toFilePath mn ++ "." ++ ext)- Right fp ->- resolveFile dir fp))- (map T.unpack exts)+resolveFiles+ :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader (Path Abs File, Path Abs Dir) m)+ => [Path Abs Dir] -- ^ Directories to look in.+ -> [Either ModuleName String] -- ^ Base names.+ -> [Text] -- ^ Extentions.+ -> m [Path Abs File]+resolveFiles dirs names exts = do+ liftM catMaybes (forM names (findCandidate dirs exts)) +-- | Find a candidate for the given module-or-filename from the list+-- of directories and given extensions.+findCandidate+ :: (MonadIO m, MonadLogger m, MonadThrow m, MonadReader (Path Abs File, Path Abs Dir) m)+ => [Path Abs Dir]+ -> [Text]+ -> Either ModuleName String+ -> m (Maybe (Path Abs File))+findCandidate dirs exts name = do+ pkg <- asks fst >>= parsePackageNameFromFilePath+ candidates <- liftIO makeNameCandidates+ case candidates of+ [candidate] -> return (Just candidate)+ [] -> do+ case name of+ Left mn+ | not (display mn == paths_pkg pkg) -> do+ logPossibilities dirs mn+ _ -> return ()+ return Nothing+ (candidate:rest) -> do+ warnMultiple name candidate rest+ return (Just candidate)+ where+ paths_pkg pkg = "Paths_" ++ packageNameString pkg+ makeNameCandidates =+ liftM (nubOrd . rights . concat) (mapM makeDirCandidates dirs)+ makeDirCandidates+ :: Path Abs Dir+ -> IO [Either ResolveException (Path Abs File)]+ makeDirCandidates dir =+ case name of+ Right fp -> liftM return (try (resolveFile dir fp))+ Left mn ->+ mapM+ (\ext ->+ try+ (resolveFile+ dir+ (Cabal.toFilePath mn ++ "." ++ ext)))+ (map T.unpack exts)++-- | Warn the user that multiple candidates are available for an+-- entry, but that we picked one anyway and continued.+warnMultiple+ :: MonadLogger m+ => Either ModuleName String -> Path b t -> [Path b t] -> m ()+warnMultiple name candidate rest =+ $logWarn+ ("There were multiple candidates for the Cabal entry \"" <>+ showName name <>+ "(" <>+ T.intercalate "," (map (T.pack . toFilePath) rest) <>+ "), picking " <>+ T.pack (toFilePath candidate))+ where showName (Left name') = T.pack (display name')+ showName (Right fp) = T.pack fp++-- | Log that we couldn't find a candidate, but there are+-- possibilities for custom preprocessor extensions.+--+-- For example: .erb for a Ruby file might exist in one of the+-- directories.+logPossibilities+ :: (MonadIO m, MonadThrow m, MonadLogger m)+ => [Path Abs Dir] -> ModuleName -> m ()+logPossibilities dirs mn = do+ possibilities <- liftM concat (makePossibilities mn)+ case possibilities of+ [] -> return ()+ _ ->+ $logWarn+ ("Unable to find a known candidate for the Cabal entry \"" <>+ T.pack (display mn) <>+ "\", but did find: " <>+ T.intercalate ", " (map (T.pack . toFilePath) possibilities) <>+ ". If you are using a custom preprocessor for this module \+ \with its own file extension, consider adding the file(s) \+ \to your .cabal under extra-source-files.")+ where+ makePossibilities name =+ mapM+ (\dir ->+ do (_,files) <- listDirectory dir+ return+ (map+ filename+ (filter+ (isPrefixOf (display name) .+ toFilePath . filename)+ files)))+ dirs+ -- | Get the filename for the cabal file in the given directory. -- -- If no .cabal file is present, or more than one is present, an exception is@@ -713,28 +847,25 @@ -- | Path for the package's build log. buildLogPath :: (MonadReader env m, HasBuildConfig env, MonadThrow m)- => Package -> m (Path Abs File)-buildLogPath package' = do+ => Package -> Maybe String -> m (Path Abs File)+buildLogPath package' msuffix = do env <- ask let stack = configProjectWorkDir env- fp <- parseRelFile $ concat- [ packageNameString $ packageName package'- , "-"- , versionString $ packageVersion package'- , ".log"- ]+ fp <- parseRelFile $ concat $+ (packageIdentifierString (packageIdentifier package')) :+ (maybe id (\suffix -> ("-" :) . (suffix :)) msuffix) [".log"] return $ stack </> $(mkRelDir "logs") </> fp -- Internal helper to define resolveFileOrWarn and resolveDirOrWarn-resolveOrWarn :: (MonadLogger m, MonadIO m, MonadReader (Path Abs File) m)+resolveOrWarn :: (MonadLogger m, MonadIO m, MonadReader (Path Abs File, Path Abs Dir) m) => Text -> (Path Abs Dir -> String -> m (Maybe a)) -> FilePath.FilePath -> m (Maybe a) resolveOrWarn subject resolver path = do cwd <- getWorkingDir- file <- ask- dir <- asks parent+ file <- asks fst+ dir <- asks (parent . fst) result <- resolver dir path when (isNothing result) $ $logWarn ("Warning: " <> subject <> " listed in " <>@@ -745,14 +876,14 @@ -- | Resolve the file, if it can't be resolved, warn for the user -- (purely to be helpful).-resolveFileOrWarn :: (MonadThrow m,MonadIO m,MonadLogger m,MonadReader (Path Abs File) m)+resolveFileOrWarn :: (MonadThrow m,MonadIO m,MonadLogger m,MonadReader (Path Abs File, Path Abs Dir) m) => FilePath.FilePath -> m (Maybe (Path Abs File)) resolveFileOrWarn = resolveOrWarn "File" resolveFileMaybe -- | Resolve the directory, if it can't be resolved, warn for the user -- (purely to be helpful).-resolveDirOrWarn :: (MonadThrow m,MonadIO m,MonadLogger m,MonadReader (Path Abs File) m)+resolveDirOrWarn :: (MonadThrow m,MonadIO m,MonadLogger m,MonadReader (Path Abs File, Path Abs Dir) m) => FilePath.FilePath -> m (Maybe (Path Abs Dir)) resolveDirOrWarn = resolveOrWarn "Directory" resolveDirMaybe
src/Stack/PackageDump.hs view
@@ -33,8 +33,7 @@ import Control.Monad.Trans.Control import Data.Attoparsec.Args import Data.Attoparsec.Text as P-import Data.Binary (Binary)-import Data.Binary.VersionTagged (taggedDecodeOrLoad, taggedEncodeFile, BinarySchema (..))+import Data.Binary.VersionTagged import Data.ByteString (ByteString) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8@@ -52,16 +51,17 @@ import Data.Typeable (Typeable) import GHC.Generics (Generic) import Path+import Path.IO (createTree) import Prelude -- Fix AMP warning import Stack.GhcPkg import Stack.Types-import System.Directory (createDirectoryIfMissing, getDirectoryContents, doesFileExist)+import System.Directory (getDirectoryContents, doesFileExist) import System.Process.Read -- | Cached information on whether package have profiling libraries and haddocks. newtype InstalledCache = InstalledCache (IORef InstalledCacheInner) newtype InstalledCacheInner = InstalledCacheInner (Map GhcPkgId InstalledCacheEntry)- deriving Binary+ deriving (Binary, NFData) instance BinarySchema InstalledCacheInner where -- Don't forget to update this if you change the datatype in any way! binarySchema _ = 1@@ -72,6 +72,8 @@ , installedCacheHaddock :: !Bool } deriving (Eq, Generic) instance Binary InstalledCacheEntry+instance NFData InstalledCacheEntry where+ rnf = genericRnf -- | Call ghc-pkg dump with appropriate flags and stream to the given @Sink@, for a single database ghcPkgDump@@ -106,7 +108,7 @@ -- | Save a @InstalledCache@ to disk saveInstalledCache :: MonadIO m => Path Abs File -> InstalledCache -> m () saveInstalledCache path (InstalledCache ref) = liftIO $ do- createDirectoryIfMissing True $ toFilePath $ parent path+ createTree (parent path) readIORef ref >>= taggedEncodeFile (toFilePath path) -- | Prune a list of possible packages down to those whose dependencies are met.@@ -224,7 +226,7 @@ let gid = dpGhcPkgId dp h <- case Map.lookup gid m of Just installed -> return (installedCacheHaddock installed)- Nothing | null (dpLibraries dp) -> return True+ Nothing | not (dpHasExposedModules dp) -> return True Nothing -> do let loop [] = return False loop (ifc:ifcs) = do@@ -240,6 +242,7 @@ { dpGhcPkgId :: !GhcPkgId , dpLibDirs :: ![FilePath] , dpLibraries :: ![ByteString]+ , dpHasExposedModules :: !Bool , dpDepends :: ![GhcPkgId] , dpHaddockInterfaces :: ![ByteString] , dpProfiling :: !profiling@@ -310,6 +313,7 @@ let libDirKey = "library-dirs" libDirs = parseM libDirKey libraries = parseM "hs-libraries"+ exposedModules = parseM "exposed-modules" haddockInterfaces = parseM "haddock-interfaces" depends <- mapM parseDepend $ parseM "depends" @@ -322,6 +326,7 @@ { dpGhcPkgId = ghcPkgId , dpLibDirs = libDirPaths , dpLibraries = S8.words $ S8.unwords libraries+ , dpHasExposedModules = not (null libraries || null exposedModules) , dpDepends = catMaybes (depends :: [Maybe GhcPkgId]) , dpHaddockInterfaces = S8.words $ S8.unwords haddockInterfaces , dpProfiling = ()
src/Stack/PackageIndex.hs view
@@ -27,6 +27,7 @@ import Control.Exception.Enclosed (tryIO) import Control.Monad (unless, when, liftM, mzero) import Control.Monad.Catch (MonadThrow, throwM, MonadCatch)+import qualified Control.Monad.Catch as C import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Logger (MonadLogger, logDebug, logInfo, logWarn)@@ -35,7 +36,7 @@ import Data.Aeson.Extended import qualified Data.Binary as Binary-import Data.Binary.VersionTagged (taggedDecodeOrLoad, BinarySchema (..))+import Data.Binary.VersionTagged import Data.ByteString (ByteString) import qualified Data.Word8 as Word8 import qualified Data.ByteString as S@@ -70,12 +71,11 @@ import Network.HTTP.Download import Path (mkRelDir, parent, parseRelDir, toFilePath,- (</>))+ parseAbsFile, (</>)) import Path.IO import Prelude -- Fix AMP warning import Stack.Types import Stack.Types.StackT-import System.Directory import System.FilePath (takeBaseName, (<.>)) import System.IO (IOMode (ReadMode, WriteMode), withBinaryFile)@@ -90,26 +90,35 @@ } deriving Generic instance Binary.Binary PackageCache+instance NFData PackageCache where+ rnf = genericRnf newtype PackageCacheMap = PackageCacheMap (Map PackageIdentifier PackageCache)- deriving Binary.Binary+ deriving (Binary.Binary, NFData) instance BinarySchema PackageCacheMap where -- Don't forget to update this if you change the datatype in any way! binarySchema _ = 1 -- | Populate the package index caches and return them. populateCache- :: (MonadIO m, MonadThrow m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, MonadBaseControl IO m, MonadCatch m)+ :: (MonadIO m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, MonadBaseControl IO m, MonadCatch m) => EnvOverride -> PackageIndex -> m (Map PackageIdentifier PackageCache) populateCache menv index = do- $logSticky "Populating index cache ..." requireIndex menv index -- This uses full on lazy I/O instead of ResourceT to provide some -- protections. Caveat emptor path <- configPackageIndex (indexName index)- lbs <- liftIO $ L.readFile $ Path.toFilePath path- pis <- loop 0 Map.empty (Tar.read lbs)+ let loadPIS = do+ $logSticky "Populating index cache ..."+ lbs <- liftIO $ L.readFile $ Path.toFilePath path+ loop 0 Map.empty (Tar.read lbs)+ pis <- loadPIS `C.catch` \e -> do+ $logWarn $ "Exception encountered when parsing index tarball: "+ <> T.pack (show (e :: Tar.FormatError))+ $logWarn "Automatically updating index and trying again"+ updateIndex menv index+ loadPIS when (indexRequireHashes index) $ forM_ (Map.toList pis) $ \(ident, pc) -> case pcDownload pc of@@ -246,7 +255,7 @@ updateIndexGit menv indexName' index gitUrl = do tarFile <- configPackageIndex indexName' let idxPath = parent tarFile- liftIO (createDirectoryIfMissing True (toFilePath idxPath))+ createTree idxPath do repoName <- parseRelDir $ takeBaseName $ T.unpack gitUrl let cloneArgs =@@ -262,15 +271,13 @@ sDir </> $(mkRelDir "git-update") acfDir = suDir </> repoName- repoExists <-- liftIO (doesDirectoryExist (toFilePath acfDir))+ repoExists <- dirExists acfDir unless repoExists (readInNull suDir "git" menv cloneArgs Nothing) $logSticky "Fetching package index ..." readInNull acfDir "git" menv ["fetch","--tags","--depth=1"] Nothing $logStickyDone "Fetched package index."- _ <-- (liftIO . tryIO) (removeFile (toFilePath tarFile))+ removeFileIfExists tarFile when (indexGpgVerify index) (do readInNull acfDir "git"@@ -294,7 +301,8 @@ ,tarFileTmp ,"current-hackage"] Nothing- liftIO $ renameFile tarFileTmp (toFilePath tarFile)+ tarFileTmpPath <- parseAbsFile tarFileTmp+ renameFile tarFileTmpPath tarFile -- | Update the index tarball via HTTP updateIndexHTTP :: (MonadIO m,MonadLogger m@@ -316,6 +324,7 @@ when toUnpack $ do let tmp = toFilePath tar <.> "tmp"+ tmpPath <- parseAbsFile tmp deleteCache indexName' @@ -325,7 +334,7 @@ sourceHandle input $$ ungzip =$ sinkHandle output- renameFile tmp $ toFilePath tar+ renameFile tmpPath tar when (indexGpgVerify index) $ $logWarn@@ -341,11 +350,11 @@ -- | Delete the package index cache deleteCache :: (MonadIO m, MonadReader env m, HasConfig env, MonadLogger m, MonadThrow m) => IndexName -> m () deleteCache indexName' = do- fp <- liftM toFilePath $ configPackageIndexCache indexName'+ fp <- configPackageIndexCache indexName' eres <- liftIO $ tryIO $ removeFile fp case eres of Left e -> $logDebug $ "Could not delete cache: " <> T.pack (show e)- Right () -> $logDebug $ "Deleted index cache at " <> T.pack fp+ Right () -> $logDebug $ "Deleted index cache at " <> T.pack (toFilePath fp) data PackageDownload = PackageDownload { pdSHA512 :: !ByteString@@ -354,6 +363,8 @@ } deriving (Show, Generic) instance Binary.Binary PackageDownload+instance NFData PackageDownload where+ rnf = genericRnf instance FromJSON PackageDownload where parseJSON = withObject "Package" $ \o -> do hashes <- o .: "package-hashes"
− src/Stack/Repl.hs
@@ -1,82 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TupleSections #-}---- | Run a REPL configured with the user's project(s).--module Stack.Repl where--import Control.Monad.Catch-import Control.Monad.IO.Class-import Control.Monad.Logger-import Control.Monad.Reader-import Data.List-import qualified Data.Map.Strict as M-import Data.Maybe-import Data.Monoid-import qualified Data.Set as S-import Data.Text (Text)-import qualified Data.Text as T-import Path-import Path.IO-import Stack.Build.Source-import Stack.Exec-import Stack.Package-import Stack.Types---- | Launch a GHCi REPL for the given local project targets with the--- given options and configure it with the load paths and extensions--- of those targets.-repl- :: (HasConfig r, HasBuildConfig r, HasEnvConfig r, MonadReader r m, MonadIO m, MonadThrow m, MonadLogger m, MonadCatch m)- => [Text] -- ^ Targets.- -> [String] -- ^ GHC options.- -> FilePath- -> Bool- -> m ()-repl targets useropts ghciPath noload = do- econfig <- asks getEnvConfig- bconfig <- asks getBuildConfig- pwd <- getWorkingDir- pkgs <-- liftM catMaybes $- forM (M.toList (bcPackages bconfig)) $- \(dir,validWanted) ->- do cabalfp <- getCabalFileName dir- name <- parsePackageNameFromFilePath cabalfp- let config =- PackageConfig- { packageConfigEnableTests = True- , packageConfigEnableBenchmarks = True- , packageConfigFlags = localFlags mempty bconfig name- , packageConfigGhcVersion = envConfigGhcVersion econfig- , packageConfigPlatform = configPlatform- (getConfig bconfig)- }- pkg <- readPackage config cabalfp- if validWanted && wanted pwd cabalfp pkg- then do- pkgOpts <- getPackageOpts (packageOpts pkg) cabalfp- srcfiles <-- getPackageFiles (packageFiles pkg) Modules cabalfp- return- (Just (packageName pkg, pkgOpts, S.toList srcfiles))- else return Nothing- let pkgopts = filter (not . badForGhci) (concat (map _2 pkgs))- srcfiles- | noload = []- | otherwise = concatMap (map toFilePath . _3) pkgs- $logInfo- ("Configuring GHCi with the following packages: " <>- T.intercalate ", " (map packageNameText (map _1 pkgs)))- exec defaultEnvSettings ghciPath ("--interactive" : pkgopts <> srcfiles <> useropts)- where- wanted pwd cabalfp pkg = isInWantedList || targetsEmptyAndInDir- where- isInWantedList = elem (packageNameText (packageName pkg)) targets- targetsEmptyAndInDir = null targets || isParentOf (parent cabalfp) pwd- badForGhci x =- isPrefixOf "-O" x || elem x (words "-debug -threaded -ticky")- _1 (x,_,_) = x- _2 (_,x,_) = x- _3 (_,_,x) = x
+ src/Stack/SDist.hs view
@@ -0,0 +1,156 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+-- Create a source distribution tarball+module Stack.SDist+ ( getSDistTarball+ ) where++import qualified Codec.Archive.Tar as Tar+import qualified Codec.Archive.Tar.Entry as Tar+import qualified Codec.Compression.GZip as GZip+import Control.Applicative ((<$>))+import Control.Concurrent.Execute (ActionContext(..))+import Control.Monad (when)+import Control.Monad.Catch (MonadCatch, MonadMask)+import Control.Monad.IO.Class+import Control.Monad.Logger+import Control.Monad.Reader (MonadReader, asks)+import Control.Monad.Trans.Resource+import qualified Data.ByteString.Lazy as L+import Data.Either (partitionEithers)+import Data.List+import qualified Data.Map.Strict as Map+import Data.Monoid ((<>))+import qualified Data.Set as Set+import qualified Data.Text as T+import Network.HTTP.Client.Conduit (HasHttpManager)+import Path+import Stack.Build (mkBaseConfigOpts)+import Stack.Build.Execute+import Stack.Build.Source (loadSourceMap, localFlags)+import Stack.Types.Build+import Stack.Constants+import Stack.Package+import Stack.Types+import Stack.Types.Internal+import qualified System.FilePath as FP+import System.IO.Temp (withSystemTempDirectory)++type M env m = (MonadIO m,MonadReader env m,HasHttpManager env,HasBuildConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,MonadMask m,HasLogLevel env,HasEnvConfig env,HasTerminal env)++-- | Given the path to a local package, creates its source+-- distribution tarball.+--+-- While this yields a 'FilePath', the name of the tarball, this+-- tarball is not written to the disk and instead yielded as a lazy+-- bytestring.+getSDistTarball :: M env m => Path Abs Dir -> m (FilePath, L.ByteString)+getSDistTarball pkgDir = do+ let pkgFp = toFilePath pkgDir+ lp <- readLocalPackage pkgDir+ $logInfo $ "Getting file list for " <> T.pack pkgFp+ fileList <- getSDistFileList lp+ $logInfo $ "Building sdist tarball for " <> T.pack pkgFp+ files <- normalizeTarballPaths (lines fileList)+ liftIO $ do+ -- NOTE: Could make this use lazy I/O to only read files as needed+ -- for upload (both GZip.compress and Tar.write are lazy).+ -- However, it seems less error prone and more predictable to read+ -- everything in at once, so that's what we're doing for now:+ let packWith f isDir fp =+ f (pkgFp FP.</> fp)+ (either error id (Tar.toTarPath isDir (pkgId FP.</> fp)))+ tarName = pkgId FP.<.> "tar.gz"+ pkgId = packageIdentifierString (packageIdentifier (lpPackage lp))+ dirEntries <- mapM (packWith Tar.packDirectoryEntry True) (dirsFromFiles files)+ fileEntries <- mapM (packWith Tar.packFileEntry False) files+ return (tarName, GZip.compress (Tar.write (dirEntries ++ fileEntries)))++-- Read in a 'LocalPackage' config. This makes some default decisions+-- about 'LocalPackage' fields that might not be appropriate for other+-- usecases.+--+-- TODO: Dedupe with similar code in "Stack.Build.Source".+readLocalPackage :: M env m => Path Abs Dir -> m LocalPackage+readLocalPackage pkgDir = do+ econfig <- asks getEnvConfig+ bconfig <- asks getBuildConfig+ cabalfp <- getCabalFileName pkgDir+ name <- parsePackageNameFromFilePath cabalfp+ let config = PackageConfig+ { packageConfigEnableTests = False+ , packageConfigEnableBenchmarks = False+ , packageConfigFlags = localFlags Map.empty bconfig name+ , packageConfigGhcVersion = envConfigGhcVersion econfig+ , packageConfigPlatform = configPlatform $ getConfig bconfig+ }+ package <- readPackage config cabalfp+ return LocalPackage+ { lpPackage = package+ , lpExeComponents = Nothing -- HACK: makes it so that sdist output goes to a log instead of a file.+ , lpDir = pkgDir+ , lpCabalFile = cabalfp+ -- NOTE: these aren't the 'correct values, but aren't used in+ -- the usage of this function in this module.+ , lpTestBench = Nothing+ , lpDirtyFiles = True+ , lpNewBuildCache = Map.empty+ , lpFiles = Set.empty+ , lpComponents = Set.empty+ }++getSDistFileList :: M env m => LocalPackage -> m String+getSDistFileList lp =+ withSystemTempDirectory (stackProgName <> "-sdist") $ \tmpdir -> do+ menv <- getMinimalEnvOverride+ let bopts = defaultBuildOpts+ baseConfigOpts <- mkBaseConfigOpts bopts+ (_mbp, locals, _extraToBuild, sourceMap) <- loadSourceMap bopts+ withExecuteEnv menv bopts baseConfigOpts locals sourceMap $ \ee -> do+ withSingleContext ac ee task (Just "sdist") $ \_package _cabalfp _pkgDir cabal _announce _console _mlogFile -> do+ let outFile = tmpdir FP.</> "source-files-list"+ cabal False ["sdist", "--list-sources", outFile]+ liftIO (readFile outFile)+ where+ package = lpPackage lp+ ac = ActionContext Set.empty+ task = Task+ { taskProvides = PackageIdentifier (packageName package) (packageVersion package)+ , taskType = TTLocal lp+ , taskConfigOpts = TaskConfigOpts+ { tcoMissing = Set.empty+ , tcoOpts = \_ -> []+ }+ , taskPresent = Set.empty+ }++normalizeTarballPaths :: M env m => [FilePath] -> m [FilePath]+normalizeTarballPaths fps = do+ --TODO: consider whether erroring out is better - otherwise the+ --user might upload an incomplete tar?+ when (not (null outsideDir)) $+ $logWarn $ T.concat+ [ "Warning: These files are outside of the package directory, and will be omitted from the tarball: "+ , T.pack (show outsideDir)]+ return files+ where+ (outsideDir, files) = partitionEithers (map pathToEither fps)+ pathToEither fp = maybe (Left fp) Right (normalizePath fp)++normalizePath :: FilePath -> (Maybe FilePath)+normalizePath = fmap FP.joinPath . go . FP.splitDirectories . FP.normalise+ where+ go [] = Just []+ go ("..":_) = Nothing+ go (_:"..":xs) = go xs+ go (x:xs) = (x :) <$> go xs++dirsFromFiles :: [FilePath] -> [FilePath]+dirsFromFiles dirs = Set.toAscList (Set.delete "." results)+ where+ results = foldl' (\s -> go s . FP.takeDirectory) Set.empty dirs+ go s x+ | Set.member x s = s+ | otherwise = go (Set.insert x s) (FP.takeDirectory x)
src/Stack/Setup.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-}@@ -16,19 +17,22 @@ import Control.Applicative import Control.Exception.Enclosed (catchIO)-import Control.Monad (liftM, when, join, void)+import Control.Monad (liftM, when, join, void, unless) import Control.Monad.Catch import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Logger import Control.Monad.Reader (MonadReader, ReaderT (..), asks) import Control.Monad.State (get, put, modify) import Control.Monad.Trans.Control+import Crypto.Hash (SHA1(SHA1)) import Data.Aeson.Extended+import Data.ByteString (ByteString) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import Data.Conduit (Conduit, ($$), (=$), await, yield, awaitForever) import Data.Conduit.Lift (evalStateC) import qualified Data.Conduit.List as CL+import Data.Either import Data.IORef import Data.List (intercalate) import Data.Map (Map)@@ -47,17 +51,19 @@ import Distribution.System (OS (..), Arch (..), Platform (..)) import Distribution.Text (simpleParse) import Network.HTTP.Client.Conduit-import Network.HTTP.Download (verifiedDownload, DownloadRequest(..))+import Network.HTTP.Download.Verified import Path import Path.IO import Prelude -- Fix AMP warning import Safe (headMay, readMay)-import Stack.Build.Types+import Stack.Types.Build+import Stack.Config (resolvePackageEntry)+import Stack.Constants (distRelativeDir)+import Stack.Fetch import Stack.GhcPkg (createDatabase, getCabalPkgVer, getGlobalDB) import Stack.Solver (getGhcVersion) import Stack.Types import Stack.Types.StackT-import System.Directory (createDirectoryIfMissing, removeFile) import System.Environment (getExecutablePath) import System.Exit (ExitCode (ExitSuccess)) import System.FilePath (searchPathSeparator)@@ -65,6 +71,8 @@ import System.IO.Temp (withSystemTempDirectory) import System.Process (rawSystem) import System.Process.Read+import System.Process.Run (runIn)+import Text.Printf (printf) data SetupOpts = SetupOpts { soptsInstallIfMissing :: !Bool@@ -79,6 +87,9 @@ -- ^ Don't check for a compatible GHC version/architecture , soptsSkipMsys :: !Bool -- ^ Do not use a custom msys installation on Windows+ , soptsUpgradeCabal :: !Bool+ -- ^ Upgrade the global Cabal library in the database to the newest+ -- version. Only works reliably with a stack-managed installation. } deriving Show data SetupException = UnsupportedSetupCombo OS Arch@@ -130,13 +141,14 @@ , soptsSanityCheck = False , soptsSkipGhcCheck = configSkipGHCCheck $ bcConfig bconfig , soptsSkipMsys = configSkipMsys $ bcConfig bconfig+ , soptsUpgradeCabal = False } mghcBin <- ensureGHC sopts menv0 <- getMinimalEnvOverride -- Modify the initial environment to include the GHC path, if a local GHC -- is being used- let env0 = case mghcBin of+ let env = removeHaskellEnvVars $ case mghcBin of Nothing -> unEnvOverride menv0 Just ghcBin -> let x = unEnvOverride menv0@@ -146,39 +158,39 @@ ++ maybe [] return mpath in Map.insert "PATH" path x - -- Remove potentially confusing environment variables- env1 = Map.delete "GHC_PACKAGE_PATH"- $ Map.delete "HASKELL_PACKAGE_SANDBOX"- $ Map.delete "HASKELL_PACKAGE_SANDBOXES"- env0-- menv1 <- mkEnvOverride platform env1- ghcVer <- getGhcVersion menv1- cabalVer <- getCabalPkgVer menv1+ menv <- mkEnvOverride platform env+ ghcVer <- getGhcVersion menv+ cabalVer <- getCabalPkgVer menv+ packages <- mapM+ (resolvePackageEntry menv (bcRoot bconfig))+ (bcPackageEntries bconfig) let envConfig0 = EnvConfig { envConfigBuildConfig = bconfig , envConfigCabalVersion = cabalVer , envConfigGhcVersion = ghcVer+ , envConfigPackages = Map.fromList $ concat packages } -- extra installation bin directories mkDirs <- runReaderT extraBinDirs envConfig0- let mpath = Map.lookup "PATH" env1+ let mpath = Map.lookup "PATH" env mkDirs' = map toFilePath . mkDirs depsPath = augmentPath (mkDirs' False) mpath localsPath = augmentPath (mkDirs' True) mpath deps <- runReaderT packageDatabaseDeps envConfig0- createDatabase menv1 deps+ createDatabase menv deps localdb <- runReaderT packageDatabaseLocal envConfig0- createDatabase menv1 localdb- globalDB <- mkEnvOverride platform env1 >>= getGlobalDB+ createDatabase menv localdb+ globalDB <- getGlobalDB menv let mkGPP locals = T.pack $ intercalate [searchPathSeparator] $ concat [ [toFilePathNoTrailingSlash localdb | locals] , [toFilePathNoTrailingSlash deps] , [toFilePathNoTrailingSlash globalDB] ] + distDir <- runReaderT distRelativeDir envConfig0+ executablePath <- liftIO getExecutablePath envRef <- liftIO $ newIORef Map.empty@@ -210,7 +222,8 @@ [ toFilePathNoTrailingSlash deps , "" ])- $ env1+ $ Map.insert "HASKELL_DIST_DIR" (T.pack $ toFilePathNoTrailingSlash distDir)+ $ env !() <- atomicModifyIORef envRef $ \m' -> (Map.insert es eo m', ()) return eo@@ -221,6 +234,7 @@ } , envConfigCabalVersion = cabalVer , envConfigGhcVersion = ghcVer+ , envConfigPackages = envConfigPackages envConfig0 } -- | Augment the PATH environment variable with the given extra paths@@ -241,6 +255,12 @@ => SetupOpts -> m (Maybe [FilePath]) ensureGHC sopts = do+ when (getMajorVersion expected < MajorVersion 7 8) $ do+ $logWarn "stack will almost certainly fail with GHC below version 7.8"+ $logWarn "Valiantly attempting to run anyway, but I know this is doomed"+ $logWarn "For more information, see: https://github.com/commercialhaskell/stack/issues/648"+ $logWarn ""+ -- Check the available GHCs menv0 <- getMinimalEnvOverride @@ -293,23 +313,91 @@ return $ Just $ map toFilePathNoTrailingSlash $ concat paths else return Nothing - when (soptsSanityCheck sopts) $ do- menv <-- case mpaths of- Nothing -> return menv0- Just paths -> do- config <- asks getConfig- let m0 = unEnvOverride menv0- path0 = Map.lookup "PATH" m0- path = augmentPath paths path0- m = Map.insert "PATH" path m0- mkEnvOverride (configPlatform config) m- sanityCheck menv+ menv <-+ case mpaths of+ Nothing -> return menv0+ Just paths -> do+ config <- asks getConfig+ let m0 = unEnvOverride menv0+ path0 = Map.lookup "PATH" m0+ path = augmentPath paths path0+ m = Map.insert "PATH" path m0+ mkEnvOverride (configPlatform config) (removeHaskellEnvVars m) + when (soptsUpgradeCabal sopts) $ do+ unless needLocal $ do+ $logWarn "Trying to upgrade Cabal library on a GHC not installed by stack."+ $logWarn "This may fail, caveat emptor!"++ upgradeCabal menv++ when (soptsSanityCheck sopts) $ sanityCheck menv+ return mpaths where expected = soptsExpected sopts +-- | Install the newest version of Cabal globally+upgradeCabal :: (MonadIO m, MonadLogger m, MonadReader env m, HasHttpManager env, HasConfig env, MonadBaseControl IO m, MonadMask m)+ => EnvOverride+ -> m ()+upgradeCabal menv = do+ let name = $(mkPackageName "Cabal")+ rmap <- resolvePackages menv Set.empty (Set.singleton name)+ newest <-+ case Map.keys rmap of+ [] -> error "No Cabal library found in index, cannot upgrade"+ [PackageIdentifier name' version]+ | name == name' -> return version+ x -> error $ "Unexpected results for resolvePackages: " ++ show x+ installed <- getCabalPkgVer menv+ if installed >= newest+ then $logInfo $ T.concat+ [ "Currently installed Cabal is "+ , T.pack $ versionString installed+ , ", newest is "+ , T.pack $ versionString newest+ , ". I'm not upgrading Cabal."+ ]+ else withSystemTempDirectory "stack-cabal-upgrade" $ \tmpdir -> do+ $logInfo $ T.concat+ [ "Installing Cabal-"+ , T.pack $ versionString newest+ , " to replace "+ , T.pack $ versionString installed+ ]+ tmpdir' <- parseAbsDir tmpdir+ let ident = PackageIdentifier name newest+ m <- unpackPackageIdents menv tmpdir' Nothing (Set.singleton ident)++ ghcPath <- join $ findExecutable menv "ghc"+ newestDir <- parseRelDir $ versionString newest+ let installRoot = toFilePath $ parent (parent ghcPath)+ </> $(mkRelDir "new-cabal")+ </> newestDir++ dir <-+ case Map.lookup ident m of+ Nothing -> error $ "upgradeCabal: Invariant violated, dir missing"+ Just dir -> return dir++ runIn dir "ghc" menv ["Setup.hs"] Nothing+ let setupExe = toFilePath $ dir </> $(mkRelFile "Setup")+ dirArgument name' = concat+ [ "--"+ , name'+ , "dir="+ , installRoot FP.</> name'+ ]+ runIn dir setupExe menv+ ( "configure"+ : map dirArgument (words "lib bin data doc")+ )+ Nothing+ runIn dir setupExe menv ["build"] Nothing+ runIn dir setupExe menv ["install"] Nothing+ $logInfo "New Cabal library installed"+ -- | Get the major version of the system GHC, if available getSystemGHC :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) => EnvOverride -> m (Maybe (Version, Arch)) getSystemGHC menv = do@@ -325,24 +413,52 @@ Just (version, arch) else return Nothing -data DownloadPair = DownloadPair Version Text+data DownloadInfo = DownloadInfo+ { downloadInfoUrl :: Text+ , downloadInfoContentLength :: Int+ , downloadInfoSha1 :: Maybe ByteString+ } deriving Show-instance FromJSON DownloadPair where- parseJSON = withObject "DownloadPair" $ \o -> DownloadPair- <$> o .: "version"- <*> o .: "url" +data VersionedDownloadInfo = VersionedDownloadInfo+ { vdiVersion :: Version+ , vdiDownloadInfo :: DownloadInfo+ }+ deriving Show++parseDownloadInfoFromObject :: Yaml.Object -> Yaml.Parser DownloadInfo+parseDownloadInfoFromObject o = do+ url <- o .: "url"+ contentLength <- o .: "content-length"+ sha1TextMay <- o .:? "sha1"+ return DownloadInfo+ { downloadInfoUrl = url+ , downloadInfoContentLength = contentLength+ , downloadInfoSha1 = fmap T.encodeUtf8 sha1TextMay+ }++instance FromJSON DownloadInfo where+ parseJSON = withObject "DownloadInfo" parseDownloadInfoFromObject+instance FromJSON VersionedDownloadInfo where+ parseJSON = withObject "VersionedDownloadInfo" $ \o -> do+ version <- o .: "version"+ downloadInfo <- parseDownloadInfoFromObject o+ return VersionedDownloadInfo+ { vdiVersion = version+ , vdiDownloadInfo = downloadInfo+ }+ data SetupInfo = SetupInfo- { siSevenzExe :: Text- , siSevenzDll :: Text- , siPortableGit :: DownloadPair- , siGHCs :: Map Text (Map MajorVersion DownloadPair)+ { siSevenzExe :: DownloadInfo+ , siSevenzDll :: DownloadInfo+ , siPortableGit :: VersionedDownloadInfo+ , siGHCs :: Map Text (Map MajorVersion VersionedDownloadInfo) } deriving Show instance FromJSON SetupInfo where parseJSON = withObject "SetupInfo" $ \o -> SetupInfo- <$> o .: "sevenzexe"- <*> o .: "sevenzdll"+ <$> o .: "sevenzexe-info"+ <*> o .: "sevenzdll-info" <*> o .: "portable-git" <*> o .: "ghc" @@ -376,7 +492,7 @@ => m [PackageIdentifier] listInstalled = do dir <- asks $ configLocalPrograms . getConfig- liftIO $ createDirectoryIfMissing True $ toFilePath dir+ createTree dir (_, files) <- listDirectory dir return $ mapMaybe toIdent files where@@ -435,7 +551,7 @@ return Nothing | otherwise = do si <- getSetupInfo'- (pair@(DownloadPair version _), installer) <-+ (VersionedDownloadInfo version downloadInfo, installer) <- case packageNameString name of "git" -> do let pair = siPortableGit si@@ -463,7 +579,7 @@ x -> error $ "Invariant violated: ensureTool on " ++ x let ident = PackageIdentifier name version - (file, at) <- downloadPair pair ident+ (file, at) <- downloadFromInfo downloadInfo ident dir <- installDir ident unmarkInstalled ident installer si file at dir ident@@ -514,11 +630,11 @@ hasLineWithFirstWord w = elem (Just w) . map (headMay . T.words) . T.lines . T.decodeUtf8With T.lenientDecode -downloadPair :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m)- => DownloadPair+downloadFromInfo :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m)+ => DownloadInfo -> PackageIdentifier -> m (Path Abs File, ArchiveType)-downloadPair (DownloadPair _ url) ident = do+downloadFromInfo downloadInfo ident = do config <- asks getConfig at <- case extension of@@ -528,9 +644,10 @@ _ -> error $ "Unknown extension: " ++ extension relfile <- parseRelFile $ packageIdentifierString ident ++ extension let path = configLocalPrograms config </> relfile- chattyDownload (packageIdentifierText ident) url path+ chattyDownload (packageIdentifierText ident) downloadInfo path return (path, at) where+ url = downloadInfoUrl downloadInfo extension = loop $ T.unpack url where@@ -553,28 +670,38 @@ -> PackageIdentifier -> m () installGHCPosix _ archiveFile archiveType destDir ident = do- menv <- getMinimalEnvOverride- zipTool <-+ platform <- asks getPlatform+ menv0 <- getMinimalEnvOverride+ menv <- mkEnvOverride platform (removeHaskellEnvVars (unEnvOverride menv0))+ $logDebug $ "menv = " <> T.pack (show (unEnvOverride menv))+ zipTool' <- case archiveType of TarXz -> return "xz" TarBz2 -> return "bzip2" SevenZ -> error "Don't know how to deal with .7z files on non-Windows"- checkDependencies $ zipTool : ["make", "tar"]+ (zipTool, makeTool, tarTool) <- checkDependencies $ (,,)+ <$> checkDependency zipTool'+ <*> (checkDependency "gmake" <|> checkDependency "make")+ <*> checkDependency "tar" + $logDebug $ "ziptool: " <> T.pack zipTool+ $logDebug $ "make: " <> T.pack makeTool+ $logDebug $ "tar: " <> T.pack tarTool+ withSystemTempDirectory "stack-setup" $ \root' -> do root <- parseAbsDir root' dir <- liftM (root Path.</>) $ parseRelDir $ packageIdentifierString ident $logSticky $ "Unpacking GHC ..." $logDebug $ "Unpacking " <> T.pack (toFilePath archiveFile)- readInNull root "tar" menv ["xf", toFilePath archiveFile] Nothing+ readInNull root tarTool menv ["xf", toFilePath archiveFile] Nothing $logSticky "Configuring GHC ..." readInNull dir (toFilePath $ dir Path.</> $(mkRelFile "configure")) menv ["--prefix=" ++ toFilePath destDir] Nothing $logSticky "Installing GHC ..."- readInNull dir "make" menv ["install"] Nothing+ readInNull dir makeTool menv ["install"] Nothing $logStickyDone $ "Installed GHC." $logDebug $ "GHC installed to " <> T.pack (toFilePath destDir)@@ -582,18 +709,37 @@ -- | Check if given processes appear to be present, throwing an exception if -- missing. checkDependencies :: (MonadIO m, MonadThrow m, MonadReader env m, HasConfig env)- => [String] -> m ()- checkDependencies tools = do+ => CheckDependency a -> m a+ checkDependencies (CheckDependency f) = do menv <- getMinimalEnvOverride- missing <- liftM catMaybes $ mapM (check menv) tools- if null missing- then return ()- else throwM $ MissingDependencies missing- where- check menv tool = do- exists <- doesExecutableExist menv tool- return $ if exists then Nothing else Just tool+ liftIO (f menv) >>= either (throwM . MissingDependencies) return +checkDependency :: String -> CheckDependency String+checkDependency tool = CheckDependency $ \menv -> do+ exists <- doesExecutableExist menv tool+ return $ if exists then Right tool else Left [tool]++newtype CheckDependency a = CheckDependency (EnvOverride -> IO (Either [String] a))+ deriving Functor+instance Applicative CheckDependency where+ pure x = CheckDependency $ \_ -> return (Right x)+ CheckDependency f <*> CheckDependency x = CheckDependency $ \menv -> do+ f' <- f menv+ x' <- x menv+ return $+ case (f', x') of+ (Left e1, Left e2) -> Left $ e1 ++ e2+ (Left e, Right _) -> Left e+ (Right _, Left e) -> Left e+ (Right f'', Right x'') -> Right $ f'' x''+instance Alternative CheckDependency where+ empty = CheckDependency $ \_ -> return $ Left []+ CheckDependency x <|> CheckDependency y = CheckDependency $ \menv -> do+ res1 <- x menv+ case res1 of+ Left _ -> y menv+ Right x' -> return $ Right x'+ installGHCWindows :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m) => SetupInfo -> Path Abs File@@ -617,7 +763,7 @@ run7z (parent archiveFile) archiveFile run7z (parent archiveFile) tarFile- liftIO (removeFile $ toFilePath tarFile) `catchIO` \e ->+ removeFile tarFile `catchIO` \e -> $logWarn (T.concat [ "Exception when removing " , T.pack $ toFilePath tarFile@@ -668,11 +814,12 @@ dll = dir </> $(mkRelFile "7z.dll") chattyDownload :: (MonadReader env m, HasHttpManager env, MonadIO m, MonadLogger m, MonadThrow m, MonadBaseControl IO m)- => Text- -> Text -- ^ URL+ => Text -- ^ label+ -> DownloadInfo -- ^ URL, content-length, and sha1 -> Path Abs File -- ^ destination -> m ()-chattyDownload label url path = do+chattyDownload label downloadInfo path = do+ let url = downloadInfoUrl downloadInfo req <- parseUrl $ T.unpack url $logSticky $ T.concat [ "Preparing to download "@@ -686,11 +833,25 @@ , T.pack $ toFilePath path , " ..." ]-+ hashChecks <- case downloadInfoSha1 downloadInfo of+ Just sha1ByteString -> do+ let sha1 = CheckHexDigestByteString sha1ByteString+ $logDebug $ T.concat+ [ "Will check against sha1 hash: "+ , T.decodeUtf8With T.lenientDecode sha1ByteString+ ]+ return [HashCheck SHA1 sha1]+ Nothing -> do+ $logWarn $ T.concat+ [ "No sha1 found in metadata,"+ , " download hash won't be checked."+ ]+ return [] let dReq = DownloadRequest { drRequest = req- , drHashChecks = []- , drLengthCheck = Nothing+ , drHashChecks = hashChecks+ , drLengthCheck = Just totalSize+ , drRetryPolicy = drRetryPolicyDefault } runInBase <- liftBaseWith $ \run -> return (void . run) x <- verifiedDownload dReq path (chattyDownloadProgress runInBase)@@ -698,7 +859,8 @@ then $logStickyDone ("Downloaded " <> label <> ".") else $logStickyDone "Already downloaded." where- chattyDownloadProgress runInBase = do+ totalSize = downloadInfoContentLength downloadInfo+ chattyDownloadProgress runInBase _ = do _ <- liftIO $ runInBase $ $logSticky $ label <> ": download has begun" CL.map (Sum . S.length)@@ -708,10 +870,51 @@ go = evalStateC 0 $ awaitForever $ \(Sum size) -> do modify (+ size) totalSoFar <- get- liftIO $ runInBase $ $logSticky $- label <> ": " <> T.pack (show totalSoFar) <> " bytes downloaded..."+ liftIO $ runInBase $ $logSticky $ T.pack $+ chattyProgressWithTotal totalSoFar totalSize + -- Note(DanBurton): Total size is now always known in this file.+ -- However, printing in the case where it isn't known may still be+ -- useful in other parts of the codebase.+ -- So I'm just commenting out the code rather than deleting it. + -- case mcontentLength of+ -- Nothing -> chattyProgressNoTotal totalSoFar+ -- Just 0 -> chattyProgressNoTotal totalSoFar+ -- Just total -> chattyProgressWithTotal totalSoFar total+ ---- Example: ghc: 42.13 KiB downloaded...+ --chattyProgressNoTotal totalSoFar =+ -- printf ("%s: " <> bytesfmt "%7.2f" totalSoFar <> " downloaded...")+ -- (T.unpack label)++ -- Example: ghc: 50.00 MiB / 100.00 MiB (50.00%) downloaded...+ chattyProgressWithTotal totalSoFar total =+ printf ("%s: " <>+ bytesfmt "%7.2f" totalSoFar <> " / " <>+ bytesfmt "%.2f" total <>+ " (%6.2f%%) downloaded...")+ (T.unpack label)+ percentage+ where percentage :: Double+ percentage = (fromIntegral totalSoFar / fromIntegral total * 100)++-- | Given a printf format string for the decimal part and a number of+-- bytes, formats the bytes using an appropiate unit and returns the+-- formatted string.+--+-- >>> bytesfmt "%.2" 512368+-- "500.359375 KiB"+bytesfmt :: Integral a => String -> a -> String+bytesfmt formatter bs = printf (formatter <> " %s")+ (fromIntegral (signum bs) * dec :: Double)+ (bytesSuffixes !! i)+ where+ (dec,i) = getSuffix (abs bs)+ getSuffix n = until p (\(x,y) -> (x / 1024, y+1)) (fromIntegral n,0)+ where p (n',numDivs) = n' < 1024 || numDivs == (length bytesSuffixes - 1)+ bytesSuffixes :: [String]+ bytesSuffixes = ["B","KiB","MiB","GiB","TiB","PiB","EiB","ZiB","YiB"]+ -- Await eagerly (collect with monoidal append), -- but space out yields by at least the given amount of time. -- The final yield may come sooner, and may be a superfluous mempty.@@ -762,3 +965,11 @@ toFilePathNoTrailingSlash :: Path loc Dir -> FilePath toFilePathNoTrailingSlash = FP.dropTrailingPathSeparator . toFilePath++-- Remove potentially confusing environment variables+removeHaskellEnvVars :: Map Text Text -> Map Text Text+removeHaskellEnvVars =+ Map.delete "GHC_PACKAGE_PATH" .+ Map.delete "HASKELL_PACKAGE_SANDBOX" .+ Map.delete "HASKELL_PACKAGE_SANDBOXES" .+ Map.delete "HASKELL_DIST_DIR"
src/Stack/Solver.hs view
@@ -14,7 +14,7 @@ import Control.Monad.Logger import Control.Monad.Reader import Control.Monad.Trans.Control-import Data.Aeson (object, (.=), toJSON)+import Data.Aeson.Extended (object, (.=), toJSON, logJSONWarnings) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import Data.Either@@ -38,10 +38,11 @@ cabalSolver :: (MonadIO m, MonadLogger m, MonadMask m, MonadBaseControl IO m, MonadReader env m, HasConfig env) => [Path Abs Dir] -- ^ cabal files- -> [String] -- ^ additional arguments, usually constraints+ -> Map PackageName Version -- ^ constraints+ -> [String] -- ^ additional arguments -> m (MajorVersion, Map PackageName (Version, Map FlagName Bool))-cabalSolver cabalfps cabalArgs = withSystemTempDirectory "cabal-solver" $ \dir -> do- configLines <- getCabalConfig dir+cabalSolver cabalfps constraints cabalArgs = withSystemTempDirectory "cabal-solver" $ \dir -> do+ configLines <- getCabalConfig dir constraints let configFile = dir FP.</> "cabal.config" liftIO $ S.writeFile configFile $ encodeUtf8 $ T.unlines configLines @@ -115,12 +116,13 @@ getCabalConfig :: (MonadReader env m, HasConfig env, MonadIO m, MonadThrow m) => FilePath -- ^ temp dir+ -> Map PackageName Version -- ^ constraints -> m [Text]-getCabalConfig dir = do+getCabalConfig dir constraints = do indices <- asks $ configPackageIndices . getConfig remotes <- mapM goIndex indices let cache = T.pack $ "remote-repo-cache: " ++ dir- return $ cache : remotes+ return $ cache : remotes ++ map goConstraint (Map.toList constraints) where goIndex index = do src <- configPackageIndex $ indexName index@@ -135,6 +137,13 @@ , ":http://0.0.0.0/fake-url" ] + goConstraint (name, version) = T.concat+ [ "constraint: "+ , T.pack $ packageNameString name+ , "=="+ , T.pack $ versionString version+ ]+ -- | Determine missing extra-deps solveExtraDeps :: (MonadReader env m, HasEnvConfig env, MonadIO m, MonadMask m, MonadLogger m, MonadBaseControl IO m, HasHttpManager env) => Bool -- ^ modify stack.yaml?@@ -142,27 +151,24 @@ solveExtraDeps modStackYaml = do $logInfo "This command is not guaranteed to give you a perfect build plan" $logInfo "It's possible that even with the changes generated below, you will still need to do some manual tweaking"+ econfig <- asks getEnvConfig bconfig <- asks getBuildConfig snapshot <- case bcResolver bconfig of ResolverSnapshot snapName -> liftM mbpPackages $ loadMiniBuildPlan snapName ResolverGhc _ -> return Map.empty+ ResolverCustom _ url -> liftM mbpPackages $ parseCustomMiniBuildPlan+ (bcStackYaml bconfig)+ url let packages = Map.union (bcExtraDeps bconfig) (fmap mpiVersion snapshot)- constraints = map- (\(k, v) -> concat- [ "--constraint="- , packageNameString k- , "=="- , versionString v- ])- (Map.toList packages) (_ghc, extraDeps) <- cabalSolver- (Map.keys $ bcPackages bconfig)- constraints+ (Map.keys $ envConfigPackages econfig)+ packages+ [] let newDeps = extraDeps `Map.difference` packages newFlags = Map.filter (not . Map.null) $ fmap snd newDeps@@ -180,7 +186,9 @@ when modStackYaml $ do let fp = toFilePath $ bcStackYaml bconfig obj <- liftIO (Yaml.decodeFileEither fp) >>= either throwM return- ProjectAndConfigMonoid project _ <- liftIO (Yaml.decodeFileEither fp) >>= either throwM return+ (ProjectAndConfigMonoid project _, warnings) <-+ liftIO (Yaml.decodeFileEither fp) >>= either throwM return+ logJSONWarnings fp warnings let obj' = HashMap.insert "extra-deps" (toJSON $ map fromTuple $ Map.toList
src/Stack/Types.hs view
@@ -12,3 +12,6 @@ import Stack.Types.Version as X import Stack.Types.Config as X import Stack.Types.Docker as X+import Stack.Types.Image as X+import Stack.Types.Build as X+import Stack.Types.Package as X
+ src/Stack/Types/Build.hs view
@@ -0,0 +1,615 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ViewPatterns #-}++-- | Build-specific types.++module Stack.Types.Build+ (StackBuildException(..)+ ,FlagSource(..)+ ,UnusedFlags(..)+ ,InstallLocation(..)+ ,ModTime+ ,modTime+ ,Installed(..)+ ,PackageInstallInfo(..)+ ,Task(..)+ ,taskLocation+ ,LocalPackage(..)+ ,BaseConfigOpts(..)+ ,Plan(..)+ ,TestOpts(..)+ ,BenchmarkOpts(..)+ ,BuildOpts(..)+ ,BuildSubset(..)+ ,defaultBuildOpts+ ,TaskType(..)+ ,TaskConfigOpts(..)+ ,ConfigCache(..)+ ,ConstructPlanException(..)+ ,configureOpts+ ,BadDependency(..)+ ,wantedLocalPackages+ ,FileCacheInfo (..))+ where++import Control.DeepSeq+import Control.Exception++import Data.Binary.VersionTagged+import qualified Data.ByteString as S+import Data.Char (isSpace)+import Data.Data+import Data.Hashable+import Data.List (dropWhileEnd, nub, intercalate)+import qualified Data.Map as Map+import Data.Map.Strict (Map)+import Data.Maybe+import Data.Monoid+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Encoding (decodeUtf8With)+import Data.Text.Encoding.Error (lenientDecode)+import Data.Time.Calendar+import Data.Time.Clock+import Distribution.System (Arch)+import Distribution.Text (display)+import GHC.Generics+import Path (Path, Abs, File, Dir, mkRelDir, toFilePath, parseRelDir, (</>))+import Prelude+import Stack.Types.FlagName+import Stack.Types.GhcPkgId+import Stack.Types.Config+import Stack.Types.Package+import Stack.Types.PackageIdentifier+import Stack.Types.PackageName+import Stack.Types.Version+import System.Exit (ExitCode)+import System.FilePath (dropTrailingPathSeparator, pathSeparator)++----------------------------------------------+-- Exceptions+data StackBuildException+ = Couldn'tFindPkgId PackageName+ | GHCVersionMismatch (Maybe (Version, Arch)) (Version, Arch) (Maybe (Path Abs File))+ -- ^ Path to the stack.yaml file+ | Couldn'tParseTargets [Text]+ | UnknownTargets+ (Set PackageName) -- no known version+ (Map PackageName Version) -- not in snapshot, here's the most recent version in the index+ (Path Abs File) -- stack.yaml+ | TestSuiteFailure PackageIdentifier (Map Text (Maybe ExitCode)) (Maybe (Path Abs File)) S.ByteString+ | ConstructPlanExceptions+ [ConstructPlanException]+ (Path Abs File) -- stack.yaml+ | CabalExitedUnsuccessfully+ ExitCode+ PackageIdentifier+ (Path Abs File) -- cabal Executable+ [String] -- cabal arguments+ (Maybe (Path Abs File)) -- logfiles location+ S.ByteString -- log contents+ | ExecutionFailure [SomeException]+ | LocalPackageDoesn'tMatchTarget+ PackageName+ Version -- local version+ Version -- version specified on command line+ | NoSetupHsFound (Path Abs Dir)+ | InvalidFlagSpecification (Set UnusedFlags)+ | TargetParseException [Text]+ deriving Typeable++data FlagSource = FSCommandLine | FSStackYaml+ deriving (Show, Eq, Ord)++data UnusedFlags = UFNoPackage FlagSource PackageName+ | UFFlagsNotDefined FlagSource Package (Set FlagName)+ deriving (Show, Eq, Ord)++instance Show StackBuildException where+ show (Couldn'tFindPkgId name) =+ ("After installing " <> packageNameString name <>+ ", the package id couldn't be found " <> "(via ghc-pkg describe " <>+ packageNameString name <> "). This shouldn't happen, " <>+ "please report as a bug")+ show (GHCVersionMismatch mactual (expected, earch) mstack) = concat+ [ case mactual of+ Nothing -> "No GHC found, expected version "+ Just (actual, arch) -> concat+ [ "GHC version mismatched, found "+ , versionString actual+ , " ("+ , display arch+ , ")"+ , ", but expected version "+ ]+ , versionString expected+ , " ("+ , display earch+ , ") (based on "+ , case mstack of+ Nothing -> "command line arguments"+ Just stack -> "resolver setting in " ++ toFilePath stack+ , "). Try running stack setup"+ ]+ show (Couldn'tParseTargets targets) = unlines+ $ "The following targets could not be parsed as package names or directories:"+ : map T.unpack targets+ show (UnknownTargets noKnown notInSnapshot stackYaml) =+ unlines $ noKnown' ++ notInSnapshot'+ where+ noKnown'+ | Set.null noKnown = []+ | otherwise = return $+ "The following target packages were not found: " +++ intercalate ", " (map packageNameString $ Set.toList noKnown)+ notInSnapshot'+ | Map.null notInSnapshot = []+ | otherwise =+ "The following packages are not in your snapshot, but exist"+ : "in your package index. Recommended action: add them to your"+ : ("extra-deps in " ++ toFilePath stackYaml)+ : "(Note: these are the most recent versions,"+ : "but there's no guarantee that they'll build together)."+ : ""+ : map+ (\(name, version) -> "- " ++ packageIdentifierString+ (PackageIdentifier name version))+ (Map.toList notInSnapshot)+ show (TestSuiteFailure ident codes mlogFile bs) = unlines $ concat+ [ ["Test suite failure for package " ++ packageIdentifierString ident]+ , flip map (Map.toList codes) $ \(name, mcode) -> concat+ [ " "+ , T.unpack name+ , ": "+ , case mcode of+ Nothing -> " executable not found"+ Just ec -> " exited with: " ++ show ec+ ]+ , return $ case mlogFile of+ Nothing -> "Logs printed to console"+ -- TODO Should we load up the full error output and print it here?+ Just logFile -> "Full log available at " ++ toFilePath logFile+ , if S.null bs+ then []+ else ["", "", doubleIndent $ T.unpack $ decodeUtf8With lenientDecode bs]+ ]+ where+ indent = dropWhileEnd isSpace . unlines . fmap (\line -> " " ++ line) . lines+ doubleIndent = indent . indent+ show (ConstructPlanExceptions exceptions stackYaml) =+ "While constructing the BuildPlan the following exceptions were encountered:" +++ appendExceptions exceptions' +++ if Map.null extras then "" else (unlines+ $ ("\n\nRecommended action: try adding the following to your extra-deps in "+ ++ toFilePath stackYaml)+ : map (\(name, version) -> concat+ [ "- "+ , packageNameString name+ , "-"+ , versionString version+ ]) (Map.toList extras)+ ++ ["", "You may also want to try the 'stack solver' command"]+ )+ where+ exceptions' = removeDuplicates exceptions+ appendExceptions = foldr (\e -> (++) ("\n\n--" ++ show e)) ""+ removeDuplicates = nub+ extras = Map.unions $ map getExtras exceptions'++ getExtras (DependencyCycleDetected _) = Map.empty+ getExtras (UnknownPackage _) = Map.empty+ getExtras (DependencyPlanFailures _ m) =+ Map.unions $ map go $ Map.toList m+ where+ go (name, (_range, Just version, NotInBuildPlan)) =+ Map.singleton name version+ go _ = Map.empty+ -- Supressing duplicate output+ show (CabalExitedUnsuccessfully exitCode taskProvides' execName fullArgs logFiles bs) =+ let fullCmd = (dropQuotes (show execName) ++ " " ++ (unwords fullArgs))+ logLocations = maybe "" (\fp -> "\n Logs have been written to: " ++ toFilePath fp) logFiles+ in "\n-- While building package " ++ dropQuotes (show taskProvides') ++ " using:\n" +++ " " ++ fullCmd ++ "\n" +++ " Process exited with code: " ++ show exitCode +++ logLocations +++ (if S.null bs+ then ""+ else "\n\n" ++ doubleIndent (T.unpack $ decodeUtf8With lenientDecode bs))+ where+ -- appendLines = foldr (\pName-> (++) ("\n" ++ show pName)) ""+ indent = dropWhileEnd isSpace . unlines . fmap (\line -> " " ++ line) . lines+ dropQuotes = filter ('\"' /=)+ doubleIndent = indent . indent+ show (ExecutionFailure es) = intercalate "\n\n" $ map show es+ show (LocalPackageDoesn'tMatchTarget name localV requestedV) = concat+ [ "Version for local package "+ , packageNameString name+ , " is "+ , versionString localV+ , ", but you asked for "+ , versionString requestedV+ , " on the command line"+ ]+ show (NoSetupHsFound dir) =+ "No Setup.hs or Setup.lhs file found in " ++ toFilePath dir+ show (InvalidFlagSpecification unused) = unlines+ $ "Invalid flag specification:"+ : map go (Set.toList unused)+ where+ showFlagSrc :: FlagSource -> String+ showFlagSrc FSCommandLine = " (specified on command line)"+ showFlagSrc FSStackYaml = " (specified in stack.yaml)"++ go :: UnusedFlags -> String+ go (UFNoPackage src name) = concat+ [ "- Package '"+ , packageNameString name+ , "' not found"+ , showFlagSrc src+ ]+ go (UFFlagsNotDefined src pkg flags) = concat+ [ "- Package '"+ , name+ , "' does not define the following flags"+ , showFlagSrc src+ , ":\n"+ , intercalate "\n"+ (map (\flag -> " " ++ flagNameString flag)+ (Set.toList flags))+ , "\n- Flags defined by package '" ++ name ++ "':\n"+ , intercalate "\n"+ (map (\flag -> " " ++ name ++ ":" ++ flagNameString flag)+ (Set.toList pkgFlags))+ ]+ where name = packageNameString (packageName pkg)+ pkgFlags = packageDefinedFlags pkg+ show (TargetParseException [err]) = "Error parsing targets: " ++ T.unpack err+ show (TargetParseException errs) = unlines+ $ "The following errors occurred while parsing the build targets:"+ : map (("- " ++) . T.unpack) errs++instance Exception StackBuildException++data ConstructPlanException+ = DependencyCycleDetected [PackageName]+ | DependencyPlanFailures PackageIdentifier (Map PackageName (VersionRange, LatestVersion, BadDependency))+ | UnknownPackage PackageName -- TODO perhaps this constructor will be removed, and BadDependency will handle it all+ -- ^ Recommend adding to extra-deps, give a helpful version number?+ deriving (Typeable, Eq)++-- | For display purposes only, Nothing if package not found+type LatestVersion = Maybe Version++-- | Reason why a dependency was not used+data BadDependency+ = NotInBuildPlan+ | Couldn'tResolveItsDependencies+ | DependencyMismatch Version+ deriving (Typeable, Eq)++instance Show ConstructPlanException where+ show e =+ let details = case e of+ (DependencyCycleDetected pNames) ->+ "While checking call stack,\n" +++ " dependency cycle detected in packages:" ++ indent (appendLines pNames)+ (DependencyPlanFailures pIdent (Map.toList -> pDeps)) ->+ "Failure when adding dependencies:" ++ doubleIndent (appendDeps pDeps) ++ "\n" +++ " needed for package: " ++ packageIdentifierString pIdent+ (UnknownPackage pName) ->+ "While attempting to add dependency,\n" +++ " Could not find package " ++ show pName ++ " in known packages"+ in indent details+ where+ appendLines = foldr (\pName-> (++) ("\n" ++ show pName)) ""+ indent = dropWhileEnd isSpace . unlines . fmap (\line -> " " ++ line) . lines+ doubleIndent = indent . indent+ appendDeps = foldr (\dep-> (++) ("\n" ++ showDep dep)) ""+ showDep (name, (range, mlatest, badDep)) = concat+ [ show name+ , ": needed ("+ , display range+ , ")"+ , case mlatest of+ Nothing -> ""+ Just latest -> ", latest is " ++ versionString latest+ , ", but "+ , case badDep of+ NotInBuildPlan -> "not present in build plan"+ Couldn'tResolveItsDependencies -> "couldn't resolve its dependencies"+ DependencyMismatch version -> versionString version ++ " found"+ ]+ {- TODO Perhaps change the showDep function to look more like this:+ dropQuotes = filter ((/=) '\"')+ (VersionOutsideRange pName pIdentifier versionRange) ->+ "Exception: Stack.Build.VersionOutsideRange\n" +++ " While adding dependency for package " ++ show pName ++ ",\n" +++ " " ++ dropQuotes (show pIdentifier) ++ " was found to be outside its allowed version range.\n" +++ " Allowed version range is " ++ display versionRange ++ ",\n" +++ " should you correct the version range for " ++ dropQuotes (show pIdentifier) ++ ", found in [extra-deps] in the project's stack.yaml?"+ -}+++----------------------------------------------++-- | Which subset of packages to build+data BuildSubset+ = BSAll+ | BSOnlySnapshot+ -- ^ Only install packages in the snapshot database, skipping+ -- packages intended for the local database.+ | BSOnlyDependencies+ deriving Show++-- | Configuration for building.+data BuildOpts =+ BuildOpts {boptsTargets :: ![Text]+ ,boptsLibProfile :: !Bool+ ,boptsExeProfile :: !Bool+ ,boptsEnableOptimizations :: !(Maybe Bool)+ ,boptsHaddock :: !Bool+ -- ^ Build haddocks?+ ,boptsHaddockDeps :: !(Maybe Bool)+ -- ^ Build haddocks for dependencies?+ ,boptsDryrun :: !Bool+ ,boptsGhcOptions :: ![Text]+ ,boptsFlags :: !(Map (Maybe PackageName) (Map FlagName Bool))+ ,boptsInstallExes :: !Bool+ -- ^ Install executables to user path after building?+ ,boptsPreFetch :: !Bool+ -- ^ Fetch all packages immediately+ ,boptsBuildSubset :: !BuildSubset+ ,boptsFileWatch :: !Bool+ -- ^ Watch files for changes and automatically rebuild+ ,boptsKeepGoing :: !(Maybe Bool)+ -- ^ Keep building/running after failure+ ,boptsForceDirty :: !Bool+ -- ^ Force treating all local packages as having dirty files++ ,boptsTests :: !Bool+ -- ^ Turn on tests for local targets+ ,boptsTestOpts :: !TestOpts+ -- ^ Additional test arguments++ ,boptsBenchmarks :: !Bool+ -- ^ Turn on benchmarks for local targets+ ,boptsBenchmarkOpts :: !BenchmarkOpts+ -- ^ Additional test arguments+ ,boptsExec :: ![(String, [String])]+ -- ^ Commands (with arguments) to run after a successful build+ }+ deriving (Show)++defaultBuildOpts :: BuildOpts+defaultBuildOpts = BuildOpts+ { boptsTargets = []+ , boptsLibProfile = False+ , boptsExeProfile = False+ , boptsEnableOptimizations = Nothing+ , boptsHaddock = False+ , boptsHaddockDeps = Nothing+ , boptsDryrun = False+ , boptsGhcOptions = []+ , boptsFlags = Map.empty+ , boptsInstallExes = False+ , boptsPreFetch = False+ , boptsBuildSubset = BSAll+ , boptsFileWatch = False+ , boptsKeepGoing = Nothing+ , boptsForceDirty = False+ , boptsTests = False+ , boptsTestOpts = defaultTestOpts+ , boptsBenchmarks = False+ , boptsBenchmarkOpts = defaultBenchmarkOpts+ , boptsExec = []+ }++-- | Options for the 'FinalAction' 'DoTests'+data TestOpts =+ TestOpts {toRerunTests :: !Bool -- ^ Whether successful tests will be run gain+ ,toAdditionalArgs :: ![String] -- ^ Arguments passed to the test program+ ,toCoverage :: !Bool -- ^ Generate a code coverage report+ ,toDisableRun :: !Bool -- ^ Disable running of tests+ } deriving (Eq,Show)++defaultTestOpts :: TestOpts+defaultTestOpts = TestOpts+ { toRerunTests = True+ , toAdditionalArgs = []+ , toCoverage = False+ , toDisableRun = False+ }++-- | Options for the 'FinalAction' 'DoBenchmarks'+data BenchmarkOpts =+ BenchmarkOpts {beoAdditionalArgs :: !(Maybe String) -- ^ Arguments passed to the benchmark program+ } deriving (Eq,Show)++defaultBenchmarkOpts :: BenchmarkOpts+defaultBenchmarkOpts = BenchmarkOpts+ { beoAdditionalArgs = Nothing+ }++-- | Package dependency oracle.+newtype PkgDepsOracle =+ PkgDeps PackageName+ deriving (Show,Typeable,Eq,Hashable,Binary,NFData)++-- | Stored on disk to know whether the flags have changed or any+-- files have changed.+data ConfigCache = ConfigCache+ { configCacheOpts :: ![S.ByteString]+ -- ^ All options used for this package.+ , configCacheDeps :: !(Set GhcPkgId)+ -- ^ The GhcPkgIds of all of the dependencies. Since Cabal doesn't take+ -- the complete GhcPkgId (only a PackageIdentifier) in the configure+ -- options, just using the previous value is insufficient to know if+ -- dependencies have changed.+ , configCacheComponents :: !(Set S.ByteString)+ -- ^ The components to be built. It's a bit of a hack to include this in+ -- here, as it's not a configure option (just a build option), but this+ -- is a convenient way to force compilation when the components change.+ , configCacheHaddock :: !Bool+ -- ^ Are haddocks to be built?+ }+ deriving (Generic,Eq,Show)+instance Binary ConfigCache+instance NFData ConfigCache where+ rnf = genericRnf++-- | A task to perform when building+data Task = Task+ { taskProvides :: !PackageIdentifier -- ^ the package/version to be built+ , taskType :: !TaskType -- ^ the task type, telling us how to build this+ , taskConfigOpts :: !TaskConfigOpts+ , taskPresent :: !(Set GhcPkgId) -- ^ GhcPkgIds of already-installed dependencies+ }+ deriving Show++-- | Given the IDs of any missing packages, produce the configure options+data TaskConfigOpts = TaskConfigOpts+ { tcoMissing :: !(Set PackageIdentifier)+ -- ^ Dependencies for which we don't yet have an GhcPkgId+ , tcoOpts :: !(Set GhcPkgId -> [Text])+ -- ^ Produce the list of options given the missing @GhcPkgId@s+ }+instance Show TaskConfigOpts where+ show (TaskConfigOpts missing f) = concat+ [ "Missing: "+ , show missing+ , ". Without those: "+ , show $ f Set.empty+ ]++-- | The type of a task, either building local code or something from the+-- package index (upstream)+data TaskType = TTLocal LocalPackage+ | TTUpstream Package InstallLocation+ deriving Show++taskLocation :: Task -> InstallLocation+taskLocation task =+ case taskType task of+ TTLocal _ -> Local+ TTUpstream _ loc -> loc++-- | A complete plan of what needs to be built and how to do it+data Plan = Plan+ { planTasks :: !(Map PackageName Task)+ , planFinals :: !(Map PackageName (Task, LocalPackageTB))+ -- ^ Final actions to be taken (test, benchmark, etc)+ , planUnregisterLocal :: !(Map GhcPkgId Text)+ -- ^ Text is reason we're unregistering, for display only+ , planInstallExes :: !(Map Text InstallLocation)+ -- ^ Executables that should be installed after successful building+ }+ deriving Show++-- | Basic information used to calculate what the configure options are+data BaseConfigOpts = BaseConfigOpts+ { bcoSnapDB :: !(Path Abs Dir)+ , bcoLocalDB :: !(Path Abs Dir)+ , bcoSnapInstallRoot :: !(Path Abs Dir)+ , bcoLocalInstallRoot :: !(Path Abs Dir)+ , bcoBuildOpts :: !BuildOpts+ }++-- | Render a @BaseConfigOpts@ to an actual list of options+configureOpts :: EnvConfig+ -> BaseConfigOpts+ -> Set GhcPkgId -- ^ dependencies+ -> Bool -- ^ wanted?+ -> InstallLocation+ -> Package+ -> [Text]+configureOpts econfig bco deps wanted loc package = map T.pack $ concat+ [ ["--user", "--package-db=clear", "--package-db=global"]+ , map (("--package-db=" ++) . toFilePath) $ case loc of+ Snap -> [bcoSnapDB bco]+ Local -> [bcoSnapDB bco, bcoLocalDB bco]+ , depOptions+ , [ "--libdir=" ++ toFilePathNoTrailingSlash (installRoot </> $(mkRelDir "lib"))+ , "--bindir=" ++ toFilePathNoTrailingSlash (installRoot </> bindirSuffix)+ , "--datadir=" ++ toFilePathNoTrailingSlash (installRoot </> $(mkRelDir "share"))+ , "--docdir=" ++ toFilePathNoTrailingSlash docDir+ , "--htmldir=" ++ toFilePathNoTrailingSlash docDir+ , "--haddockdir=" ++ toFilePathNoTrailingSlash docDir]+ , ["--enable-library-profiling" | boptsLibProfile bopts || boptsExeProfile bopts]+ , ["--enable-executable-profiling" | boptsExeProfile bopts]+ , map (\(name,enabled) ->+ "-f" <>+ (if enabled+ then ""+ else "-") <>+ flagNameString name)+ (Map.toList (packageFlags package))+ -- FIXME Chris: where does this come from now? , ["--ghc-options=-O2" | gconfigOptimize gconfig]+ , if wanted+ then concatMap (\x -> ["--ghc-options", T.unpack x]) (boptsGhcOptions bopts)+ else []+ , map (("--extra-include-dirs=" ++) . T.unpack) (Set.toList (configExtraIncludeDirs config))+ , map (("--extra-lib-dirs=" ++) . T.unpack) (Set.toList (configExtraLibDirs config))+ ]+ where+ config = getConfig econfig+ bopts = bcoBuildOpts bco+ toFilePathNoTrailingSlash = dropTrailingPathSeparator . toFilePath+ docDir =+ case pkgVerDir of+ Nothing -> installRoot </> docDirSuffix+ Just dir -> installRoot </> docDirSuffix </> dir+ installRoot =+ case loc of+ Snap -> bcoSnapInstallRoot bco+ Local -> bcoLocalInstallRoot bco+ pkgVerDir =+ parseRelDir (packageIdentifierString (PackageIdentifier (packageName package)+ (packageVersion package)) +++ [pathSeparator])++ depOptions = map toDepOption $ Set.toList deps+ where+ toDepOption =+ if envConfigCabalVersion econfig >= $(mkVersion "1.22")+ then toDepOption1_22+ else toDepOption1_18++ toDepOption1_22 gid = concat+ [ "--dependency="+ , packageNameString $ packageIdentifierName $ ghcPkgIdPackageIdentifier gid+ , "="+ , ghcPkgIdString gid+ ]++ toDepOption1_18 gid = concat+ [ "--constraint="+ , packageNameString name+ , "=="+ , versionString version+ ]+ where+ PackageIdentifier name version = ghcPkgIdPackageIdentifier gid++-- | Get set of wanted package names from locals.+wantedLocalPackages :: [LocalPackage] -> Set PackageName+wantedLocalPackages = Set.fromList . map (packageName . lpPackage) . filter lpWanted++-- | One-way conversion to serialized time.+modTime :: UTCTime -> ModTime+modTime x =+ ModTime+ ( toModifiedJulianDay+ (utctDay x)+ , toRational+ (utctDayTime x))++data Installed = Library GhcPkgId | Executable PackageIdentifier+ deriving (Show, Eq, Ord)
src/Stack/Types/BuildPlan.hs view
@@ -32,8 +32,7 @@ import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, withText, (.!=), (.:), (.:?), (.=))-import Data.Binary as Binary (Binary)-import Data.Binary.VersionTagged (BinarySchema (..))+import Data.Binary.VersionTagged import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as S8 import Data.Hashable (Hashable)@@ -241,7 +240,7 @@ -- | Name of an executable. newtype ExeName = ExeName { unExeName :: ByteString }- deriving (Show, Eq, Ord, Hashable, IsString, Generic)+ deriving (Show, Eq, Ord, Hashable, IsString, Generic, NFData) instance Binary ExeName instance ToJSON ExeName where toJSON = toJSON . S8.unpack . unExeName@@ -365,7 +364,9 @@ , mbpPackages :: !(Map PackageName MiniPackageInfo) } deriving (Generic, Show, Eq)-instance Binary.Binary MiniBuildPlan+instance Binary MiniBuildPlan+instance NFData MiniBuildPlan where+ rnf = genericRnf instance BinarySchema MiniBuildPlan where -- Don't forget to update this if you change the datatype in any way! binarySchema _ = 1@@ -386,7 +387,9 @@ -- ^ Is there a library present? } deriving (Generic, Show, Eq)-instance Binary.Binary MiniPackageInfo+instance Binary MiniPackageInfo+instance NFData MiniPackageInfo where+ rnf = genericRnf isWindows :: OS -> Bool
src/Stack/Types/Config.hs view
@@ -1,8 +1,10 @@ {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE RecordWildCards #-} -- | The Config type.@@ -13,9 +15,13 @@ import Control.Exception import Control.Monad (liftM, mzero) import Control.Monad.Catch (MonadThrow, throwM)+import Control.Monad.Logger (LogLevel(..)) import Control.Monad.Reader (MonadReader, ask, asks, MonadIO, liftIO)-import Data.Aeson.Extended (ToJSON, toJSON, FromJSON, parseJSON, withText, withObject, object- ,(.=), (.:?), (.!=), (.:), Value (String, Object))+import Data.Aeson.Extended+ (ToJSON, toJSON, FromJSON, parseJSON, withText, withObject, object,+ (.=), (.:), (..:), (..:?), (..!=), Value(String, Object),+ withObjectWarnings, WarningParser, Object, jsonSubWarnings, JSONWarning,+ jsonSubWarningsMT) import Data.Binary (Binary) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as S8@@ -23,9 +29,9 @@ import Data.Hashable (Hashable) import Data.Map (Map) import qualified Data.Map as Map+import Data.Monoid import Data.Set (Set) import qualified Data.Set as Set-import Data.Monoid import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8, decodeUtf8)@@ -33,13 +39,14 @@ import Data.Yaml (ParseException) import Distribution.System (Platform) import qualified Distribution.Text-import Distribution.Version (anyVersion, intersectVersionRanges)-import qualified Paths_stack as Meta+import Distribution.Version (anyVersion) import Network.HTTP.Client (parseUrl) import Path+import qualified Paths_stack as Meta import Stack.Types.BuildPlan (SnapName, renderSnapName, parseSnapName) import Stack.Types.Docker import Stack.Types.FlagName+import Stack.Types.Image import Stack.Types.PackageIdentifier import Stack.Types.PackageName import Stack.Types.Version@@ -103,6 +110,13 @@ -- ^ @ConfigMonoid@ used to generate this ,configConcurrentTests :: !Bool -- ^ Run test suites concurrently+ ,configImage :: !ImageOpts+ ,configAuthorEmail :: !(Maybe Text)+ -- ^ Email of the author using stack.+ ,configAuthorName :: !(Maybe Text)+ -- ^ Name of the author using stack.+ ,configScmInit :: !(Maybe SCM)+ -- ^ Initialize SCM (e.g. git) when creating new projects. } -- | Information on a single package index@@ -118,12 +132,12 @@ -- ^ Require that hashes and package size information be available for packages in this index } deriving Show-instance FromJSON PackageIndex where- parseJSON = withObject "PackageIndex" $ \o -> do- name <- o .: "name"- prefix <- o .: "download-prefix"- mgit <- o .:? "git"- mhttp <- o .:? "http"+instance FromJSON (PackageIndex, [JSONWarning]) where+ parseJSON = withObjectWarnings "PackageIndex" $ \o -> do+ name <- o ..: "name"+ prefix <- o ..: "download-prefix"+ mgit <- o ..:? "git"+ mhttp <- o ..:? "http" loc <- case (mgit, mhttp) of (Nothing, Nothing) -> fail $@@ -132,8 +146,8 @@ (Just git, Nothing) -> return $ ILGit git (Nothing, Just http) -> return $ ILHttp http (Just git, Just http) -> return $ ILGitHttp git http- gpgVerify <- o .:? "gpg-verify" .!= False- reqHashes <- o .:? "require-hashes" .!= False+ gpgVerify <- o ..:? "gpg-verify" ..!= False+ reqHashes <- o ..:? "require-hashes" ..!= False return PackageIndex { indexName = name , indexLocation = loc@@ -171,6 +185,42 @@ } deriving (Show, Eq, Ord) +data ExecOpts = ExecOpts+ { eoCmd :: !String+ , eoArgs :: ![String]+ , eoExtra :: !ExecOptsExtra+ }++data ExecOptsExtra+ = ExecOptsPlain+ | ExecOptsEmbellished+ { eoEnvSettings :: !EnvSettings+ , eoPackages :: ![String]+ }+-- | Parsed global command-line options.+data GlobalOpts = GlobalOpts+ { globalReExec :: !Bool+ , globalLogLevel :: !LogLevel -- ^ Log level+ , globalConfigMonoid :: !ConfigMonoid -- ^ Config monoid, for passing into 'loadConfig'+ , globalResolver :: !(Maybe AbstractResolver) -- ^ Resolver override+ , globalTerminal :: !Bool -- ^ We're in a terminal?+ , globalStackYaml :: !(Maybe FilePath) -- ^ Override project stack.yaml+ } deriving (Show)++-- | Either an actual resolver value, or an abstract description of one (e.g.,+-- latest nightly).+data AbstractResolver+ = ARLatestNightly+ | ARLatestLTS+ | ARLatestLTSMajor !Int+ | ARResolver !Resolver+ | ARGlobal+ deriving Show++-- | Default logging level should be something useful but not crazy.+defaultLogLevel :: LogLevel+defaultLogLevel = LevelInfo+ -- | A superset of 'Config' adding information on how to build code. The reason -- for this breakdown is because we will need some of the information from -- 'Config' in order to determine the values here.@@ -181,7 +231,7 @@ -- packages. , bcGhcVersionExpected :: !Version -- ^ Version of GHC we expected for this build- , bcPackages :: !(Map (Path Abs Dir) Bool)+ , bcPackageEntries :: ![PackageEntry] -- ^ Local packages identified by a path, Bool indicates whether it is -- a non-dependency (the opposite of 'peExtraDep') , bcExtraDeps :: !(Map PackageName Version)@@ -189,8 +239,6 @@ -- -- These dependencies will not be installed to a shared location, and -- will override packages provided by the resolver.- , bcRoot :: !(Path Abs Dir)- -- ^ Directory containing the project's stack.yaml file , bcStackYaml :: !(Path Abs File) -- ^ Location of the stack.yaml file. --@@ -198,13 +246,25 @@ -- different from bcRoot </> "stack.yaml" , bcFlags :: !(Map PackageName (Map FlagName Bool)) -- ^ Per-package flag overrides+ , bcImplicitGlobal :: !Bool+ -- ^ Are we loading from the implicit global stack.yaml? This is useful+ -- for providing better error messages. } +-- | Directory containing the project's stack.yaml file+bcRoot :: BuildConfig -> Path Abs Dir+bcRoot = parent . bcStackYaml++-- | Directory containing the project's stack.yaml file+bcWorkDir :: BuildConfig -> Path Abs Dir+bcWorkDir = (</> workDirRel) . parent . bcStackYaml+ -- | Configuration after the environment has been setup. data EnvConfig = EnvConfig {envConfigBuildConfig :: !BuildConfig ,envConfigCabalVersion :: !Version- ,envConfigGhcVersion :: !Version}+ ,envConfigGhcVersion :: !Version+ ,envConfigPackages :: !(Map (Path Abs Dir) Bool)} instance HasBuildConfig EnvConfig where getBuildConfig = envConfigBuildConfig instance HasConfig EnvConfig@@ -219,17 +279,12 @@ data LoadConfig m = LoadConfig { lcConfig :: !Config -- ^ Top-level Stack configuration.- , lcLoadBuildConfig :: !(Maybe Resolver -> NoBuildConfigStrategy -> m BuildConfig)+ , lcLoadBuildConfig :: !(Maybe AbstractResolver -> m BuildConfig) -- ^ Action to load the remaining 'BuildConfig'. , lcProjectRoot :: !(Maybe (Path Abs Dir)) -- ^ The project root directory, if in a project. } -data NoBuildConfigStrategy- = ThrowException- | ExecStrategy- deriving (Show, Eq, Ord)- data PackageEntry = PackageEntry { peExtraDepMaybe :: !(Maybe Bool) -- ^ Is this package a dependency? This means the local package will be@@ -265,20 +320,20 @@ , "location" .= peLocation pe , "subdirs" .= peSubdirs pe ]-instance FromJSON PackageEntry where+instance FromJSON (PackageEntry, [JSONWarning]) where parseJSON (String t) = do loc <- parseJSON $ String t- return PackageEntry- { peExtraDepMaybe = Nothing- , peValidWanted = Nothing- , peLocation = loc- , peSubdirs = []- }- parseJSON v = withObject "PackageEntry" (\o -> PackageEntry- <$> o .:? "extra-dep"- <*> o .:? "valid-wanted"- <*> o .: "location"- <*> o .:? "subdirs" .!= []) v+ return (PackageEntry+ { peExtraDepMaybe = Nothing+ , peValidWanted = Nothing+ , peLocation = loc+ , peSubdirs = []+ }, [])+ parseJSON v = withObjectWarnings "PackageEntry" (\o -> PackageEntry+ <$> o ..:? "extra-dep"+ <*> o ..:? "valid-wanted"+ <*> o ..: "location"+ <*> o ..:? "subdirs" ..!= []) v data PackageLocation = PLFilePath FilePath@@ -337,31 +392,45 @@ -- ^ Require a specific GHC major version, but otherwise provide no build -- plan. Intended for use cases where end user wishes to specify all upstream -- dependencies manually, such as using a dependency solver.++ | ResolverCustom !Text !Text+ -- ^ A custom resolver based on the given name and URL. This file is assumed+ -- to be completely immutable. deriving (Show) instance ToJSON Resolver where- toJSON = toJSON . renderResolver+ toJSON (ResolverSnapshot name) = toJSON $ renderSnapName name+ toJSON (ResolverGhc (MajorVersion x y)) = toJSON $ T.pack $ concat ["ghc-", show x, ".", show y]+ toJSON (ResolverCustom name location) = object+ [ "name" .= name+ , "location" .= location+ ] instance FromJSON Resolver where- parseJSON = withText "Resolver" $- either (fail . show) return . parseResolver+ -- Strange structuring is to give consistent error messages+ parseJSON v@(Object _) = withObject "Resolver" (\o -> ResolverCustom+ <$> o .: "name"+ <*> o .: "location") v --- | Convert a Resolver into its @Text@ representation, as will be used by JSON/YAML-renderResolver :: Resolver -> Text-renderResolver (ResolverSnapshot name) = renderSnapName name-renderResolver (ResolverGhc (MajorVersion x y)) = T.pack $ concat ["ghc-", show x, ".", show y]+ parseJSON (String t) = either (fail . show) return (parseResolverText t) --- | Try to parse a @Resolver@, using same format as JSON/YAML/'renderResolver'-parseResolver :: MonadThrow m => Text -> m Resolver-parseResolver t =- case parseSnapName t of- Right x -> return $ ResolverSnapshot x- Left _ ->- case parseGhc of- Just m -> return $ ResolverGhc m- Nothing -> throwM $ ParseResolverException t- where- parseGhc = T.stripPrefix "ghc-" t >>= parseMajorVersionFromString . T.unpack+ parseJSON _ = fail $ "Invalid Resolver, must be Object or String" +-- | Convert a Resolver into its @Text@ representation, as will be used by+-- directory names+resolverName :: Resolver -> Text+resolverName (ResolverSnapshot name) = renderSnapName name+resolverName (ResolverGhc (MajorVersion x y)) = T.pack $ concat ["ghc-", show x, ".", show y]+resolverName (ResolverCustom name _) = "custom-" <> name++-- | Try to parse a @Resolver@ from a @Text@. Won't work for complex resolvers (like custom).+parseResolverText :: MonadThrow m => Text -> m Resolver+parseResolverText t+ | Right x <- parseSnapName t = return $ ResolverSnapshot x+ | Just t' <- T.stripPrefix "ghc-" t+ , Just v <- parseMajorVersionFromString $ T.unpack t'+ = return $ ResolverGhc v+ | otherwise = throwM $ ParseResolverException t+ -- | Class for environment values which have access to the stack root class HasStackRoot env where getStackRoot :: env -> Path Abs Dir@@ -436,6 +505,16 @@ -- ^ See: 'configExtraLibDirs' ,configMonoidConcurrentTests :: !(Maybe Bool) -- ^ See: 'configConcurrentTests'+ ,configMonoidLocalBinPath :: !(Maybe FilePath)+ -- ^ Used to override the binary installation dir+ ,configMonoidImageOpts :: !ImageOptsMonoid+ -- ^ Image creation options.+ ,configMonoidAuthorEmail :: !(Maybe Text)+ -- ^ Author's email address.+ ,configMonoidAuthorName :: !(Maybe Text)+ -- ^ Author's name.+ ,configMonoidScmInit :: !(Maybe SCM)+ -- ^ Initialize SCM (e.g. git init) when making new projects? } deriving Show @@ -457,6 +536,11 @@ , configMonoidExtraIncludeDirs = Set.empty , configMonoidExtraLibDirs = Set.empty , configMonoidConcurrentTests = Nothing+ , configMonoidLocalBinPath = Nothing+ , configMonoidImageOpts = mempty+ , configMonoidAuthorEmail = mempty+ , configMonoidAuthorName = mempty+ , configMonoidScmInit = Nothing } mappend l r = ConfigMonoid { configMonoidDockerOpts = configMonoidDockerOpts l <> configMonoidDockerOpts r@@ -476,32 +560,46 @@ , configMonoidExtraIncludeDirs = Set.union (configMonoidExtraIncludeDirs l) (configMonoidExtraIncludeDirs r) , configMonoidExtraLibDirs = Set.union (configMonoidExtraLibDirs l) (configMonoidExtraLibDirs r) , configMonoidConcurrentTests = configMonoidConcurrentTests l <|> configMonoidConcurrentTests r+ , configMonoidLocalBinPath = configMonoidLocalBinPath l <|> configMonoidLocalBinPath r+ , configMonoidImageOpts = configMonoidImageOpts l <> configMonoidImageOpts r+ , configMonoidAuthorName = configMonoidAuthorName l <|> configMonoidAuthorName r+ , configMonoidAuthorEmail = configMonoidAuthorEmail l <|> configMonoidAuthorEmail r+ , configMonoidScmInit = configMonoidScmInit l <|> configMonoidScmInit r } -instance FromJSON ConfigMonoid where- parseJSON =- withObject "ConfigMonoid" $- \obj ->- do configMonoidDockerOpts <- obj .:? T.pack "docker" .!= mempty- configMonoidConnectionCount <- obj .:? "connection-count"- configMonoidHideTHLoading <- obj .:? "hide-th-loading"- configMonoidLatestSnapshotUrl <- obj .:? "latest-snapshot-url"- configMonoidPackageIndices <- obj .:? "package-indices"- configMonoidSystemGHC <- obj .:? "system-ghc"- configMonoidInstallGHC <- obj .:? "install-ghc"- configMonoidSkipGHCCheck <- obj .:? "skip-ghc-check"- configMonoidSkipMsys <- obj .:? "skip-msys"- configMonoidRequireStackVersion <- unVersionRangeJSON <$>- obj .:? "require-stack-version"- .!= VersionRangeJSON anyVersion- configMonoidOS <- obj .:? "os"- configMonoidArch <- obj .:? "arch"- configMonoidJobs <- obj .:? "jobs"- configMonoidExtraIncludeDirs <- obj .:? "extra-include-dirs" .!= Set.empty- configMonoidExtraLibDirs <- obj .:? "extra-lib-dirs" .!= Set.empty- configMonoidConcurrentTests <- obj .:? "concurrent-tests"- return ConfigMonoid {..}+instance FromJSON (ConfigMonoid, [JSONWarning]) where+ parseJSON = withObjectWarnings "ConfigMonoid" parseConfigMonoidJSON +-- | Parse a partial configuration. Used both to parse both a standalone config+-- file and a project file, so that a sub-parser is not required, which would interfere with+-- warnings for missing fields.+parseConfigMonoidJSON :: Object -> WarningParser ConfigMonoid+parseConfigMonoidJSON obj = do+ configMonoidDockerOpts <- jsonSubWarnings (obj ..:? "docker" ..!= mempty)+ configMonoidConnectionCount <- obj ..:? "connection-count"+ configMonoidHideTHLoading <- obj ..:? "hide-th-loading"+ configMonoidLatestSnapshotUrl <- obj ..:? "latest-snapshot-url"+ configMonoidPackageIndices <- jsonSubWarningsMT (obj ..:? "package-indices")+ configMonoidSystemGHC <- obj ..:? "system-ghc"+ configMonoidInstallGHC <- obj ..:? "install-ghc"+ configMonoidSkipGHCCheck <- obj ..:? "skip-ghc-check"+ configMonoidSkipMsys <- obj ..:? "skip-msys"+ configMonoidRequireStackVersion <- unVersionRangeJSON <$>+ obj ..:? "require-stack-version"+ ..!= VersionRangeJSON anyVersion+ configMonoidOS <- obj ..:? "os"+ configMonoidArch <- obj ..:? "arch"+ configMonoidJobs <- obj ..:? "jobs"+ configMonoidExtraIncludeDirs <- obj ..:? "extra-include-dirs" ..!= Set.empty+ configMonoidExtraLibDirs <- obj ..:? "extra-lib-dirs" ..!= Set.empty+ configMonoidConcurrentTests <- obj ..:? "concurrent-tests"+ configMonoidLocalBinPath <- obj ..:? "local-bin-path"+ configMonoidImageOpts <- jsonSubWarnings (obj ..:? "image" ..!= mempty)+ configMonoidAuthorName <- obj ..:? authorNameKey+ configMonoidAuthorEmail <- obj ..:? authorEmailKey+ configMonoidScmInit <- obj ..:? scmInitKey+ return ConfigMonoid {..}+ -- | Newtype for non-orphan FromJSON instance. newtype VersionRangeJSON = VersionRangeJSON { unVersionRangeJSON :: VersionRange } @@ -519,6 +617,7 @@ | UnexpectedTarballContents [Path Abs Dir] [Path Abs File] | BadStackVersionException VersionRange | NoMatchingSnapshot [SnapName]+ | NoSuchDirectory FilePath deriving Typeable instance Show ConfigException where show (ParseConfigFileException configFile exception) = concat@@ -568,6 +667,10 @@ , "\n\nYou can also try falling back to a dependency solver with:\n\n" , " stack init --solver" ]+ show (NoSuchDirectory dir) = concat+ ["No directory could be located matching the supplied path: "+ ,dir+ ] instance Exception ConfigException -- | Helper function to ask the environment and apply getConfig@@ -644,7 +747,7 @@ snapshots <- snapshotsDir bc <- asks getBuildConfig ec <- asks getEnvConfig- name <- parseRelDir $ T.unpack $ renderResolver $ bcResolver bc+ name <- parseRelDir $ T.unpack $ resolverName $ bcResolver bc ghc <- parseRelDir $ versionString $ envConfigGhcVersion ec return $ snapshots </> name </> ghc @@ -653,7 +756,7 @@ installationRootLocal = do bc <- asks getBuildConfig ec <- asks getEnvConfig- name <- parseRelDir $ T.unpack $ renderResolver $ bcResolver bc+ name <- parseRelDir $ T.unpack $ resolverName $ bcResolver bc ghc <- parseRelDir $ versionString $ envConfigGhcVersion ec platform <- platformRelDir return $ configProjectWorkDir bc </> $(mkRelDir "install") </> platform </> name </> ghc@@ -692,9 +795,13 @@ bindirSuffix = $(mkRelDir "bin") -- | Suffix applied to an installation root to get the doc dir-docdirSuffix :: Path Rel Dir-docdirSuffix = $(mkRelDir "doc")+docDirSuffix :: Path Rel Dir+docDirSuffix = $(mkRelDir "doc") +-- | Suffix applied to an installation root to get the hpc dir+hpcDirSuffix :: Path Rel Dir+hpcDirSuffix = $(mkRelDir "hpc")+ -- | Get the extra bin directories (for the PATH). Puts more local first -- -- Bool indicates whether or not to include the locals@@ -721,18 +828,18 @@ data ProjectAndConfigMonoid = ProjectAndConfigMonoid !Project !ConfigMonoid -instance FromJSON ProjectAndConfigMonoid where- parseJSON = withObject "Project, ConfigMonoid" $ \o -> do- dirs <- o .:? "packages" .!= [packageEntryCurrDir]- extraDeps' <- o .:? "extra-deps" .!= []+instance (warnings ~ [JSONWarning]) => FromJSON (ProjectAndConfigMonoid, warnings) where+ parseJSON = withObjectWarnings "ProjectAndConfigMonoid" $ \o -> do+ dirs <- jsonSubWarningsMT (o ..:? "packages") ..!= [packageEntryCurrDir]+ extraDeps' <- o ..:? "extra-deps" ..!= [] extraDeps <- case partitionEithers $ goDeps extraDeps' of ([], x) -> return $ Map.fromList x (errs, _) -> fail $ unlines errs - flags <- o .:? "flags" .!= mempty- resolver <- o .: "resolver"- config <- parseJSON $ Object o+ flags <- o ..:? "flags" ..!= mempty+ resolver <- o ..: "resolver"+ config <- parseConfigMonoidJSON o let project = Project { projectPackages = dirs , projectExtraDeps = extraDeps@@ -766,3 +873,29 @@ , peLocation = PLFilePath "." , peSubdirs = [] }++-- | A software control system.+data SCM = Git+ deriving (Show)++instance FromJSON SCM where+ parseJSON v = do+ s <- parseJSON v+ case s of+ "git" -> return Git+ _ -> fail ("Unknown or unsupported SCM: " <> s)++instance ToJSON SCM where+ toJSON Git = toJSON ("git" :: Text)++-- | Key used for the YAML file and templates.+authorEmailKey :: Text+authorEmailKey = "author-email"++-- | Key used for the YAML file and templates.+authorNameKey :: Text+authorNameKey = "author-name"++-- | Key used for the YAML file and templates.+scmInitKey :: Text+scmInitKey = "scm-init"
src/Stack/Types/Docker.hs view
@@ -36,8 +36,6 @@ -- ^ Arguments to pass directly to @docker run@. ,dockerMount :: ![Mount] -- ^ Volumes to mount in the container.- ,dockerPassHost :: !Bool- -- ^ Pass Docker daemon connection information into container. ,dockerDatabasePath :: !(Path Abs File) -- ^ Location of image usage database. }@@ -72,32 +70,29 @@ -- ^ Arguments to pass directly to @docker run@ ,dockerMonoidMount :: ![Mount] -- ^ Volumes to mount in the container- ,dockerMonoidPassHost :: !(Maybe Bool)- -- ^ Pass Docker daemon connection information into container. ,dockerMonoidDatabasePath :: !(Maybe String) -- ^ Location of image usage database. } deriving (Show) -- | Decode uninterpreted docker options from JSON/YAML.-instance FromJSON DockerOptsMonoid where- parseJSON = withObject "DockerOptsMonoid"+instance FromJSON (DockerOptsMonoid, [JSONWarning]) where+ parseJSON = withObjectWarnings "DockerOptsMonoid" (\o -> do dockerMonoidExists <- pure (Just True)- dockerMonoidEnable <- o .:? dockerEnableArgName- dockerMonoidRepoOrImage <- ((Just . DockerMonoidImage) <$> o .: dockerImageArgName) <|>- ((Just . DockerMonoidRepo) <$> o .: dockerRepoArgName) <|>+ dockerMonoidEnable <- o ..:? dockerEnableArgName+ dockerMonoidRepoOrImage <- ((Just . DockerMonoidImage) <$> o ..: dockerImageArgName) <|>+ ((Just . DockerMonoidRepo) <$> o ..: dockerRepoArgName) <|> pure Nothing- dockerMonoidRegistryLogin <- o .:? dockerRegistryLoginArgName- dockerMonoidRegistryUsername <- o .:? dockerRegistryUsernameArgName- dockerMonoidRegistryPassword <- o .:? dockerRegistryPasswordArgName- dockerMonoidAutoPull <- o .:? dockerAutoPullArgName- dockerMonoidDetach <- o .:? dockerDetachArgName- dockerMonoidPersist <- o .:? dockerPersistArgName- dockerMonoidContainerName <- o .:? dockerContainerNameArgName- dockerMonoidRunArgs <- o .:? dockerRunArgsArgName .!= []- dockerMonoidMount <- o .:? dockerMountArgName .!= []- dockerMonoidPassHost <- o .:? dockerPassHostArgName- dockerMonoidDatabasePath <- o .:? dockerDatabasePathArgName+ dockerMonoidRegistryLogin <- o ..:? dockerRegistryLoginArgName+ dockerMonoidRegistryUsername <- o ..:? dockerRegistryUsernameArgName+ dockerMonoidRegistryPassword <- o ..:? dockerRegistryPasswordArgName+ dockerMonoidAutoPull <- o ..:? dockerAutoPullArgName+ dockerMonoidDetach <- o ..:? dockerDetachArgName+ dockerMonoidPersist <- o ..:? dockerPersistArgName+ dockerMonoidContainerName <- o ..:? dockerContainerNameArgName+ dockerMonoidRunArgs <- o ..:? dockerRunArgsArgName ..!= []+ dockerMonoidMount <- o ..:? dockerMountArgName ..!= []+ dockerMonoidDatabasePath <- o ..:? dockerDatabasePathArgName return DockerOptsMonoid{..}) -- | Left-biased combine Docker options@@ -115,7 +110,6 @@ ,dockerMonoidContainerName = Nothing ,dockerMonoidRunArgs = [] ,dockerMonoidMount = []- ,dockerMonoidPassHost = Nothing ,dockerMonoidDatabasePath = Nothing } mappend l r = DockerOptsMonoid@@ -131,7 +125,6 @@ ,dockerMonoidContainerName = dockerMonoidContainerName l <|> dockerMonoidContainerName r ,dockerMonoidRunArgs = dockerMonoidRunArgs r <> dockerMonoidRunArgs l ,dockerMonoidMount = dockerMonoidMount r <> dockerMonoidMount l- ,dockerMonoidPassHost = dockerMonoidPassHost l <|> dockerMonoidPassHost r ,dockerMonoidDatabasePath = dockerMonoidDatabasePath l <|> dockerMonoidDatabasePath r } @@ -209,10 +202,6 @@ -- | Docker persist argument name. dockerPersistArgName :: Text dockerPersistArgName = "persist"---- | Docker pass host argument name.-dockerPassHostArgName :: Text-dockerPassHostArgName = "pass-host" -- | Docker database path argument name. dockerDatabasePathArgName :: Text
src/Stack/Types/FlagName.hs view
@@ -26,7 +26,7 @@ import Data.Aeson.Extended import Data.Attoparsec.ByteString.Char8 import Data.Attoparsec.Combinators-import Data.Binary (Binary)+import Data.Binary.VersionTagged import qualified Data.ByteString as S import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as S8@@ -54,7 +54,7 @@ -- | A flag name. newtype FlagName = FlagName ByteString- deriving (Typeable,Data,Generic,Hashable,Binary)+ deriving (Typeable,Data,Generic,Hashable,Binary,NFData) instance Eq FlagName where x == y = (compare x y) == EQ instance Ord FlagName where
src/Stack/Types/GhcPkgId.hs view
@@ -16,7 +16,7 @@ import Control.Monad.Catch import Data.Aeson.Extended import Data.Attoparsec.ByteString.Char8-import Data.Binary (Binary)+import Data.Binary.VersionTagged import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as S8 import Data.Char (isLetter)@@ -43,6 +43,8 @@ instance Hashable GhcPkgId instance Binary GhcPkgId+instance NFData GhcPkgId where+ rnf = genericRnf instance Show GhcPkgId where show = show . ghcPkgIdString
+ src/Stack/Types/Image.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Stack.Types.Image where++import Control.Applicative+import Data.Aeson.Extended+import Data.Monoid+import Data.Map (Map)+import Data.Text (Text)++-- | Image options. Currently only Docker image options.+data ImageOpts = ImageOpts+ { imgDocker :: !(Maybe ImageDockerOpts)+ -- ^ Maybe a section for docker image settings.+ } deriving (Show)++data ImageDockerOpts = ImageDockerOpts+ { imgDockerBase :: !(Maybe String)+ -- ^ Maybe have a docker base image name. (Although we will not+ -- be able to create any Docker images without this.)+ , imgDockerEntrypoints :: !(Maybe [String])+ -- ^ Maybe have a specific ENTRYPOINT list that will be used to+ -- create images.+ , imgDockerAdd :: !(Map FilePath FilePath)+ -- ^ Maybe have some static project content to include in a+ -- specific directory in all the images.+ , imgDockerImageName :: !(Maybe String)+ -- ^ Maybe have a name for the image we are creating+ } deriving (Show)++data ImageOptsMonoid = ImageOptsMonoid+ { imgMonoidDocker :: !(Maybe ImageDockerOptsMonoid)+ } deriving (Show)++data ImageDockerOptsMonoid = ImageDockerOptsMonoid+ { imgDockerMonoidBase :: !(Maybe String)+ , imgDockerMonoidEntrypoints :: !(Maybe [String])+ , imgDockerMonoidAdd :: !(Maybe (Map String FilePath))+ , imgDockerMonoidImageName :: !(Maybe String)+ } deriving (Show)++instance FromJSON (ImageOptsMonoid, [JSONWarning]) where+ parseJSON = withObjectWarnings+ "ImageOptsMonoid"+ (\o ->+ do imgMonoidDocker <- jsonSubWarningsT (o ..:? imgDockerArgName)+ return+ ImageOptsMonoid+ { ..+ })++instance Monoid ImageOptsMonoid where+ mempty = ImageOptsMonoid+ { imgMonoidDocker = Nothing+ }+ mappend l r = ImageOptsMonoid+ { imgMonoidDocker = imgMonoidDocker l <|> imgMonoidDocker r+ }++instance FromJSON (ImageDockerOptsMonoid, [JSONWarning]) where+ parseJSON = withObjectWarnings+ "ImageDockerOptsMonoid"+ (\o ->+ do imgDockerMonoidBase <- o ..:? imgDockerBaseArgName+ imgDockerMonoidEntrypoints <- o ..:?+ imgDockerEntrypointsArgName+ imgDockerMonoidAdd <- o ..:? imgDockerAddArgName+ imgDockerMonoidImageName <- o ..:? imgDockerImageNameArgName+ return+ ImageDockerOptsMonoid+ { ..+ })++instance Monoid ImageDockerOptsMonoid where+ mempty = ImageDockerOptsMonoid+ { imgDockerMonoidBase = Nothing+ , imgDockerMonoidEntrypoints = Nothing+ , imgDockerMonoidAdd = Nothing+ , imgDockerMonoidImageName = Nothing+ }+ mappend l r = ImageDockerOptsMonoid+ { imgDockerMonoidBase = imgDockerMonoidBase l <|> imgDockerMonoidBase r+ , imgDockerMonoidEntrypoints = imgDockerMonoidEntrypoints l <|> imgDockerMonoidEntrypoints+ r+ , imgDockerMonoidAdd = imgDockerMonoidAdd l <|> imgDockerMonoidAdd r+ , imgDockerMonoidImageName = imgDockerMonoidImageName l <|> imgDockerMonoidImageName r+ }++imgArgName :: Text+imgArgName = "image"++imgDockerArgName :: Text+imgDockerArgName = "container"++imgDockerBaseArgName :: Text+imgDockerBaseArgName = "base"++imgDockerAddArgName :: Text+imgDockerAddArgName = "add"++imgDockerEntrypointsArgName :: Text+imgDockerEntrypointsArgName = "entrypoints"++imgDockerImageNameArgName :: Text+imgDockerImageNameArgName = "name"
src/Stack/Types/Internal.hs view
@@ -13,6 +13,7 @@ Env {envConfig :: !config ,envLogLevel :: !LogLevel ,envTerminal :: !Bool+ ,envReExec :: !Bool ,envManager :: !Manager ,envSticky :: !Sticky} @@ -44,6 +45,12 @@ instance HasTerminal (Env config) where getTerminal = envTerminal++class HasReExec r where+ getReExec :: r -> Bool++instance HasReExec (Env config) where+ getReExec = envReExec newtype Sticky = Sticky { unSticky :: Maybe (MVar (Maybe Text))
+ src/Stack/Types/Package.hs view
@@ -0,0 +1,231 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+-- |++module Stack.Types.Package where++import Control.DeepSeq+import Control.Exception hiding (try,catch)+import Control.Monad.Catch+import Control.Monad.IO.Class+import Control.Monad.Logger (MonadLogger)+import Control.Monad.Reader+import Data.Binary+import Data.Binary.VersionTagged+import qualified Data.ByteString as S+import Data.Data+import Data.Function+import Data.List+import Data.Map.Strict (Map)+import Data.Maybe+import Data.Monoid+import Data.Set (Set)+import Data.Text (Text)+import Data.Text.Encoding (encodeUtf8)+import Distribution.InstalledPackageInfo (PError)+import Distribution.ModuleName (ModuleName)+import Distribution.Package hiding (Package,PackageName,packageName,packageVersion,PackageIdentifier)+import Distribution.System (Platform (..))+import GHC.Generics+import Path as FL+import Prelude+import Stack.Types.Config+import Stack.Types.FlagName+import Stack.Types.PackageName+import Stack.Types.Version++-- | All exceptions thrown by the library.+data PackageException+ = PackageInvalidCabalFile (Maybe (Path Abs File)) PError+ | PackageNoCabalFileFound (Path Abs Dir)+ | PackageMultipleCabalFilesFound (Path Abs Dir) [Path Abs File]+ | MismatchedCabalName (Path Abs File) PackageName+ deriving Typeable+instance Exception PackageException+instance Show PackageException where+ show (PackageInvalidCabalFile mfile err) =+ "Unable to parse cabal file" +++ (case mfile of+ Nothing -> ""+ Just file -> ' ' : toFilePath file) +++ ": " +++ show err+ show (PackageNoCabalFileFound dir) =+ "No .cabal file found in directory " +++ toFilePath dir+ show (PackageMultipleCabalFilesFound dir files) =+ "Multiple .cabal files found in directory " +++ toFilePath dir +++ ": " +++ intercalate ", " (map (toFilePath . filename) files)+ show (MismatchedCabalName fp name) = concat+ [ "cabal file "+ , toFilePath fp+ , " has a mismatched package name: "+ , packageNameString name+ ]++-- | Some package info.+data Package =+ Package {packageName :: !PackageName -- ^ Name of the package.+ ,packageVersion :: !Version -- ^ Version of the package+ ,packageFiles :: !GetPackageFiles -- ^ Get all files of the package.+ ,packageModules :: !GetPackageModules -- ^ Get the modules of the package.+ ,packageDeps :: !(Map PackageName VersionRange) -- ^ Packages that the package depends on.+ ,packageTools :: ![Dependency] -- ^ A build tool name.+ ,packageAllDeps :: !(Set PackageName) -- ^ Original dependencies (not sieved).+ ,packageFlags :: !(Map FlagName Bool) -- ^ Flags used on package.+ ,packageHasLibrary :: !Bool -- ^ does the package have a buildable library stanza?+ ,packageTests :: !(Set Text) -- ^ names of test suites+ ,packageBenchmarks :: !(Set Text) -- ^ names of benchmarks+ ,packageExes :: !(Set Text) -- ^ names of executables+ ,packageOpts :: !GetPackageOpts -- ^ Args to pass to GHC.+ ,packageHasExposedModules :: !Bool -- ^ Does the package have exposed modules?+ ,packageSimpleType :: !Bool -- ^ Does the package of build-type: Simple+ ,packageDefinedFlags :: !(Set FlagName) -- ^ All flags defined in the .cabal file+ }+ deriving (Show,Typeable)++-- | Files that the package depends on, relative to package directory.+-- Argument is the location of the .cabal file+newtype GetPackageOpts = GetPackageOpts+ { getPackageOpts :: forall env m. (MonadIO m,HasEnvConfig env, HasPlatform env, MonadThrow m, MonadReader env m)+ => SourceMap+ -> [PackageName]+ -> Path Abs File+ -> m [String]+ }+instance Show GetPackageOpts where+ show _ = "<GetPackageOpts>"++-- | Files that the package depends on, relative to package directory.+-- Argument is the location of the .cabal file+newtype GetPackageFiles = GetPackageFiles+ { getPackageFiles :: forall m env. (MonadIO m, MonadLogger m, MonadThrow m, MonadCatch m, MonadReader env m, HasPlatform env, HasEnvConfig env)+ => Path Abs File+ -> m (Set (Path Abs File))+ }+instance Show GetPackageFiles where+ show _ = "<GetPackageFiles>"++-- | Modules in the package.+newtype GetPackageModules = GetPackageModules+ { getPackageModules :: forall m env. (MonadIO m, MonadLogger m, MonadThrow m, MonadCatch m, MonadReader env m, HasPlatform env, HasEnvConfig env)+ => Path Abs File+ -> m (Set ModuleName)+ }+instance Show GetPackageModules where+ show _ = "<GetPackageModules>"++-- | Package build configuration+data PackageConfig =+ PackageConfig {packageConfigEnableTests :: !Bool -- ^ Are tests enabled?+ ,packageConfigEnableBenchmarks :: !Bool -- ^ Are benchmarks enabled?+ ,packageConfigFlags :: !(Map FlagName Bool) -- ^ Package config flags.+ ,packageConfigGhcVersion :: !Version -- ^ GHC version+ ,packageConfigPlatform :: !Platform -- ^ host platform+ }+ deriving (Show,Typeable)++-- | Compares the package name.+instance Ord Package where+ compare = on compare packageName++-- | Compares the package name.+instance Eq Package where+ (==) = on (==) packageName++type SourceMap = Map PackageName PackageSource++-- | Where the package's source is located: local directory or package index+data PackageSource+ = PSLocal LocalPackage+ | PSUpstream Version InstallLocation (Map FlagName Bool)+ -- ^ Upstream packages could be installed in either local or snapshot+ -- databases; this is what 'InstallLocation' specifies.+ deriving Show++instance PackageInstallInfo PackageSource where+ piiVersion (PSLocal lp) = packageVersion $ lpPackage lp+ piiVersion (PSUpstream v _ _) = v++ piiLocation (PSLocal _) = Local+ piiLocation (PSUpstream _ loc _) = loc++-- | Datatype which tells how which version of a package to install and where+-- to install it into+class PackageInstallInfo a where+ piiVersion :: a -> Version+ piiLocation :: a -> InstallLocation++-- | Second-stage build information: tests and benchmarks+data LocalPackageTB = LocalPackageTB+ { lptbPackage :: !Package+ -- ^ Package resolved with dependencies for tests and benchmarks, depending+ -- on which components are active+ , lptbTests :: !(Set Text)+ -- ^ Test components+ , lptbBenches :: !(Set Text)+ -- ^ Benchmark components+ }+ deriving Show++-- | Information on a locally available package of source code+data LocalPackage = LocalPackage+ { lpPackage :: !Package -- ^ The @Package@ info itself, after resolution with package flags, not including any tests or benchmarks+ , lpExeComponents :: !(Maybe (Set Text)) -- ^ Executable components to build, Nothing if not a target++ , lpTestBench :: !(Maybe LocalPackageTB)++ , lpDir :: !(Path Abs Dir) -- ^ Directory of the package.+ , lpCabalFile :: !(Path Abs File) -- ^ The .cabal file+ , lpDirtyFiles :: !Bool -- ^ are there files that have changed since the last build?+ , lpNewBuildCache :: !(Map FilePath FileCacheInfo) -- ^ current state of the files+ , lpFiles :: !(Set (Path Abs File)) -- ^ all files used by this package+ , lpComponents :: !(Set NamedComponent)+ }+ deriving Show++-- | Is the given local a target+lpWanted :: LocalPackage -> Bool+lpWanted lp = isJust (lpExeComponents lp) || isJust (lpTestBench lp)++-- | A single, fully resolved component of a package+data NamedComponent+ = CLib+ | CExe !Text+ | CTest !Text+ | CBench !Text+ deriving (Show, Eq, Ord)++renderComponent :: NamedComponent -> S.ByteString+renderComponent CLib = "lib"+renderComponent (CExe x) = "exe:" <> encodeUtf8 x+renderComponent (CTest x) = "test:" <> encodeUtf8 x+renderComponent (CBench x) = "bench:" <> encodeUtf8 x++-- | A location to install a package into, either snapshot or local+data InstallLocation = Snap | Local+ deriving (Show, Eq)+instance Monoid InstallLocation where+ mempty = Snap+ mappend Local _ = Local+ mappend _ Local = Local+ mappend Snap Snap = Snap++data FileCacheInfo = FileCacheInfo+ { fciModTime :: !ModTime+ , fciSize :: !Word64+ , fciHash :: !S.ByteString+ }+ deriving (Generic, Show)+instance Binary FileCacheInfo+instance NFData FileCacheInfo where+ rnf = genericRnf++-- | Used for storage and comparison.+newtype ModTime = ModTime (Integer,Rational)+ deriving (Ord,Show,Generic,Eq,NFData,Binary)
src/Stack/Types/PackageName.hs view
@@ -20,7 +20,8 @@ ,fromCabalPackageName ,toCabalPackageName ,parsePackageNameFromFilePath- ,mkPackageName)+ ,mkPackageName+ ,packageNameArgument) where import Control.Applicative@@ -45,6 +46,7 @@ import Language.Haskell.TH import Language.Haskell.TH.Syntax import Path+import qualified Options.Applicative as O -- | A parse fail. data PackageNameParseFail@@ -150,3 +152,17 @@ fmap Map.fromList $ mapM go $ Map.toList m where go (k, v) = fmap (, v) $ either (fail . show) return $ parsePackageNameFromString k++-- | An argument which accepts a template name of the format+-- @foo.hsfiles@.+packageNameArgument :: O.Mod O.ArgumentFields PackageName+ -> O.Parser PackageName+packageNameArgument =+ O.argument+ (do s <- O.str+ either O.readerError return (p s))+ where+ p s =+ case parsePackageNameFromString s of+ Just x -> Right x+ Nothing -> Left ("Expected valid package name, but got: " ++ s)
src/Stack/Types/StackT.hs view
@@ -8,6 +8,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | The monad used for the command-line executable @stack@.@@ -16,7 +17,9 @@ (StackT ,StackLoggingT ,runStackT+ ,runStackTGlobal ,runStackLoggingT+ ,runStackLoggingTGlobal ,newTLSManager ,logSticky ,logStickyDone)@@ -45,6 +48,7 @@ import Network.HTTP.Conduit import Prelude -- Fix AMP warning import Stack.Types.Internal+import Stack.Types.Config (GlobalOpts (..)) import System.IO import System.Log.FastLogger @@ -79,16 +83,22 @@ instance (MonadIO m) => MonadLogger (StackT config m) where monadLoggerLog = stickyLoggerFunc +-- | Run a Stack action, using global options.+runStackTGlobal :: (MonadIO m,MonadBaseControl IO m)+ => Manager -> config -> GlobalOpts -> StackT config m a -> m a+runStackTGlobal manager config GlobalOpts{..} m =+ runStackT manager globalLogLevel config globalTerminal globalReExec m+ -- | Run a Stack action. runStackT :: (MonadIO m,MonadBaseControl IO m)- => Manager -> LogLevel -> config -> Bool -> StackT config m a -> m a-runStackT manager logLevel config terminal m =+ => Manager -> LogLevel -> config -> Bool -> Bool -> StackT config m a -> m a+runStackT manager logLevel config terminal reExec m = withSticky terminal (\sticky -> runReaderT (unStackT m)- (Env config logLevel terminal manager sticky))+ (Env config logLevel terminal reExec manager sticky)) -------------------------------------------------------------------------------- -- Logging only StackLoggingT monad transformer@@ -97,6 +107,7 @@ data LoggingEnv = LoggingEnv { lenvLogLevel :: !LogLevel , lenvTerminal :: !Bool+ , lenvReExec :: !Bool , lenvManager :: !Manager , lenvSticky :: !Sticky }@@ -135,10 +146,19 @@ instance HasTerminal LoggingEnv where getTerminal = lenvTerminal +instance HasReExec LoggingEnv where+ getReExec = lenvReExec++-- | Run the logging monad, using global options.+runStackLoggingTGlobal :: MonadIO m+ => Manager -> GlobalOpts -> StackLoggingT m a -> m a+runStackLoggingTGlobal manager GlobalOpts{..} m =+ runStackLoggingT manager globalLogLevel globalTerminal globalReExec m+ -- | Run the logging monad. runStackLoggingT :: MonadIO m- => Manager -> LogLevel -> Bool -> StackLoggingT m a -> m a-runStackLoggingT manager logLevel terminal m =+ => Manager -> LogLevel -> Bool -> Bool -> StackLoggingT m a -> m a+runStackLoggingT manager logLevel terminal reExec m = withSticky terminal (\sticky ->@@ -149,6 +169,7 @@ , lenvManager = manager , lenvSticky = sticky , lenvTerminal = terminal+ , lenvReExec = reExec }) -- | Convenience for getting a 'Manager'@@ -224,8 +245,9 @@ do maxLogLevel <- asks getLogLevel when (level >= maxLogLevel) (liftIO (do out <- getOutput maxLogLevel- S8.putStrLn (S8.pack out)))- where getOutput maxLogLevel =+ S8.hPutStrLn outputChannel (S8.pack out)))+ where outputChannel = stderr+ getOutput maxLogLevel = do date <- getDate l <- getLevel lc <- getLoc
+ src/Stack/Types/TemplateName.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- | Template name handling.++module Stack.Types.TemplateName where++import Data.Monoid+import Data.Text (Text)+import qualified Data.Text as T+import Language.Haskell.TH+import qualified Options.Applicative as O+import Path+import Path.Internal++-- | A template name of the format @foo.hsfiles@.+data TemplateName = TemplateName !Text !(Path Rel File)+ deriving (Ord,Eq,Show)++-- | An argument which accepts a template name of the format+-- @foo.hsfiles@ or @foo@, ultimately normalized to @foo.hsfiles@.+templateNameArgument :: O.Mod O.ArgumentFields TemplateName+ -> O.Parser TemplateName+templateNameArgument =+ O.argument+ (do string <- O.str+ either O.readerError return (parseTemplateNameFromString string))++-- | Parse a template name from a string.+parseTemplateNameFromString :: String -> Either String TemplateName+parseTemplateNameFromString fname =+ case T.stripSuffix ".hsfiles" (T.pack fname) of+ Nothing -> parseValidFile (T.pack fname) (fname <> ".hsfiles")+ Just prefix -> parseValidFile prefix fname+ where+ parseValidFile prefix str =+ case parseRelFile str of+ Nothing -> Left expected+ Just fp -> return (TemplateName prefix fp)+ expected = "Expected a template filename like: foo or foo.hsfiles"+++-- | Make a template name.+mkTemplateName :: String -> Q Exp+mkTemplateName s =+ case parseTemplateNameFromString s of+ Left{} -> error ("Invalid template name: " ++ show s)+ Right (TemplateName (T.unpack -> prefix) (Path pn)) ->+ [|TemplateName (T.pack prefix) (Path pn)|]++-- | Get a text representation of the template name.+templateName :: TemplateName -> Text+templateName (TemplateName prefix _) = prefix++-- | Get the path of the template.+templatePath :: TemplateName -> Path Rel File+templatePath (TemplateName _ fp) = fp
src/Stack/Types/Version.hs view
@@ -24,7 +24,8 @@ ,fromCabalVersion ,mkVersion ,versionRangeText- ,withinRange)+ ,withinRange+ ,Stack.Types.Version.intersectVersionRanges) where import Control.Applicative@@ -201,3 +202,7 @@ -- | Check if a version is within a version range. withinRange :: Version -> Cabal.VersionRange -> Bool withinRange v r = toCabalVersion v `Cabal.withinRange` r++-- | A modified intersection which also simplifies, for better display.+intersectVersionRanges :: Cabal.VersionRange -> Cabal.VersionRange -> Cabal.VersionRange+intersectVersionRanges x y = Cabal.simplifyVersionRange $ Cabal.intersectVersionRanges x y
src/Stack/Upgrade.hs view
@@ -16,7 +16,7 @@ import Path import qualified Paths_stack as Paths import Stack.Build-import Stack.Build.Types+import Stack.Types.Build import Stack.Config import Stack.Fetch import Stack.PackageIndex@@ -27,9 +27,9 @@ import System.IO.Temp (withSystemTempDirectory) import System.Process.Run -upgrade :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, HasTerminal env, HasLogLevel env, MonadBaseControl IO m)+upgrade :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, HasTerminal env, HasReExec env, HasLogLevel env, MonadBaseControl IO m) => Bool -- ^ use Git?- -> Maybe Resolver+ -> Maybe AbstractResolver -> m () upgrade fromGit mresolver = withSystemTempDirectory "stack-upgrade" $ \tmp' -> do menv <- getMinimalEnvOverride@@ -40,7 +40,7 @@ $logInfo "Cloning stack" runIn tmp "git" menv [ "clone"- , "git@github.com:commercialhaskell/stack" -- TODO allow to be configured+ , "https://github.com/commercialhaskell/stack" -- TODO allow to be configured , "stack" , "--depth" , "1"@@ -75,16 +75,18 @@ manager <- asks getHttpManager logLevel <- asks getLogLevel terminal <- asks getTerminal+ reExec <- asks getReExec configMonoid <- asks $ configConfigMonoid . getConfig forM_ mdir $ \dir -> liftIO $ do- bconfig <- runStackLoggingT manager logLevel terminal $ do+ bconfig <- runStackLoggingT manager logLevel terminal reExec $ do lc <- loadConfig configMonoid (Just $ dir </> $(mkRelFile "stack.yaml"))- lcLoadBuildConfig lc mresolver ThrowException- envConfig1 <- runStackT manager logLevel bconfig terminal setupEnv- runStackT manager logLevel envConfig1 terminal $ build (const $ return ()) defaultBuildOpts+ lcLoadBuildConfig lc mresolver+ envConfig1 <- runStackT manager logLevel bconfig terminal reExec setupEnv+ runStackT manager logLevel envConfig1 terminal reExec $+ build (const $ return ()) Nothing defaultBuildOpts { boptsTargets = ["stack"] , boptsInstallExes = True }
src/Stack/Upload.hs view
@@ -7,6 +7,7 @@ mkUploader , Uploader , upload+ , uploadBytes , UploadSettings , defaultUploadSettings , setUploadUrl@@ -44,6 +45,7 @@ import Data.Typeable (Typeable) import Network.HTTP.Client (BodyReader, Manager, Response,+ RequestBody(RequestBodyLBS), applyBasicAuth, brRead, checkStatus, newManager, parseUrl,@@ -51,26 +53,16 @@ responseBody, responseStatus, withResponse)-import Network.HTTP.Client.MultipartFormData (formDataBody, partFile)+import Network.HTTP.Client.MultipartFormData (formDataBody, partFileRequestBody) import Network.HTTP.Client.TLS (tlsManagerSettings) import Network.HTTP.Types (statusCode) import Path (toFilePath) import Stack.Types import System.Directory (createDirectoryIfMissing,- doesDirectoryExist,- doesFileExist,- getDirectoryContents, removeFile)-import System.Exit (ExitCode (ExitSuccess))-import System.FilePath (takeExtension, (</>))-import System.IO (hClose, hFlush,- hGetEcho, hSetEcho,+import System.FilePath ((</>), takeFileName)+import System.IO (hFlush, hGetEcho, hSetEcho, stdin, stdout)-import System.IO.Temp (withSystemTempDirectory)-import System.Process (StdStream (CreatePipe),- createProcess, cwd,- proc, std_in,- waitForProcess) -- | Username and password to log into Hackage. --@@ -202,14 +194,14 @@ , checkStatus = \_ _ _ -> Nothing } return Uploader- { upload_ = \fp0 -> withTarball fp0 $ \fp -> do- let formData = [partFile "package" fp]+ { upload_ = \tarName bytes -> do+ let formData = [partFileRequestBody "package" tarName (RequestBodyLBS bytes)] req2 <- formDataBody formData req1 let req3 = applyBasicAuth (encodeUtf8 $ hcUsername creds) (encodeUtf8 $ hcPassword creds) req2- putStr $ "Uploading " ++ fp ++ "... "+ putStr $ "Uploading " ++ tarName ++ "... " hFlush stdout withResponse req3 manager $ \res -> case statusCode $ responseStatus res of@@ -232,39 +224,9 @@ code -> do putStrLn $ "unhandled status code: " ++ show code printBody res- error $ "Upload failed on " ++ fp+ error $ "Upload failed on " ++ tarName } --- | Given either a file, return it. Given a directory, run @cabal sdist@ and--- get the resulting tarball.-withTarball :: FilePath -> (FilePath -> IO a) -> IO a-withTarball fp0 inner = do- isFile <- doesFileExist fp0- if isFile then inner fp0 else withSystemTempDirectory "stackage-upload-tarball" $ \dir -> do- isDir <- doesDirectoryExist fp0- when (not isDir) $ error $ "Invalid argument: " ++ fp0-- (Just h, Nothing, Nothing, ph) <-- -- The insanity: the Cabal library seems to sometimes generate tarballs- -- in the wrong format. For now, just falling back to cabal-install.- -- Sigh.-- createProcess $ (proc "cabal"- [ "sdist"- , "--builddir=" ++ dir- ])- { cwd = Just fp0- , std_in = CreatePipe- }- hClose h- ec <- waitForProcess ph- when (ec /= ExitSuccess) $- error $ "Could not create tarball for " ++ fp0- contents <- getDirectoryContents dir- case filter ((== ".gz") . takeExtension) contents of- [x] -> inner (dir </> x)- _ -> error $ "Unexpected directory contents after cabal sdist: " ++ show contents- printBody :: Response BodyReader -> IO () printBody res = loop@@ -281,14 +243,21 @@ -- -- Since 0.1.0.0 data Uploader = Uploader- { upload_ :: !(FilePath -> IO ())+ { upload_ :: !(String -> L.ByteString -> IO ()) } -- | Upload a single tarball with the given @Uploader@. -- -- Since 0.1.0.0 upload :: Uploader -> FilePath -> IO ()-upload = upload_+upload uploader fp = upload_ uploader (takeFileName fp) =<< L.readFile fp++-- | Upload a single tarball with the given @Uploader@. Instead of+-- sending a file like 'upload', this sends a lazy bytestring.+--+-- Since 0.1.2.1+uploadBytes :: Uploader -> String -> L.ByteString -> IO ()+uploadBytes = upload_ -- | Settings for creating an @Uploader@. --
src/System/Process/Read.hs view
@@ -59,8 +59,9 @@ import Data.Typeable (Typeable) import Distribution.System (OS (Windows, OtherOS), Platform (Platform)) import Path (Path, Abs, Dir, toFilePath, File, parseAbsFile)+import Path.IO (createTree) import Prelude -- Fix AMP warning-import System.Directory (createDirectoryIfMissing, doesFileExist, getCurrentDirectory)+import System.Directory (doesFileExist, getCurrentDirectory) import System.Environment (getEnvironment) import System.Exit import qualified System.FilePath as FP@@ -267,8 +268,12 @@ -- executable path. preProcess :: (MonadIO m) => Maybe (Path Abs Dir) -> EnvOverride -> String -> m FilePath preProcess wd menv name = do- name' <- liftIO $ liftM toFilePath $ join $ findExecutable menv name- liftIO (maybe (return ()) (createDirectoryIfMissing True . toFilePath) wd)+ exists <- liftIO $ doesFileExist name+ name' <-+ if exists+ then return name+ else liftIO $ liftM toFilePath $ join $ findExecutable menv name+ maybe (return ()) createTree wd return name' -- | Check if the given executable exists on the given PATH
src/System/Process/Run.hs view
@@ -4,15 +4,19 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-} -- | Reading from external processes. module System.Process.Run (runIn- ,callProcess)+ ,callProcess+ ,callProcess'+ ,ProcessExitedUnsuccessfully) where -import Control.Exception+import Control.Exception.Lifted+import Control.Monad.Trans.Control (MonadBaseControl) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Logger (MonadLogger, logError) import Data.Conduit.Process hiding (callProcess)@@ -29,7 +33,7 @@ -- and stderr. If it exits with anything but success, prints an error -- and then calls 'exitWith' to exit the program. runIn :: forall (m :: * -> *).- (MonadLogger m,MonadIO m)+ (MonadLogger m,MonadIO m,MonadBaseControl IO m) => Path Abs Dir -- ^ directory to run in -> FilePath -- ^ command to run -> EnvOverride@@ -37,7 +41,7 @@ -> Maybe Text -> m () runIn wd cmd menv args errMsg = do- result <- liftIO (try (callProcess (Just wd) menv cmd args))+ result <- try (callProcess (Just wd) menv cmd args) case result of Left (ProcessExitedUnsuccessfully _ ec) -> do $logError $@@ -56,20 +60,34 @@ -- | Like as @System.Process.callProcess@, but takes an optional working directory and -- environment override, and throws ProcessExitedUnsuccessfully if the -- process exits unsuccessfully. Inherits stdout and stderr.-callProcess :: (MonadIO m)- => Maybe (Path Abs Dir)+callProcess :: (MonadIO m, MonadLogger m)+ => Maybe (Path Abs Dir)+ -> EnvOverride+ -> String+ -> [String]+ -> m ()+callProcess =+ callProcess' id++-- | Like as @System.Process.callProcess@, but takes an optional working directory and+-- environment override, and throws ProcessExitedUnsuccessfully if the+-- process exits unsuccessfully. Inherits stdout and stderr.+callProcess' :: (MonadIO m, MonadLogger m)+ => (CreateProcess -> CreateProcess)+ -> Maybe (Path Abs Dir) -> EnvOverride -> String -> [String] -> m ()-callProcess wd menv cmd0 args = do+callProcess' modCP wd menv cmd0 args = do cmd <- preProcess wd menv cmd0- let c = (proc cmd args) { delegate_ctlc = True- , cwd = fmap toFilePath wd- , env = envHelper menv }+ let c = modCP $ (proc cmd args) { delegate_ctlc = True+ , cwd = fmap toFilePath wd+ , env = envHelper menv } action (_, _, _, p) = do exit_code <- waitForProcess p case exit_code of ExitSuccess -> return () ExitFailure _ -> throwIO (ProcessExitedUnsuccessfully c exit_code)+ $logProcessRun cmd args liftIO (System.Process.createProcess c >>= action)
src/main/Main.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-}@@ -10,34 +11,38 @@ module Main where import Control.Exception+import qualified Control.Exception.Lifted as EL import Control.Monad import Control.Monad.IO.Class import Control.Monad.Logger-import Control.Monad.Reader (ask)+import Control.Monad.Reader (ask, asks)+import Control.Monad.Trans.Control (MonadBaseControl) import Data.Attoparsec.Args (withInterpreterArgs)-import Data.Char (toLower)+import qualified Data.ByteString.Lazy as L+import Data.IORef import Data.List import qualified Data.List as List-import Data.Map (Map) import qualified Data.Map as Map+import qualified Data.Map.Strict as M import Data.Maybe import Data.Monoid import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as T-import Data.Traversable+import Data.Traversable (sequenceA) import Network.HTTP.Client import Options.Applicative.Args import Options.Applicative.Builder.Extra import Options.Applicative.Simple import Options.Applicative.Types (readerAsk) import Path+import Path.IO import qualified Paths_stack as Meta import Plugins import Prelude hiding (pi) import Stack.Build-import Stack.Build.Types+import Stack.Types.Build import Stack.Config import Stack.Constants import qualified Stack.Docker as Docker@@ -45,11 +50,15 @@ import Stack.Exec import Stack.Fetch import Stack.FileWatch+import Stack.Ide+import qualified Stack.Image as Image import Stack.Init import Stack.New+import Stack.Options+import Stack.Package (getCabalFileName) import qualified Stack.PackageIndex-import Stack.Repl-import Stack.Ide+import Stack.Ghci+import Stack.SDist (getSDistTarball) import Stack.Setup import Stack.Solver (solveExtraDeps) import Stack.Types@@ -57,17 +66,69 @@ import Stack.Types.StackT import Stack.Upgrade import qualified Stack.Upload as Upload-import System.Directory (canonicalizePath)+import System.Directory (canonicalizePath, doesFileExist, doesDirectoryExist, createDirectoryIfMissing) import System.Environment (getArgs, getProgName) import System.Exit-import System.FilePath (searchPathSeparator,dropTrailingPathSeparator)+import System.FileLock (lockFile, tryLockFile, unlockFile, SharedExclusive(Exclusive), FileLock)+import System.FilePath (dropTrailingPathSeparator) import System.IO (hIsTerminalDevice, stderr, stdin, stdout, hSetBuffering, BufferMode(..)) import System.Process.Read +#if WINDOWS+import System.Win32.Console (setConsoleCP, setConsoleOutputCP, getConsoleCP, getConsoleOutputCP)+import System.IO (hSetEncoding, utf8, hPutStrLn)+#endif++-- | Set the code page for this process as necessary. Only applies to Windows.+-- See: https://github.com/commercialhaskell/stack/issues/738+fixCodePage :: IO a -> IO a+#if WINDOWS+fixCodePage inner = do+ origCPI <- getConsoleCP+ origCPO <- getConsoleOutputCP++ let setInput = origCPI /= expected+ setOutput = origCPO /= expected+ fixInput+ | setInput = bracket_+ (do+ setConsoleCP expected+ hSetEncoding stdin utf8+ )+ (setConsoleCP origCPI)+ | otherwise = id+ fixOutput+ | setInput = bracket_+ (do+ setConsoleOutputCP expected+ hSetEncoding stdout utf8+ hSetEncoding stderr utf8+ )+ (setConsoleOutputCP origCPO)+ | otherwise = id++ case (setInput, setOutput) of+ (False, False) -> return ()+ (True, True) -> warn ""+ (True, False) -> warn " input"+ (False, True) -> warn " output"++ fixInput $ fixOutput inner+ where+ expected = 65001 -- UTF-8+ warn typ = hPutStrLn stderr $ concat+ [ "Setting"+ , typ+ , " codepage to UTF-8 (65001) to ensure correct output from GHC"+ ]+#else+fixCodePage = id+#endif+ -- | Commandline dispatcher. main :: IO ()-main = withInterpreterArgs stackProgName $ \args isInterpreter ->- do -- Line buffer the output by default, particularly for non-terminal runs.+main = withInterpreterArgs stackProgName $ \args isInterpreter -> do+ -- Line buffer the output by default, particularly for non-terminal runs. -- See https://github.com/commercialhaskell/stack/pull/360 hSetBuffering stdout LineBuffering hSetBuffering stdin LineBuffering@@ -79,7 +140,7 @@ isTerminal <- hIsTerminalDevice stdout execExtraHelp args dockerHelpOptName- (Docker.dockerOptsParser True)+ (dockerOptsParser True) ("Only showing --" ++ Docker.dockerCmdName ++ "* options.") let versionString' = $(simpleVersion Meta.version) eGlobalRun <- try $@@ -88,36 +149,39 @@ "stack - The Haskell Tool Stack" "" (extraHelpOption progName (Docker.dockerCmdName ++ "*") dockerHelpOptName <*>- globalOpts isTerminal)+ globalOptsParser isTerminal) (do addCommand "build" "Build the project(s) in this directory/configuration"- (buildCmd DoNothing)- (buildOpts Build)+ (buildCmd Nothing)+ (buildOptsParser Build) addCommand "install"- "Build executables and install to a user path"- installCmd- (buildOpts Build)+ "Shortcut for 'build --copy-bins'"+ (buildCmd $ Just ("install", "copy-bins"))+ (buildOptsParser Install)+ addCommand "uninstall"+ "DEPRECATED: This command performs no actions, and is present for documentation only"+ uninstallCmd+ (many $ strArgument $ metavar "IGNORED") addCommand "test"- "Build and test the project(s) in this directory/configuration"- (\(rerun, bopts) -> buildCmd (DoTests rerun) bopts)- ((,)- <$> boolFlags True- "rerun-tests"- "running already successful tests"- idm- <*> (buildOpts Test))+ "Shortcut for 'build --test'"+ (buildCmd $ Just ("test", "test"))+ (buildOptsParser Test) addCommand "bench"- "Build and benchmark the project(s) in this directory/configuration"- (buildCmd DoBenchmarks)- (buildOpts Build)+ "Shortcut for 'build --bench'"+ (buildCmd $ Just ("bench", "bench"))+ (buildOptsParser Bench) addCommand "haddock"- "Generate haddocks for the project(s) in this directory/configuration"- (buildCmd DoNothing)- (buildOpts Haddock)+ "Shortcut for 'build --haddock'"+ (buildCmd $ Just ("haddock", "haddock"))+ (buildOptsParser Haddock) addCommand "new"- "Create a brand new project"+ "Create a new project from a template. Run `stack templates' to see available templates." newCmd- initOptsParser+ newOptsParser+ addCommand "templates"+ "List the templates available for `stack new'."+ templatesCmd+ (pure ()) addCommand "init" "Initialize a stack project based on one or more cabal packages" initCmd@@ -127,7 +191,7 @@ solverCmd solverOptsParser addCommand "setup"- "Get the appropriate ghc for your project"+ "Get the appropriate GHC for your project" setupCmd setupParser addCommand "path"@@ -162,6 +226,10 @@ "Upload a package to Hackage" uploadCmd (many $ strArgument $ metavar "TARBALL/DIR")+ addCommand "sdist"+ "Create source distribution tarballs"+ sdistCmd+ (many $ strArgument $ metavar "DIR") addCommand "dot" "Visualize your project's dependency graph using Graphviz dot" dotCmd@@ -176,34 +244,8 @@ (execOptsParser $ Just "ghc") addCommand "ghci" "Run ghci in the context of project(s)"- replCmd- ((,,,) <$>- fmap (map T.pack)- (many (strArgument- (metavar "TARGET" <>- help "If none specified, use all packages defined in current directory"))) <*>- fmap (fromMaybe [])- (optional (argsOption (long "ghc-options" <>- metavar "OPTION" <>- help "Additional options passed to GHCi"))) <*>- fmap (fromMaybe "ghc")- (optional (strOption (long "with-ghc" <>- metavar "GHC" <>- help "Use this command for the GHC to run"))) <*>- flag False True (long "no-load" <>- help "Don't load modules on start-up"))- addCommand "ide"- "Run ide-backend-client with the correct arguments"- ideCmd- ((,) <$>- fmap (map T.pack)- (many (strArgument- (metavar "TARGET" <>- help "If none specified, use all packages defined in current directory"))) <*>- fmap (fromMaybe [])- (optional (argsOption (long "ghc-options" <>- metavar "OPTION" <>- help "Additional options passed to GHCi"))))+ ghciCmd+ ghciOptsParser addCommand "runghc" "Run runghc" execCmd@@ -212,7 +254,37 @@ "Clean the local packages" cleanCmd (pure ())+ addCommand "list-dependencies"+ "List the dependencies"+ listDependenciesCmd+ (T.pack <$> strOption (long "separator" <>+ metavar "SEP" <>+ help ("Separator between package name " <>+ "and package version.") <>+ value " " <>+ showDefault)) addSubCommands+ "ide"+ "IDE-specific commands"+ (do addCommand+ "start"+ "Start the ide-backend service"+ ideCmd+ (((,) <$>+ fmap (map T.pack)+ (many (strArgument+ (metavar "TARGET" <>+ help "If none specified, use all packages defined in current directory"))) <*>+ argsOption (long "ghc-options" <>+ metavar "OPTION" <>+ help "Additional options passed to GHCi" <>+ value [])))+ addCommand+ "packages"+ "List all available local loadable packages"+ packagesCmd+ (pure ()))+ addSubCommands Docker.dockerCmdName "Subcommands specific to Docker use" (do addCommand Docker.dockerPullCmdName@@ -227,8 +299,14 @@ addCommand Docker.dockerCleanupCmdName "Clean up Docker images and containers" dockerCleanupCmd- dockerCleanupOpts)- )+ dockerCleanupOptsParser)+ addSubCommands+ Image.imgCmdName+ "Subcommands specific to imaging (EXPERIMENTAL)"+ (addCommand Image.imgDockerCmdName+ "Build a Docker image for the project"+ imgDockerCmd+ (pure ()))) -- commandsFromPlugins plugins pluginShouldHaveRun) https://github.com/commercialhaskell/stack/issues/322 case eGlobalRun of Left (exitCode :: ExitCode) -> do@@ -243,7 +321,7 @@ throwIO exitCode Right (global,run) -> do when (globalLogLevel global == LevelDebug) $ putStrLn versionString'- run global `catch` \e -> do+ fixCodePage $ run global `catch` \e -> do -- This special handler stops "stack: " from being printed before the -- exception case fromException e of@@ -281,10 +359,10 @@ -- support others later). pathCmd :: [Text] -> GlobalOpts -> IO () pathCmd keys go =- withBuildConfig+ withBuildConfigAndLock go- ExecStrategy- (do env <- ask+ (\_ ->+ do env <- ask let cfg = envConfig env bc = envConfigBuildConfig cfg menv <- getMinimalEnvOverride@@ -299,7 +377,7 @@ null keys || elem key keys) paths) (\(_,key,path) ->- $logInfo+ liftIO $ T.putStrLn ((if length keys == 1 then "" else key <> ": ") <>@@ -385,6 +463,14 @@ , "local-install-root" , \pi -> T.pack (toFilePathNoTrailing (piLocalRoot pi)))+ , ( "Snapshot documentation root"+ , "snapshot-doc-root"+ , \pi ->+ T.pack (toFilePathNoTrailing (piSnapRoot pi </> docDirSuffix)))+ , ( "Local project documentation root"+ , "local-doc-root"+ , \pi ->+ T.pack (toFilePathNoTrailing (piLocalRoot pi </> docDirSuffix))) , ( "Dist work directory" , "dist-dir" , \pi ->@@ -394,15 +480,23 @@ data SetupCmdOpts = SetupCmdOpts { scoGhcVersion :: !(Maybe Version) , scoForceReinstall :: !Bool+ , scoUpgradeCabal :: !Bool } setupParser :: Parser SetupCmdOpts setupParser = SetupCmdOpts- <$> (optional $ argument readVersion (metavar "VERSION"))+ <$> (optional $ argument readVersion+ (metavar "GHC_MAJOR_VERSION" <>+ help ("Major version of GHC to install, e.g. 7.10. " +++ "The default is to install the version implied by the resolver."))) <*> boolFlags False "reinstall"- "Reinstall GHC, even if available (implies no-system-ghc)"+ "reinstalling GHC, even if available (implies no-system-ghc)" idm+ <*> boolFlags False+ "upgrade-cabal"+ "installing the newest version of the Cabal library globally"+ idm where readVersion = do s <- readerAsk@@ -413,17 +507,20 @@ setupCmd :: SetupCmdOpts -> GlobalOpts -> IO () setupCmd SetupCmdOpts{..} go@GlobalOpts{..} = do (manager,lc) <- loadConfigWithOpts go- runStackT manager globalLogLevel (lcConfig lc) globalTerminal $+ withUserFileLock (configStackRoot $ lcConfig lc) $ \lk ->+ runStackTGlobal manager (lcConfig lc) go $ Docker.reexecWithOptionalContainer (lcProjectRoot lc)- (runStackLoggingT manager globalLogLevel globalTerminal $ do+ Nothing+ (runStackLoggingTGlobal manager go $ do (ghc, mstack) <- case scoGhcVersion of Just v -> return (v, Nothing) Nothing -> do- bc <- lcLoadBuildConfig lc globalResolver ExecStrategy+ bc <- lcLoadBuildConfig lc globalResolver return (bcGhcVersionExpected bc, Just $ bcStackYaml bc)- mpaths <- runStackT manager globalLogLevel (lcConfig lc) globalTerminal $ ensureGHC SetupOpts+ mpaths <- runStackTGlobal manager (lcConfig lc) go $+ ensureGHC SetupOpts { soptsInstallIfMissing = True , soptsUseSystem = (configSystemGHC $ lcConfig lc)@@ -434,174 +531,219 @@ , soptsSanityCheck = True , soptsSkipGhcCheck = False , soptsSkipMsys = configSkipMsys $ lcConfig lc+ , soptsUpgradeCabal = scoUpgradeCabal } case mpaths of- Nothing -> $logInfo "GHC on PATH would be used"- Just ps -> $logInfo $ "Would add the following to PATH: "- <> T.pack (intercalate [searchPathSeparator] ps)- )+ Nothing -> $logInfo "stack will use the GHC on your PATH"+ Just _ -> $logInfo "stack will use a locally installed GHC"+ $logInfo "For more information on paths, see 'stack path' and 'stack exec env'"+ $logInfo "To use this GHC and packages outside of a project, consider using:"+ $logInfo "stack ghc, stack ghci, stack runghc, or stack exec"+ )+ Nothing+ (Just $ liftIO$ unlockFile lk) -withConfig :: GlobalOpts+-- | Enforce mutual exclusion of every action running via this+-- function, on this path, on this users account.+--+-- A lock file is created inside the given directory. Currently,+-- stack uses locks per-snapshot. In the future, stack may refine+-- this to an even more fine-grain locking approach.+--+withUserFileLock :: (MonadBaseControl IO m, MonadIO m)+ => Path Abs Dir+ -> (FileLock -> m a)+ -> m a+withUserFileLock dir act = do+ let lockfile = $(mkRelFile "lockfile")+ let pth = dir </> lockfile+ liftIO $ createDirectoryIfMissing True (toFilePath dir)+ -- Just in case of asynchronous exceptions, we need to be careful+ -- when using tryLockFile here:+ EL.bracket (liftIO $ tryLockFile (toFilePath pth) Exclusive)+ (\fstTry -> maybe (return ()) (liftIO . unlockFile) fstTry)+ (\fstTry ->+ case fstTry of+ Just lk -> EL.finally (act lk) (liftIO $ unlockFile lk)+ Nothing ->+ do liftIO $ putStrLn $ "Failed to grab lock ("++show pth+++ "); other stack instance running. Waiting..."+ EL.bracket (liftIO $ lockFile (toFilePath pth) Exclusive)+ (liftIO . unlockFile)+ (\lk -> do+ liftIO $ putStrLn "Lock acquired, proceeding."+ act lk))++withConfigAndLock :: GlobalOpts -> StackT Config IO () -> IO ()-withConfig go@GlobalOpts{..} inner = do+withConfigAndLock go@GlobalOpts{..} inner = do (manager, lc) <- loadConfigWithOpts go- runStackT manager globalLogLevel (lcConfig lc) globalTerminal $- Docker.reexecWithOptionalContainer (lcProjectRoot lc) $- runStackT manager globalLogLevel (lcConfig lc) globalTerminal- inner+ withUserFileLock (configStackRoot $ lcConfig lc) $ \lk ->+ runStackTGlobal manager (lcConfig lc) go $+ Docker.reexecWithOptionalContainer (lcProjectRoot lc)+ Nothing+ (runStackTGlobal manager (lcConfig lc) go inner)+ Nothing+ (Just $ liftIO $ unlockFile lk) +-- For now the non-locking version just unlocks immediately.+-- That is, there's still a serialization point. withBuildConfig :: GlobalOpts- -> NoBuildConfigStrategy- -> StackT EnvConfig IO ()- -> IO ()-withBuildConfig go@GlobalOpts{..} strat inner = do+ -> (StackT EnvConfig IO ())+ -> IO ()+withBuildConfig go inner =+ withBuildConfigAndLock go (\lk -> do liftIO $ unlockFile lk+ inner)++withBuildConfigAndLock :: GlobalOpts+ -> (FileLock -> StackT EnvConfig IO ())+ -> IO ()+withBuildConfigAndLock go inner =+ withBuildConfigExt go Nothing inner Nothing++withBuildConfigExt+ :: GlobalOpts+ -> Maybe (StackT Config IO ())+ -- ^ Action to perform after before build. This will be run on the host+ -- OS even if Docker is enabled for builds. The build config is not+ -- available in this action, since that would require build tools to be+ -- installed on the host OS.+ -> (FileLock -> StackT EnvConfig IO ())+ -- ^ Action that uses the build config. If Docker is enabled for builds,+ -- this will be run in a Docker container.+ -> Maybe (StackT Config IO ())+ -- ^ Action to perform after the build. This will be run on the host+ -- OS even if Docker is enabled for builds. The build config is not+ -- available in this action, since that would require build tools to be+ -- installed on the host OS.+ -> IO ()+withBuildConfigExt go@GlobalOpts{..} mbefore inner mafter = do (manager, lc) <- loadConfigWithOpts go- runStackT manager globalLogLevel (lcConfig lc) globalTerminal $- Docker.reexecWithOptionalContainer (lcProjectRoot lc) $ do- bconfig <- runStackLoggingT manager globalLogLevel globalTerminal $- lcLoadBuildConfig lc globalResolver strat- envConfig <-- runStackT- manager globalLogLevel bconfig globalTerminal- setupEnv- runStackT- manager- globalLogLevel- envConfig- globalTerminal- inner -cleanCmd :: () -> GlobalOpts -> IO ()-cleanCmd () go = withBuildConfig go ThrowException clean+ withUserFileLock (configStackRoot $ lcConfig lc) $ \lk0 -> do+ -- A local bit of state for communication between callbacks:+ curLk <- newIORef lk0+ let inner' lk =+ -- Locking policy: This is only used for build commands, which+ -- only need to lock the snapshot, not the global lock. We+ -- trade in the lock here.+ do dir <- installationRootDeps+ -- Hand-over-hand locking:+ withUserFileLock dir $ \lk2 -> do+ liftIO $ writeIORef curLk lk2+ liftIO $ unlockFile lk+ inner lk2 --- | Parser for package names-readPackageName :: ReadM PackageName-readPackageName = do- s <- readerAsk- case parsePackageNameFromString s of- Nothing -> readerError $ "Invalid package name: " ++ s- Just x -> return x+ let inner'' lk = do+ bconfig <- runStackLoggingTGlobal manager go $+ lcLoadBuildConfig lc globalResolver+ envConfig <-+ runStackTGlobal+ manager bconfig go+ setupEnv+ runStackTGlobal+ manager+ envConfig+ go+ (inner' lk) --- | Parser for package:[-]flag-readFlag :: ReadM (Map (Maybe PackageName) (Map FlagName Bool))-readFlag = do- s <- readerAsk- case break (== ':') s of- (pn, ':':mflag) -> do- pn' <-- case parsePackageNameFromString pn of- Nothing- | pn == "*" -> return Nothing- | otherwise -> readerError $ "Invalid package name: " ++ pn- Just x -> return $ Just x- let (b, flagS) =- case mflag of- '-':x -> (False, x)- _ -> (True, mflag)- flagN <-- case parseFlagNameFromString flagS of- Nothing -> readerError $ "Invalid flag name: " ++ flagS- Just x -> return x- return $ Map.singleton pn' $ Map.singleton flagN b- _ -> readerError "Must have a colon"+ runStackTGlobal manager (lcConfig lc) go $+ Docker.reexecWithOptionalContainer (lcProjectRoot lc) mbefore (inner'' lk0) mafter+ (Just $ liftIO $+ do lk' <- readIORef curLk+ unlockFile lk') +cleanCmd :: () -> GlobalOpts -> IO ()+cleanCmd () go = withBuildConfigAndLock go (\_ -> clean)+ -- | Helper for build and install commands-buildCmdHelper :: NoBuildConfigStrategy -> FinalAction -> BuildOpts -> GlobalOpts -> IO ()-buildCmdHelper strat finalAction opts go+buildCmd :: Maybe (Text, Text) -- ^ option synonym+ -> BuildOpts -> GlobalOpts -> IO ()+buildCmd moptionSynonym opts go | boptsFileWatch opts = fileWatch inner | otherwise = inner $ const $ return () where- inner setLocalFiles =- withBuildConfig go strat $- Stack.Build.build setLocalFiles opts { boptsFinalAction = finalAction }---- | Build the project.-buildCmd :: FinalAction -> BuildOpts -> GlobalOpts -> IO ()-buildCmd = buildCmdHelper ThrowException+ inner setLocalFiles = withBuildConfigAndLock go $ \lk -> do+ case moptionSynonym of+ Nothing -> return ()+ Just (cmd, opt) -> $logInfo $ T.concat+ [ "NOTE: the "+ , cmd+ , " command is functionally equivalent to 'build --"+ , opt+ , "'"+ ]+ Stack.Build.build setLocalFiles (Just lk) opts --- | Install-installCmd :: BuildOpts -> GlobalOpts -> IO ()-installCmd opts = buildCmdHelper ExecStrategy DoNothing opts { boptsInstallExes = True }+uninstallCmd :: [String] -> GlobalOpts -> IO ()+uninstallCmd _ go = withConfigAndLock go $ do+ $logError "stack does not manage installations in global locations"+ $logError "The only global mutation stack performs is executable copying"+ $logError "For the default executable destination, please run 'stack path --local-bin-path'" -- | Unpack packages to the filesystem unpackCmd :: [String] -> GlobalOpts -> IO ()-unpackCmd names go = withConfig go $ do+unpackCmd names go = withConfigAndLock go $ do menv <- getMinimalEnvOverride Stack.Fetch.unpackPackages menv "." names -- | Update the package index updateCmd :: () -> GlobalOpts -> IO ()-updateCmd () go = withConfig go $+updateCmd () go = withConfigAndLock go $ getMinimalEnvOverride >>= Stack.PackageIndex.updateAllIndices upgradeCmd :: Bool -> GlobalOpts -> IO ()-upgradeCmd fromGit go = withConfig go $+upgradeCmd fromGit go = withConfigAndLock go $ upgrade fromGit (globalResolver go) -- | Upload to Hackage uploadCmd :: [String] -> GlobalOpts -> IO ()+uploadCmd [] _ = error "To upload the current package, please run 'stack upload .'" uploadCmd args go = do- (manager,lc) <- loadConfigWithOpts go- let config = lcConfig lc- if null args- then error "To upload the current project, please run 'stack upload .'"- else liftIO $ do- uploader <- Upload.mkUploader- config- $ Upload.setGetManager (return manager)- Upload.defaultUploadSettings- mapM_ (Upload.upload uploader) args--data ExecOpts = ExecOpts- { eoCmd :: !String- , eoArgs :: ![String]- , eoExtra :: !ExecOptsExtra- }--data ExecOptsExtra- = ExecOptsPlain- | ExecOptsEmbellished- { eoEnvSettings :: !EnvSettings- , eoPackages :: ![String]- }--execOptsParser :: Maybe String -- ^ command- -> Parser ExecOpts-execOptsParser mcmd =- ExecOpts- <$> maybe eoCmdParser pure mcmd- <*> eoArgsParser- <*> (eoPlainParser <|>- ExecOptsEmbellished- <$> eoEnvSettingsParser- <*> eoPackagesParser)- where- eoCmdParser :: Parser String- eoCmdParser = strArgument (metavar "CMD")-- eoArgsParser :: Parser [String]- eoArgsParser = many (strArgument (metavar "-- ARGS (e.g. stack ghc -- X.hs -o x)"))-- eoEnvSettingsParser :: Parser EnvSettings- eoEnvSettingsParser = EnvSettings- <$> pure True- <*> boolFlags True- "ghc-package-path"- "setting the GHC_PACKAGE_PATH variable for the subprocess"- idm- <*> boolFlags True- "stack-exe"- "setting the STACK_EXE environment variable to the path for the stack executable"- idm-- eoPackagesParser :: Parser [String]- eoPackagesParser = many (strOption (long "package" <> help "Additional packages that must be installed"))+ let partitionM _ [] = return ([], [])+ partitionM f (x:xs) = do+ r <- f x+ (as, bs) <- partitionM f xs+ return $ if r then (x:as, bs) else (as, x:bs)+ (files, nonFiles) <- partitionM doesFileExist args+ (dirs, invalid) <- partitionM doesDirectoryExist nonFiles+ when (not (null invalid)) $ error $+ "stack upload expects a list sdist tarballs or cabal directories. Can't find " +++ show invalid+ let getUploader :: (HasStackRoot config, HasPlatform config, HasConfig config) => StackT config IO Upload.Uploader+ getUploader = do+ config <- asks getConfig+ manager <- asks envManager+ let uploadSettings =+ Upload.setGetManager (return manager) $+ Upload.defaultUploadSettings+ liftIO $ Upload.mkUploader config uploadSettings+ if null dirs+ then withConfigAndLock go $ do+ uploader <- getUploader+ liftIO $ forM_ files (canonicalizePath >=> Upload.upload uploader)+ else withBuildConfigAndLock go $ \_ -> do+ uploader <- getUploader+ liftIO $ forM_ files (canonicalizePath >=> Upload.upload uploader)+ forM_ dirs $ \dir -> do+ pkgDir <- parseAbsDir =<< liftIO (canonicalizePath dir)+ (tarName, tarBytes) <- getSDistTarball pkgDir+ liftIO $ Upload.uploadBytes uploader tarName tarBytes - eoPlainParser :: Parser ExecOptsExtra- eoPlainParser = flag' ExecOptsPlain- (long "plain" <>- help "Use an unmodified environment (only useful with Docker)")+sdistCmd :: [String] -> GlobalOpts -> IO ()+sdistCmd dirs go =+ withBuildConfig go $ do -- No locking needed.+ -- If no directories are specified, build all sdist tarballs.+ dirs' <- if null dirs+ then asks (Map.keys . envConfigPackages . getEnvConfig)+ else mapM (parseAbsDir <=< liftIO . canonicalizePath) dirs+ forM_ dirs' $ \dir -> do+ (tarName, tarBytes) <- getSDistTarball dir+ distDir <- distDirFromDir dir+ tarPath <- fmap (distDir </>) $ parseRelFile tarName+ liftIO $ L.writeFile (toFilePath tarPath) tarBytes+ $logInfo $ "Wrote sdist tarball to " <> T.pack (toFilePath tarPath) -- | Execute a command. execCmd :: ExecOpts -> GlobalOpts -> IO ()@@ -609,268 +751,102 @@ case eoExtra of ExecOptsPlain -> do (manager,lc) <- liftIO $ loadConfigWithOpts go- runStackT manager globalLogLevel (lcConfig lc) globalTerminal $+ withUserFileLock (configStackRoot $ lcConfig lc) $ \lk ->+ runStackTGlobal manager (lcConfig lc) go $ Docker.execWithOptionalContainer (lcProjectRoot lc)- (return (eoCmd, eoArgs, id)) $- runStackT manager globalLogLevel (lcConfig lc) globalTerminal $- exec plainEnvSettings eoCmd eoArgs+ (return (eoCmd, eoArgs, [], id))+ -- Unlock before transferring control away, whether using docker or not:+ (Just $ liftIO $ unlockFile lk)+ (runStackTGlobal manager (lcConfig lc) go $ do+ exec plainEnvSettings eoCmd eoArgs)+ Nothing+ Nothing -- Unlocked already above. ExecOptsEmbellished {..} ->- withBuildConfig go ExecStrategy $ do+ withBuildConfigAndLock go $ \lk -> do let targets = concatMap words eoPackages unless (null targets) $- Stack.Build.build (const $ return ()) defaultBuildOpts+ Stack.Build.build (const $ return ()) (Just lk) defaultBuildOpts { boptsTargets = map T.pack targets }+ liftIO $ unlockFile lk -- Unlock before transferring control away. exec eoEnvSettings eoCmd eoArgs --- | Run the REPL in the context of a project.-replCmd :: ([Text], [String], FilePath, Bool) -> GlobalOpts -> IO ()-replCmd (targets,args,path,noload) go@GlobalOpts{..} = withBuildConfig go ExecStrategy $ do- repl targets args path noload+-- | Run GHCi in the context of a project.+ghciCmd :: GhciOpts -> GlobalOpts -> IO ()+ghciCmd ghciOpts go@GlobalOpts{..} =+ withBuildConfigAndLock go $ \lk -> do+ let packageTargets = concatMap words (ghciAdditionalPackages ghciOpts)+ unless (null packageTargets) $+ Stack.Build.build (const $ return ()) (Just lk) defaultBuildOpts+ { boptsTargets = map T.pack packageTargets+ }+ liftIO $ unlockFile lk -- Don't hold the lock while in the GHCI.+ ghci ghciOpts -- | Run ide-backend in the context of a project. ideCmd :: ([Text], [String]) -> GlobalOpts -> IO ()-ideCmd (targets,args) go@GlobalOpts{..} = withBuildConfig go ExecStrategy $ do+ideCmd (targets,args) go@GlobalOpts{..} =+ withBuildConfig go $ -- No locking needed. ide targets args +-- | Run ide-backend in the context of a project.+packagesCmd :: () -> GlobalOpts -> IO ()+packagesCmd () go@GlobalOpts{..} =+ withBuildConfig go $+ do econfig <- asks getEnvConfig+ locals <-+ forM (M.toList (envConfigPackages econfig)) $+ \(dir,_) ->+ do cabalfp <- getCabalFileName dir+ parsePackageNameFromFilePath cabalfp+ forM_ locals (liftIO . putStrLn . packageNameString)+ -- | Pull the current Docker image. dockerPullCmd :: () -> GlobalOpts -> IO () dockerPullCmd _ go@GlobalOpts{..} = do (manager,lc) <- liftIO $ loadConfigWithOpts go- runStackT manager globalLogLevel (lcConfig lc) globalTerminal $- Docker.preventInContainer Docker.pull+ -- TODO: can we eliminate this lock if it doesn't touch ~/.stack/?+ withUserFileLock (configStackRoot $ lcConfig lc) $ \_ ->+ runStackTGlobal manager (lcConfig lc) go $+ Docker.preventInContainer Docker.pull -- | Reset the Docker sandbox. dockerResetCmd :: Bool -> GlobalOpts -> IO () dockerResetCmd keepHome go@GlobalOpts{..} = do (manager,lc) <- liftIO (loadConfigWithOpts go)- runStackLoggingT manager globalLogLevel globalTerminal$ Docker.preventInContainer $- Docker.reset (lcProjectRoot lc) keepHome+ -- TODO: can we eliminate this lock if it doesn't touch ~/.stack/?+ withUserFileLock (configStackRoot $ lcConfig lc) $ \_ ->+ runStackLoggingTGlobal manager go $+ Docker.preventInContainer $ Docker.reset (lcProjectRoot lc) keepHome -- | Cleanup Docker images and containers. dockerCleanupCmd :: Docker.CleanupOpts -> GlobalOpts -> IO () dockerCleanupCmd cleanupOpts go@GlobalOpts{..} = do (manager,lc) <- liftIO $ loadConfigWithOpts go- runStackT manager globalLogLevel (lcConfig lc) globalTerminal $+ -- TODO: can we eliminate this lock if it doesn't touch ~/.stack/?+ withUserFileLock (configStackRoot $ lcConfig lc) $ \_ ->+ runStackTGlobal manager (lcConfig lc) go $ Docker.preventInContainer $ Docker.cleanup cleanupOpts --- | Command sum type for conditional arguments.-data Command- = Build- | Test- | Haddock- deriving (Eq)---- | Parser for build arguments.-buildOpts :: Command -> Parser BuildOpts-buildOpts cmd = fmap process $- BuildOpts <$> target <*> libProfiling <*> exeProfiling <*>- optimize <*> haddock <*> haddockDeps <*> finalAction <*> dryRun <*> ghcOpts <*>- flags <*> installExes <*> preFetch <*> testArgs <*> onlySnapshot <*> coverage <*>- fileWatch' <*> keepGoing- where process bopts =- if boptsCoverage bopts- then bopts { boptsExeProfile = True- , boptsLibProfile = True- , boptsGhcOptions = "-fhpc" : boptsGhcOptions bopts}- else bopts- optimize =- maybeBoolFlags "optimizations" "optimizations for TARGETs and all its dependencies" idm- target =- fmap (map T.pack)- (many (strArgument- (metavar "TARGET" <>- help "If none specified, use all packages defined in current directory")))- libProfiling =- boolFlags False- "library-profiling"- "library profiling for TARGETs and all its dependencies"- idm- exeProfiling =- boolFlags False- "executable-profiling"- "library profiling for TARGETs and all its dependencies"- idm- haddock =- boolFlags (cmd == Haddock)- "haddock"- "building Haddocks"- idm- haddockDeps =- if cmd == Haddock- then maybeBoolFlags- "haddock-deps"- "building Haddocks for dependencies"- idm- else pure Nothing- finalAction = pure DoNothing- installExes = pure False- dryRun = flag False True (long "dry-run" <>- help "Don't build anything, just prepare to")- ghcOpts = (++)- <$> flag [] ["-Wall", "-Werror"]- ( long "pedantic"- <> help "Turn on -Wall and -Werror (note: option name may change in the future"- )- <*> many (fmap T.pack- (strOption (long "ghc-options" <>- metavar "OPTION" <>- help "Additional options passed to GHC")))-- flags =- fmap (Map.unionsWith Map.union) $ many- (option readFlag- ( long "flag"- <> metavar "PACKAGE:[-]FLAG"- <> help "Override flags set in stack.yaml (applies to local packages and extra-deps)"- ))-- preFetch = flag False True- (long "prefetch" <>- help "Fetch packages necessary for the build immediately, useful with --dry-run")- testArgs =- fmap (fromMaybe [])- (if cmd == Test- then optional- (argsOption- (long "test-arguments" <> metavar "TEST_ARGS" <>- help "Arguments passed in to the test suite program"))- else pure Nothing)-- onlySnapshot = flag False True- (long "only-snapshot" <>- help "Only build packages for the snapshot database, not the local database")- coverage =- if cmd == Test- then flag False True- (long "coverage" <>- help "Generate a code coverage report")- else pure False-- fileWatch' = flag False True- (long "file-watch" <>- help "Watch for changes in local files and automatically rebuild")-- keepGoing = maybeBoolFlags- "keep-going"- "continue running after a step fails (default: false for build, true for test/bench)"- idm---- | Parser for docker cleanup arguments.-dockerCleanupOpts :: Parser Docker.CleanupOpts-dockerCleanupOpts =- Docker.CleanupOpts <$>- (flag' Docker.CleanupInteractive- (short 'i' <>- long "interactive" <>- help "Show cleanup plan in editor and allow changes (default)") <|>- flag' Docker.CleanupImmediate- (short 'y' <>- long "immediate" <>- help "Immediately execute cleanup plan") <|>- flag' Docker.CleanupDryRun- (short 'n' <>- long "dry-run" <>- help "Display cleanup plan but do not execute") <|>- pure Docker.CleanupInteractive) <*>- opt (Just 14) "known-images" "LAST-USED" <*>- opt Nothing "unknown-images" "CREATED" <*>- opt (Just 0) "dangling-images" "CREATED" <*>- opt Nothing "stopped-containers" "CREATED" <*>- opt Nothing "running-containers" "CREATED"- where opt def' name mv =- fmap Just- (option auto- (long name <>- metavar (mv ++ "-DAYS-AGO") <>- help ("Remove " ++- toDescr name ++- " " ++- map toLower (toDescr mv) ++- " N days ago" ++- case def' of- Just n -> " (default " ++ show n ++ ")"- Nothing -> ""))) <|>- flag' Nothing- (long ("no-" ++ name) <>- help ("Do not remove " ++- toDescr name ++- case def' of- Just _ -> ""- Nothing -> " (default)")) <|>- pure def'- toDescr = map (\c -> if c == '-' then ' ' else c)---- | Parser for global command-line options.-globalOpts :: Bool -> Parser GlobalOpts-globalOpts defaultTerminal =- GlobalOpts <$> logLevelOpt <*>- configOptsParser False <*>- optional resolverParser <*>- flag- defaultTerminal- False- (long "no-terminal" <>- help- "Override terminal detection in the case of running in a false terminal") <*>- (optional (strOption- (long "stack-yaml" <>- metavar "STACK-YAML" <>- help "Override project stack.yaml file (overrides any STACK_YAML environment variable)")))---- | Parse for a logging level.-logLevelOpt :: Parser LogLevel-logLevelOpt =- fmap parse- (strOption (long "verbosity" <>- metavar "VERBOSITY" <>- help "Verbosity: silent, error, warn, info, debug")) <|>- flag defaultLogLevel- verboseLevel- (short 'v' <> long "verbose" <>- help ("Enable verbose mode: verbosity level \"" <> showLevel verboseLevel <> "\""))- where verboseLevel = LevelDebug- showLevel l =- case l of- LevelDebug -> "debug"- LevelInfo -> "info"- LevelWarn -> "warn"- LevelError -> "error"- LevelOther x -> T.unpack x- parse s =- case s of- "debug" -> LevelDebug- "info" -> LevelInfo- "warn" -> LevelWarn- "error" -> LevelError- _ -> LevelOther (T.pack s)--resolverParser :: Parser Resolver-resolverParser =- option readResolver- (long "resolver" <>- metavar "RESOLVER" <>- help "Override resolver in project file")---- | Default logging level should be something useful but not crazy.-defaultLogLevel :: LogLevel-defaultLogLevel = LevelInfo---- | Parsed global command-line options.-data GlobalOpts = GlobalOpts- { globalLogLevel :: LogLevel -- ^ Log level- , globalConfigMonoid :: ConfigMonoid -- ^ Config monoid, for passing into 'loadConfig'- , globalResolver :: Maybe Resolver -- ^ Resolver override- , globalTerminal :: Bool -- ^ We're in a terminal?- , globalStackYaml :: Maybe FilePath -- ^ Override project stack.yaml- } deriving (Show)+imgDockerCmd :: () -> GlobalOpts -> IO ()+imgDockerCmd () go@GlobalOpts{..} = do+ withBuildConfigExt+ go+ Nothing+ (\lk ->+ do Stack.Build.build+ (const (return ()))+ (Just lk)+ defaultBuildOpts+ Image.stageContainerImageArtifacts)+ (Just Image.createContainerImageFromStage) -- | Load the configuration with a manager. Convenience function used -- throughout this module. loadConfigWithOpts :: GlobalOpts -> IO (Manager,LoadConfig (StackLoggingT IO))-loadConfigWithOpts GlobalOpts{..} = do+loadConfigWithOpts go@GlobalOpts{..} = do manager <- newTLSManager mstackYaml <- case globalStackYaml of@@ -878,37 +854,42 @@ Just fp -> do path <- canonicalizePath fp >>= parseAbsFile return $ Just path- lc <- runStackLoggingT+ lc <- runStackLoggingTGlobal manager- globalLogLevel- globalTerminal+ go (loadConfig globalConfigMonoid mstackYaml) return (manager,lc) -- | Project initialization initCmd :: InitOpts -> GlobalOpts -> IO ()-initCmd initOpts go = withConfig go $ initProject initOpts+initCmd initOpts go =+ withConfigAndLock go $+ do pwd <- getWorkingDir+ initProject pwd initOpts --- | Project creation-newCmd :: InitOpts -> GlobalOpts -> IO ()-newCmd initOpts go@GlobalOpts{..} = withConfig go $ do- newProject- initProject initOpts+-- | Create a project directory structure and initialize the stack config.+newCmd :: (NewOpts,InitOpts) -> GlobalOpts -> IO ()+newCmd (newOpts,initOpts) go@GlobalOpts{..} =+ withConfigAndLock go $+ do dir <- new newOpts+ initProject dir initOpts +-- | List the available templates.+templatesCmd :: () -> GlobalOpts -> IO ()+templatesCmd _ go@GlobalOpts{..} = withConfigAndLock go listTemplates+ -- | Fix up extra-deps for a project solverCmd :: Bool -- ^ modify stack.yaml automatically? -> GlobalOpts -> IO () solverCmd fixStackYaml go =- withBuildConfig go ThrowException (solveExtraDeps fixStackYaml)---- | Parser for @solverCmd@-solverOptsParser :: Parser Bool-solverOptsParser = boolFlags False- "modify-stack-yaml"- "Automatically modify stack.yaml with the solver's recommendations"- idm+ withBuildConfigAndLock go (\_ -> solveExtraDeps fixStackYaml) -- | Visualize dependencies dotCmd :: DotOpts -> GlobalOpts -> IO ()-dotCmd dotOpts go = withBuildConfig go ThrowException (dot dotOpts)+dotCmd dotOpts go = withBuildConfigAndLock go (\_ -> dot dotOpts)++-- | List the dependencies+listDependenciesCmd :: Text -> GlobalOpts -> IO ()+listDependenciesCmd sep go = withBuildConfig go (listDependencies sep')+ where sep' = T.replace "\\t" "\t" (T.replace "\\n" "\n" sep)
src/test/Network/HTTP/Download/VerifiedSpec.hs view
@@ -4,6 +4,7 @@ import Crypto.Hash import Control.Monad (unless) import Control.Monad.Trans.Reader+import Control.Retry (limitRetries) import Data.Maybe import Network.HTTP.Client.Conduit import Network.HTTP.Download.Verified@@ -34,6 +35,7 @@ { drRequest = req , drHashChecks = [exampleHashCheck] , drLengthCheck = Just exampleLengthCheck+ , drRetryPolicy = limitRetries 1 } exampleHashCheck :: HashCheck@@ -90,7 +92,7 @@ spec :: Spec spec = beforeAll setup $ afterAll teardown $ do- let exampleProgressHook = return ()+ let exampleProgressHook _ = return () describe "verifiedDownload" $ do -- Preconditions:@@ -154,9 +156,9 @@ { drRequest = req , drHashChecks = [] , drLengthCheck = Nothing+ , drRetryPolicy = limitRetries 1 }- let progressHook = return ()- let go = runWith manager $ verifiedDownload dReq dest progressHook+ let go = runWith manager $ verifiedDownload dReq dest exampleProgressHook doesFileExist destFp `shouldReturn` False go `shouldReturn` True doesFileExist destFp `shouldReturn` True
src/test/Stack/Build/ExecuteSpec.hs view
@@ -8,17 +8,4 @@ main = hspec spec spec :: Spec-spec = describe "compareTestComponents" $ do- let test comps names expected = it (show (comps, names)) $- compareTestsComponents- (T.words $ T.pack comps)- (T.words $ T.pack names)- `shouldBe`- (T.words $ T.pack expected)-- test "" "" ""- test "" "foo" "foo"- test "foo" "bar" ""- test "foo" "foo bar" "foo"- test "test:foo" "foo bar" "foo"- test "test:foo exe:bar" "foo bar" "foo"+spec = return ()
+ src/test/Stack/Build/TargetSpec.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+module Stack.Build.TargetSpec (main, spec) where++import qualified Data.Text as T+import Stack.Build.Target+import Stack.Types+import Test.Hspec++main :: IO ()+main = hspec spec++spec :: Spec+spec = do+ describe "parseRawTarget" $ do+ let test s e = it s $ parseRawTarget (T.pack s) `shouldBe` e+ test "foobar" $ Just $ RTPackage $(mkPackageName "foobar")+ test "foobar-1.2.3" $ Just $ RTPackageIdentifier $ PackageIdentifier+ $(mkPackageName "foobar") $(mkVersion "1.2.3")+ test "./foobar" Nothing+ test "foobar/" Nothing+ test "/foobar" Nothing+ test ":some-exe" $ Just $ RTComponent "some-exe"+ test "foobar:some-exe" $ Just $ RTPackageComponent $(mkPackageName "foobar") $ UnresolvedComponent "some-exe"+ test "foobar:exe:some-exe" $ Just $ RTPackageComponent $(mkPackageName "foobar")+ $ ResolvedComponent $ CExe "some-exe"
src/test/Stack/BuildPlanSpec.hs view
@@ -39,8 +39,8 @@ spec :: Spec spec = beforeAll setup $ afterAll teardown $ do let logLevel = LevelDebug- let loadConfig' m = runStackLoggingT m logLevel False (loadConfig mempty Nothing)- let loadBuildConfigRest m = runStackLoggingT m logLevel False+ let loadConfig' m = runStackLoggingT m logLevel False False (loadConfig mempty Nothing)+ let loadBuildConfigRest m = runStackLoggingT m logLevel False False let inTempDir action = do currentDirectory <- getCurrentDirectory withSystemTempDirectory "Stack_BuildPlanSpec" $ \tempDir -> do@@ -53,8 +53,8 @@ -- github still depends on failure. writeFile "stack.yaml" "resolver: lts-2.9" LoadConfig{..} <- loadConfig' manager- bconfig <- loadBuildConfigRest manager (lcLoadBuildConfig Nothing ThrowException)- runStackT manager logLevel bconfig False $ do+ bconfig <- loadBuildConfigRest manager (lcLoadBuildConfig Nothing)+ runStackT manager logLevel bconfig False False $ do menv <- getMinimalEnvOverride mbp <- loadMiniBuildPlan $ LTS 2 9 eres <- try $ resolveBuildPlan
src/test/Stack/ConfigSpec.hs view
@@ -60,8 +60,8 @@ describe "loadConfig" $ do- let loadConfig' m = runStackLoggingT m logLevel False (loadConfig mempty Nothing)- let loadBuildConfigRest m = runStackLoggingT m logLevel False+ let loadConfig' m = runStackLoggingT m logLevel False False (loadConfig mempty Nothing)+ let loadBuildConfigRest m = runStackLoggingT m logLevel False False -- TODO(danburton): make sure parent dirs also don't have config file it "works even if no config file exists" $ \T{..} -> example $ do _config <- loadConfig' manager@@ -79,9 +79,9 @@ createDirectory childDir setCurrentDirectory childDir LoadConfig{..} <- loadConfig' manager- BuildConfig{..} <- loadBuildConfigRest manager- (lcLoadBuildConfig Nothing ThrowException)- bcRoot `shouldBe` parentDir+ bc@BuildConfig{..} <- loadBuildConfigRest manager+ (lcLoadBuildConfig Nothing)+ bcRoot bc `shouldBe` parentDir it "respects the STACK_YAML env variable" $ \T{..} -> inTempDir $ do withSystemTempDirectory "config-is-here" $ \dirFilePath -> do@@ -91,8 +91,9 @@ withEnvVar "STACK_YAML" stackYamlFp $ do LoadConfig{..} <- loadConfig' manager BuildConfig{..} <- loadBuildConfigRest manager- (lcLoadBuildConfig Nothing ThrowException)- bcRoot `shouldBe` dir+ (lcLoadBuildConfig Nothing)+ bcStackYaml `shouldBe` dir </> stackDotYaml+ parent bcStackYaml `shouldBe` dir it "STACK_YAML can be relative" $ \T{..} -> inTempDir $ do parentDir <- getCurrentDirectory >>= parseAbsDir@@ -104,5 +105,5 @@ withEnvVar "STACK_YAML" (toFilePath yamlRel) $ do LoadConfig{..} <- loadConfig' manager BuildConfig{..} <- loadBuildConfigRest manager- (lcLoadBuildConfig Nothing ThrowException)+ (lcLoadBuildConfig Nothing) bcStackYaml `shouldBe` yamlAbs
src/test/Stack/DotSpec.hs view
@@ -1,31 +1,33 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-} -- | Test suite for Stack.Dot module Stack.DotSpec where +import Control.Monad (filterM) import Data.ByteString.Char8 (ByteString)-import qualified Data.Foldable as F+import Data.Foldable as F import Data.Functor.Identity import Data.List ((\\)) import qualified Data.Map as Map import Data.Maybe (fromMaybe) import Data.Set (Set) import qualified Data.Set as Set-import Options.Applicative (execParserPure,idm,prefs,info,getParseResult) import Stack.Types import Test.Hspec import Test.Hspec.QuickCheck (prop)-#if MIN_VERSION_QuickCheck(2,8,0)-import Test.QuickCheck (forAll,sublistOf)-#endif+import Test.QuickCheck (forAll,choose,Gen) import Stack.Dot +dummyVersion :: Version+dummyVersion = fromMaybe (error "dotspec: parser error") (parseVersionFromString "0.0.0.0")+ spec :: Spec spec = do let graph = Map.mapKeys pkgName- . fmap (Set.map pkgName)+ . fmap (\p -> (Set.map pkgName p, Just dummyVersion)) . Map.fromList $ [("one",Set.fromList ["base","free"]) ,("two",Set.fromList ["base","free","mtl","transformers","one"]) ]@@ -34,37 +36,42 @@ resolveDependencies (Just 0) graph stubLoader `shouldBe` return graph it "with depth 1, more dependencies are resolved" $ do- let graph' = Map.insert (pkgName "cycle") (Set.singleton (pkgName "cycle")) graph+ let graph' = Map.insert (pkgName "cycle")+ (Set.singleton (pkgName "cycle"), Just dummyVersion)+ graph resultGraph = runIdentity (resolveDependencies (Just 0) graph stubLoader) resultGraph' = runIdentity (resolveDependencies (Just 1) graph' stubLoader) Map.size resultGraph < Map.size resultGraph' `shouldBe` True it "cycles are ignored" $ do- let graph' = Map.insert (pkgName "cycle") (Set.singleton (pkgName "cycle")) graph+ let graph' = Map.insert (pkgName "cycle")+ (Set.singleton (pkgName "cycle"), Just dummyVersion)+ graph resultGraph = resolveDependencies Nothing graph stubLoader resultGraph' = resolveDependencies Nothing graph' stubLoader fmap Map.size resultGraph' `shouldBe` fmap ((+1) . Map.size) resultGraph -#if MIN_VERSION_QuickCheck(2,8,0)+ let graphElem e = Set.member e . Set.unions . Map.elems+ prop "requested packages are pruned" $ do let resolvedGraph = runIdentity (resolveDependencies Nothing graph stubLoader)- allPackages g = Set.map show (Map.keysSet g `Set.union` F.fold g)+ allPackages g = Set.map show (Map.keysSet g `Set.union` F.fold (fmap fst g)) forAll (sublistOf (Set.toList (allPackages resolvedGraph))) $ \toPrune -> let pruned = pruneGraph [pkgName "one", pkgName "two"] toPrune resolvedGraph in Set.null (allPackages pruned `Set.intersection` Set.fromList toPrune) prop "pruning removes orhpans" $ do let resolvedGraph = runIdentity (resolveDependencies Nothing graph stubLoader)- allPackages g = Set.map show (Map.keysSet g `Set.union` F.fold g)+ allPackages g = Set.map show (Map.keysSet g `Set.union` F.fold (fmap fst g)) orphans g = Map.filterWithKey (\k _ -> not (graphElem k g)) g forAll (sublistOf (Set.toList (allPackages resolvedGraph))) $ \toPrune -> let pruned = pruneGraph [pkgName "one", pkgName "two"] toPrune resolvedGraph- in null (Map.keys (orphans pruned) \\ [pkgName "one", pkgName "two"])-#endif-- where graphElem e graph = Set.member e . Set.unions . Map.elems $ graph+ in null (Map.keys (orphans (fmap fst pruned)) \\ [pkgName "one", pkgName "two"]) {- Helper functions below -}+-- Backport from QuickCheck 2.8 to 2.7.6+sublistOf :: [a] -> Gen [a]+sublistOf = filterM (\_ -> choose (False, True)) -- Unsafe internal helper to create a package name pkgName :: ByteString -> PackageName@@ -73,8 +80,8 @@ failure = error "Internal error during package name creation in DotSpec.pkgName" -- Stub, simulates the function to load package dependecies-stubLoader :: PackageName -> Identity (Set PackageName)-stubLoader name = return . Set.fromList . map pkgName $ case show name of+stubLoader :: PackageName -> Identity (Set PackageName, Maybe Version)+stubLoader name = return . (, Just dummyVersion) . Set.fromList . map pkgName $ case show name of "StateVar" -> ["stm","transformers"] "array" -> [] "bifunctors" -> ["semigroupoids","semigroups","tagged"]
src/test/Stack/PackageDumpSpec.hs view
@@ -76,6 +76,7 @@ , dpLibDirs = ["/opt/ghc/7.8.4/lib/ghc-7.8.4/haskell2010-1.1.2.0"] , dpDepends = depends , dpLibraries = ["HShaskell2010-1.1.2.0"]+ , dpHasExposedModules = True , dpHaddockInterfaces = ["/opt/ghc/7.8.4/share/doc/ghc/html/libraries/haskell2010-1.1.2.0/haskell2010.haddock"] , dpProfiling = () , dpHaddock = ()@@ -109,6 +110,7 @@ , dpHaddockInterfaces = ["/opt/ghc/7.10.1/share/doc/ghc/html/libraries/ghc-7.10.1/ghc.haddock"] , dpDepends = depends , dpLibraries = ["HSghc-7.10.1-EMlWrQ42XY0BNVbSrKixqY"]+ , dpHasExposedModules = True , dpProfiling = () , dpHaddock = () }@@ -138,6 +140,7 @@ , dpHaddockInterfaces = ["/Users/alexbiehl/.stack/snapshots/x86_64-osx/lts-2.13/7.8.4/doc/html/hmatrix.haddock"] , dpDepends = depends , dpLibraries = ["HShmatrix-0.16.1.5"]+ , dpHasExposedModules = True , dpProfiling = () , dpHaddock = () }
stack.cabal view
@@ -1,5 +1,5 @@ name: stack-version: 0.1.2.0+version: 0.1.3.0 synopsis: The Haskell Tool Stack description: Please see the README.md for usage information, and the wiki on Github for more details. Also, note that@@ -23,13 +23,6 @@ test/package-dump/ghc-7.8.4-osx.txt test/package-dump/ghc-7.10.txt - new-template/src/Lib.hs- new-template/new-template.cabal- new-template/test/Spec.hs- new-template/app/Main.hs- new-template/LICENSE- new-template/Setup.hs- stack.yaml flag integration-tests@@ -54,11 +47,14 @@ Stack.GhcPkg Stack.Init Stack.New+ Stack.Options Stack.Package Stack.PackageDump Stack.PackageIndex- Stack.Repl+ Stack.Ghci Stack.Ide+ Stack.Image+ Stack.SDist Stack.Setup Stack.Solver Stack.Types@@ -68,18 +64,23 @@ Stack.Types.Docker Stack.Types.FlagName Stack.Types.GhcPkgId+ Stack.Types.Image Stack.Types.PackageIdentifier Stack.Types.PackageName+ Stack.Types.TemplateName Stack.Types.Version Stack.Types.StackT+ Stack.Types.Build+ Stack.Types.Package Stack.Build Stack.Build.Cache+ Stack.Build.Coverage Stack.Build.ConstructPlan Stack.Build.Execute Stack.Build.Haddock Stack.Build.Installed Stack.Build.Source- Stack.Build.Types+ Stack.Build.Target Stack.Upgrade Stack.Upload System.Process.Read@@ -87,10 +88,10 @@ System.Process.Run Network.HTTP.Download.Verified Data.Attoparsec.Args+ Path.IO other-modules: Network.HTTP.Download Control.Concurrent.Execute Path.Find- Path.IO System.Process.PagerEditor Paths_stack Data.Aeson.Extended@@ -116,10 +117,13 @@ , containers >= 0.5.5.1 , cryptohash >= 0.11.6 , cryptohash-conduit+ , deepseq-generics , directory >= 1.2.1.0 , enclosed-exceptions , exceptions >= 0.8.0.2+ , extra , fast-logger >= 2.3.1+ , filelock >= 0.1.0.1 , filepath >= 1.3.0.2 , fsnotify , hashable >= 1.2.3.2@@ -134,6 +138,7 @@ , mtl >= 2.1.3.1 , old-locale >= 1.0.0.6 , optparse-applicative+ , optparse-simple >= 0.0.3 , path >= 0.5.1 , persistent >= 2.1.2 , persistent-sqlite >= 2.1.4@@ -141,6 +146,7 @@ , pretty , process >= 1.2.0.0 , resourcet >= 1.1.4.1+ , retry >= 0.6 , safe >= 0.3 , split , stm >= 2.4.4@@ -152,6 +158,7 @@ , time >= 1.4.2 , transformers >= 0.3.0.0 , transformers-base >= 0.4.4+ , unix-compat , unordered-containers >= 0.2.5.1 , vector >= 0.10.12.3 , vector-binary-instances@@ -161,6 +168,8 @@ , deepseq , file-embed , word8+ , hastache+ , project-template >= 0.2 if !os(windows) build-depends: unix >= 2.7.0.1 default-language: Haskell2010@@ -168,16 +177,20 @@ executable stack hs-source-dirs: src/main main-is: Main.hs- ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N+ ghc-options: -Wall -threaded -rtsopts other-modules: Plugins Plugins.Commands+ Paths_stack build-depends: base >=4.7 && < 5 , bytestring >= 0.10.4.0 , containers , exceptions , filepath+ , filelock >= 0.1.0.1 , http-conduit >= 2.1.5+ , lifted-base+ , monad-control , monad-logger >= 0.3.13.1 , mtl >= 2.1.3.1 , old-locale >= 1.0.0.6@@ -197,6 +210,9 @@ , transformers , http-client default-language: Haskell2010+ if os(windows)+ build-depends: Win32+ cpp-options: -DWINDOWS test-suite stack-test type: exitcode-stdio-1.0@@ -205,6 +221,7 @@ other-modules: Spec , Stack.BuildPlanSpec , Stack.Build.ExecuteSpec+ , Stack.Build.TargetSpec , Stack.ConfigSpec , Stack.DotSpec , Stack.PackageDumpSpec@@ -232,6 +249,7 @@ , optparse-applicative , bytestring , QuickCheck+ , retry >= 0.6 default-language: Haskell2010 test-suite stack-integration-test
stack.yaml view
@@ -4,4 +4,13 @@ - path-0.5.2 - Win32-notify-0.3.0.1 - hfsevents-0.1.5+- project-template-0.2.0+- filelock-0.1.0.1 resolver: lts-2.17+image:+ container:+ base: "fpco/ubuntu-with-libgmp:14.04"+ add:+ man/: /usr/local/share/man/+ entrypoints:+ - stack