stack 1.0.0 → 1.0.2
raw patch · 42 files changed
+2112/−1312 lines, 42 filesdep −email-validatedep ~Cabaldep ~aesondep ~attoparsec
Dependencies removed: email-validate
Dependency ranges changed: Cabal, aeson, attoparsec, conduit, conduit-extra, hspec, http-client, monad-logger, optparse-applicative, resourcet, stack, text
Files
- CONTRIBUTING.md +6/−0
- ChangeLog.md +62/−0
- LICENSE +1/−1
- src/Network/HTTP/Download/Verified.hs +2/−2
- src/Options/Applicative/Builder/Extra.hs +15/−33
- src/Stack/Build.hs +32/−34
- src/Stack/Build/Cache.hs +3/−0
- src/Stack/Build/Execute.hs +90/−107
- src/Stack/BuildPlan.hs +298/−123
- src/Stack/Config.hs +90/−7
- src/Stack/Config/Nix.hs +16/−16
- src/Stack/ConfigCmd.hs +1/−1
- src/Stack/Constants.hs +5/−3
- src/Stack/Coverage.hs +3/−2
- src/Stack/Docker.hs +35/−17
- src/Stack/FileWatch.hs +28/−23
- src/Stack/Ghci.hs +64/−25
- src/Stack/Ide.hs +1/−1
- src/Stack/Image.hs +37/−80
- src/Stack/Init.hs +126/−169
- src/Stack/Nix.hs +15/−9
- src/Stack/Options.hs +32/−20
- src/Stack/Package.hs +18/−10
- src/Stack/PackageIndex.hs +11/−2
- src/Stack/Setup.hs +105/−93
- src/Stack/Setup/Installed.hs +1/−1
- src/Stack/Solver.hs +503/−118
- src/Stack/Types/Build.hs +6/−10
- src/Stack/Types/BuildPlan.hs +31/−0
- src/Stack/Types/Config.hs +38/−14
- src/Stack/Types/Config.hs-boot +5/−0
- src/Stack/Types/Image.hs +30/−39
- src/Stack/Types/Nix.hs +7/−2
- src/Stack/Types/Package.hs +1/−0
- src/Stack/Types/StackT.hs +10/−9
- src/Stack/Upgrade.hs +5/−1
- src/System/Process/Read.hs +49/−23
- src/main/Main.hs +273/−276
- src/test/Stack/NixSpec.hs +2/−2
- stack.cabal +40/−32
- stack.yaml +9/−7
- test/integration/lib/StackTest.hs +6/−0
CONTRIBUTING.md view
@@ -67,3 +67,9 @@ [newcomer](https://github.com/commercialhaskell/stack/issues?q=is%3Aopen+is%3Aissue+label%3A%22awaiting+pr%22+label%3Anewcomer) label. Best to post a comment to the issue before you start work, in case anyone has already started.++Please include a+[ChangeLog](https://github.com/commercialhaskell/stack/blob/master/ChangeLog.md)+entry and+[documentation](https://github.com/commercialhaskell/stack/tree/master/doc/)+updates with your pull request.
ChangeLog.md view
@@ -1,5 +1,67 @@ # Changelog +## 1.0.2++Release notes:++- Arch Linux: Stack has been adopted into the+ [official community repository](https://www.archlinux.org/packages/community/x86_64/stack/),+ so we will no longer be updating the AUR with new versions. See the+ [install/upgrade guide](http://docs.haskellstack.org/en/stable/install_and_upgrade.html#arch-linux)+ for current download instructions.++Major changes:++- `stack init` and `solver` overhaul+ [#1583](https://github.com/commercialhaskell/stack/pull/1583)++Other enhancements:++- Disable locale/codepage hacks when GHC >=7.10.3+ [#1552](https://github.com/commercialhaskell/stack/issues/1552)+- Specify multiple images to build for `stack image container`+ [docs](http://docs.haskellstack.org/en/v1.0.2/yaml_configuration.html#image)+- Specify which executables to include in images for `stack image container`+ [docs](http://docs.haskellstack.org/en/v1.0.2/yaml_configuration.html#image)+- Docker: pass supplemantary groups and umask into container+- If git fetch fails wipe the directory and try again from scratch+ [#1418](https://github.com/commercialhaskell/stack/issues/1418)+- Warn if newly installed executables won't be available on the PATH+ [#1362](https://github.com/commercialhaskell/stack/issues/1362)+- stack.yaml: for `stack image container`, specify multiple images to generate,+ and which executables should be added to those images+- GHCI: add interactive Main selection+ [#1068](https://github.com/commercialhaskell/stack/issues/1068)+- Care less about the particular name of a GHCJS sdist folder+ [#1622](https://github.com/commercialhaskell/stack/issues/1622)+- Unified Enable/disable help messaging+ [#1613](https://github.com/commercialhaskell/stack/issues/1613)++Bug fixes:++- Don't share precompiled packages between GHC/platform variants and Docker+ [#1551](https://github.com/commercialhaskell/stack/issues/1551)+- Properly redownload corrupted downloads with the correct file size.+ [Mailing list discussion](https://groups.google.com/d/msg/haskell-stack/iVGDG5OHYxs/FjUrR5JsDQAJ)+- Gracefully handle invalid paths in error/warning messages+ [#1561](https://github.com/commercialhaskell/stack/issues/1561)+- Nix: select the correct GHC version corresponding to the snapshot+ even when an abstract resolver is passed via `--resolver` on the+ command-line.+ [#1641](https://github.com/commercialhaskell/stack/issues/1641)+- Fix: Stack does not allow using an external package from ghci+ [#1557](https://github.com/commercialhaskell/stack/issues/1557)+- Disable ambiguous global '--resolver' option for 'stack init'+ [#1531](https://github.com/commercialhaskell/stack/issues/1531)+- Obey `--no-nix` flag+- Fix: GHCJS Execute.hs: Non-exhaustive patterns in lambda+ [#1591](https://github.com/commercialhaskell/stack/issues/1591)+- Send file-watch and sticky logger messages to stderr+ [#1302](https://github.com/commercialhaskell/stack/issues/1302)+ [#1635](https://github.com/commercialhaskell/stack/issues/1635)+- Use globaldb path for querying Cabal version+ [#1647](https://github.com/commercialhaskell/stack/issues/1647)+ ## 1.0.0 Release notes:
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2015, Stack contributors+Copyright (c) 2015-2016, Stack contributors All rights reserved. Redistribution and use in source and binary forms, with or without
src/Network/HTTP/Download/Verified.hs view
@@ -243,8 +243,8 @@ -- precondition: file exists -- TODO: add logging fileMatchesExpectations =- (checkExpectations >> return True)- `catch` \(_ :: VerifyFileException) -> return False+ ((checkExpectations >> return True)+ `catch` \(_ :: VerifyFileException) -> return False) `catch` \(_ :: VerifiedDownloadException) -> return False checkExpectations = bracket (openFile fp ReadMode) hClose $ \h -> do
src/Options/Applicative/Builder/Extra.hs view
@@ -29,9 +29,7 @@ boolFlags defaultValue = enableDisableFlags defaultValue True False -- | Enable/disable flags for a 'Bool', without a default case (to allow chaining with '<|>').-boolFlagsNoDefault :: Maybe Bool -- ^ Hide the enabling or disabling flag from the- -- brief description?- -> String -- ^ Flag name+boolFlagsNoDefault :: String -- ^ Flag name -> String -- ^ Help suffix -> Mod FlagFields Bool -> Parser Bool@@ -54,54 +52,38 @@ -> Mod FlagFields a -> Parser a enableDisableFlags defaultValue enabledValue disabledValue name helpSuffix mods =- enableDisableFlagsNoDefault enabledValue disabledValue (Just defaultValue) name helpSuffix mods <|>+ enableDisableFlagsNoDefault enabledValue disabledValue name helpSuffix mods <|> pure defaultValue -- | Enable/disable flags for any type, without a default (to allow chaining with '<|>') enableDisableFlagsNoDefault :: (Eq a) => a -- ^ Enabled value -> a -- ^ Disabled value- -> Maybe a -- ^ Hide the enabling or disabling flag- -- from the brief description?? -> String -- ^ Name -> String -- ^ Help suffix -> Mod FlagFields a -> Parser a-enableDisableFlagsNoDefault enabledValue disabledValue maybeHideValue name helpSuffix mods =- last <$> some (enableDisableFlagsNoDefault' enabledValue disabledValue maybeHideValue name helpSuffix mods)--enableDisableFlagsNoDefault' :: (Eq a) => a -> a -> Maybe a -> String -> String -> Mod FlagFields a -> Parser a-enableDisableFlagsNoDefault' enabledValue disabledValue maybeHideValue name helpSuffix mods =- let hideEnabled = Just enabledValue == maybeHideValue- hideDisabled = Just disabledValue == maybeHideValue- in flag'+enableDisableFlagsNoDefault enabledValue disabledValue name helpSuffix mods =+ last <$> some+ ((flag' enabledValue- ((if hideEnabled- then hidden <> internal- else idm) <>+ (hidden <>+ internal <> long name <>- help- (concat $ concat- [ ["Enable ", helpSuffix]- , [" (--no-" ++ name ++ " to disable)" | hideDisabled]]) <>+ help helpSuffix <> mods) <|> flag'- enabledValue- (hidden <> internal <> long ("enable-" ++ name) <> mods) <|>- flag' disabledValue- ((if hideDisabled- then hidden <> internal- else idm) <>+ (hidden <>+ internal <> long ("no-" ++ name) <>- help- (concat $ concat- [ ["Disable ", helpSuffix]- , [" (--" ++ name ++ " to enable)" | hideEnabled]]) <>- mods) <|>+ help helpSuffix <>+ mods)) <|> flag' disabledValue- (hidden <> internal <> long ("disable-" ++ name) <> mods)+ (long (concat ["[no-]", name]) <>+ help (concat ["Enable/disable ", helpSuffix]) <>+ mods)) -- | Show an extra help option (e.g. @--docker-help@ shows help for all @--docker*@ args). --
src/Stack/Build.hs view
@@ -77,7 +77,7 @@ -> Maybe FileLock -> BuildOpts -> m ()-build setLocalFiles mbuildLk bopts = fixCodePage' $ do+build setLocalFiles mbuildLk bopts = fixCodePage $ do menv <- getMinimalEnvOverride (_, mbp, locals, extraToBuild, sourceMap) <- loadSourceMap NeedTargets bopts@@ -261,35 +261,42 @@ -- | Set the code page for this process as necessary. Only applies to Windows. -- See: https://github.com/commercialhaskell/stack/issues/738-fixCodePage :: (MonadIO m, MonadMask m, MonadLogger m) => m a -> m a+fixCodePage :: M env m => m a -> m a #ifdef WINDOWS fixCodePage inner = do- origCPI <- liftIO getConsoleCP- origCPO <- liftIO getConsoleOutputCP+ mcp <- asks $ configModifyCodePage . getConfig+ ec <- asks getEnvConfig+ if mcp && getGhcVersion (envConfigCompilerVersion ec) < $(mkVersion "7.10.3")+ then fixCodePage'+ -- GHC >=7.10.3 doesn't need this code page hack.+ else inner+ where+ fixCodePage' = do+ origCPI <- liftIO getConsoleCP+ origCPO <- liftIO getConsoleOutputCP - let setInput = origCPI /= expected- setOutput = origCPO /= expected- fixInput- | setInput = Catch.bracket_- (liftIO $ do- setConsoleCP expected)- (liftIO $ setConsoleCP origCPI)- | otherwise = id- fixOutput- | setInput = Catch.bracket_- (liftIO $ do- setConsoleOutputCP expected)- (liftIO $ setConsoleOutputCP origCPO)- | otherwise = id+ let setInput = origCPI /= expected+ setOutput = origCPO /= expected+ fixInput+ | setInput = Catch.bracket_+ (liftIO $ do+ setConsoleCP expected)+ (liftIO $ setConsoleCP origCPI)+ | otherwise = id+ fixOutput+ | setInput = Catch.bracket_+ (liftIO $ do+ setConsoleOutputCP expected)+ (liftIO $ setConsoleOutputCP origCPO)+ | otherwise = id - case (setInput, setOutput) of- (False, False) -> return ()- (True, True) -> warn ""- (True, False) -> warn " input"- (False, True) -> warn " output"+ case (setInput, setOutput) of+ (False, False) -> return ()+ (True, True) -> warn ""+ (True, False) -> warn " input"+ (False, True) -> warn " output" - fixInput $ fixOutput inner- where+ fixInput $ fixOutput inner expected = 65001 -- UTF-8 warn typ = $logInfo $ T.concat [ "Setting"@@ -299,15 +306,6 @@ #else fixCodePage = id #endif--fixCodePage' :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env)- => m a- -> m a-fixCodePage' inner = do- mcp <- asks $ configModifyCodePage . getConfig- if mcp- then fixCodePage inner- else inner -- | Query information about the build and print the result to stdout in YAML format. queryBuildInfo :: M env m
src/Stack/Build/Cache.hs view
@@ -268,8 +268,11 @@ -- cache hit just because it was installed in a different directory. copts' <- parseRelFile $ S8.unpack $ B16.encode $ SHA256.hashlazy cacheInput + platformRelDir <- platformGhcRelDir+ return $ getStackRoot ec </> $(mkRelDir "precompiled")+ </> platformRelDir </> compiler </> cabal </> pkg
src/Stack/Build/Execute.hs view
@@ -18,14 +18,14 @@ import Control.Applicative import Control.Arrow ((&&&))-import Control.Concurrent.Async (withAsync, wait) import Control.Concurrent.Execute import Control.Concurrent.MVar.Lifted import Control.Concurrent.STM-import Control.Exception.Enclosed (catchIO, tryIO)+import Control.Exception.Enclosed (catchIO) import Control.Exception.Lifted-import Control.Monad (liftM, when, unless, void, join, filterM, (<=<))+import Control.Monad (liftM, when, unless, void, join) import Control.Monad.Catch (MonadCatch, MonadMask)+import Control.Monad.Extra (anyM, (&&^)) import Control.Monad.IO.Class import Control.Monad.Logger import Control.Monad.Reader (MonadReader, asks)@@ -33,6 +33,7 @@ import Control.Monad.Trans.Resource import Data.Attoparsec.Text import qualified Data.ByteString as S+import Data.Char (isSpace) import Data.Conduit import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.List as CL@@ -349,13 +350,6 @@ createTree destDir destDir' <- liftIO . D.canonicalizePath . toFilePath $ destDir- isInPATH <- liftIO . fmap (any (FP.equalFilePath destDir')) . (mapM D.canonicalizePath <=< filterM D.doesDirectoryExist) $ (envSearchPath menv)- when (not isInPATH) $- $logWarn $ T.concat- [ "Installation path "- , T.pack destDir'- , " not found in PATH environment variable"- ] platform <- asks getPlatform let ext =@@ -393,17 +387,56 @@ Platform _ Windows | FP.equalFilePath destFile currExe -> windowsRenameCopy (toFilePath file) destFile _ -> D.copyFile (toFilePath file) destFile- return $ Just (destDir', [T.append name (T.pack ext)])+ return $ Just (name <> T.pack ext) - let destToInstalled = Map.fromListWith (++) installed- unless (Map.null destToInstalled) $ $logInfo ""- forM_ (Map.toList destToInstalled) $ \(dest, executables) -> do+ unless (null installed) $ do+ $logInfo "" $logInfo $ T.concat [ "Copied executables to "- , T.pack dest+ , T.pack destDir' , ":"]- forM_ executables $ \exe -> $logInfo $ T.append "- " exe+ forM_ installed $ \exe -> $logInfo ("- " <> exe) + searchPath <- liftIO FP.getSearchPath+ destDirIsInPATH <- liftIO $+ anyM (\dir -> D.doesDirectoryExist dir &&^ fmap (FP.equalFilePath destDir') (D.canonicalizePath dir)) searchPath+ if destDirIsInPATH+ then forM_ installed $ \exe -> do+ mexePath <- (liftIO . D.findExecutable . T.unpack) exe+ case mexePath of+ Just exePath -> do+ exeDir <- (liftIO . fmap FP.takeDirectory . D.canonicalizePath) exePath+ unless (exeDir `FP.equalFilePath` destDir') $ do+ $logWarn ""+ $logWarn $ T.concat+ [ "WARNING: The \""+ , exe+ , "\" executable found on the PATH environment variable is "+ , T.pack exePath+ , ", and not the version that was just installed."+ ]+ $logWarn $ T.concat+ [ "This means that \""+ , exe+ , "\" calls on the command line will not use this version."+ ]+ Nothing -> do+ $logWarn ""+ $logWarn $ T.concat+ [ "WARNING: Installation path "+ , T.pack destDir'+ , " is on the PATH but the \""+ , exe+ , "\" executable that was just installed could not be found on the PATH."+ ]+ else do+ $logWarn ""+ $logWarn $ T.concat+ [ "WARNING: Installation path "+ , T.pack destDir'+ , " not found on the PATH environment variable"+ ]+ config <- asks getConfig menv' <- liftIO $ configEnvOverride config EnvSettings { esIncludeLocals = True@@ -808,63 +841,39 @@ ++ ["-package-db=" ++ toFilePathNoTrailingSep (bcoSnapDB eeBaseConfigOpts)] setupArgs = ("--builddir=" ++ toFilePathNoTrailingSep distRelativeDir') : args- runExe exeName fullArgs = do- $logProcessRun (toFilePath exeName) fullArgs-- -- Use createProcess_ to avoid the log file being closed afterwards- (Nothing, moutH, merrH, ph) <- liftIO $ createProcess_ "singleBuild" cp-- let makeAbsolute = stripTHLoading -- If users want control, we should add a config option for this-- ec <-- liftIO $- withAsync (runInBase $ maybePrintBuildOutput stripTHLoading makeAbsolute pkgDir LevelInfo mlogFile moutH) $ \outThreadID ->- withAsync (runInBase $ maybePrintBuildOutput False makeAbsolute pkgDir LevelWarn mlogFile merrH) $ \errThreadID -> do- ec <- waitForProcess ph- wait errThreadID- wait outThreadID- return ec- case ec of- ExitSuccess -> return ()- _ -> do- bss <-- case mlogFile of- Nothing -> return []- Just (logFile, h) -> do- liftIO $ hClose h- runResourceT- $ CB.sourceFile (toFilePath logFile)- =$= CT.decodeUtf8- $$ mungeBuildOutput stripTHLoading makeAbsolute pkgDir- =$ CL.consume- throwM $ CabalExitedUnsuccessfully- ec- taskProvides- exeName- fullArgs- (fmap fst mlogFile)- bss- where- cp0 = proc (toFilePath exeName) fullArgs- cp = cp0- { cwd = Just $ toFilePath pkgDir- , Process.env = envHelper menv- -- 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- Just (_, h) -> UseHandle h- , std_err =+ runExe exeName fullArgs =+ runAndOutput `catch` \(ProcessExitedUnsuccessfully _ ec) -> do+ bss <- case mlogFile of- Nothing -> CreatePipe- Just (_, h) -> UseHandle h- }+ Nothing -> return []+ Just (logFile, h) -> do+ liftIO $ hClose h+ runResourceT+ $ CB.sourceFile (toFilePath logFile)+ =$= CT.decodeUtf8+ $$ mungeBuildOutput stripTHLoading makeAbsolute pkgDir+ =$ CL.consume+ throwM $ CabalExitedUnsuccessfully+ ec+ taskProvides+ exeName+ fullArgs+ (fmap fst mlogFile)+ bss+ where+ runAndOutput = case mlogFile of+ Just (_, h) ->+ sinkProcessStderrStdoutHandle (Just pkgDir) menv (toFilePath exeName) fullArgs h h+ Nothing ->+ void $ sinkProcessStderrStdout (Just pkgDir) menv (toFilePath exeName) fullArgs+ (outputSink False LevelWarn)+ (outputSink stripTHLoading LevelInfo)+ outputSink excludeTH level =+ CT.decodeUtf8+ =$ mungeBuildOutput excludeTH makeAbsolute pkgDir+ =$ CL.mapM_ (runInBase . monadLoggerLog $(TH.location >>= liftLoc) "" level)+ -- If users want control, we should add a config option for this+ makeAbsolute = stripTHLoading wc <- getWhichCompiler (exeName, fullArgs) <- case (esetupexehs, wc) of@@ -893,14 +902,6 @@ return (outputFile, setupArgs) runExe exeName $ (if boptsCabalVerbose eeBuildOpts then ("--verbose":) else id) fullArgs - maybePrintBuildOutput stripTHLoading makeAbsolute pkgDir level mlogFile mh =- case mh of- Just h ->- case mlogFile of- Just{} -> return ()- Nothing -> printBuildOutput stripTHLoading makeAbsolute pkgDir level h- Nothing -> return ()- singleBuild :: M env m => (m () -> IO ()) -> ActionContext@@ -974,7 +975,7 @@ _ -> return Nothing copyPreCompiled (PrecompiledCache mlib exes) = do- announceTask task "copying precompiled package"+ announceTask task "using precompiled package" forM_ mlib $ \libpath -> do menv <- getMinimalEnvOverride withMVar eeInstallLock $ \() -> do@@ -996,7 +997,9 @@ , "--force" , packageIdentifierString taskProvides ])- (\(ReadProcessException _ _ _ _) -> return ())+ (\ex -> case ex of+ ReadProcessException{} -> return ()+ _ -> throwM ex) readProcessNull Nothing menv' "ghc-pkg" [ "register"@@ -1320,25 +1323,8 @@ announce "benchmarks" cabal False ("bench" : args) --- | Grab all output from the given @Handle@ and log it, stripping--- Template Haskell "Loading package" lines and making paths absolute.--- thread.-printBuildOutput :: (MonadIO m, MonadBaseControl IO m, MonadLogger m,- MonadThrow m)- => Bool -- ^ exclude TH loading?- -> Bool -- ^ convert paths to absolute?- -> Path Abs Dir -- ^ package's root directory- -> LogLevel- -> Handle- -> m ()-printBuildOutput excludeTHLoading makeAbsolute pkgDir level outH = void $- CB.sourceHandle outH- $$ CT.decodeUtf8- =$ mungeBuildOutput excludeTHLoading makeAbsolute pkgDir- =$ CL.mapM_ (monadLoggerLog $(TH.location >>= liftLoc) "" level)- -- | Strip Template Haskell "Loading package" lines and making paths absolute.-mungeBuildOutput :: MonadIO m+mungeBuildOutput :: (MonadIO m, MonadThrow m) => Bool -- ^ exclude TH loading? -> Bool -- ^ convert paths to absolute? -> Path Abs Dir -- ^ package's root directory@@ -1363,21 +1349,18 @@ let (x, y) = T.break (== ':') bs mabs <- if isValidSuffix y- then do- efp <- liftIO $ tryIO $ resolveFile pkgDir (T.unpack x)- case efp of- Left _ -> return Nothing- Right fp -> return $ Just $ T.pack (toFilePath fp)+ then liftM (fmap ((T.takeWhile isSpace x <>) . T.pack . toFilePath)) $+ resolveFileMaybe pkgDir (T.unpack $ T.dropWhile isSpace x) else return Nothing case mabs of Nothing -> return bs Just fp -> return $ fp `T.append` y -- | Match the line:column format at the end of lines- isValidSuffix = isRight . parseOnly (lineCol <* endOfInput)+ isValidSuffix = isRight . parseOnly lineCol lineCol = char ':' >> (decimal :: Parser Int) >> char ':' >> (decimal :: Parser Int)- >> (string ":" <|> string ": Warning:")+ >> char ':' >> return () -- | Strip @\r@ characters from the byte vector. Used because Windows.
src/Stack/BuildPlan.hs view
@@ -10,17 +10,21 @@ -- snapshot. module Stack.BuildPlan- ( BuildPlanException (..)+ ( gpdPackages+ , BuildPlanException (..)+ , BuildPlanCheck (..)+ , checkSnapBuildPlan , MiniBuildPlan(..) , MiniPackageInfo(..)- , Snapshots (..)- , getSnapshots , loadMiniBuildPlan+ , removeSrcPkgDefaultFlags , resolveBuildPlan- , findBuildPlan+ , selectBestSnapshot , ToolMap , getToolMap , shadowMiniBuildPlan+ , showCompilerErrors+ , showDepErrors , parseCustomMiniBuildPlan ) where @@ -35,7 +39,7 @@ put) import Control.Monad.Trans.Control (MonadBaseControl) import qualified Crypto.Hash.SHA256 as SHA256-import Data.Aeson.Extended (FromJSON (..), withObject, withText, (.:), (.:?), (.!=))+import Data.Aeson.Extended (FromJSON (..), withObject, (.:), (.:?), (.!=)) import Data.Binary.VersionTagged (taggedDecodeOrLoad) import Data.ByteString (ByteString) import qualified Data.ByteString.Base16 as B16@@ -43,20 +47,17 @@ import qualified Data.ByteString.Char8 as S8 import Data.Either (partitionEithers) import qualified Data.Foldable as F-import qualified Data.HashMap.Strict as HM-import Data.IntMap (IntMap)-import qualified Data.IntMap as IntMap+import qualified Data.HashSet as HashSet import Data.List (intercalate) import Data.Map (Map) import qualified Data.Map as Map-import Data.Maybe (fromMaybe, mapMaybe)+import Data.Maybe (fromJust, fromMaybe, mapMaybe) 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 (encodeUtf8)-import Data.Time (Day) import qualified Data.Traversable as Tr import Data.Typeable (Typeable) import Data.Yaml (decodeEither', decodeFileEither)@@ -64,6 +65,7 @@ flagDefault, flagManual, flagName, genPackageFlags, executables, exeName, library, libBuildInfo, buildable)+import Distribution.System (Platform) import qualified Distribution.Package as C import qualified Distribution.PackageDescription as C import qualified Distribution.Version as C@@ -392,39 +394,6 @@ $ Set.toList $ mpiExes mpi --- | Download the 'Snapshots' value from stackage.org.-getSnapshots :: (MonadThrow m, MonadIO m, MonadReader env m, HasHttpManager env, HasStackRoot env, HasConfig env)- => m Snapshots-getSnapshots = askLatestSnapshotUrl >>= parseUrl . T.unpack >>= downloadJSON---- | Most recent Nightly and newest LTS version per major release.-data Snapshots = Snapshots- { snapshotsNightly :: !Day- , snapshotsLts :: !(IntMap Int)- }- deriving Show-instance FromJSON Snapshots where- parseJSON = withObject "Snapshots" $ \o -> Snapshots- <$> (o .: "nightly" >>= parseNightly)- <*> (fmap IntMap.unions- $ mapM (parseLTS . snd)- $ filter (isLTS . fst)- $ HM.toList o)- where- parseNightly t =- case parseSnapName t of- Left e -> fail $ show e- Right (LTS _ _) -> fail "Unexpected LTS value"- Right (Nightly d) -> return d-- isLTS = ("lts-" `T.isPrefixOf`)-- parseLTS = withText "LTS" $ \t ->- case parseSnapName t of- Left e -> fail $ show e- Right (LTS x y) -> return $ IntMap.singleton x y- Right (Nightly _) -> fail "Unexpected nightly value"- -- | Load up a 'MiniBuildPlan', preferably from cache loadMiniBuildPlan :: (MonadIO m, MonadThrow m, MonadLogger m, MonadReader env m, HasHttpManager env, HasConfig env, HasGHCVariant env, MonadBaseControl IO m, MonadCatch m)@@ -494,67 +463,136 @@ handle404 (Status 404 _) _ _ = Just $ SomeException $ SnapshotNotFound name handle404 _ _ _ = Nothing --- | Find the set of @FlagName@s necessary to get the given--- @GenericPackageDescription@ to compile against the given @BuildPlan@. Will--- only modify non-manual flags, and will prefer default values for flags.--- Returns @Nothing@ if no combination exists.-checkBuildPlan :: (MonadLogger m, MonadThrow m, MonadIO m, MonadReader env m, HasConfig env, MonadCatch m)- => Map PackageName Version -- ^ locally available packages- -> MiniBuildPlan- -> GenericPackageDescription- -> m (Either DepErrors (Map PackageName (Map FlagName Bool)))-checkBuildPlan locals mbp gpd = do- platform <- asks (configPlatform . getConfig)- return $ loop platform flagOptions- where- packages = Map.union locals $ fmap mpiVersion $ mbpPackages mbp- loop _ [] = assert False $ Left Map.empty- loop platform (flags:rest)- | Map.null errs = Right $- if Map.null flags- then Map.empty- else Map.singleton (packageName pkg) flags- | null rest = Left errs- | otherwise = loop platform rest- where- errs = checkDeps (packageName pkg) (packageDeps pkg) packages- pkg = resolvePackage pkgConfig gpd+gpdPackages :: [GenericPackageDescription] -> Map PackageName Version+gpdPackages gpds = Map.fromList $+ map (fromCabalIdent . C.package . C.packageDescription) gpds+ where+ fromCabalIdent (C.PackageIdentifier name version) =+ (fromCabalPackageName name, fromCabalVersion version)++gpdPackageName :: GenericPackageDescription -> PackageName+gpdPackageName = fromCabalPackageName+ . C.pkgName+ . C.package+ . C.packageDescription++gpdPackageDeps+ :: GenericPackageDescription+ -> CompilerVersion+ -> Platform+ -> Map FlagName Bool+ -> Map PackageName VersionRange+gpdPackageDeps gpd cv platform flags =+ Map.filterWithKey (const . (/= name)) (packageDependencies pkgDesc)+ where+ name = gpdPackageName gpd+ pkgDesc = resolvePackageDescription pkgConfig gpd pkgConfig = PackageConfig { packageConfigEnableTests = True , packageConfigEnableBenchmarks = True , packageConfigFlags = flags- , packageConfigCompilerVersion = compilerVersion+ , packageConfigCompilerVersion = cv , packageConfigPlatform = platform } - compilerVersion = mbpCompilerVersion mbp+-- Remove any src package flags having default values+-- Remove any package entries with no flags set+removeSrcPkgDefaultFlags :: [C.GenericPackageDescription]+ -> Map PackageName (Map FlagName Bool)+ -> Map PackageName (Map FlagName Bool)+removeSrcPkgDefaultFlags gpds flags =+ let defaults = Map.unions (map gpdDefaultFlags gpds)+ flags' = Map.differenceWith removeSame flags defaults+ in Map.filter (not . Map.null) flags'+ where+ removeSame f1 f2 =+ let diff v v' = if v == v' then Nothing else Just v+ in Just $ Map.differenceWith diff f1 f2 - flagName' = fromCabalFlagName . flagName+ gpdDefaultFlags gpd =+ let tuples = map getDefault (C.genPackageFlags gpd)+ in Map.singleton (gpdPackageName gpd) (Map.fromList tuples) - -- Avoid exponential complexity in flag combinations making us sad pandas.- -- See: https://github.com/commercialhaskell/stack/issues/543- maxFlagOptions = 128+ flagName' = fromCabalFlagName . C.flagName+ getDefault f+ | C.flagDefault f = (flagName' f, True)+ | otherwise = (flagName' f, False) - flagOptions = take maxFlagOptions $ map Map.fromList $ mapM getOptions $ genPackageFlags gpd- getOptions f- | flagManual f = [(flagName' f, flagDefault f)]- | flagDefault f =- [ (flagName' f, True)- , (flagName' f, False)- ]- | otherwise =- [ (flagName' f, False)- , (flagName' f, True)- ]+-- | Find the set of @FlagName@s necessary to get the given+-- @GenericPackageDescription@ to compile against the given @BuildPlan@. Will+-- only modify non-manual flags, and will prefer default values for flags.+-- Returns the plan which produces least number of dep errors+selectPackageBuildPlan+ :: Platform+ -> CompilerVersion+ -> Map PackageName Version+ -> GenericPackageDescription+ -> (Map PackageName (Map FlagName Bool), DepErrors)+selectPackageBuildPlan platform compiler pool gpd =+ fromJust (go flagOptions Nothing)+ where+ go :: [Map FlagName Bool] -> Maybe (Map PackageName (Map FlagName Bool), DepErrors) -> Maybe (Map PackageName (Map FlagName Bool), DepErrors)+ -- impossible+ go [] Nothing = assert False Nothing+ -- last+ go [] (Just plan) = Just plan+ -- got the best possible result+ go _ (Just plan) | Map.null (snd plan) = Just plan+ -- initial+ go (flags:rest) Nothing = go rest $ Just (nextPlan flags)+ -- keep looking for better results+ go (flags:rest) (Just plan) =+ go rest $ Just (betterPlan plan (nextPlan flags)) + nextPlan flags = checkPackageBuildPlan platform compiler pool flags gpd++ betterPlan (f1, e1) (f2, e2)+ | (Map.size e1) <= (Map.size e2) = (f1, e1)+ | otherwise = (f2, e2)++ flagName' = fromCabalFlagName . flagName++ -- Avoid exponential complexity in flag combinations making us sad pandas.+ -- See: https://github.com/commercialhaskell/stack/issues/543+ maxFlagOptions = 128++ flagOptions :: [Map FlagName Bool]+ flagOptions = take maxFlagOptions $ map Map.fromList $ mapM getOptions $ genPackageFlags gpd+ getOptions f+ | flagManual f = [(flagName' f, flagDefault f)]+ | flagDefault f =+ [ (flagName' f, True)+ , (flagName' f, False)+ ]+ | otherwise =+ [ (flagName' f, False)+ , (flagName' f, True)+ ]++-- | Check whether with the given set of flags a package's dependency+-- constraints can be satisfied against a given build plan or pool of packages.+checkPackageBuildPlan+ :: Platform+ -> CompilerVersion+ -> Map PackageName Version+ -> Map FlagName Bool+ -> GenericPackageDescription+ -> (Map PackageName (Map FlagName Bool), DepErrors)+checkPackageBuildPlan platform compiler pool flags gpd =+ (Map.singleton pkg flags, errs)+ where+ pkg = gpdPackageName gpd+ errs = checkPackageDeps pkg constraints pool+ constraints = gpdPackageDeps gpd compiler platform flags+ -- | Checks if the given package dependencies can be satisfied by the given set -- of packages. Will fail if a package is either missing or has a version -- outside of the version range.-checkDeps :: PackageName -- ^ package using dependencies, for constructing DepErrors- -> Map PackageName VersionRange- -> Map PackageName Version+checkPackageDeps :: PackageName -- ^ package using dependencies, for constructing DepErrors+ -> Map PackageName VersionRange -- ^ dependency constraints+ -> Map PackageName Version -- ^ Available package pool or index -> DepErrors-checkDeps myName deps packages =+checkPackageDeps myName deps packages = Map.unionsWith mappend $ map go $ Map.toList deps where go :: (PackageName, VersionRange) -> DepErrors@@ -575,47 +613,165 @@ data DepError = DepError { deVersion :: !(Maybe Version) , deNeededBy :: !(Map PackageName VersionRange)- }+ } deriving Show instance Monoid DepError where mempty = DepError Nothing Map.empty mappend (DepError a x) (DepError b y) = DepError (maybe a Just b) (Map.unionWith C.intersectVersionRanges x y) --- | Find a snapshot and set of flags that is compatible with the given--- 'GenericPackageDescription'. Returns 'Nothing' if no such snapshot is found.-findBuildPlan :: (MonadIO m, MonadCatch m, MonadLogger m, MonadReader env m, HasHttpManager env, HasConfig env, HasGHCVariant env, MonadBaseControl IO m)- => [GenericPackageDescription]- -> [SnapName]- -> m (Maybe (SnapName, Map PackageName (Map FlagName Bool)))-findBuildPlan gpds0 =- loop- where- loop [] = return Nothing- loop (name:names') = do- mbp <- loadMiniBuildPlan name- $logInfo $ "Checking against build plan " <> renderSnapName name- res <- mapM (checkBuildPlan localNames mbp) gpds0- case partitionEithers res of- ([], flags) -> return $ Just (name, Map.unions flags)- (errs, _) -> do- $logInfo ""- $logInfo "* Build plan did not match your requirements:"- displayDepErrors $ Map.unionsWith mappend errs- $logInfo ""- loop names'+-- | Given a bundle of packages (a list of @GenericPackageDescriptions@'s) to+-- build and an available package pool (snapshot) check whether the bundle's+-- dependencies can be satisfied. If flags is passed as Nothing flag settings+-- will be chosen automatically.+checkBundleBuildPlan+ :: Platform+ -> CompilerVersion+ -> Map PackageName Version+ -> Maybe (Map PackageName (Map FlagName Bool))+ -> [GenericPackageDescription]+ -> (Map PackageName (Map FlagName Bool), DepErrors)+checkBundleBuildPlan platform compiler pool flags gpds =+ (Map.unionsWith dupError (map fst plans)+ , Map.unionsWith mappend (map snd plans)) - localNames = Map.fromList $ map (fromCabalIdent . C.package . C.packageDescription) gpds0+ where+ plans = map (pkgPlan flags) gpds+ pkgPlan Nothing gpd =+ selectPackageBuildPlan platform compiler pool' gpd+ pkgPlan (Just f) gpd =+ checkPackageBuildPlan platform compiler pool' (flags' f gpd) gpd+ flags' f gpd = maybe Map.empty id (Map.lookup (gpdPackageName gpd) f)+ pool' = Map.union (gpdPackages gpds) pool - fromCabalIdent (C.PackageIdentifier name version) =- (fromCabalPackageName name, fromCabalVersion version)+ dupError _ _ = error "Bug: Duplicate packages are not expected here" -displayDepErrors :: MonadLogger m => DepErrors -> m ()-displayDepErrors errs =- F.forM_ (Map.toList errs) $ \(depName, DepError mversion neededBy) -> do- $logInfo $ T.concat- [ " "- , T.pack $ packageNameString depName+data BuildPlanCheck =+ BuildPlanCheckOk (Map PackageName (Map FlagName Bool))+ | BuildPlanCheckPartial (Map PackageName (Map FlagName Bool)) DepErrors+ | BuildPlanCheckFail (Map PackageName (Map FlagName Bool)) DepErrors+ CompilerVersion++-- | Check a set of 'GenericPackageDescription's and a set of flags against a+-- given snapshot. Returns how well the snapshot satisfies the dependencies of+-- the packages.+checkSnapBuildPlan+ :: ( MonadIO m, MonadCatch m, MonadLogger m, MonadReader env m+ , HasHttpManager env, HasConfig env, HasGHCVariant env+ , MonadBaseControl IO m)+ => [GenericPackageDescription]+ -> Maybe (Map PackageName (Map FlagName Bool))+ -> SnapName+ -> m BuildPlanCheck+checkSnapBuildPlan gpds flags snap = do+ platform <- asks (configPlatform . getConfig)+ mbp <- loadMiniBuildPlan snap++ let+ compiler = mbpCompilerVersion mbp+ snapPkgs = fmap mpiVersion $ mbpPackages mbp+ (f, errs) = checkBundleBuildPlan platform compiler snapPkgs flags gpds+ cerrs = compilerErrors compiler errs++ if Map.null errs then+ return $ BuildPlanCheckOk f+ else if Map.null cerrs then do+ return $ BuildPlanCheckPartial f errs+ else+ return $ BuildPlanCheckFail f cerrs compiler+ where+ compilerErrors compiler errs+ | whichCompiler compiler == Ghc = ghcErrors errs+ -- FIXME not sure how to handle ghcjs boot packages+ | otherwise = Map.empty++ isGhcWiredIn p _ = p `HashSet.member` wiredInPackages+ ghcErrors = Map.filterWithKey isGhcWiredIn++-- | Find a snapshot and set of flags that is compatible with and matches as+-- best as possible with the given 'GenericPackageDescription's. Returns+-- 'Nothing' if no such snapshot is found.+selectBestSnapshot+ :: ( MonadIO m, MonadCatch m, MonadLogger m, MonadReader env m+ , HasHttpManager env, HasConfig env, HasGHCVariant env+ , MonadBaseControl IO m)+ => [GenericPackageDescription]+ -> [SnapName]+ -> m (Maybe SnapName)+selectBestSnapshot gpds snaps = do+ $logInfo $ "Selecting the best among "+ <> T.pack (show (length snaps))+ <> " snapshots...\n"+ loop Nothing snaps+ where+ loop Nothing [] = return Nothing+ loop (Just (snap, _)) [] = return $ Just snap+ loop bestYet (snap:rest) = do+ result <- checkSnapBuildPlan gpds Nothing snap+ reportResult result snap+ case result of+ BuildPlanCheckFail _ _ _ -> loop bestYet rest+ BuildPlanCheckOk _ -> return $ Just snap+ BuildPlanCheckPartial _ e -> do+ case bestYet of+ Nothing -> loop (Just (snap, e)) rest+ Just prev ->+ loop (Just (betterSnap prev (snap, e))) rest++ betterSnap (s1, e1) (s2, e2)+ | (Map.size e1) <= (Map.size e2) = (s1, e1)+ | otherwise = (s2, e2)++ reportResult (BuildPlanCheckOk _) snap = do+ $logInfo $ "* Selected " <> renderSnapName snap+ $logInfo ""++ reportResult (BuildPlanCheckPartial f errs) snap = do+ $logWarn $ "* Partially matches " <> renderSnapName snap+ $logWarn $ indent $ showDepErrors f errs++ reportResult (BuildPlanCheckFail f errs compiler) snap = do+ $logWarn $ "* Rejected " <> renderSnapName snap+ $logWarn $ indent $ showCompilerErrors f errs compiler++ indent t = T.unlines $ fmap (" " <>) (T.lines t)++showCompilerErrors+ :: Map PackageName (Map FlagName Bool)+ -> DepErrors+ -> CompilerVersion+ -> Text+showCompilerErrors flags errs compiler =+ -- TODO print the package filename to enable quick mapping for the user+ T.concat+ [ compilerVersionText compiler+ , " cannot be used for these packages:\n"+ , T.concat (map formatError (Map.toList errs))+ , showDepErrors flags errs -- TODO only in debug mode+ ]+ where+ formatError (_, DepError _ neededBy) = T.concat $+ map formatItem (Map.toList neededBy)++ formatItem (user, _) = T.concat+ [ " - "+ , T.pack $ packageNameString user+ , "\n"+ ]++showDepErrors :: Map PackageName (Map FlagName Bool) -> DepErrors -> Text+showDepErrors flags errs =+ T.concat $ map formatError (Map.toList errs)+ where+ formatError (depName, DepError mversion neededBy) = T.concat+ [ showDepVersion depName mversion+ , T.concat (map showRequirement (Map.toList neededBy))+ -- TODO only in debug+ , T.concat (map showFlags (Map.toList neededBy))+ ]++ showDepVersion depName mversion = T.concat+ [ T.pack $ packageNameString depName , case mversion of Nothing -> " not found" Just version -> T.concat@@ -623,14 +779,33 @@ , T.pack $ versionString version , " found" ]+ , "\n" ]- F.forM_ (Map.toList neededBy) $ \(user, range) -> $logInfo $ T.concat++ showRequirement (user, range) = T.concat [ " - " , T.pack $ packageNameString user , " requires " , T.pack $ display range+ , "\n" ]- $logInfo ""++ showFlags (user, _) =+ maybe "" (printFlags user) (Map.lookup user flags)++ printFlags user fl =+ if (not $ Map.null fl) then+ T.concat+ [ " - "+ , T.pack $ packageNameString user+ , " flags: "+ , T.pack $ intercalate ", "+ $ map formatFlags (Map.toList fl)+ , "\n"+ ]+ else ""++ formatFlags (f, v) = (show f) ++ " = " ++ (show v) shadowMiniBuildPlan :: MiniBuildPlan -> Set PackageName
src/Stack/Config.hs view
@@ -28,17 +28,20 @@ ,resolvePackageEntry ,getImplicitGlobalProjectDir ,getIsGMP4+ ,getSnapshots+ ,makeConcreteResolver ) where import qualified Codec.Archive.Tar as Tar import qualified Codec.Compression.GZip as GZip import Control.Applicative import Control.Arrow ((***))+import Control.Exception (assert) import Control.Monad import Control.Monad.Catch (MonadThrow, MonadCatch, catchAll, 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@@ -58,7 +61,7 @@ import Distribution.Version (simplifyVersionRange) import GHC.Conc (getNumProcessors) import Network.HTTP.Client.Conduit (HasHttpManager, getHttpManager, Manager, parseUrl)-import Network.HTTP.Download (download)+import Network.HTTP.Download (download, downloadJSON) import Options.Applicative (Parser, strOption, long, help) import Path import Path.Extra (toFilePathNoTrailingSep)@@ -70,7 +73,6 @@ import Stack.Config.Nix import Stack.Constants import qualified Stack.Image as Image-import Stack.Init import Stack.PackageIndex import Stack.Types import Stack.Types.Internal@@ -79,6 +81,87 @@ import System.IO import System.Process.Read +-- | If deprecated path exists, use it and print a warning.+-- Otherwise, return the new path.+tryDeprecatedPath+ :: (MonadIO m, MonadLogger m)+ => Maybe T.Text -- ^ Description of file for warning (if Nothing, no deprecation warning is displayed)+ -> (Path Abs a -> m Bool) -- ^ Test for existence+ -> Path Abs a -- ^ New path+ -> Path Abs a -- ^ Deprecated path+ -> m (Path Abs a, Bool) -- ^ (Path to use, whether it already exists)+tryDeprecatedPath mWarningDesc exists new old = do+ newExists <- exists new+ if newExists+ then return (new, True)+ else do+ oldExists <- exists old+ if oldExists+ then do+ case mWarningDesc of+ Nothing -> return ()+ Just desc ->+ $logWarn $ T.concat+ [ "Warning: Location of ", desc, " at '"+ , T.pack (toFilePath old)+ , "' is deprecated; rename it to '"+ , T.pack (toFilePath new)+ , "' instead" ]+ return (old, True)+ else return (new, False)++-- | Get the location of the implicit global project directory.+-- If the directory already exists at the deprecated location, its location is returned.+-- Otherwise, the new location is returned.+getImplicitGlobalProjectDir+ :: (MonadIO m, MonadLogger m)+ => Config -> m (Path Abs Dir)+getImplicitGlobalProjectDir config =+ --TEST no warning printed+ liftM fst $ tryDeprecatedPath+ Nothing+ dirExists+ (implicitGlobalProjectDir stackRoot)+ (implicitGlobalProjectDirDeprecated stackRoot)+ where+ stackRoot = configStackRoot config++-- | Download the 'Snapshots' value from stackage.org.+getSnapshots :: (MonadThrow m, MonadIO m, MonadReader env m, HasHttpManager env, HasStackRoot env, HasConfig env)+ => m Snapshots+getSnapshots = askLatestSnapshotUrl >>= parseUrl . T.unpack >>= downloadJSON++-- | 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+ config <- asks getConfig+ implicitGlobalDir <- getImplicitGlobalProjectDir config+ let fp = implicitGlobalDir </> 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+ -- | Get the latest snapshot resolver available. getLatestResolver :: (MonadIO m, MonadThrow m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m)@@ -151,7 +234,7 @@ configDocker <- dockerOptsFromMonoid (fmap fst mproject) configStackRoot mresolver configMonoidDockerOpts- configNix <- nixOptsFromMonoid (fmap fst mproject) mresolver configMonoidNixOpts os+ configNix <- nixOptsFromMonoid (fmap fst mproject) configMonoidNixOpts os rawEnv <- liftIO getEnvironment pathsEnv <- augmentPathMap (map toFilePath configMonoidExtraPath)@@ -367,7 +450,7 @@ , "# '", encodeUtf8 (T.pack $ toFilePath $ configUserConfigPath config), "' instead.\n" , "#\n" , "# For more information about stack's configuration, see\n"- , "# https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md\n"+ , "# http://docs.haskellstack.org/en/stable/yaml_configuration.html\n" , "#\n" , Yaml.encode p] S.writeFile (toFilePath $ parent dest </> $(mkRelFile "README.txt")) $ S.concat@@ -431,7 +514,7 @@ subs -> mapM (resolveDir entryRoot) subs case peValidWanted pe of Nothing -> return ()- Just _ -> $logWarn "Warning: you are using the deprecated valid-wanted field. You should instead use extra-dep. See: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md#packages"+ Just _ -> $logWarn "Warning: you are using the deprecated valid-wanted field. You should instead use extra-dep. See: http://docs.haskellstack.org/en/stable/yaml_configuration.html#packages" return $ map (, not $ peExtraDep pe) paths -- | Resolve a PackageLocation into a path, downloading and cloning as@@ -643,7 +726,7 @@ liftIO $ S.writeFile (toFilePath path) $ S.concat [ "# This file contains default non-project-specific settings for 'stack', used\n" , "# in all projects. For more information about stack's configuration, see\n"- , "# https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md\n"+ , "# http://docs.haskellstack.org/en/stable/yaml_configuration.html\n" , "#\n" , Yaml.encode (mempty :: Object) ] return path
src/Stack/Config/Nix.hs view
@@ -6,7 +6,8 @@ ,StackNixException(..) ) where -import Control.Monad (when)+import Control.Applicative+import Control.Monad (join, when) import qualified Data.Text as T import Data.Maybe import Data.Typeable@@ -14,41 +15,40 @@ import Stack.Types import Control.Exception.Lifted import Control.Monad.Catch (throwM,MonadCatch)-+import Prelude -- | Interprets NixOptsMonoid options. nixOptsFromMonoid :: (Monad m, MonadCatch m) => Maybe Project- -> Maybe AbstractResolver -> NixOptsMonoid -> OS -> m NixOpts-nixOptsFromMonoid mproject maresolver NixOptsMonoid{..} os = do+nixOptsFromMonoid mproject NixOptsMonoid{..} os = do let nixEnable = fromMaybe nixMonoidDefaultEnable nixMonoidEnable defaultPure = case os of OSX -> False _ -> True nixPureShell = fromMaybe defaultPure nixMonoidPureShell- mresolver = case maresolver of- Just (ARResolver resolver) -> Just resolver- Just _ -> Nothing- Nothing -> fmap projectResolver mproject- pkgs = fromMaybe [] nixMonoidPackages- nixPackages = case mproject of- Nothing -> pkgs- Just _ -> pkgs ++ [case mresolver of- Just (ResolverSnapshot (LTS x y)) ->- T.pack ("haskell.packages.lts-" ++ show x ++ "_" ++ show y ++ ".ghc")- _ -> T.pack "ghc"]+ nixPackages = fromMaybe [] nixMonoidPackages nixInitFile = nixMonoidInitFile nixShellOptions = fromMaybe [] nixMonoidShellOptions ++ prefixAll (T.pack "-I") (fromMaybe [] nixMonoidPath)- when (not (null pkgs) && isJust nixInitFile) $+ nixCompiler resolverOverride compilerOverride =+ let mresolver = resolverOverride <|> fmap projectResolver mproject+ mcompiler = compilerOverride <|> join (fmap projectCompiler mproject)+ in case (mresolver, mcompiler) of+ (_, Just (GhcVersion v)) -> nixCompilerFromVersion v+ (Just (ResolverCompiler (GhcVersion v)), _) -> nixCompilerFromVersion v+ (Just (ResolverSnapshot (LTS x y)), _) ->+ T.pack ("haskell.packages.lts-" ++ show x ++ "_" ++ show y ++ ".ghc")+ _ -> T.pack "ghc"+ when (not (null nixPackages) && isJust nixInitFile) $ throwM NixCannotUseShellFileAndPackagesException return NixOpts{..} where prefixAll p (x:xs) = p : x : prefixAll p xs prefixAll _ _ = []+ nixCompilerFromVersion v = T.filter (/= '.') $ T.append (T.pack "haskell.compiler.ghc") (versionText v) -- Exceptions thown specifically by Stack.Nix data StackNixException
src/Stack/ConfigCmd.hs view
@@ -21,7 +21,7 @@ import Network.HTTP.Client.Conduit (HasHttpManager) import Path import Stack.BuildPlan-import Stack.Init+import Stack.Config (makeConcreteResolver) import Stack.Types data ConfigCmdSet = ConfigCmdSetResolver AbstractResolver
src/Stack/Constants.hs view
@@ -267,12 +267,14 @@ return $ projectRoot </> workDir </> $(mkRelDir "docker/") -- | Image staging dir from project root.-imageStagingDir :: (MonadReader env m, HasConfig env)+imageStagingDir :: (MonadReader env m, HasConfig env, MonadThrow m) => Path Abs Dir -- ^ Project root+ -> Int -- ^ Index of image -> m (Path Abs Dir) -- ^ Docker sandbox-imageStagingDir projectRoot = do+imageStagingDir projectRoot imageIdx = do workDir <- getWorkDir- return $ projectRoot </> workDir </> $(mkRelDir "image/")+ idxRelDir <- parseRelDir (show imageIdx)+ return $ projectRoot </> workDir </> $(mkRelDir "image") </> idxRelDir -- | Name of the 'stack' program, uppercased stackProgNameUpper :: String
src/Stack/Coverage.hs view
@@ -163,7 +163,8 @@ ["--hpcdir", toFilePathNoTrailingSep hpcRelDir, "--reset-hpcdirs"] menv <- getMinimalEnvOverride $logInfo $ "Generating " <> report- outputLines <- liftM S8.lines $ readProcessStdout Nothing menv "hpc"+ outputLines <- liftM (map (S8.filter (/= '\r')) . S8.lines) $+ readProcessStdout Nothing menv "hpc" ( "report" : toFilePath tixSrc : (args ++ extraReportArgs)@@ -186,7 +187,7 @@ generateHpcErrorReport reportDir (msg True) else do -- Print output, stripping @\r@ characters because Windows.- forM_ outputLines ($logInfo . T.decodeUtf8 . S8.filter (/= '\r'))+ forM_ outputLines ($logInfo . T.decodeUtf8) $logInfo ("The " <> report <> " is available at " <> T.pack (toFilePath (reportDir </> $(mkRelFile "hpc_index.html"))))
src/Stack/Docker.hs view
@@ -72,6 +72,7 @@ import System.IO.Error (isDoesNotExistError) import System.IO.Unsafe (unsafePerformIO) import qualified System.PosixCompat.User as User+import qualified System.PosixCompat.Files as Files import System.Process.PagerEditor (editByteString) import System.Process.Read import System.Process.Run@@ -82,6 +83,7 @@ import Control.Concurrent (threadDelay) import Control.Monad.Trans.Control (liftBaseWith) import System.Posix.Signals+import qualified System.Posix.User as PosixUser #endif -- | If Docker is enabled, re-runs the currently running OS command in a Docker container.@@ -104,10 +106,16 @@ where getCmdArgs docker envOverride imageInfo isRemoteDocker = do config <- asks getConfig- deUidGid <-+ deUser <- if fromMaybe (not isRemoteDocker) (dockerSetUser docker)- then liftIO $ Just <$>- ((,) <$> User.getEffectiveUserID <*> User.getEffectiveGroupID)+ then liftIO $ do+ duUid <- User.getEffectiveUserID+ duGid <- User.getEffectiveGroupID+ duGroups <- User.getGroups+ duUmask <- Files.setFileCreationMask 0o022+ -- Only way to get old umask seems to be to change it, so set it back afterward+ _ <- Files.setFileCreationMask duUmask+ return (Just DockerUser{..}) else return Nothing args <- fmap@@ -713,10 +721,10 @@ estackUserEntry0 <- liftIO $ tryJust (guard . isDoesNotExistError) $ User.getUserEntryForName stackUserName -- Switch UID/GID if needed, and update user's home directory- case deUidGid of+ case deUser of Nothing -> return ()- Just (0,_) -> return ()- Just (uid,gid) -> updateOrCreateStackUser envOverride estackUserEntry0 homeDir uid gid+ Just (DockerUser 0 _ _ _) -> return ()+ Just du -> updateOrCreateStackUser envOverride estackUserEntry0 homeDir du case estackUserEntry0 of Left _ -> return () Right ue -> do@@ -751,35 +759,45 @@ copyFile srcIndex destIndex return True where- updateOrCreateStackUser envOverride estackUserEntry homeDir uid gid = do+ updateOrCreateStackUser envOverride estackUserEntry homeDir DockerUser{..} = do case estackUserEntry of Left _ -> do -- If no 'stack' user in image, create one with correct UID/GID and home directory readProcessNull Nothing envOverride "groupadd" ["-o"- ,"--gid",show gid+ ,"--gid",show duGid ,stackUserName] readProcessNull Nothing envOverride "useradd" ["-oN"- ,"--uid",show uid- ,"--gid",show gid+ ,"--uid",show duUid+ ,"--gid",show duGid ,"--home",toFilePathNoTrailingSep homeDir ,stackUserName] Right _ -> do- -- If there is already a 'stack' user in thr image, adjust its UID/GID and home directory+ -- If there is already a 'stack' user in the image, adjust its UID/GID and home directory readProcessNull Nothing envOverride "usermod" ["-o"- ,"--uid",show uid+ ,"--uid",show duUid ,"--home",toFilePathNoTrailingSep homeDir ,stackUserName] readProcessNull Nothing envOverride "groupmod" ["-o"- ,"--gid",show gid+ ,"--gid",show duGid ,stackUserName]+ forM_ duGroups $ \gid -> do+ readProcessNull Nothing envOverride "groupadd"+ ["-o"+ ,"--gid",show gid+ ,"group" ++ show gid] -- 'setuid' to the wanted UID and GID liftIO $ do- User.setGroupID gid- User.setUserID uid+ User.setGroupID duGid+#ifndef WINDOWS+ PosixUser.setGroups duGroups+#endif+ User.setUserID duUid+ _ <- Files.setFileCreationMask duUmask+ return () stackUserName = "stack"::String -- | MVar used to ensure the Docker entrypoint is performed exactly once@@ -909,8 +927,8 @@ parseJSON v = do o <- parseJSON v ImageConfig- <$> o .:? "Env" .!= []- <*> o .:? "Entrypoint" .!= []+ <$> fmap join (o .:? "Env") .!= []+ <*> fmap join (o .:? "Entrypoint") .!= [] -- | Exceptions thrown by Stack.Docker. data StackDockerException
src/Stack/FileWatch.hs view
@@ -25,19 +25,21 @@ import System.Console.ANSI import System.Exit import System.FSNotify-import System.IO (stdout, stderr)+import System.IO (Handle, stdout, stderr, hPutStrLn) -- | Print an exception to stderr printExceptionStderr :: Exception e => e -> IO () printExceptionStderr e = L.hPut stderr $ toLazyByteString $ fromShow e <> copyByteString "\n" -fileWatch :: ((Set (Path Abs File) -> IO ()) -> IO ())+fileWatch :: Handle+ -> ((Set (Path Abs File) -> IO ()) -> IO ()) -> IO () fileWatch = fileWatchConf defaultConfig -fileWatchPoll :: ((Set (Path Abs File) -> IO ()) -> IO ())- -> IO ()+fileWatchPoll :: Handle+ -> ((Set (Path Abs File) -> IO ()) -> IO ())+ -> IO () fileWatchPoll = fileWatchConf $ defaultConfig { confUsePolling = True } -- | Run an action, watching for file changes@@ -45,9 +47,20 @@ -- The action provided takes a callback that is used to set the files to be -- watched. When any of those files are changed, we rerun the action again. fileWatchConf :: WatchConfig+ -> Handle -> ((Set (Path Abs File) -> IO ()) -> IO ()) -> IO ()-fileWatchConf cfg inner = withManagerConf cfg $ \manager -> do+fileWatchConf cfg out inner = withManagerConf cfg $ \manager -> do+ let putLn = hPutStrLn out+ let withColor color action = do+ outputIsTerminal <- hIsTerminalDevice stdout+ if outputIsTerminal+ then do+ setSGR [SetColor Foreground Dull color]+ action+ setSGR [Reset]+ else action+ allFiles <- newTVarIO Set.empty dirtyVar <- newTVarIO True watchVar <- newTVarIO Map.empty@@ -87,22 +100,23 @@ listen <- watchDir manager dir' (const True) onChange return $ Just listen + let watchInput = do line <- getLine unless (line == "quit") $ do case line of "help" -> do- putStrLn ""- putStrLn "help: display this help"- putStrLn "quit: exit"- putStrLn "build: force a rebuild"- putStrLn "watched: display watched files"+ putLn ""+ putLn "help: display this help"+ putLn "quit: exit"+ putLn "build: force a rebuild"+ putLn "watched: display watched files" "build" -> atomically $ writeTVar dirtyVar True "watched" -> do watch <- readTVarIO allFiles- mapM_ putStrLn (Set.toList watch)+ mapM_ putLn (Set.toList watch) "" -> atomically $ writeTVar dirtyVar True- _ -> putStrLn $ concat+ _ -> putLn $ concat [ "Unknown command: " , show line , ". Try 'help'"@@ -125,15 +139,6 @@ -- https://github.com/commercialhaskell/stack/issues/822 atomically $ writeTVar dirtyVar False - let withColor color action = do- outputIsTerminal <- hIsTerminalDevice stdout- if outputIsTerminal- then do- setSGR [SetColor Foreground Dull color]- action- setSGR [Reset]- else action- case eres of Left e -> do let color = case fromException e of@@ -141,6 +146,6 @@ _ -> Red withColor color $ printExceptionStderr e _ -> withColor Green $- putStrLn "Success! Waiting for next file change."+ putLn "Success! Waiting for next file change." - putStrLn "Type help for available commands. Press enter to force a rebuild."+ putLn "Type help for available commands. Press enter to force a rebuild."
src/Stack/Ghci.hs view
@@ -15,6 +15,7 @@ , ghci ) where +import Control.Applicative import Control.Exception.Enclosed (tryAny) import Control.Monad.Catch import Control.Monad.IO.Class@@ -52,6 +53,7 @@ import Stack.Types import Stack.Types.Internal import System.Directory (getTemporaryDirectory)+import Text.Read (readMaybe) #ifndef WINDOWS import qualified System.Posix.Files as Posix@@ -93,10 +95,9 @@ { boptsTestOpts = (boptsTestOpts ghciBuildOpts) { toDisableRun = True } , boptsBenchmarkOpts = (boptsBenchmarkOpts ghciBuildOpts) { beoDisableRun = True } }- (targets,mainIsTargets,pkgs) <- ghciSetup bopts ghciNoBuild ghciSkipIntermediate ghciMainIs+ (targets,mainIsTargets,pkgs) <- ghciSetup bopts ghciNoBuild ghciSkipIntermediate ghciMainIs ghciAdditionalPackages config <- asks getConfig bconfig <- asks getBuildConfig- mainFile <- figureOutMainFile bopts mainIsTargets targets pkgs wc <- getWhichCompiler let pkgopts = hidePkgOpt ++ genOpts ++ ghcOpts hidePkgOpt = if null pkgs || not ghciHidePackages then [] else ["-hide-all-packages"]@@ -117,11 +118,12 @@ ("The following GHC options are incompatible with GHCi and have not been passed to it: " <> T.unwords (map T.pack (nubOrd omittedOpts))) oiDir <- objectInterfaceDir bconfig- let modulesToLoad = nubOrd $- concatMap (map display . S.toList . ghciPkgModules) pkgs- thingsToLoad =- maybe [] (return . toFilePath) mainFile <> modulesToLoad- odir =+ (modulesToLoad, thingsToLoad) <- if ghciNoLoadModules then return ([], []) else do+ mainFile <- figureOutMainFile bopts mainIsTargets targets pkgs+ let modulesToLoad = nubOrd $ concatMap (map display . S.toList . ghciPkgModules) pkgs+ thingsToLoad = maybe [] (return . toFilePath) mainFile <> modulesToLoad+ return (modulesToLoad, thingsToLoad)+ let odir = [ "-odir=" <> toFilePathNoTrailingSep oiDir , "-hidir=" <> toFilePathNoTrailingSep oiDir ] $logInfo@@ -155,7 +157,7 @@ -- is none, sometimes it's unambiguous, sometimes it's -- ambiguous. Warns and returns nothing if it's ambiguous. figureOutMainFile- :: (Monad m, MonadLogger m)+ :: (Monad m, MonadLogger m, MonadIO m) => BuildOpts -> Maybe (Map PackageName SimpleTarget) -> Map PackageName SimpleTarget@@ -166,18 +168,22 @@ [] -> return Nothing [c@(_,_,fp)] -> do $logInfo ("Using main module: " <> renderCandidate c) return (Just fp)- candidate:_ -> borderedWarning $ do+ candidate:_ -> do+ borderedWarning $ do $logWarn "The main module to load is ambiguous. Candidates are: " forM_ (map renderCandidate candidates) $logWarn $logWarn- "None will be loaded. You can specify which one to pick by: "+ "You can specify which one to pick by: " $logWarn- (" 1) Specifying targets to stack ghci e.g. stack ghci " <>+ (" * Specifying targets to stack ghci e.g. stack ghci " <> sampleTargetArg candidate) $logWarn- (" 2) Specifying what the main is e.g. stack ghci " <>+ (" * Specifying what the main is e.g. stack ghci " <> sampleMainIsArg candidate)- return Nothing+ $logWarn+ (" * Choosing from the candidate above [1.." <>+ T.pack (show $ length candidates) <> "]")+ liftIO userOption where targets = fromMaybe targets0 mainIsTargets candidates = do@@ -194,11 +200,35 @@ where wantedComponents = wantedPackageComponents bopts target (ghciPkgPackage pkg)- renderCandidate (pkgName,namedComponent,mainIs) =- "Package `" <> packageNameText pkgName <> "' component " <>- renderComp namedComponent <>- " with main-is file: " <>- T.pack (toFilePath mainIs)+ renderCandidate c@(pkgName,namedComponent,mainIs) =+ let candidateIndex = T.pack . show . (+1) . fromMaybe 0 . elemIndex c+ in candidateIndex candidates <> ". Package `" <>+ packageNameText pkgName <>+ "' component " <>+ renderComp namedComponent <>+ " with main-is file: " <>+ T.pack (toFilePath mainIs)+ candidateIndices = take (length candidates) [1 :: Int ..]+ userOption = do+ putStr "Specify main module to use (press enter to load none): "+ option <- getLine+ let selected = fromMaybe+ ((+1) $ length candidateIndices)+ (readMaybe option :: Maybe Int)+ case elemIndex selected candidateIndices of+ Nothing -> do+ putStrLn+ "Not loading any maim modules, as no valid module selected"+ putStrLn ""+ return Nothing+ Just op -> do+ let (_,_,fp) = candidates !! op+ putStrLn+ ("Loading main module from cadidate " <>+ show (op + 1) <> ", --main-is " <>+ toFilePath fp)+ putStrLn ""+ return $ Just fp renderComp c = case c of CLib -> "lib"@@ -218,15 +248,23 @@ -> Bool -> Bool -> Maybe Text+ -> [String] -> m (Map PackageName SimpleTarget, Maybe (Map PackageName SimpleTarget), [GhciPkgInfo])-ghciSetup bopts noBuild skipIntermediate mainIs = do- (_,_,targets) <- parseTargetsFromBuildOpts AllowNoTargets bopts+ghciSetup bopts0 noBuild skipIntermediate mainIs additionalPackages = do+ (_,_,targets) <- parseTargetsFromBuildOpts AllowNoTargets bopts0 mainIsTargets <- case mainIs of Nothing -> return Nothing Just target -> do- (_,_,targets') <- parseTargetsFromBuildOpts AllowNoTargets bopts { boptsTargets = [target] }+ (_,_,targets') <- parseTargetsFromBuildOpts AllowNoTargets bopts0 { boptsTargets = [target] } return (Just targets')+ addPkgs <- forM additionalPackages $ \name -> do+ let mres = (packageIdentifierName <$> parsePackageIdentifierFromString name)+ <|> parsePackageNameFromString name+ maybe (fail $ "Failed to parse --package option " ++ name) return mres+ let bopts = bopts0+ { boptsTargets = boptsTargets bopts0 ++ map T.pack additionalPackages+ } econfig <- asks getEnvConfig (realTargets,_,_,_,sourceMap) <- loadSourceMap AllowNoTargets bopts menv <- getMinimalEnvOverride@@ -273,7 +311,7 @@ infos <- forM wanted $ \(name,(cabalfp,target)) ->- makeGhciPkgInfo bopts sourceMap installedMap localLibs name cabalfp target+ makeGhciPkgInfo bopts sourceMap installedMap localLibs addPkgs name cabalfp target checkForIssues infos return (realTargets, mainIsTargets, infos) where@@ -290,11 +328,12 @@ -> SourceMap -> InstalledMap -> [PackageName]+ -> [PackageName] -> PackageName -> Path Abs File -> SimpleTarget -> m GhciPkgInfo-makeGhciPkgInfo bopts sourceMap installedMap locals name cabalfp target = do+makeGhciPkgInfo bopts sourceMap installedMap locals addPkgs name cabalfp target = do econfig <- asks getEnvConfig bconfig <- asks getBuildConfig let config =@@ -307,7 +346,7 @@ } (warnings,pkg) <- readPackage config cabalfp mapM_ (printCabalFileWarning cabalfp) warnings- (mods,files,opts) <- getPackageOpts (packageOpts pkg) sourceMap installedMap locals cabalfp+ (mods,files,opts) <- getPackageOpts (packageOpts pkg) sourceMap installedMap locals addPkgs cabalfp let filteredOpts = filterWanted opts filterWanted = M.filterWithKey (\k _ -> k `S.member` allWanted) allWanted = wantedPackageComponents bopts target pkg@@ -451,7 +490,7 @@ let fps = nubOrd (concatMap (mapMaybe (bioCabalMacros . snd) . ghciPkgOpts) pkgs) files <- mapM (S8.readFile . toFilePath) fps if null files then return [] else do- S8.writeFile (toFilePath out) $ S8.intercalate "\n#undef CURRENT_PACKAGE_KEY\n" files+ S8.writeFile (toFilePath out) $ S8.concat $ map (<> "\n#undef CURRENT_PACKAGE_KEY\n") files return ["-optP-include", "-optP" <> toFilePath out] setScriptPerms :: MonadIO m => FilePath -> m ()
src/Stack/Ide.hs view
@@ -48,7 +48,7 @@ { boptsTargets = targets , boptsBuildSubset = BSOnlyDependencies }- (_realTargets,_,pkgs) <- ghciSetup bopts False False Nothing+ (_realTargets,_,pkgs) <- ghciSetup bopts False False Nothing [] pwd <- getWorkingDir (pkgopts,_srcfiles) <- liftM mconcat $ forM pkgs $ getPackageOptsAndTargetFiles pwd
src/Stack/Image.hs view
@@ -10,11 +10,9 @@ -- | This module builds Docker (OpenContainer) images. module Stack.Image (stageContainerImageArtifacts, createContainerImageFromStage,- imgCmdName, imgDockerCmdName, imgOptsFromMonoid,- imgDockerOptsFromMonoid, imgOptsParser, imgDockerOptsParser)+ imgCmdName, imgDockerCmdName, imgOptsFromMonoid) where -import Control.Applicative import Control.Exception.Lifted hiding (finally) import Control.Monad import Control.Monad.Catch hiding (bracket)@@ -25,10 +23,7 @@ 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.Extra import Path.IO@@ -45,11 +40,14 @@ -- directory under '.stack-work' stageContainerImageArtifacts :: Build e m => m () stageContainerImageArtifacts = do- imageDir <- getWorkingDir >>= imageStagingDir- removeTreeIfExists imageDir- createTree imageDir- stageExesInDir imageDir- syncAddContentToDir imageDir+ config <- asks getConfig+ workingDir <- getWorkingDir+ forM_ (zip [0..] $ imgDockers $ configImage config) $ \(idx, opts) -> do+ imageDir <- imageStagingDir workingDir idx+ removeTreeIfExists imageDir+ createTree imageDir+ stageExesInDir opts imageDir+ syncAddContentToDir opts imageDir -- | Builds a Docker (OpenContainer) image extending the `base` image -- specified in the project's stack.yaml. Then new image will be@@ -57,29 +55,34 @@ -- in the config file. createContainerImageFromStage :: Assemble e m => m () createContainerImageFromStage = do- imageDir <- getWorkingDir >>= imageStagingDir- createDockerImage imageDir- extendDockerImageWithEntrypoint imageDir+ config <- asks getConfig+ workingDir <- getWorkingDir+ forM_ (zip [0..] $ imgDockers $ configImage config) $ \(idx, opts) -> do+ imageDir <- imageStagingDir workingDir idx+ createDockerImage opts imageDir+ extendDockerImageWithEntrypoint opts 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+stageExesInDir :: Build e m => ImageDockerOpts -> Path Abs Dir -> m ()+stageExesInDir opts dir = do srcBinPath <-- (</> $(mkRelDir "bin")) <$>- installationRootLocal+ liftM (</> $(mkRelDir "bin")) installationRootLocal let destBinPath = dir </> $(mkRelDir "usr/local/bin") createTree destBinPath- copyDirectoryRecursive srcBinPath destBinPath+ case imgDockerExecutables opts of+ Nothing -> copyDirectoryRecursive srcBinPath destBinPath+ Just exes -> forM_ exes $ \exe -> do+ exeRelFile <- parseRelFile exe+ copyFile (srcBinPath </> exeRelFile) (destBinPath </> exeRelFile) -- | 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+syncAddContentToDir :: Build e m => ImageDockerOpts -> Path Abs Dir -> m ()+syncAddContentToDir opts dir = do bconfig <- asks getBuildConfig- let imgAdd = maybe Map.empty imgDockerAdd (imgDocker (configImage config))+ let imgAdd = imgDockerAdd opts forM_ (Map.toList imgAdd) (\(source,dest) ->@@ -95,18 +98,12 @@ imageName :: Path Abs Dir -> String imageName = map toLower . toFilePathNoTrailingSep . dirname -mkDockerConfig :: (HasConfig e, MonadReader e m) => m (Maybe ImageDockerOpts)-mkDockerConfig = do- config <- asks getConfig- return (imgDocker (configImage config))- -- | 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+createDockerImage :: Assemble e m => ImageDockerOpts -> Path Abs Dir -> m ()+createDockerImage dockerConfig dir = do menv <- getMinimalEnvOverride- dockerConfig <- mkDockerConfig- case imgDockerBase =<< dockerConfig of+ case imgDockerBase dockerConfig of Nothing -> throwM StackImageDockerBaseUnspecifiedException Just base -> do liftIO@@ -118,22 +115,21 @@ let args = [ "build" , "-t" , fromMaybe- (imageName (parent (parent dir)))- (imgDockerImageName =<< dockerConfig)+ (imageName (parent (parent (parent dir))))+ (imgDockerImageName dockerConfig) , toFilePathNoTrailingSep dir] callProcess $ Cmd Nothing "docker" menv args -- | Extend the general purpose docker image with entrypoints (if -- specified).-extendDockerImageWithEntrypoint :: Assemble e m => Path Abs Dir -> m ()-extendDockerImageWithEntrypoint dir = do+extendDockerImageWithEntrypoint :: Assemble e m => ImageDockerOpts -> Path Abs Dir -> m ()+extendDockerImageWithEntrypoint dockerConfig dir = do menv <- getMinimalEnvOverride- dockerConfig <- mkDockerConfig let dockerImageName = fromMaybe- (imageName (parent (parent dir)))- (imgDockerImageName =<< dockerConfig)- let imgEntrypoints = maybe Nothing imgDockerEntrypoints dockerConfig+ (imageName (parent (parent (parent dir))))+ (imgDockerImageName dockerConfig)+ let imgEntrypoints = imgDockerEntrypoints dockerConfig case imgEntrypoints of Nothing -> return () Just eps ->@@ -167,50 +163,11 @@ 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+ { imgDockers = imgMonoidDockers }- where emptyToNothing Nothing = Nothing- emptyToNothing (Just s)- | null s =- Nothing- | otherwise =- Just s -- | Stack image exceptions. data StackImageException =
src/Stack/Init.hs view
@@ -3,96 +3,89 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} module Stack.Init- ( findCabalFiles- , initProject+ ( initProject , InitOpts (..) , SnapPref (..) , Method (..)- , makeConcreteResolver- , tryDeprecatedPath- , getImplicitGlobalProjectDir ) where import Control.Exception (assert) import Control.Exception.Enclosed (catchAny, handleIO)-import Control.Monad (liftM, when, zipWithM_)-import Control.Monad.Catch (MonadMask, MonadThrow, throwM)+import Control.Monad (liftM, when)+import Control.Monad.Catch (MonadMask, throwM) import Control.Monad.IO.Class import Control.Monad.Logger-import Control.Monad.Reader (MonadReader, asks)+import Control.Monad.Reader (MonadReader) import Control.Monad.Trans.Control (MonadBaseControl) import qualified Data.ByteString.Builder as B import qualified Data.ByteString.Lazy as L import qualified Data.HashMap.Strict as HM import qualified Data.IntMap as IntMap import qualified Data.Foldable as F-import Data.List (isSuffixOf,sortBy)+import Data.List (sortBy) import Data.List.Extra (nubOrd) import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe (mapMaybe) import Data.Monoid-import Data.Set (Set)-import qualified Data.Set as Set import qualified Data.Text as T import qualified Data.Yaml as Yaml import qualified Distribution.PackageDescription as C import Network.HTTP.Client.Conduit (HasHttpManager) import Path-import Path.Find import Path.IO import Stack.BuildPlan import Stack.Constants-import Stack.Package import Stack.Solver import Stack.Types-import System.Directory (getDirectoryContents)--findCabalFiles :: MonadIO m => Bool -> Path Abs Dir -> m [Path Abs File]-findCabalFiles recurse dir =- liftIO $ findFiles dir isCabal (\subdir -> recurse && not (isIgnored subdir))- where- isCabal path = ".cabal" `isSuffixOf` toFilePath path-- isIgnored path = toFilePath (dirname path) `Set.member` ignoredDirs---- | Special directories that we don't want to traverse for .cabal files-ignoredDirs :: Set FilePath-ignoredDirs = Set.fromList- [ ".git"- , "dist"- , ".stack-work"- ]+import Stack.Types.Internal ( HasTerminal, HasReExec+ , HasLogLevel)+import System.Directory ( getDirectoryContents+ , makeRelativeToCurrentDirectory)+import Stack.Config ( getSnapshots+ , makeConcreteResolver) -- | Generate stack.yaml-initProject :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpManager env, HasGHCVariant env, MonadLogger m, MonadBaseControl IO m)- => Path Abs Dir- -> InitOpts- -> m ()+initProject+ :: ( MonadBaseControl IO m, MonadIO m, MonadLogger m, MonadMask m+ , MonadReader env m, HasConfig env , HasGHCVariant env+ , HasHttpManager env , HasLogLevel env , HasReExec env+ , HasTerminal env)+ => Path Abs Dir+ -> InitOpts+ -> m () initProject currDir initOpts = do let dest = currDir </> stackDotYaml dest' = toFilePath dest++ reldest <- liftIO $ makeRelativeToCurrentDirectory dest'+ exists <- fileExists dest- when (not (forceOverwrite initOpts) && exists) $- error ("Refusing to overwrite existing stack.yaml, " <>- "please delete before running stack init " <>- "or if you are sure use \"--force\"")+ when (not (forceOverwrite initOpts) && exists) $ do+ error ("Stack configuration file " <> reldest <>+ " exists, use 'stack solver' to fix the existing config file or \+ \'--force' to overwrite it.") - cabalfps <- findCabalFiles (includeSubDirs initOpts) currDir- $logInfo $ "Writing default config file to: " <> T.pack dest'- $logInfo $ "Basing on cabal files:"- mapM_ (\path -> $logInfo $ "- " <> T.pack (toFilePath path)) cabalfps- $logInfo ""+ let noPkgMsg = "In order to init, you should have an existing .cabal \+ \file. Please try \"stack new\" instead." - when (null cabalfps) $ error "In order to init, you should have an existing .cabal file. Please try \"stack new\" instead"- (warnings,gpds) <- fmap unzip (mapM readPackageUnresolved cabalfps)- zipWithM_ (mapM_ . printCabalFileWarning) cabalfps warnings+ dupPkgFooter = "You have the following options:\n"+ <> "- Use '--ignore-subdirs' command line switch to ignore "+ <> "packages in subdirectories. You can init subdirectories as "+ <> "independent projects.\n"+ <> "- Put selected packages in the stack config file "+ <> "and then use 'stack solver' command to automatically resolve "+ <> "dependencies and update the config file." - (r, flags, extraDeps) <- getDefaultResolver cabalfps gpds initOpts+ cabalfps <- findCabalFiles (includeSubDirs initOpts) currDir+ gpds <- cabalPackagesCheck cabalfps noPkgMsg dupPkgFooter++ (r, flags, extraDeps) <-+ getDefaultResolver dest (map parent cabalfps) gpds initOpts let p = Project { projectPackages = pkgs , projectExtraDeps = extraDeps- , projectFlags = flags+ , projectFlags = removeSrcPkgDefaultFlags gpds flags , projectResolver = r , projectCompiler = Nothing , projectExtraPackageDBs = []@@ -109,9 +102,14 @@ Just rel -> toFilePath rel , peSubdirs = [] }- $logInfo $ "Selected resolver: " <> resolverName r++ $logInfo $ "Initialising configuration using resolver: " <> resolverName r+ $logInfo $+ (if exists then "Overwriting existing configuration file: "+ else "Writing configuration to file: ")+ <> T.pack reldest liftIO $ L.writeFile dest' $ B.toLazyByteString $ renderStackYaml p- $logInfo $ "Wrote project config to: " <> T.pack dest'+ $logInfo "All done." -- | Render a stack.yaml file with comments, see: -- https://github.com/commercialhaskell/stack/issues/226@@ -122,7 +120,7 @@ _ -> assert False $ B.byteString $ Yaml.encode p where renderObject o =- B.byteString "# For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md\n\n" <>+ B.byteString "# For more information, see: http://docs.haskellstack.org/en/stable/yaml_configuration.html\n\n" <> F.foldMap (goComment o) comments <> goOthers (o `HM.difference` HM.fromList comments) <> B.byteString@@ -136,7 +134,9 @@ \# arch: x86_64\n\n\ \# Extra directories used by stack for building\n\ \# extra-include-dirs: [/path/to/dir]\n\- \# extra-lib-dirs: [/path/to/dir]\n"+ \# extra-lib-dirs: [/path/to/dir]\n\n\+ \# Allow a newer minor version of GHC than the snapshot specifies\n\+ \# compiler-check: newer-minor\n" comments = [ ("resolver", "Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2)")@@ -175,54 +175,85 @@ $logError "" $logError "You can try again, or create your stack.yaml file by hand. See:" $logError ""- $logError " https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md"+ $logError " http://docs.haskellstack.org/en/stable/yaml_configuration.html" $logError "" $logError $ "Exception was: " <> T.pack (show e) return Nothing -- | Get the default resolver value-getDefaultResolver :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpManager env, HasGHCVariant env, MonadLogger m, MonadBaseControl IO m)- => [Path Abs File] -- ^ cabal files- -> [C.GenericPackageDescription] -- ^ cabal descriptions- -> InitOpts- -> m (Resolver, Map PackageName (Map FlagName Bool), Map PackageName Version)-getDefaultResolver cabalfps gpds initOpts =- case ioMethod initOpts of- MethodSnapshot snapPref -> do- msnapshots <- getSnapshots'- names <-- case msnapshots of- Nothing -> return []- Just snapshots -> getRecommendedSnapshots snapshots snapPref- mpair <- findBuildPlan gpds names- case mpair of- Just (snap, flags) ->- return (ResolverSnapshot snap, flags, Map.empty)- Nothing -> throwM $ NoMatchingSnapshot names- MethodResolver aresolver -> do- resolver <- makeConcreteResolver aresolver- mpair <-- case resolver of- ResolverSnapshot name -> findBuildPlan gpds [name]- ResolverCompiler _ -> 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- (compilerVersion, extraDeps) <- cabalSolver Ghc (map parent cabalfps) Map.empty Map.empty []- return- ( ResolverCompiler compilerVersion- , Map.filter (not . Map.null) $ fmap snd extraDeps- , fmap fst extraDeps- )+getDefaultResolver+ :: ( MonadBaseControl IO m, MonadIO m, MonadLogger m, MonadMask m+ , MonadReader env m, HasConfig env , HasGHCVariant env+ , HasHttpManager env , HasLogLevel env , HasReExec env+ , HasTerminal env)+ => Path Abs File -- ^ stack.yaml+ -> [Path Abs Dir] -- ^ cabal dirs+ -> [C.GenericPackageDescription] -- ^ cabal descriptions+ -> InitOpts+ -> m ( Resolver+ , Map PackageName (Map FlagName Bool)+ , Map PackageName Version)+getDefaultResolver stackYaml cabalDirs gpds initOpts = do+ resolver <- getResolver (ioMethod initOpts)+ result <- checkResolverSpec gpds Nothing resolver + case result of+ BuildPlanCheckOk f-> return (resolver, f, Map.empty)+ BuildPlanCheckPartial f e+ | needSolver resolver initOpts -> solve (resolver, f)+ | otherwise ->+ throwM $ ResolverPartial resolver (showDepErrors f e)+ BuildPlanCheckFail f e c ->+ throwM $ ResolverMismatch resolver (showCompilerErrors f e c)++ where+ solve (res, f) = do+ let srcConstraints = mergeConstraints (gpdPackages gpds) f+ mresolver <- solveResolverSpec stackYaml cabalDirs+ (res, srcConstraints, Map.empty)+ case mresolver of+ Just (src, ext) -> do+ return (res, fmap snd (Map.union src ext), fmap fst ext)+ Nothing+ | forceOverwrite initOpts -> do+ $logWarn "\nSolver could not arrive at a workable build \+ \plan.\nProceeding to create a config with an \+ \incomplete plan anyway..."+ return (res, f, Map.empty)+ | otherwise -> throwM (SolverGiveUp giveUpMsg)++ giveUpMsg = concat+ [ " - Use '--ignore-subdirs' to skip packages in subdirectories.\n"+ , " - Update external packages with 'stack update' and try again.\n"+ , " - Use '--force' to create an initial "+ , toFilePath stackDotYaml <> ", tweak it and run 'stack solver':\n"+ , " - Remove any unnecessary packages.\n"+ , " - Add any missing remote packages.\n"+ , " - Add extra dependencies to guide solver.\n"+ ]++ -- TODO support selecting best across regular and custom snapshots+ getResolver (MethodSnapshot snapPref) = selectSnapResolver snapPref+ getResolver (MethodResolver aresolver) = makeConcreteResolver aresolver++ selectSnapResolver snapPref = do+ msnaps <- getSnapshots'+ snaps <- maybe (error "No snapshots to select from.")+ (getRecommendedSnapshots snapPref)+ msnaps+ selectBestSnapshot gpds snaps+ >>= maybe (throwM (NoMatchingSnapshot snaps))+ (return . ResolverSnapshot)++ needSolver _ (InitOpts {useSolver = True}) = True+ needSolver (ResolverCompiler _) _ = True+ needSolver _ _ = False+ getRecommendedSnapshots :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpManager env, HasGHCVariant env, MonadLogger m, MonadBaseControl IO m)- => Snapshots- -> SnapPref+ => SnapPref+ -> Snapshots -> m [SnapName]-getRecommendedSnapshots snapshots pref = do+getRecommendedSnapshots pref snapshots = do -- Get the most recent LTS and Nightly in the snapshots directory and -- prefer them over anything else, since odds are high that something -- already exists for them.@@ -254,6 +285,8 @@ data InitOpts = InitOpts { ioMethod :: !Method+ -- ^ Use solver+ , useSolver :: Bool -- ^ Preferred snapshots , forceOverwrite :: Bool -- ^ Overwrite existing files@@ -264,80 +297,4 @@ data SnapPref = PrefNone | PrefLTS | PrefNightly -- | Method of initializing-data Method = MethodSnapshot SnapPref | MethodResolver AbstractResolver | MethodSolver---- | 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- config <- asks getConfig- implicitGlobalDir <- getImplicitGlobalProjectDir config- let fp = implicitGlobalDir </> 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---- | Get the location of the implicit global project directory.--- If the directory already exists at the deprecated location, its location is returned.--- Otherwise, the new location is returned.-getImplicitGlobalProjectDir- :: (MonadIO m, MonadLogger m)- => Config -> m (Path Abs Dir)-getImplicitGlobalProjectDir config =- --TEST no warning printed- liftM fst $ tryDeprecatedPath- Nothing- dirExists- (implicitGlobalProjectDir stackRoot)- (implicitGlobalProjectDirDeprecated stackRoot)- where- stackRoot = configStackRoot config---- | If deprecated path exists, use it and print a warning.--- Otherwise, return the new path.-tryDeprecatedPath- :: (MonadIO m, MonadLogger m)- => Maybe T.Text -- ^ Description of file for warning (if Nothing, no deprecation warning is displayed)- -> (Path Abs a -> m Bool) -- ^ Test for existence- -> Path Abs a -- ^ New path- -> Path Abs a -- ^ Deprecated path- -> m (Path Abs a, Bool) -- ^ (Path to use, whether it already exists)-tryDeprecatedPath mWarningDesc exists new old = do- newExists <- exists new- if newExists- then return (new, True)- else do- oldExists <- exists old- if oldExists- then do- case mWarningDesc of- Nothing -> return ()- Just desc ->- $logWarn $ T.concat- [ "Warning: Location of ", desc, " at '"- , T.pack (toFilePath old)- , "' is deprecated; rename it to '"- , T.pack (toFilePath new)- , "' instead" ]- return (old, True)- else return (new, False)+data Method = MethodSnapshot SnapPref | MethodResolver AbstractResolver
src/Stack/Nix.hs view
@@ -14,7 +14,7 @@ import Control.Applicative import Control.Arrow ((***)) import Control.Exception (Exception,throw)-import Control.Monad+import Control.Monad hiding (mapM) import Control.Monad.Catch (try,MonadCatch) import Control.Monad.IO.Class (MonadIO,liftIO) import Control.Monad.Logger (MonadLogger,logDebug)@@ -33,8 +33,9 @@ import Path import Path.IO import qualified Paths_stack as Meta-import Prelude -- Fix redundant import warnings+import Prelude hiding (mapM) -- Fix redundant import warnings import Stack.Constants (stackProgName,platformVariantEnvVar)+import Stack.Config (makeConcreteResolver) import Stack.Docker (reExecArgName) import Stack.Exec (exec) import System.Process.Read (getEnvOverride)@@ -43,20 +44,21 @@ import System.Environment (lookupEnv,getArgs,getExecutablePath) import System.Exit (exitSuccess, exitWith) - -- | If Nix is enabled, re-runs the currently running OS command in a Nix container. -- Otherwise, runs the inner action. reexecWithOptionalShell :: M env m => Maybe (Path Abs Dir)+ -> Maybe AbstractResolver+ -> Maybe CompilerVersion -> IO () -> m ()-reexecWithOptionalShell mprojectRoot inner =+reexecWithOptionalShell mprojectRoot maresolver mcompiler inner = do config <- asks getConfig inShell <- getInShell isReExec <- asks getReExec if nixEnable (configNix config) && not inShell && not isReExec- then runShellAndExit mprojectRoot getCmdArgs+ then runShellAndExit mprojectRoot maresolver mcompiler getCmdArgs else liftIO inner where getCmdArgs = do@@ -70,30 +72,34 @@ runShellAndExit :: M env m => Maybe (Path Abs Dir)+ -> Maybe AbstractResolver+ -> Maybe CompilerVersion -> m (String, [String]) -> m ()-runShellAndExit mprojectRoot getCmdArgs = do+runShellAndExit mprojectRoot maresolver mcompiler getCmdArgs = do config <- asks getConfig+ mresolver <- mapM makeConcreteResolver maresolver envOverride <- getEnvOverride (configPlatform config) (cmnd,args) <- fmap (escape *** map escape) getCmdArgs mshellFile <- traverse (resolveFile (fromMaybeProjectRoot mprojectRoot)) $ nixInitFile (configNix config) let pkgsInConfig = nixPackages (configNix config)+ pkgs = pkgsInConfig ++ [nixCompiler (configNix config) mresolver mcompiler] pureShell = nixPureShell (configNix config) nixopts = case mshellFile of Just fp -> [toFilePath fp] Nothing -> ["-E", T.unpack $ T.intercalate " " $ concat [["with (import <nixpkgs> {});" ,"runCommand \"myEnv\" {"- ,"buildInputs=lib.optional stdenv.isLinux glibcLocales ++ ["],pkgsInConfig,["];"+ ,"buildInputs=lib.optional stdenv.isLinux glibcLocales ++ ["],pkgs,["];" ,T.pack platformVariantEnvVar <> "=''nix'';" ,T.pack inShellEnvVar <> "=1;" ,"STACK_IN_NIX_EXTRA_ARGS=''"] , (map (\p -> T.concat ["--extra-lib-dirs=${",p,"}/lib" ," --extra-include-dirs=${",p,"}/include "])- pkgsInConfig), ["'' ;"+ pkgs), ["'' ;" ,"} \"\""]]] -- glibcLocales is necessary on Linux to avoid warnings about GHC being incapable to set the locale. fullArgs = concat [if pureShell then ["--pure"] else [],@@ -105,7 +111,7 @@ $logDebug $ "Using a nix-shell environment " <> (case mshellFile of Just path -> "from file: " <> (T.pack (toFilePath path))- Nothing -> "with nix packages: " <> (T.intercalate ", " pkgsInConfig))+ Nothing -> "with nix packages: " <> (T.intercalate ", " pkgs)) e <- try (exec envOverride "nix-shell" fullArgs) case e of Left (ProcessExitedUnsuccessfully _ ec) -> liftIO (exitWith ec)
src/Stack/Options.hs view
@@ -1,7 +1,8 @@ {-# LANGUAGE OverloadedStrings,RecordWildCards #-} module Stack.Options- (Command(..)+ (BuildCommand(..)+ ,GlobalOptsContext(..) ,benchOptsParser ,buildOptsParser ,cleanOptsParser@@ -58,7 +59,7 @@ import Stack.Types.TemplateName -- | Command sum type for conditional arguments.-data Command+data BuildCommand = Build | Test | Haddock@@ -66,6 +67,13 @@ | Install deriving (Eq) +-- | Allows adjust global options depending on their context+data GlobalOptsContext+ = OuterGlobalOpts -- ^ Global options before subcommand name+ | InitCmdGlobalOpts -- ^ Global options following 'stack init'+ | OtherCmdGlobalOpts -- ^ Global options following any other subcommand+ deriving (Show, Eq)+ -- | Parser for bench arguments. benchOptsParser :: Parser BenchmarkOpts benchOptsParser = BenchmarkOpts@@ -77,7 +85,7 @@ help "Disable running of benchmarks. (Benchmarks will still be built.)") -- | Parser for build arguments.-buildOptsParser :: Command+buildOptsParser :: BuildCommand -> Parser BuildOpts buildOptsParser cmd = transform <$> trace <*> profile <*> options@@ -390,7 +398,7 @@ where hide = hideMods hide0 overrideActivation m =- if m /= mempty then m { nixMonoidEnable = Just True }+ if m /= mempty then m { nixMonoidEnable = Just . fromMaybe True $ nixMonoidEnable m } else m -- | Options parser configuration for Docker.@@ -622,14 +630,18 @@ help "Use an unmodified environment (only useful with Docker)") -- | Parser for global command-line options.-globalOptsParser :: Bool -> Maybe LogLevel -> Parser GlobalOptsMonoid-globalOptsParser hide0 defLogLevel =+globalOptsParser :: GlobalOptsContext -> Maybe LogLevel -> Parser GlobalOptsMonoid+globalOptsParser kind defLogLevel = GlobalOptsMonoid <$> optional (strOption (long Docker.reExecArgName <> hidden <> internal)) <*> optional (option auto (long dockerEntrypointArgName <> hidden <> internal)) <*> logLevelOptsParser hide0 defLogLevel <*> configOptsParser hide0 <*>- optional (abstractResolverOptsParser hide0) <*>+ (if kind == InitCmdGlobalOpts+ -- The 'stack init' command has its own '--resolver' option, and having a global+ -- one causes ambiguity, so disable it.+ then pure Nothing+ else optional (abstractResolverOptsParser hide0)) <*> optional (compilerOptsParser hide0) <*> maybeBoolFlags "terminal"@@ -640,7 +652,9 @@ help ("Override project stack.yaml file " <> "(overrides any STACK_YAML environment variable)") <> hide))- where hide = hideMods hide0+ where+ hide = hideMods hide0+ hide0 = kind /= OuterGlobalOpts -- | Create GlobalOpts from GlobalOptsMonoid. globalOptsFromMonoid :: Bool -> GlobalOptsMonoid -> GlobalOpts@@ -656,20 +670,18 @@ initOptsParser :: Parser InitOpts initOptsParser =- InitOpts <$> method <*> overwrite <*> fmap not ignoreSubDirs+ InitOpts <$> method <*> solver <*> overwrite <*> fmap not ignoreSubDirs where ignoreSubDirs = switch (long "ignore-subdirs" <> help "Do not search for .cabal files in sub directories") overwrite = switch (long "force" <>- help "Force overwriting of an existing stack.yaml if it exists")- method = solver- <|> (MethodResolver <$> resolver)- <|> (MethodSnapshot <$> snapPref)+ help "Force overwriting an existing stack.yaml or \+ \creating a stack.yaml with incomplete config.")+ solver = switch (long "solver" <>+ help "Use a dependency solver to determine extra dependencies") - solver =- flag' MethodSolver- (long "solver" <>- help "Use a dependency solver to determine dependencies")+ method = (MethodResolver <$> resolver)+ <|> (MethodSnapshot <$> snapPref) snapPref = flag' PrefLTS@@ -683,7 +695,7 @@ resolver = option readAbstractResolver (long "resolver" <> metavar "RESOLVER" <>- help "Use the given resolver, even if not all dependencies are met")+ help "Use the specified resolver") -- | Parser for a logging level. logLevelOptsParser :: Bool -> Maybe LogLevel -> Parser (Maybe LogLevel)@@ -772,8 +784,8 @@ -- | Parser for @solverCmd@ solverOptsParser :: Parser Bool solverOptsParser = boolFlags False- "modify-stack-yaml"- "Automatically modify stack.yaml with the solver's recommendations"+ "update-config"+ "Automatically update stack.yaml with the solver's recommendations" idm -- | Parser for test arguments.
src/Stack/Package.hs view
@@ -206,10 +206,10 @@ [T.pack (exeName b) | b <- executables pkg , buildable (buildInfo b)] , packageOpts = GetPackageOpts $- \sourceMap installedMap omitPkgs cabalfp ->+ \sourceMap installedMap omitPkgs addPkgs cabalfp -> do (componentsModules,componentFiles,_,_) <- getPackageFiles pkgFiles cabalfp componentsOpts <-- generatePkgDescOpts sourceMap installedMap omitPkgs cabalfp pkg componentFiles+ generatePkgDescOpts sourceMap installedMap omitPkgs addPkgs cabalfp pkg componentFiles return (componentsModules,componentFiles,componentsOpts) , packageHasExposedModules = maybe False@@ -241,11 +241,12 @@ => SourceMap -> InstalledMap -> [PackageName] -- ^ Packages to omit from the "-package" / "-package-id" flags+ -> [PackageName] -- ^ Packages to add to the "-package" flags -> Path Abs File -> PackageDescription -> Map NamedComponent (Set DotCabalPath) -> m (Map NamedComponent BuildInfoOpts)-generatePkgDescOpts sourceMap installedMap omitPkgs cabalfp pkg componentPaths = do+generatePkgDescOpts sourceMap installedMap omitPkgs addPkgs cabalfp pkg componentPaths = do distDir <- distDirFromDir cabalDir let cabalMacros = autogenDir distDir </> $(mkRelFile "cabal_macros.h") exists <- fileExists cabalMacros@@ -262,6 +263,7 @@ cabalDir distDir omitPkgs+ addPkgs binfo (fromMaybe mempty (M.lookup namedComponent componentPaths)) namedComponent)@@ -301,11 +303,12 @@ -> Path Abs Dir -> Path Abs Dir -> [PackageName]+ -> [PackageName] -> BuildInfo -> Set DotCabalPath -> NamedComponent -> BuildInfoOpts-generateBuildInfoOpts sourceMap installedMap mcabalMacros cabalDir distDir omitPkgs b dotCabalPaths componentName =+generateBuildInfoOpts sourceMap installedMap mcabalMacros cabalDir distDir omitPkgs addPkgs b dotCabalPaths componentName = BuildInfoOpts { bioOpts = ghcOpts b ++ cppOptions b -- NOTE for future changes: Due to this use of nubOrd (and other uses@@ -328,15 +331,20 @@ cfiles = mapMaybe dotCabalCFilePath (S.toList dotCabalPaths) deps = concat- [ case M.lookup (fromCabalPackageName name) installedMap of+ [ case M.lookup name installedMap of Just (_, Stack.Types.Library _ident ipid) -> ["-package-id=" <> ghcPkgIdString ipid]- _ -> ["-package=" <> display name <>+ _ -> ["-package=" <> packageNameString name <> maybe "" -- This empty case applies to e.g. base. ((("-" <>) . versionString) . sourceVersion)- (M.lookup (fromCabalPackageName name) sourceMap)]- | Dependency name _ <- targetBuildDepends b- , name `notElem` fmap toCabalPackageName omitPkgs]- -- Generates: -package=base -package=base16-bytestring-0.1.1.6 ...+ (M.lookup name sourceMap)]+ | name <- pkgs]+ pkgs =+ addPkgs +++ [ name+ | Dependency cname _ <- targetBuildDepends b+ , let name = fromCabalPackageName cname+ , name `notElem` omitPkgs]+ -- Generates: -package=base -package=base16-bytestring-0.1.1.6 ... sourceVersion (PSUpstream ver _ _) = ver sourceVersion (PSLocal localPkg) = packageVersion (lpPackage localPkg) ghcOpts = concatMap snd . filter (isGhc . fst) . options
src/Stack/PackageIndex.hs view
@@ -13,6 +13,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-} -- | Dealing with the 00-index file and all its cabal files. module Stack.PackageIndex@@ -64,7 +65,8 @@ import System.FilePath (takeBaseName, (<.>)) import System.IO (IOMode (ReadMode, WriteMode), withBinaryFile)-import System.Process.Read (readInNull, EnvOverride, doesExecutableExist)+import System.Process.Read (readInNull, readProcessNull, ReadProcessException(..),+ EnvOverride, doesExecutableExist) -- | Populate the package index caches and return them. populateCache@@ -243,7 +245,14 @@ unless repoExists (readInNull suDir "git" menv cloneArgs Nothing) $logSticky "Fetching package index ..."- readInNull acfDir "git" menv ["fetch","--tags","--depth=1"] Nothing+ readProcessNull (Just acfDir) menv "git" ["fetch","--tags","--depth=1"] `C.catch` \(ex :: ReadProcessException) -> do+ -- we failed, so wipe the directory and try again, see #1418+ $logWarn (T.pack (show ex))+ $logStickyDone "Failed to fetch package index, retrying."+ removeTree acfDir+ readInNull suDir "git" menv cloneArgs Nothing+ $logSticky "Fetching package index ..."+ readInNull acfDir "git" menv ["fetch","--tags","--depth=1"] Nothing $logStickyDone "Fetched package index." removeFileIfExists tarFile when (indexGpgVerify index)
src/Stack/Setup.hs view
@@ -16,8 +16,10 @@ ( setupEnv , ensureCompiler , ensureDockerStackExe+ , getSystemCompiler , SetupOpts (..) , defaultStackSetupYaml+ , removeHaskellEnvVars ) where import Control.Applicative@@ -156,7 +158,7 @@ [ "The GHC located at " , toFilePath ghc , " failed to compile a sanity check. Please see:\n\n"- , " https://github.com/commercialhaskell/stack/blob/release/doc/install_and_upgrade.md\n\n"+ , " http://docs.haskellstack.org/en/stable/install_and_upgrade.html\n\n" , "for more information. Exception was:\n" , show e ]@@ -246,7 +248,7 @@ executablePath <- liftIO getExecutablePath - utf8EnvVars <- getUtf8LocaleVars menv+ utf8EnvVars <- getUtf8EnvVars menv compilerVer envRef <- liftIO $ newIORef Map.empty let getEnvOverride' es = do@@ -541,9 +543,9 @@ eres <- tryProcessStdout Nothing menv exeName ["--info"] let minfo = do Right bs <- Just eres- pairs <- readMay $ S8.unpack bs :: Maybe [(String, String)]- version <- lookup "Project version" pairs >>= parseVersionFromString- arch <- lookup "Target platform" pairs >>= simpleParse . takeWhile (/= '-')+ pairs_ <- readMay $ S8.unpack bs :: Maybe [(String, String)]+ version <- lookup "Project version" pairs_ >>= parseVersionFromString+ arch <- lookup "Target platform" pairs_ >>= simpleParse . takeWhile (/= '-') return (version, arch) case (wc, minfo) of (Ghc, Just (version, arch)) -> return (Just (GhcVersion version, arch))@@ -652,7 +654,7 @@ ghcKey <- getGhcKey case Map.lookup ghcKey $ siGHCs si of Nothing -> throwM $ UnknownOSKey ghcKey- Just pairs -> getWantedCompilerInfo ghcKey versionCheck wanted GhcVersion pairs+ Just pairs_ -> getWantedCompilerInfo ghcKey versionCheck wanted GhcVersion pairs_ config <- asks getConfig let installer = case configPlatform config of@@ -676,14 +678,11 @@ _ -> throwM GHCJSRequiresStandardVariant (selectedVersion, downloadInfo) <- case Map.lookup "source" $ siGHCJSs si of Nothing -> throwM $ UnknownOSKey "source"- Just pairs -> getWantedCompilerInfo "source" versionCheck wanted id pairs+ Just pairs_ -> getWantedCompilerInfo "source" versionCheck wanted id pairs_ $logInfo "Preparing to install GHCJS to an isolated location." $logInfo "This will not interfere with any system-level installation." let tool = ToolGhcjs selectedVersion- installer = installGHCJS $ case selectedVersion of- GhcjsVersion version _ -> version- _ -> error "Invariant violated: expected ghcjs version in downloadAndInstallCompiler."- downloadAndInstallTool (configLocalPrograms config) si downloadInfo tool installer+ downloadAndInstallTool (configLocalPrograms config) si downloadInfo tool installGHCJS getWantedCompilerInfo :: (Ord k, MonadThrow m) => Text@@ -692,15 +691,15 @@ -> (k -> CompilerVersion) -> Map k a -> m (k, a)-getWantedCompilerInfo key versionCheck wanted toCV pairs =+getWantedCompilerInfo key versionCheck wanted toCV pairs_ = case mpair of Just pair -> return pair- Nothing -> throwM $ UnknownCompilerVersion key wanted (map toCV (Map.keys pairs))+ Nothing -> throwM $ UnknownCompilerVersion key wanted (map toCV (Map.keys pairs_)) where mpair = listToMaybe $ sortBy (flip (comparing fst)) $- filter (isWantedCompiler versionCheck wanted . toCV . fst) (Map.toList pairs)+ filter (isWantedCompiler versionCheck wanted . toCV . fst) (Map.toList pairs_) getGhcKey :: (MonadReader env m, MonadThrow m, HasPlatform env, HasGHCVariant env, MonadLogger m, MonadIO m, MonadCatch m, MonadBaseControl IO m) => m Text@@ -806,13 +805,12 @@ $logDebug $ "GHC installed to " <> T.pack (toFilePath destDir) installGHCJS :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, HasTerminal env, HasReExec env, HasLogLevel env, MonadBaseControl IO m)- => Version- -> SetupInfo+ => SetupInfo -> Path Abs File -> ArchiveType -> Path Abs Dir -> m ()-installGHCJS version si archiveFile archiveType destDir = do+installGHCJS si archiveFile archiveType destDir = do platform <- asks getPlatform menv0 <- getMinimalEnvOverride -- This ensures that locking is disabled for the invocations of@@ -833,10 +831,9 @@ -- install cabal-install. This lets us also fix the version of -- cabal-install used. let unpackDir = destDir </> $(mkRelDir "src")- tarComponent <- parseRelDir ("ghcjs-" ++ versionString version) runUnpack <- case platform of Platform _ Cabal.Windows -> return $- withUnpackedTarball7z "GHCJS" si archiveFile archiveType tarComponent unpackDir+ withUnpackedTarball7z "GHCJS" si archiveFile archiveType Nothing unpackDir _ -> do zipTool' <- case archiveType of@@ -852,7 +849,8 @@ return $ do removeTreeIfExists unpackDir readInNull destDir tarTool menv ["xf", toFilePath archiveFile] Nothing- renameDir (destDir </> tarComponent) unpackDir+ innerDir <- expectSingleUnpackedDir archiveFile destDir+ renameDir innerDir unpackDir $logSticky $ T.concat ["Unpacking GHCJS into ", T.pack . toFilePath $ unpackDir, " ..."] $logDebug $ "Unpacking " <> T.pack (toFilePath archiveFile)@@ -1042,7 +1040,7 @@ -> m () installGHCWindows version si archiveFile archiveType destDir = do tarComponent <- parseRelDir $ "ghc-" ++ versionString version- withUnpackedTarball7z "GHC" si archiveFile archiveType tarComponent destDir+ withUnpackedTarball7z "GHC" si archiveFile archiveType (Just tarComponent) destDir $logInfo $ "GHC installed to " <> T.pack (toFilePath destDir) installMsys2Windows :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m)@@ -1061,7 +1059,7 @@ throwM e msys <- parseRelDir $ "msys" ++ T.unpack (fromMaybe "32" $ T.stripPrefix "windows" osKey)- withUnpackedTarball7z "MSYS2" si archiveFile archiveType msys destDir+ withUnpackedTarball7z "MSYS2" si archiveFile archiveType (Just msys) destDir platform <- asks getPlatform menv0 <- getMinimalEnvOverride@@ -1089,10 +1087,10 @@ -> SetupInfo -> Path Abs File -- ^ Path to archive file -> ArchiveType- -> Path Rel Dir -- ^ Name of directory expected to be in archive.+ -> Maybe (Path Rel Dir) -- ^ Name of directory expected in archive. If Nothing, expects a single folder. -> Path Abs Dir -- ^ Destination directory. -> m ()-withUnpackedTarball7z name si archiveFile archiveType srcDir destDir = do+withUnpackedTarball7z name si archiveFile archiveType msrcDir destDir = do suffix <- case archiveType of TarXz -> return ".xz"@@ -1107,7 +1105,9 @@ let tmpName = toFilePathNoTrailingSep (dirname destDir) ++ "-tmp" createTree (parent destDir) withCanonicalizedTempDirectory (toFilePath $ parent destDir) tmpName $ \tmpDir -> do- let absSrcDir = tmpDir </> srcDir+ absSrcDir <- case msrcDir of+ Just srcDir -> return $ tmpDir </> srcDir+ Nothing -> expectSingleUnpackedDir archiveFile tmpDir removeTreeIfExists destDir run7z (parent archiveFile) archiveFile run7z tmpDir tarFile@@ -1120,6 +1120,13 @@ ]) renameDir absSrcDir destDir +expectSingleUnpackedDir :: (MonadIO m, MonadThrow m) => Path Abs File -> Path Abs Dir -> m (Path Abs Dir)+expectSingleUnpackedDir archiveFile destDir = do+ contents <- listDirectory destDir+ case contents of+ ([dir], []) -> return dir+ _ -> error $ "Expected a single directory within unpacked " ++ toFilePath archiveFile+ -- | Download 7z as necessary, and get a function for unpacking things. -- -- Returned function takes an unpack directory and archive.@@ -1302,77 +1309,82 @@ Map.delete "HASKELL_PACKAGE_SANDBOXES" . Map.delete "HASKELL_DIST_DIR" --- | Get map of environment variables to set to change the locale's encoding to UTF-8-getUtf8LocaleVars+-- | Get map of environment variables to set to change the GHC's encoding to UTF-8+getUtf8EnvVars :: forall m env. (MonadReader env m, HasPlatform env, MonadLogger m, MonadCatch m, MonadBaseControl IO m, MonadIO m)- => EnvOverride -> m (Map Text Text)-getUtf8LocaleVars menv = do- Platform _ os <- asks getPlatform- if os == Cabal.Windows- then- -- On Windows, locale is controlled by the code page, so we don't set any environment- -- variables.- return- Map.empty- else do- let checkedVars = map checkVar (Map.toList $ eoTextMap menv)- -- List of environment variables that will need to be updated to set UTF-8 (because- -- they currently do not specify UTF-8).- needChangeVars = concatMap fst checkedVars- -- Set of locale-related environment variables that have already have a value.- existingVarNames = Set.unions (map snd checkedVars)- -- True if a locale is already specified by one of the "global" locale variables.- hasAnyExisting =- any (`Set.member` existingVarNames) ["LANG", "LANGUAGE", "LC_ALL"]- if null needChangeVars && hasAnyExisting- then- -- If no variables need changes and at least one "global" variable is set, no- -- changes to environment need to be made.- return- Map.empty- else do- -- Get a list of known locales by running @locale -a@.- elocales <- tryProcessStdout Nothing menv "locale" ["-a"]- let- -- Filter the list to only include locales with UTF-8 encoding.- utf8Locales =- case elocales of- Left _ -> []- Right locales ->- filter- isUtf8Locale- (T.lines $- T.decodeUtf8With- T.lenientDecode- locales)- mfallback = getFallbackLocale utf8Locales- when- (isNothing mfallback)- ($logWarn- "Warning: unable to set locale to UTF-8 encoding; GHC may fail with 'invalid character'")- let- -- Get the new values of variables to adjust.- changes =- Map.unions $- map- (adjustedVarValue utf8Locales mfallback)- needChangeVars- -- Get the values of variables to add.- adds- | hasAnyExisting =- -- If we already have a "global" variable, then nothing needs- -- to be added.- Map.empty- | otherwise =- -- If we don't already have a "global" variable, then set LANG to the- -- fallback.- case mfallback of- Nothing -> Map.empty- Just fallback ->- Map.singleton "LANG" fallback- return (Map.union changes adds)+ => EnvOverride -> CompilerVersion -> m (Map Text Text)+getUtf8EnvVars menv compilerVer = do+ if getGhcVersion compilerVer >= $(mkVersion "7.10.3")+ -- GHC_CHARENC supported by GHC >=7.10.3+ then return $ Map.singleton "GHC_CHARENC" "UTF-8"+ else legacyLocale where+ legacyLocale = do+ Platform _ os <- asks getPlatform+ if os == Cabal.Windows+ then+ -- On Windows, locale is controlled by the code page, so we don't set any environment+ -- variables.+ return+ Map.empty+ else do+ let checkedVars = map checkVar (Map.toList $ eoTextMap menv)+ -- List of environment variables that will need to be updated to set UTF-8 (because+ -- they currently do not specify UTF-8).+ needChangeVars = concatMap fst checkedVars+ -- Set of locale-related environment variables that have already have a value.+ existingVarNames = Set.unions (map snd checkedVars)+ -- True if a locale is already specified by one of the "global" locale variables.+ hasAnyExisting =+ any (`Set.member` existingVarNames) ["LANG", "LANGUAGE", "LC_ALL"]+ if null needChangeVars && hasAnyExisting+ then+ -- If no variables need changes and at least one "global" variable is set, no+ -- changes to environment need to be made.+ return+ Map.empty+ else do+ -- Get a list of known locales by running @locale -a@.+ elocales <- tryProcessStdout Nothing menv "locale" ["-a"]+ let+ -- Filter the list to only include locales with UTF-8 encoding.+ utf8Locales =+ case elocales of+ Left _ -> []+ Right locales ->+ filter+ isUtf8Locale+ (T.lines $+ T.decodeUtf8With+ T.lenientDecode+ locales)+ mfallback = getFallbackLocale utf8Locales+ when+ (isNothing mfallback)+ ($logWarn+ "Warning: unable to set locale to UTF-8 encoding; GHC may fail with 'invalid character'")+ let+ -- Get the new values of variables to adjust.+ changes =+ Map.unions $+ map+ (adjustedVarValue utf8Locales mfallback)+ needChangeVars+ -- Get the values of variables to add.+ adds+ | hasAnyExisting =+ -- If we already have a "global" variable, then nothing needs+ -- to be added.+ Map.empty+ | otherwise =+ -- If we don't already have a "global" variable, then set LANG to the+ -- fallback.+ case mfallback of+ Nothing -> Map.empty+ Just fallback ->+ Map.singleton "LANG" fallback+ return (Map.union changes adds) -- Determines whether an environment variable is locale-related and, if so, whether it needs to -- be adjusted. checkVar
src/Stack/Setup/Installed.hs view
@@ -152,7 +152,7 @@ { edBins :: ![FilePath] , edInclude :: ![FilePath] , edLib :: ![FilePath]- }+ } deriving (Show) instance Monoid ExtraDirs where mempty = ExtraDirs [] [] [] mappend (ExtraDirs a b c) (ExtraDirs x y z) = ExtraDirs
src/Stack/Solver.hs view
@@ -3,11 +3,16 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} module Stack.Solver- ( cabalSolver+ ( checkResolverSpec+ , cabalPackagesCheck+ , findCabalFiles+ , mergeConstraints , solveExtraDeps+ , solveResolverSpec ) where import Control.Applicative+import Control.Exception (assert) import Control.Exception.Enclosed (tryIO) import Control.Monad.Catch import Control.Monad.IO.Class@@ -18,67 +23,64 @@ import qualified Data.ByteString as S import Data.Either import qualified Data.HashMap.Strict as HashMap+import Data.List ((\\), isSuffixOf, intercalate)+import Data.List.Extra (groupSortOn) 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 T import Data.Text.Encoding (decodeUtf8, encodeUtf8)+import Data.Text.Encoding.Error (lenientDecode)+import qualified Data.Text.Lazy as LT+import Data.Text.Lazy.Encoding (decodeUtf8With) import qualified Data.Yaml as Yaml+import qualified Distribution.PackageDescription as C import Network.HTTP.Client.Conduit (HasHttpManager) import Path-import Path.IO (parseRelAsAbsDir)+import Path.Find (findFiles)+import Path.IO (getWorkingDir, parseRelAsAbsDir) import Prelude import Stack.BuildPlan+import Stack.Constants (stackDotYaml)+import Stack.Package (printCabalFileWarning+ , readPackageUnresolved)+import Stack.Setup import Stack.Setup.Installed import Stack.Types+import Stack.Types.Internal ( HasTerminal+ , HasReExec+ , HasLogLevel) import System.Directory (copyFile, createDirectoryIfMissing,- getTemporaryDirectory)+ getTemporaryDirectory,+ makeRelativeToCurrentDirectory) import qualified System.FilePath as FP import System.IO.Temp (withSystemTempDirectory) import System.Process.Read +data ConstraintType = Constraint | Preference deriving (Eq)+type ConstraintSpec = Map PackageName (Version, Map FlagName Bool)+ cabalSolver :: (MonadIO m, MonadLogger m, MonadMask m, MonadBaseControl IO m, MonadReader env m, HasConfig env)- => WhichCompiler+ => EnvOverride -> [Path Abs Dir] -- ^ cabal files- -> Map PackageName Version -- ^ constraints- -> Map PackageName (Map FlagName Bool) -- ^ user-specified flags+ -> ConstraintType+ -> ConstraintSpec -- ^ src constraints+ -> ConstraintSpec -- ^ dep constraints -> [String] -- ^ additional arguments- -> m (CompilerVersion, Map PackageName (Version, Map FlagName Bool))-cabalSolver wc cabalfps constraints userFlags cabalArgs = withSystemTempDirectory "cabal-solver" $ \dir -> do- when (null cabalfps) $ throwM SolverNoCabalFiles- configLines <- getCabalConfig dir constraints+ -> m (Maybe ConstraintSpec)+cabalSolver menv cabalfps constraintType+ srcConstraints depConstraints cabalArgs =+ withSystemTempDirectory "cabal-solver" $ \dir -> do++ let versionConstraints = fmap fst depConstraints+ configLines <- getCabalConfig dir constraintType versionConstraints let configFile = dir FP.</> "cabal.config" liftIO $ S.writeFile configFile $ encodeUtf8 $ T.unlines configLines - menv0 <- getMinimalEnvOverride- mghc <- findExecutable menv0 "ghc"- platform <- asks getPlatform- menv <-- case mghc of- Just _ -> return menv0- Nothing -> do- localPrograms <- asks $ configLocalPrograms . getConfig- tools <- listInstalled localPrograms- let ghcName = $(mkPackageName "ghc")- case [version | Tool (PackageIdentifier name version) <- tools, name == ghcName] of- [] -> throwM SolverMissingGHC- versions -> do- let version = maximum versions- $logInfo $ "No GHC on path, selecting: " <>- T.pack (versionString version)- ed <- extraDirs $ Tool $ PackageIdentifier ghcName version- pathsEnv <- augmentPathMap (edBins ed)- (unEnvOverride menv0)- mkEnvOverride platform pathsEnv- mcabal <- findExecutable menv "cabal"- case mcabal of- Nothing -> throwM SolverMissingCabalInstall- Just _ -> return ()-- compilerVersion <- getCompilerVersion menv wc- -- Run from a temporary directory to avoid cabal getting confused by any -- sandbox files, see: -- https://github.com/commercialhaskell/stack/issues/356@@ -91,7 +93,6 @@ : "install" : "--enable-tests" : "--enable-benchmarks"- : "-v" : "--dry-run" : "--only-dependencies" : "--reorder-goals"@@ -99,28 +100,47 @@ : "--package-db=clear" : "--package-db=global" : cabalArgs ++- toConstraintArgs userFlags ++- fmap toFilePath cabalfps ++- ["--ghcjs" | wc == Ghcjs]+ toConstraintArgs (flagConstraints constraintType) +++ fmap toFilePath cabalfps - $logInfo "Asking cabal to calculate a build plan, please wait"+ catch (liftM Just (readProcessStdout (Just tmpdir) menv "cabal" args))+ (\ex -> case ex of+ ReadProcessException _ _ _ err -> do+ let errMsg = decodeUtf8With lenientDecode err+ if LT.isInfixOf "Could not resolve dependencies" errMsg+ then do+ $logInfo "Attempt failed."+ $logInfo "\n>>>> Cabal errors begin"+ $logInfo $ LT.toStrict errMsg+ <> "<<<< Cabal errors end\n"+ return Nothing+ else throwM ex+ _ -> throwM ex)+ >>= maybe (return Nothing) parseCabalOutput - menv' <- mkEnvOverride platform- $ Map.delete "GHCJS_PACKAGE_PATH"- $ Map.delete "GHC_PACKAGE_PATH" $ unEnvOverride menv- bs <- readProcessStdout (Just tmpdir) menv' "cabal" args- let ls = drop 1- $ dropWhile (not . T.isPrefixOf "In order, ")- $ T.lines- $ decodeUtf8 bs- (errs, pairs) = partitionEithers $ map parseLine ls- if null errs- then return (compilerVersion, Map.fromList pairs)- else error $ "Could not parse cabal-install output: " ++ show errs where+ parseCabalOutput bs = do+ let ls = drop 1+ $ dropWhile (not . T.isPrefixOf "In order, ")+ $ T.lines+ $ decodeUtf8 bs+ (errs, pairs) = partitionEithers $ map parseLine ls+ if null errs+ then return $ Just (Map.fromList pairs)+ else error $ "Could not parse cabal-install output: " ++ show errs+ parseLine t0 = maybe (Left t0) Right $ do- -- get rid of (new package) and (latest: ...) bits- ident':flags' <- Just $ T.words $ T.takeWhile (/= '(') t0+ -- Sample output to parse:+ -- text-1.2.1.1 (latest: 1.2.2.0) -integer-simple (via: parsec-3.1.9) (new package))+ -- An ugly parser to extract module id and flags+ let t1 = T.concat $+ [ T.takeWhile (/= '(')+ , (T.takeWhile (/= '('))+ . (T.drop 1)+ . (T.dropWhile (/= ')'))+ ] <*> [t0]++ ident':flags' <- Just $ T.words t1 PackageIdentifier name version <- parsePackageIdentifierFromString $ T.unpack ident' flags <- mapM parseFlag flags'@@ -137,18 +157,30 @@ Just x -> (x, True) Just x -> (x, False) toConstraintArgs userFlagMap =- [formatFlagConstraint package flag enabled | (package, fs) <- Map.toList userFlagMap- , (flag, enabled) <- Map.toList fs]+ [formatFlagConstraint package flag enabled+ | (package, fs) <- Map.toList userFlagMap+ , (flag, enabled) <- Map.toList fs]+ formatFlagConstraint package flag enabled = let sign = if enabled then '+' else '-' in "--constraint=" ++ unwords [packageNameString package, sign : flagNameString flag] -getCabalConfig :: (MonadReader env m, HasConfig env, MonadIO m, MonadThrow m)+ -- Note the order of the Map union is important+ -- We override a package in snapshot by a src package+ flagConstraints Constraint = fmap snd (Map.union srcConstraints+ depConstraints)+ -- Even when using preferences we want to+ -- keep the src package flags unchanged+ -- TODO - this should be done only for manual flags.+ flagConstraints Preference = fmap snd srcConstraints++getCabalConfig :: (MonadLogger m, MonadReader env m, HasConfig env, MonadIO m, MonadThrow m) => FilePath -- ^ temp dir+ -> ConstraintType -> Map PackageName Version -- ^ constraints -> m [Text]-getCabalConfig dir constraints = do+getCabalConfig dir constraintType constraints = do indices <- asks $ configPackageIndices . getConfig remotes <- mapM goIndex indices let cache = T.pack $ "remote-repo-cache: " ++ dir@@ -167,71 +199,424 @@ , ":http://0.0.0.0/fake-url" ] - goConstraint (name, version) = T.concat- [ "constraint: "- , T.pack $ packageNameString name- , "=="- , T.pack $ versionString version- ]+ goConstraint (name, version) =+ assert (not . null . versionString $ version) $+ T.concat+ [ (if constraintType == Constraint+ then "constraint: "+ else "preference: ")+ , 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?- -> m ()+setupCompiler+ :: ( MonadBaseControl IO m, MonadIO m, MonadLogger m, MonadMask m+ , MonadReader env m, HasConfig env , HasGHCVariant env+ , HasHttpManager env , HasLogLevel env , HasReExec env+ , HasTerminal env)+ => CompilerVersion+ -> m (Maybe ExtraDirs)+setupCompiler compiler = do+ let msg = Just $ T.concat+ [ "Compiler version (" <> compilerVersionText compiler <> ") "+ , "required by your resolver specification cannot be found.\n\n"+ , "Please use '--install-ghc' command line switch to automatically "+ , "install the compiler or '--system-ghc' to use a suitable "+ , "compiler available on your PATH." ]++ config <- asks getConfig+ mpaths <- ensureCompiler SetupOpts+ { soptsInstallIfMissing = configInstallGHC config+ , soptsUseSystem = configSystemGHC config+ , soptsWantedCompiler = compiler+ , soptsCompilerCheck = configCompilerCheck config++ , soptsStackYaml = Nothing+ , soptsForceReinstall = False+ , soptsSanityCheck = False+ , soptsSkipGhcCheck = False+ , soptsSkipMsys = configSkipMsys config+ , soptsUpgradeCabal = False+ , soptsResolveMissingGHC = msg+ , soptsStackSetupYaml = defaultStackSetupYaml+ , soptsGHCBindistURL = Nothing+ }++ return mpaths++setupCabalEnv+ :: ( MonadBaseControl IO m, MonadIO m, MonadLogger m, MonadMask m+ , MonadReader env m, HasConfig env , HasGHCVariant env+ , HasHttpManager env , HasLogLevel env , HasReExec env+ , HasTerminal env)+ => CompilerVersion+ -> m EnvOverride+setupCabalEnv compiler = do+ mpaths <- setupCompiler compiler+ menv0 <- getMinimalEnvOverride+ envMap <- removeHaskellEnvVars+ <$> augmentPathMap (maybe [] edBins mpaths)+ (unEnvOverride menv0)+ platform <- asks getPlatform+ menv <- mkEnvOverride platform envMap++ mcabal <- findExecutable menv "cabal"+ case mcabal of+ Nothing -> throwM SolverMissingCabalInstall+ Just _ -> return ()++ mver <- getSystemCompiler menv (whichCompiler compiler)+ case mver of+ Just (version, _) ->+ $logInfo $ "Using compiler: " <> compilerVersionText version+ Nothing -> error "Failed to determine compiler version. \+ \This is most likely a bug."+ return menv++mergeConstraints+ :: Map PackageName v+ -> Map PackageName (Map p f)+ -> Map PackageName (v, Map p f)+mergeConstraints = Map.mergeWithKey+ -- combine entry in both maps+ (\_ v f -> Just (v, f))+ -- convert entry in first map only+ (fmap (flip (,) Map.empty))+ -- convert entry in second map only+ (\m -> if Map.null m then Map.empty+ else error "Bug: An entry in flag map must have a corresponding \+ \entry in the version map")++diffConstraints+ :: (Eq v, Eq f)+ => (v, f) -> (v, f) -> Maybe (v, f)+diffConstraints (v, f) (v', f')+ | (v == v') && (f == f') = Nothing+ | otherwise = Just (v, f)++solveResolverSpec+ :: ( MonadBaseControl IO m, MonadIO m, MonadLogger m, MonadMask m+ , MonadReader env m, HasConfig env , HasGHCVariant env+ , HasHttpManager env , HasLogLevel env , HasReExec env+ , HasTerminal env)+ => Path Abs File -- ^ stack.yaml file location+ -> [Path Abs Dir] -- ^ package dirs containing cabal files+ -> ( Resolver+ , ConstraintSpec+ , ConstraintSpec) -- ^ ( resolver+ -- , src package constraints+ -- , extra dependency constraints )+ -> m (Maybe ( ConstraintSpec+ , ConstraintSpec)) -- ^ ( resulting src package specs+ -- , resulting external package specs )++solveResolverSpec stackYaml cabalDirs+ (resolver, srcConstraints, extraConstraints) = do+ $logInfo $ "Using resolver: " <> resolverName resolver+ (compilerVer, snapConstraints) <- getResolverConstraints resolver+ menv <- setupCabalEnv compilerVer++ let -- Note - The order in Map.union below is important.+ -- We want to override snapshot with extra deps+ depConstraints = Map.union extraConstraints snapConstraints+ -- Make sure deps do not include any src packages+ -- There are two reasons for this:+ -- 1. We do not want snapshot versions to override the sources+ -- 2. Sources may not have versions leading to bad cabal constraints+ depOnlyConstraints = Map.difference depConstraints srcConstraints+ solver t = cabalSolver menv cabalDirs t+ srcConstraints depOnlyConstraints $+ ["-v"] -- TODO make it conditional on debug+ ++ ["--ghcjs" | (whichCompiler compilerVer) == Ghcjs]++ let srcNames = (T.intercalate " and ") $+ ["packages from " <> resolverName resolver+ | not (Map.null snapConstraints)] +++ [T.pack ((show $ Map.size extraConstraints) <> " external packages")+ | not (Map.null extraConstraints)]++ $logInfo "Asking cabal to calculate a build plan..."+ unless (Map.null depOnlyConstraints)+ ($logInfo $ "Trying with " <> srcNames <> " as hard constraints...")++ mdeps <- solver Constraint+ mdeps' <- case mdeps of+ Nothing | not (Map.null depOnlyConstraints) -> do+ $logInfo $ "Retrying with " <> srcNames <> " as preferences..."+ solver Preference+ _ -> return mdeps++ case mdeps' of+ Just deps -> do+ let+ -- All src package constraints returned by cabal.+ -- Flags may have changed.+ srcs = Map.intersection deps srcConstraints+ inSnap = Map.intersection deps snapConstraints+ -- All packages which are in the snapshot but cabal solver+ -- returned versions or flags different from the snapshot.+ inSnapChanged = Map.differenceWith diffConstraints+ inSnap snapConstraints+ -- Packages neither in snapshot, nor srcs+ extra = Map.difference deps (Map.union srcConstraints+ snapConstraints)+ external = Map.union inSnapChanged extra++ $logInfo $ "Successfully determined a build plan with "+ <> T.pack (show $ Map.size external)+ <> " external dependencies."++ return $ Just (srcs, external)+ Nothing -> do+ $logInfo $ "Failed to arrive at a workable build plan using "+ <> resolverName resolver <> " resolver."+ return Nothing+ where+ mpiConstraints mpi = (mpiVersion mpi, mpiFlags mpi)+ mbpConstraints mbp = fmap mpiConstraints (mbpPackages mbp)++ getResolverConstraints (ResolverSnapshot snapName) = do+ mbp <- loadMiniBuildPlan snapName+ return (mbpCompilerVersion mbp, mbpConstraints mbp)++ getResolverConstraints (ResolverCompiler compiler) =+ return (compiler, Map.empty)++ -- FIXME instead of passing the stackYaml dir we should maintain+ -- the file URL in the custom resolver always relative to stackYaml.+ getResolverConstraints (ResolverCustom _ url) = do+ mbp <- parseCustomMiniBuildPlan stackYaml url+ return (mbpCompilerVersion mbp, mbpConstraints mbp)++-- | Given a bundle of packages and a resolver, check the resolver with respect+-- to the packages and return how well the resolver satisfies the depndencies+-- of the packages. If 'flags' is passed as 'Nothing' then flags are chosen+-- automatically.++checkResolverSpec+ :: ( MonadIO m, MonadCatch m, MonadLogger m, MonadReader env m+ , HasHttpManager env, HasConfig env, HasGHCVariant env+ , MonadBaseControl IO m)+ => [C.GenericPackageDescription]+ -> Maybe (Map PackageName (Map FlagName Bool))+ -> Resolver+ -> m BuildPlanCheck+checkResolverSpec gpds flags resolver = do+ case resolver of+ ResolverSnapshot name -> checkSnapBuildPlan gpds flags name+ ResolverCompiler _ -> return $ BuildPlanCheckPartial Map.empty Map.empty+ -- TODO support custom resolver for stack init+ ResolverCustom _ _ -> return $ BuildPlanCheckPartial Map.empty Map.empty++findCabalFiles :: MonadIO m => Bool -> Path Abs Dir -> m [Path Abs File]+findCabalFiles recurse dir =+ liftIO $ findFiles dir isCabal (\subdir -> recurse && not (isIgnored subdir))+ where+ isCabal path = ".cabal" `isSuffixOf` toFilePath path++ isIgnored path = FP.dropTrailingPathSeparator (toFilePath (dirname path))+ `Set.member` ignoredDirs++-- | Special directories that we don't want to traverse for .cabal files+ignoredDirs :: Set FilePath+ignoredDirs = Set.fromList+ [ ".git"+ , "dist"+ , ".stack-work"+ ]++-- | Do some basic checks on a list of cabal file paths to be used for creating+-- stack config, print some informative and error messages and if all is ok+-- return @GenericPackageDescription@ list.+cabalPackagesCheck+ :: ( MonadBaseControl IO m, MonadIO m, MonadLogger m, MonadMask m+ , MonadReader env m, HasConfig env , HasGHCVariant env+ , HasHttpManager env , HasLogLevel env , HasReExec env+ , HasTerminal env)+ => [Path Abs File]+ -> String+ -> String+ -> m [C.GenericPackageDescription]+cabalPackagesCheck cabalfps noPkgMsg dupPkgFooter = do+ when (null cabalfps) $+ error noPkgMsg++ relpaths <- mapM makeRel cabalfps+ $logInfo $ "Using cabal packages:"+ $logInfo $ T.pack (formatGroup relpaths)++ when (dupGroups relpaths /= []) $+ error $ "Duplicate cabal package names cannot be used in a single "+ <> "stack project. Following duplicates were found:\n"+ <> intercalate "\n" (dupGroups relpaths)+ <> "\n"+ <> dupPkgFooter++ (warnings,gpds) <- fmap unzip (mapM readPackageUnresolved cabalfps)+ zipWithM_ (mapM_ . printCabalFileWarning) cabalfps warnings+ return gpds++ where+ groups = filter ((> 1) . length) . groupSortOn (FP.takeFileName)+ dupGroups = (map formatGroup) . groups++makeRel :: (MonadIO m) => Path Abs File -> m FilePath+makeRel = liftIO . makeRelativeToCurrentDirectory . toFilePath++formatGroup :: [String] -> String+formatGroup = concat . (map formatPath)+ where formatPath path = "- " <> path <> "\n"++reportMissingCabalFiles+ :: (MonadIO m, MonadLogger m) => [Path Abs File] -> Bool -> m ()+reportMissingCabalFiles cabalfps includeSubdirs = do+ allCabalfps <- findCabalFiles (includeSubdirs) =<< getWorkingDir++ relpaths <- mapM makeRel (allCabalfps \\ cabalfps)+ when (not (null relpaths)) $ do+ $logWarn $ "The following packages are missing from the config:"+ $logWarn $ T.pack (formatGroup relpaths)++-- | Solver can be thought of as a counterpart of init. init creates a+-- stack.yaml whereas solver verifies or fixes an existing one. It can verify+-- the dependencies of the packages and determine if any extra-dependecies+-- outside the snapshots are needed.+--+-- TODO Currently solver uses a stack.yaml in the parent chain when there is+-- no stack.yaml in the current directory. It should instead look for a+-- stack yaml only in the current directory and suggest init if there is+-- none available. That will make the behavior consistent with init and provide+-- a correct meaning to a --ignore-subdirs option if implemented.++solveExtraDeps+ :: ( MonadBaseControl IO m, MonadIO m, MonadLogger m, MonadMask m+ , MonadReader env m, HasConfig env , HasEnvConfig env, HasGHCVariant env+ , HasHttpManager env , HasLogLevel env , HasReExec env+ , HasTerminal env)+ => Bool -- ^ modify stack.yaml?+ -> m () solveExtraDeps modStackYaml = do econfig <- asks getEnvConfig bconfig <- asks getBuildConfig- snapshot <-- case bcResolver bconfig of- ResolverSnapshot snapName -> liftM mbpPackages $ loadMiniBuildPlan snapName- ResolverCompiler _ -> return Map.empty- ResolverCustom _ url -> liftM mbpPackages $ parseCustomMiniBuildPlan- (bcStackYaml bconfig)- url - let packages = Map.union- (bcExtraDeps bconfig)- (mpiVersion <$> snapshot)+ let stackYaml = bcStackYaml bconfig+ relStackYaml <- makeRel stackYaml - wc <- getWhichCompiler- (_compilerVersion, extraDeps) <- cabalSolver- wc- (Map.keys $ envConfigPackages econfig)- packages- (bcFlags bconfig)- []+ $logInfo $ "Using configuration file: " <> T.pack relStackYaml+ let cabalDirs = Map.keys $ envConfigPackages econfig+ noPkgMsg = "No cabal packages found in " <> relStackYaml <>+ ". Please add at least one directory containing a .cabal \+ \file. You can also use 'stack init' to automatically \+ \generate the config file."+ dupPkgFooter = "Please remove the directories containing duplicate \+ \entries from '" <> relStackYaml <> "'." - let newDeps = extraDeps `Map.difference` packages- newFlags = Map.filter (not . Map.null) $ fmap snd newDeps+ cabalfps <- liftM concat (mapM (findCabalFiles False) cabalDirs)+ gpds <- cabalPackagesCheck cabalfps noPkgMsg dupPkgFooter - $logInfo "This command is not guaranteed to give you a perfect build plan"- if Map.null newDeps- then $logInfo "No needed changes found"- else do- $logInfo "It's possible that even with the changes generated below, you will still need to do some manual tweaking"- let o = object- $ ("extra-deps" .= map fromTuple (Map.toList $ fmap fst newDeps))- : (if Map.null newFlags- then []- else ["flags" .= newFlags])- mapM_ $logInfo $ T.lines $ decodeUtf8 $ Yaml.encode o+ -- TODO when solver supports --ignore-subdirs option pass that as the+ -- second argument here.+ reportMissingCabalFiles cabalfps True - if modStackYaml- then do- let fp = toFilePath $ bcStackYaml bconfig- obj <- 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- $ Map.union (projectExtraDeps project) (fmap fst newDeps))- $ HashMap.insert ("flags" :: Text)- (toJSON $ Map.union (projectFlags project) newFlags)- obj- liftIO $ Yaml.encodeFile fp obj'- $logInfo $ T.pack $ "Updated " ++ fp- else do+ let oldFlags = bcFlags bconfig+ oldExtraVersions = bcExtraDeps bconfig+ resolver = bcResolver bconfig+ oldSrcs = gpdPackages gpds+ oldSrcFlags = Map.intersection oldFlags oldSrcs+ oldExtraFlags = Map.intersection oldFlags oldExtraVersions++ srcConstraints = mergeConstraints oldSrcs oldSrcFlags+ extraConstraints = mergeConstraints oldExtraVersions oldExtraFlags++ resolverResult <- checkResolverSpec gpds (Just oldSrcFlags) resolver+ resultSpecs <- case resolverResult of+ BuildPlanCheckOk flags ->+ return $ Just ((mergeConstraints oldSrcs flags), Map.empty)+ BuildPlanCheckPartial _ _ ->+ solveResolverSpec stackYaml cabalDirs+ (resolver, srcConstraints, extraConstraints)+ BuildPlanCheckFail f e c ->+ throwM $ ResolverMismatch resolver (showCompilerErrors f e c)++ (srcs, edeps) <- case resultSpecs of+ Nothing -> throwM (SolverGiveUp giveUpMsg)+ Just x -> return x++ let+ flags = removeSrcPkgDefaultFlags gpds (fmap snd (Map.union srcs edeps))+ versions = fmap fst edeps++ vDiff v v' = if v == v' then Nothing else Just v+ versionsDiff = Map.differenceWith vDiff+ newVersions = versionsDiff versions oldExtraVersions+ goneVersions = versionsDiff oldExtraVersions versions++ fDiff f f' = if f == f' then Nothing else Just f+ flagsDiff = Map.differenceWith fDiff+ newFlags = flagsDiff flags oldFlags+ goneFlags = flagsDiff oldFlags flags++ changed = any (not . Map.null) [newVersions, goneVersions]+ || any (not . Map.null) [newFlags, goneFlags]++ if changed then do $logInfo ""- $logInfo "To automatically modify your stack.yaml file, rerun with '--modify-stack-yaml'"+ $logInfo $ "The following changes will be made to "+ <> T.pack relStackYaml <> ":"++ -- TODO print whether resolver changed from previous+ $logInfo $ "* Resolver is " <> resolverName resolver++ -- TODO indent the yaml output+ printFlags newFlags "* Flags to be added"+ printDeps newVersions "* Dependencies to be added"++ printFlags goneFlags "* Flags to be deleted"+ printDeps goneVersions "* Dependencies to be deleted"++ -- TODO backup the old config file+ if modStackYaml then do+ writeStackYaml stackYaml resolver versions flags+ $logInfo $ "Updated " <> T.pack relStackYaml+ else do+ $logInfo $ "To automatically update " <> T.pack relStackYaml+ <> ", rerun with '--update-config'"+ else+ $logInfo $ "No changes needed to " <> T.pack relStackYaml++ where+ indent t = T.unlines $ fmap (" " <>) (T.lines t)++ printFlags fl msg = do+ when ((not . Map.null) fl) $ do+ $logInfo $ T.pack msg+ $logInfo $ indent $ decodeUtf8 $ Yaml.encode+ $ object ["flags" .= fl]++ printDeps deps msg = do+ when ((not . Map.null) deps) $ do+ $logInfo $ T.pack msg+ $logInfo $ indent $ decodeUtf8 $ Yaml.encode $ object $+ [("extra-deps" .= map fromTuple (Map.toList deps))]++ writeStackYaml path res deps fl = do+ let fp = toFilePath path+ obj <- liftIO (Yaml.decodeFileEither fp) >>= either throwM return+ (ProjectAndConfigMonoid _ _, warnings) <-+ liftIO (Yaml.decodeFileEither fp) >>= either throwM return+ logJSONWarnings fp warnings+ let obj' =+ HashMap.insert "extra-deps"+ (toJSON $ map fromTuple $ Map.toList deps)+ $ HashMap.insert ("flags" :: Text) (toJSON fl)+ $ HashMap.insert ("resolver" :: Text) (toJSON (resolverName res)) obj+ liftIO $ Yaml.encodeFile fp obj'++ giveUpMsg = concat+ [ " - Update external packages with 'stack update' and try again.\n"+ , " - Tweak " <> toFilePath stackDotYaml <> " and try again\n"+ , " - Remove any unnecessary packages.\n"+ , " - Add any missing remote packages.\n"+ , " - Add extra dependencies to guide solver.\n"+ ]
src/Stack/Types/Build.hs view
@@ -120,9 +120,8 @@ | InvalidFlagSpecification (Set UnusedFlags) | TargetParseException [Text] | DuplicateLocalPackageNames [(PackageName, [Path Abs Dir])]+ | SolverGiveUp String | SolverMissingCabalInstall- | SolverMissingGHC- | SolverNoCabalFiles | SomeTargetsNotBuildable [(PackageName, NamedComponent)] deriving Typeable @@ -322,17 +321,14 @@ : (packageNameString name ++ " used in:") : map goDir dirs goDir dir = "- " ++ toFilePath dir+ show (SolverGiveUp msg) = concat+ [ "\nSolver could not resolve package dependencies.\n"+ , "You can try the following:\n"+ , msg+ ] show SolverMissingCabalInstall = unlines [ "Solver requires that cabal be on your PATH" , "Try running 'stack install cabal-install'"- ]- show SolverMissingGHC = unlines- [ "Solver requires that GHC be on your PATH"- , "Try running 'stack setup'"- ]- show SolverNoCabalFiles = unlines- [ "No cabal files provided. Maybe this is due to not having a stack.yaml file?"- , "Try running 'stack init' to create a stack.yaml" ] show (SomeTargetsNotBuildable xs) = "The following components have 'buildable: False' set in the cabal configuration, and so cannot be targets:\n " ++
src/Stack/Types/BuildPlan.hs view
@@ -15,6 +15,7 @@ , Maintainer (..) , ExeName (..) , SimpleDesc (..)+ , Snapshots (..) , DepInfo (..) , Component (..) , SnapName (..)@@ -34,6 +35,8 @@ import Data.Binary.VersionTagged import Data.Hashable (Hashable) import qualified Data.HashMap.Strict as HashMap+import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe (fromMaybe)@@ -358,6 +361,34 @@ nightly = do t1 <- T.stripPrefix "nightly-" t0 Nightly <$> readMay (T.unpack t1)++-- | Most recent Nightly and newest LTS version per major release.+data Snapshots = Snapshots+ { snapshotsNightly :: !Day+ , snapshotsLts :: !(IntMap Int)+ }+ deriving Show+instance FromJSON Snapshots where+ parseJSON = withObject "Snapshots" $ \o -> Snapshots+ <$> (o .: "nightly" >>= parseNightly)+ <*> (fmap IntMap.unions+ $ mapM (parseLTS . snd)+ $ filter (isLTS . fst)+ $ HashMap.toList o)+ where+ parseNightly t =+ case parseSnapName t of+ Left e -> fail $ show e+ Right (LTS _ _) -> fail "Unexpected LTS value"+ Right (Nightly d) -> return d++ isLTS = ("lts-" `T.isPrefixOf`)++ parseLTS = withText "LTS" $ \t ->+ case parseSnapName t of+ Left e -> fail $ show e+ Right (LTS x y) -> return $ IntMap.singleton x y+ Right (Nightly _) -> fail "Unexpected nightly value" instance ToJSON a => ToJSON (Map ExeName a) where toJSON = toJSON . Map.mapKeysWith const unExeName
src/Stack/Types/Config.hs view
@@ -119,6 +119,7 @@ ,SetupInfoLocation(..) -- ** Docker entrypoint ,DockerEntrypoint(..)+ ,DockerUser(..) ) where import Control.Applicative@@ -169,7 +170,7 @@ import Stack.Types.PackageName import Stack.Types.TemplateName import Stack.Types.Version-import System.PosixCompat.Types (UserID, GroupID)+import System.PosixCompat.Types (UserID, GroupID, FileMode) import System.Process.Read (EnvOverride) #ifdef mingw32_HOST_OS import qualified Crypto.Hash.SHA1 as SHA1@@ -1075,6 +1076,8 @@ | UnexpectedTarballContents [Path Abs Dir] [Path Abs File] | BadStackVersionException VersionRange | NoMatchingSnapshot [SnapName]+ | ResolverMismatch Resolver Text+ | ResolverPartial Resolver Text | NoSuchDirectory FilePath | ParseGHCVariantException String deriving Typeable@@ -1084,7 +1087,7 @@ , toFilePath configFile , "':\n" , show exception- , "\nSee https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md."+ , "\nSee http://docs.haskellstack.org/en/stable/yaml_configuration.html." ] show (ParseResolverException t) = concat [ "Invalid resolver value: "@@ -1115,17 +1118,30 @@ , T.unpack (versionRangeText requiredRange) , ")." ] show (NoMatchingSnapshot names) = concat- [ "There was no snapshot found that matched the package "- , "bounds in your .cabal files.\n"- , "Please choose one of the following commands to get started.\n\n"- , unlines $ map- (\name -> " stack init --resolver " ++ T.unpack (renderSnapName name))- names- , "\nYou'll then need to add some extra-deps. See:\n\n"- , " https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md#extra-deps"- , "\n\nYou can also try falling back to a dependency solver with:\n\n"- , " stack init --solver"+ [ "None of the following snapshots provides a compiler matching "+ , "your package(s):\n"+ , unlines $ map (\name -> " - " <> T.unpack (renderSnapName name))+ names+ , "\nYou can try the following options:\n"+ , " - Exclude mismatching package(s) and build the rest.\n"+ , " - Use '--ignore-subdirs' to exclude subdirectories.\n"+ , " - Manually create a config, then use 'stack solver'\n"+ , " - Use '--resolver' to specify a matching snapshot/resolver\n"+ , " - Use a custom snapshot having the right compiler.\n" ]+ show (ResolverMismatch resolver errDesc) = concat+ [ "Selected resolver '"+ , T.unpack (resolverName resolver)+ , "' does not have a matching compiler to build your package(s).\n"+ , T.unpack errDesc+ ]+ show (ResolverPartial resolver errDesc) = concat+ [ "Selected resolver '"+ , T.unpack (resolverName resolver)+ , "' does not have all the packages to match your requirements.\n"+ , T.unpack $ T.unlines $ fmap (" " <>) (T.lines errDesc)+ , "\nHowever, you can try '--solver' to use external packages."+ ] show (NoSuchDirectory dir) = concat ["No directory could be located matching the supplied path: " ,dir@@ -1598,6 +1614,14 @@ -- | Data passed into Docker container for the Docker entrypoint's use data DockerEntrypoint = DockerEntrypoint- { deUidGid :: !(Maybe (UserID, GroupID))- -- ^ UID/GID of host user, if we wish to perform UID/GID switch in container+ { deUser :: !(Maybe DockerUser)+ -- ^ UID/GID/etc of host user, if we wish to perform UID/GID switch in container+ } deriving (Read,Show)++-- | Docker host user info+data DockerUser = DockerUser+ { duUid :: UserID -- ^ uid+ , duGid :: GroupID -- ^ gid+ , duGroups :: [GroupID] -- ^ Supplemantal groups+ , duUmask :: FileMode -- ^ File creation mask } } deriving (Read,Show)
+ src/Stack/Types/Config.hs-boot view
@@ -0,0 +1,5 @@+module Stack.Types.Config where++data AbstractResolver+data Resolver+data Config
src/Stack/Types/Image.hs view
@@ -1,20 +1,22 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-} module Stack.Types.Image where -import Control.Applicative import Data.Aeson.Extended import Data.Monoid import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe (maybeToList) import Data.Text (Text) import Prelude -- Fix redundant import warnings -- | Image options. Currently only Docker image options. data ImageOpts = ImageOpts- { imgDocker :: !(Maybe ImageDockerOpts)- -- ^ Maybe a section for docker image settings.+ { imgDockers :: ![ImageDockerOpts]+ -- ^ One or more stanzas for docker image settings. } deriving (Show) data ImageDockerOpts = ImageDockerOpts@@ -29,24 +31,21 @@ -- specific directory in all the images. , imgDockerImageName :: !(Maybe String) -- ^ Maybe have a name for the image we are creating+ , imgDockerExecutables :: !(Maybe [FilePath])+ -- ^ Filenames of executables to add (if Nothing, add them all) } 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)+ { imgMonoidDockers :: ![ImageDockerOpts] } deriving (Show) instance FromJSON (ImageOptsMonoid, [JSONWarning]) where parseJSON = withObjectWarnings "ImageOptsMonoid" (\o ->- do imgMonoidDocker <- jsonSubWarningsT (o ..:? imgDockerArgName)+ do (oldDocker :: Maybe ImageDockerOpts) <- jsonSubWarningsT (o ..:? imgDockerOldArgName)+ (dockers :: [ImageDockerOpts]) <- jsonSubWarningsT (o ..:? imgDockersArgName ..!= [])+ let imgMonoidDockers = dockers ++ maybeToList oldDocker return ImageOptsMonoid { ..@@ -54,47 +53,36 @@ instance Monoid ImageOptsMonoid where mempty = ImageOptsMonoid- { imgMonoidDocker = Nothing+ { imgMonoidDockers = [] } mappend l r = ImageOptsMonoid- { imgMonoidDocker = imgMonoidDocker l <|> imgMonoidDocker r+ { imgMonoidDockers = imgMonoidDockers l <> imgMonoidDockers r } -instance FromJSON (ImageDockerOptsMonoid, [JSONWarning]) where+instance FromJSON (ImageDockerOpts, [JSONWarning]) where parseJSON = withObjectWarnings- "ImageDockerOptsMonoid"+ "ImageDockerOpts" (\o ->- do imgDockerMonoidBase <- o ..:? imgDockerBaseArgName- imgDockerMonoidEntrypoints <- o ..:?- imgDockerEntrypointsArgName- imgDockerMonoidAdd <- o ..:? imgDockerAddArgName- imgDockerMonoidImageName <- o ..:? imgDockerImageNameArgName+ do imgDockerBase <- o ..:? imgDockerBaseArgName+ imgDockerEntrypoints <- o ..:? imgDockerEntrypointsArgName+ imgDockerAdd <- o ..:? imgDockerAddArgName ..!= Map.empty+ imgDockerImageName <- o ..:? imgDockerImageNameArgName+ imgDockerExecutables <- o ..:? imgDockerExecutablesArgName return- ImageDockerOptsMonoid+ ImageDockerOpts { .. }) -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"+-- Kept for backward compatibility+imgDockerOldArgName :: Text+imgDockerOldArgName = "container" +imgDockersArgName :: Text+imgDockersArgName = "containers"+ imgDockerBaseArgName :: Text imgDockerBaseArgName = "base" @@ -106,3 +94,6 @@ imgDockerImageNameArgName :: Text imgDockerImageNameArgName = "name"++imgDockerExecutablesArgName :: Text+imgDockerExecutablesArgName = "executables"
src/Stack/Types/Nix.hs view
@@ -10,10 +10,13 @@ import Data.Aeson.Extended import Data.Text (Text) import Data.Monoid- import Prelude+import Stack.Types.Compiler (CompilerVersion)+import {-# SOURCE #-} Stack.Types.Config (Resolver)+import Text.Show.Functions () --- | Nix configuration.+-- | Nix configuration. Parameterize by resolver type to avoid cyclic+-- dependency. data NixOpts = NixOpts {nixEnable :: !Bool ,nixPureShell :: !Bool@@ -23,6 +26,8 @@ -- ^ The path of a file containing preconfiguration of the environment (e.g shell.nix) ,nixShellOptions :: ![Text] -- ^ Options to be given to the nix-shell command line+ ,nixCompiler :: !(Maybe Resolver -> Maybe CompilerVersion -> Text)+ -- ^ Yield a compiler attribute name given a resolver override. } deriving (Show)
src/Stack/Types/Package.hs view
@@ -105,6 +105,7 @@ => SourceMap -> InstalledMap -> [PackageName]+ -> [PackageName] -> Path Abs File -> m (Map NamedComponent (Set ModuleName) ,Map NamedComponent (Set DotCabalPath)
src/Stack/Types/StackT.hs view
@@ -223,6 +223,7 @@ case mref of Nothing -> loggerFunc+ out loc src (case level of@@ -239,7 +240,7 @@ (maybe 0 T.length sticky) clear = liftIO- (S8.putStr+ (S8.hPutStr out (repeating backSpaceChar <> repeating ' ' <> repeating backSpaceChar))@@ -255,26 +256,27 @@ case level of LevelOther "sticky-done" -> do clear- liftIO (T.putStrLn msgText)+ liftIO (T.hPutStrLn out msgText) return Nothing LevelOther "sticky" -> do clear- liftIO (T.putStr msgText)+ liftIO (T.hPutStr out msgText) return (Just msgText) _ | level >= maxLogLevel -> do clear- loggerFunc loc src level $ toLogStr msgText+ loggerFunc out loc src level $ toLogStr msgText case sticky of Nothing -> return Nothing Just line -> do- liftIO (T.putStr line)+ liftIO (T.hPutStr out line) return sticky | otherwise -> return sticky liftIO (putMVar ref newState) where+ out = stderr msgTextRaw = T.decodeUtf8With T.lenientDecode msgBytes msgBytes = fromLogStr (toLogStr msg) @@ -286,14 +288,13 @@ -- | Logging function takes the log level into account. loggerFunc :: (MonadIO m,ToLogStr msg,MonadReader r m,HasLogLevel r)- => Loc -> Text -> LogLevel -> msg -> m ()-loggerFunc loc _src level msg =+ => Handle -> Loc -> Text -> LogLevel -> msg -> m ()+loggerFunc outputChannel loc _src level msg = do maxLogLevel <- asks getLogLevel when (level >= maxLogLevel) (liftIO (do out <- getOutput maxLogLevel T.hPutStrLn outputChannel out))- where outputChannel = stderr- getOutput maxLogLevel =+ where getOutput maxLogLevel = do timestamp <- getTimestamp l <- getLevel lc <- getLoc
src/Stack/Upgrade.hs view
@@ -56,7 +56,11 @@ return Nothing else do $logInfo "Cloning stack"- let args = [ "clone", repo , "stack", "--depth", "1"]+ -- NOTE: "--recursive" was added after v1.0.0 (and before the+ -- next release). This means that we can't use submodules in+ -- the stack repo until we're comfortable with "stack upgrade+ -- --git" not working for earlier versions.+ let args = [ "clone", repo , "stack", "--depth", "1", "--recursive"] runCmd (Cmd (Just tmp) "git" menv args) Nothing return $ Just $ tmp </> $(mkRelDir "stack") Nothing -> do
src/System/Process/Read.hs view
@@ -14,6 +14,7 @@ ,tryProcessStdout ,sinkProcessStdout ,sinkProcessStderrStdout+ ,sinkProcessStderrStdoutHandle ,readProcess ,EnvOverride(..) ,unEnvOverride@@ -34,9 +35,8 @@ ) where -import Control.Applicative import Control.Arrow ((***), first)-import Control.Concurrent.Async (Concurrently (..))+import Control.Concurrent.Async (concurrently) import Control.Exception hiding (try, catch) import Control.Monad (join, liftM, unless) import Control.Monad.Catch (MonadThrow, MonadCatch, throwM, try, catch)@@ -69,6 +69,7 @@ import System.Environment (getEnvironment) import System.Exit import qualified System.FilePath as FP+import System.IO (Handle) import System.Process.Log -- | Override the environment received by a child process.@@ -192,12 +193,13 @@ | ExecutableNotFoundAt FilePath deriving Typeable instance Show ReadProcessException where- show (ReadProcessException cp ec out err) = concat+ show (ReadProcessException cp ec out err) = concat $ [ "Running "- , showSpec $ cmdspec cp- , " exited with "+ , showSpec $ cmdspec cp] +++ maybe [] (\x -> [" in directory ", x]) (cwd cp) +++ [ " exited with " , show ec- , "\n"+ , "\n\n" , toStr out , "\n" , toStr err@@ -255,7 +257,7 @@ return sinkRet -- | Consume the stdout and stderr of a process feeding strict 'S.ByteString's to the consumers.-sinkProcessStderrStdout :: (MonadIO m, MonadLogger m)+sinkProcessStderrStdout :: forall m e o. (MonadIO m, MonadLogger m) => Maybe (Path Abs Dir) -- ^ Optional directory to run in -> EnvOverride -> String -- ^ Command@@ -266,16 +268,33 @@ sinkProcessStderrStdout wd menv name args sinkStderr sinkStdout = do $logProcessRun name args name' <- preProcess wd menv name- liftIO (withCheckedProcess- (proc name' args) { env = envHelper menv, cwd = fmap toFilePath wd }- (\ClosedStream out err ->- runConcurrently $- (,) <$>- Concurrently (asBSSource err $$ sinkStderr) <*>- Concurrently (asBSSource out $$ sinkStdout)))- where asBSSource :: Source m S.ByteString -> Source m S.ByteString- asBSSource = id+ liftIO $ withCheckedProcess+ (proc name' args) { env = envHelper menv, cwd = fmap toFilePath wd }+ (\ClosedStream out err -> f err out)+ where+ f :: Source IO S.ByteString -> Source IO S.ByteString -> IO (e, o)+ f err out = (err $$ sinkStderr) `concurrently` (out $$ sinkStdout) +sinkProcessStderrStdoutHandle :: (MonadIO m, MonadLogger m)+ => Maybe (Path Abs Dir) -- ^ Optional directory to run in+ -> EnvOverride+ -> String -- ^ Command+ -> [String] -- ^ Command line arguments+ -> Handle+ -> Handle+ -> m ()+sinkProcessStderrStdoutHandle wd menv name args err out = do+ $logProcessRun name args+ name' <- preProcess wd menv name+ liftIO $ withCheckedProcess+ (proc name' args)+ { env = envHelper menv+ , cwd = fmap toFilePath wd+ , std_err = UseHandle err+ , std_out = UseHandle out+ }+ (\ClosedStream UseProvidedHandle UseProvidedHandle -> return ())+ -- | Perform pre-call-process tasks. Ensure the working directory exists and find the -- executable path. preProcess :: (MonadIO m)@@ -307,13 +326,20 @@ -- -- Throws a 'ReadProcessException' if unsuccessful. findExecutable :: (MonadIO m, MonadThrow n) => EnvOverride -> String -> m (n (Path Abs File))-findExecutable _ name | any FP.isPathSeparator name = do- exists <- liftIO $ doesFileExist name- if exists- then do- path <- liftIO $ parseRelAsAbsFile name- return $ return path- else return $ throwM $ ExecutableNotFoundAt name+findExecutable eo name0 | any FP.isPathSeparator name0 = do+ let names0+ | null (eoExeExtension eo) = [name0]+ -- Support `stack exec foo/bar.exe` on Windows+ | otherwise = [name0 ++ eoExeExtension eo, name0]+ testNames [] = return $ throwM $ ExecutableNotFoundAt name0+ testNames (name:names) = do+ exists <- liftIO $ doesFileExist name+ if exists+ then do+ path <- liftIO $ parseRelAsAbsFile name+ return $ return path+ else testNames names+ testNames names0 findExecutable eo name = liftIO $ do m <- readIORef $ eoExeCache eo epath <- case Map.lookup name m of
src/main/Main.hs view
@@ -18,8 +18,6 @@ import Control.Monad.Logger import Control.Monad.Reader (ask, asks, runReaderT) import Control.Monad.Trans.Control (MonadBaseControl)-import Control.Monad.Trans.Either (EitherT)-import Control.Monad.Trans.Writer (Writer) import Data.Attoparsec.Args (parseArgs, EscapingMode (Escaping)) import Data.Attoparsec.Interpreter (getInterpreterArgs) import qualified Data.ByteString.Lazy as L@@ -181,9 +179,9 @@ (Just versionString') "stack - The Haskell Tool Stack" ""- (globalOpts False)+ (globalOpts OuterGlobalOpts) (Just failureCallback)- (addCommands (globalOpts True) isInterpreter)+ addCommands where failureCallback f args = case stripPrefix "Invalid argument" (fst (renderFailure f "")) of@@ -203,267 +201,262 @@ handleParseResult (overFailure (vcatErrorHelp hlp) (Failure f)) else handleParseResult (Failure f) - globalOpts hide =- extraHelpOption hide progName (Docker.dockerCmdName ++ "*") Docker.dockerHelpOptName <*>- extraHelpOption hide progName (Nix.nixCmdName ++ "*") Nix.nixHelpOptName <*>- globalOptsParser hide (if isInterpreter- then Just $ LevelOther "silent"- else Nothing)+ addCommands = do+ when (not isInterpreter) (do+ addCommand' "build"+ "Build the package(s) in this directory/configuration"+ buildCmd+ (buildOptsParser Build)+ addCommand' "install"+ "Shortcut for 'build --copy-bins'"+ buildCmd+ (buildOptsParser Install)+ addCommand' "uninstall"+ "DEPRECATED: This command performs no actions, and is present for documentation only"+ uninstallCmd+ (many $ strArgument $ metavar "IGNORED")+ addCommand' "test"+ "Shortcut for 'build --test'"+ buildCmd+ (buildOptsParser Test)+ addCommand' "bench"+ "Shortcut for 'build --bench'"+ buildCmd+ (buildOptsParser Bench)+ addCommand' "haddock"+ "Shortcut for 'build --haddock'"+ buildCmd+ (buildOptsParser Haddock)+ addCommand' "new"+ "Create a new project from a template. Run `stack templates' to see available templates."+ newCmd+ 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"+ globalFooter+ initCmd+ (globalOpts InitCmdGlobalOpts)+ initOptsParser+ addCommand' "solver"+ "Use a dependency solver to try and determine missing extra-deps"+ solverCmd+ solverOptsParser+ addCommand' "setup"+ "Get the appropriate GHC for your project"+ setupCmd+ setupParser+ addCommand' "path"+ "Print out handy path information"+ pathCmd+ (mapMaybeA+ (\(desc,name,_) ->+ flag Nothing+ (Just name)+ (long (T.unpack name) <>+ help desc))+ paths)+ addCommand' "unpack"+ "Unpack one or more packages locally"+ unpackCmd+ (some $ strArgument $ metavar "PACKAGE")+ addCommand' "update"+ "Update the package index"+ updateCmd+ (pure ())+ addCommand' "upgrade"+ "Upgrade to the latest stack (experimental)"+ upgradeCmd+ ((,) <$> switch+ ( long "git"+ <> help "Clone from Git instead of downloading from Hackage (more dangerous)" )+ <*> strOption+ ( long "git-repo"+ <> help "Clone from specified git repository"+ <> value "https://github.com/commercialhaskell/stack"+ <> showDefault ))+ addCommand' "upload"+ "Upload a package to Hackage"+ uploadCmd+ ((,,,)+ <$> many (strArgument $ metavar "TARBALL/DIR")+ <*> optional pvpBoundsOption+ <*> ignoreCheckSwitch+ <*> flag False True+ (long "sign" <>+ help "GPG sign & submit signature"))+ addCommand' "sdist"+ "Create source distribution tarballs"+ sdistCmd+ ((,,)+ <$> many (strArgument $ metavar "DIR")+ <*> optional pvpBoundsOption+ <*> ignoreCheckSwitch)+ addCommand' "dot"+ "Visualize your project's dependency graph using Graphviz dot"+ dotCmd+ dotOptsParser+ addCommand' "exec"+ "Execute a command"+ execCmd+ (execOptsParser Nothing)+ addCommand' "ghc"+ "Run ghc"+ execCmd+ (execOptsParser $ Just ExecGhc)+ addCommand' "ghci"+ "Run ghci in the context of package(s) (experimental)"+ ghciCmd+ ghciOptsParser+ addCommand' "repl"+ "Run ghci in the context of package(s) (experimental) (alias for 'ghci')"+ ghciCmd+ ghciOptsParser+ ) -globalFooter :: String-globalFooter = "Run 'stack --help' for global options that apply to all subcommands."+ -- These two are the only commands allowed in interpreter mode as well+ addCommand' "runghc"+ "Run runghc"+ execCmd+ (execOptsParser $ Just ExecRunGhc)+ addCommand' "runhaskell"+ "Run runghc (alias for 'runghc')"+ execCmd+ (execOptsParser $ Just ExecRunGhc) -addCommands- :: Monoid c- => Parser c- -> Bool- -> EitherT (GlobalOpts -> IO ())- (Writer (Mod CommandFields (GlobalOpts -> IO (), c)))- ()-addCommands globalOpts isInterpreter = do- when (not isInterpreter) (do- addCommand' "build"- "Build the package(s) in this directory/configuration"- buildCmd- (buildOptsParser Build)- addCommand' "install"- "Shortcut for 'build --copy-bins'"- buildCmd- (buildOptsParser Install)- addCommand' "uninstall"- "DEPRECATED: This command performs no actions, and is present for documentation only"- uninstallCmd- (many $ strArgument $ metavar "IGNORED")- addCommand' "test"- "Shortcut for 'build --test'"- buildCmd- (buildOptsParser Test)- addCommand' "bench"- "Shortcut for 'build --bench'"- buildCmd- (buildOptsParser Bench)- addCommand' "haddock"- "Shortcut for 'build --haddock'"- buildCmd- (buildOptsParser Haddock)- addCommand' "new"- "Create a new project from a template. Run `stack templates' to see available templates."- newCmd- 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- initOptsParser- addCommand' "solver"- "Use a dependency solver to try and determine missing extra-deps"- solverCmd- solverOptsParser- addCommand' "setup"- "Get the appropriate GHC for your project"- setupCmd- setupParser- addCommand' "path"- "Print out handy path information"- pathCmd- (mapMaybeA- (\(desc,name,_) ->- flag Nothing- (Just name)- (long (T.unpack name) <>- help desc))- paths)- addCommand' "unpack"- "Unpack one or more packages locally"- unpackCmd- (some $ strArgument $ metavar "PACKAGE")- addCommand' "update"- "Update the package index"- updateCmd- (pure ())- addCommand' "upgrade"- "Upgrade to the latest stack (experimental)"- upgradeCmd- ((,) <$> switch- ( long "git"- <> help "Clone from Git instead of downloading from Hackage (more dangerous)" )- <*> strOption- ( long "git-repo"- <> help "Clone from specified git repository"- <> value "https://github.com/commercialhaskell/stack"- <> showDefault ))- addCommand' "upload"- "Upload a package to Hackage"- uploadCmd- ((,,,)- <$> many (strArgument $ metavar "TARBALL/DIR")- <*> optional pvpBoundsOption- <*> ignoreCheckSwitch- <*> flag False True- (long "sign" <>- help "GPG sign & submit signature"))- addCommand' "sdist"- "Create source distribution tarballs"- sdistCmd- ((,,)- <$> many (strArgument $ metavar "DIR")- <*> optional pvpBoundsOption- <*> ignoreCheckSwitch)- addCommand' "dot"- "Visualize your project's dependency graph using Graphviz dot"- dotCmd- dotOptsParser- addCommand' "exec"- "Execute a command"- execCmd- (execOptsParser Nothing)- addCommand' "ghc"- "Run ghc"- execCmd- (execOptsParser $ Just ExecGhc)- addCommand' "ghci"- "Run ghci in the context of package(s) (experimental)"- ghciCmd- ghciOptsParser- addCommand' "repl"- "Run ghci in the context of package(s) (experimental) (alias for 'ghci')"- ghciCmd- ghciOptsParser- )+ when (not isInterpreter) (do+ addCommand' "eval"+ "Evaluate some haskell code inline. Shortcut for 'stack exec ghc -- -e CODE'"+ evalCmd+ (evalOptsParser "CODE")+ addCommand' "clean"+ "Clean the local packages"+ cleanCmd+ cleanOptsParser+ addCommand' "list-dependencies"+ "List the dependencies"+ listDependenciesCmd+ (textOption (long "separator" <>+ metavar "SEP" <>+ help ("Separator between package name " <>+ "and package version.") <>+ value " " <>+ showDefault))+ addCommand' "query"+ "Query general build information (experimental)"+ queryCmd+ (many $ strArgument $ metavar "SELECTOR...")+ addSubCommands'+ "ide"+ "IDE-specific commands"+ (do addCommand'+ "start"+ "Start the ide-backend service"+ ideCmd+ ((,) <$> many (textArgument+ (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 ())+ addCommand'+ "load-targets"+ "List all load targets for a package target"+ targetsCmd+ (textArgument+ (metavar "TARGET")))+ addSubCommands'+ Docker.dockerCmdName+ "Subcommands specific to Docker use"+ (do addCommand' Docker.dockerPullCmdName+ "Pull latest version of Docker image from registry"+ dockerPullCmd+ (pure ())+ addCommand' "reset"+ "Reset the Docker sandbox"+ dockerResetCmd+ (switch (long "keep-home" <>+ help "Do not delete sandbox's home directory"))+ addCommand' Docker.dockerCleanupCmdName+ "Clean up Docker images and containers"+ dockerCleanupCmd+ dockerCleanupOptsParser)+ addSubCommands'+ ConfigCmd.cfgCmdName+ "Subcommands specific to modifying stack.yaml files"+ (addCommand' ConfigCmd.cfgCmdSetName+ "Sets a field in the project's stack.yaml to value"+ cfgSetCmd+ configCmdSetParser)+ addSubCommands'+ Image.imgCmdName+ "Subcommands specific to imaging (EXPERIMENTAL)"+ (addCommand' Image.imgDockerCmdName+ "Build a Docker image for the project"+ imgDockerCmd+ (boolFlags True+ "build"+ "building the project before creating the container"+ idm))+ addSubCommands'+ "hpc"+ "Subcommands specific to Haskell Program Coverage"+ (addCommand' "report"+ "Generate HPC report a combined HPC report"+ hpcReportCmd+ hpcReportOptsParser)+ addSubCommands'+ Sig.sigCmdName+ "Subcommands specific to package signatures (EXPERIMENTAL)"+ (addSubCommands'+ Sig.sigSignCmdName+ "Sign a a single package or all your packages"+ (addCommand'+ Sig.sigSignSdistCmdName+ "Sign a single sdist package file"+ sigSignSdistCmd+ Sig.sigSignSdistOpts))+ )+ where+ ignoreCheckSwitch =+ switch (long "ignore-check"+ <> help "Do not check package for common mistakes") - -- These two are the only commands allowed in interpreter mode as well- addCommand' "runghc"- "Run runghc"- execCmd- (execOptsParser $ Just ExecRunGhc)- addCommand' "runhaskell"- "Run runghc (alias for 'runghc')"- execCmd- (execOptsParser $ Just ExecRunGhc)+ -- addCommand hiding global options+ addCommand' cmd title constr =+ addCommand cmd title globalFooter constr (globalOpts OtherCmdGlobalOpts) - when (not isInterpreter) (do- addCommand' "eval"- "Evaluate some haskell code inline. Shortcut for 'stack exec ghc -- -e CODE'"- evalCmd- (evalOptsParser "CODE")- addCommand' "clean"- "Clean the local packages"- cleanCmd- cleanOptsParser- addCommand' "list-dependencies"- "List the dependencies"- listDependenciesCmd- (textOption (long "separator" <>- metavar "SEP" <>- help ("Separator between package name " <>- "and package version.") <>- value " " <>- showDefault))- addCommand' "query"- "Query general build information (experimental)"- queryCmd- (many $ strArgument $ metavar "SELECTOR...")- addSubCommands'- "ide"- "IDE-specific commands"- (do addCommand'- "start"- "Start the ide-backend service"- ideCmd- ((,) <$> many (textArgument- (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 ())- addCommand'- "load-targets"- "List all load targets for a package target"- targetsCmd- (textArgument- (metavar "TARGET")))- addSubCommands'- Docker.dockerCmdName- "Subcommands specific to Docker use"- (do addCommand' Docker.dockerPullCmdName- "Pull latest version of Docker image from registry"- dockerPullCmd- (pure ())- addCommand' "reset"- "Reset the Docker sandbox"- dockerResetCmd- (switch (long "keep-home" <>- help "Do not delete sandbox's home directory"))- addCommand' Docker.dockerCleanupCmdName- "Clean up Docker images and containers"- dockerCleanupCmd- dockerCleanupOptsParser)- addSubCommands'- ConfigCmd.cfgCmdName- "Subcommands specific to modifying stack.yaml files"- (addCommand' ConfigCmd.cfgCmdSetName- "Sets a field in the project's stack.yaml to value"- cfgSetCmd- configCmdSetParser)- addSubCommands'- Image.imgCmdName- "Subcommands specific to imaging (EXPERIMENTAL)"- (addCommand' Image.imgDockerCmdName- "Build a Docker image for the project"- imgDockerCmd- (boolFlags True- "build"- "building the project before creating the container"- idm))- addSubCommands'- "hpc"- "Subcommands specific to Haskell Program Coverage"- (addCommand' "report"- "Generate HPC report a combined HPC report"- hpcReportCmd- hpcReportOptsParser)- addSubCommands'- Sig.sigCmdName- "Subcommands specific to package signatures (EXPERIMENTAL)"- (addSubCommands'- Sig.sigSignCmdName- "Sign a a single package or all your packages"- (addCommand'- Sig.sigSignSdistCmdName- "Sign a single sdist package file"- sigSignSdistCmd- Sig.sigSignSdistOpts))- )- where- ignoreCheckSwitch =- switch (long "ignore-check"- <> help "Do not check package for common mistakes")+ addSubCommands' cmd title =+ addSubCommands cmd title globalFooter (globalOpts OtherCmdGlobalOpts) - -- addCommand hiding global options- addCommand' cmd title constr =- addCommand cmd title globalFooter constr globalOpts - addSubCommands' cmd title =- addSubCommands cmd title globalFooter globalOpts+ globalOpts kind =+ extraHelpOption hide progName (Docker.dockerCmdName ++ "*") Docker.dockerHelpOptName <*>+ extraHelpOption hide progName (Nix.nixCmdName ++ "*") Nix.nixHelpOptName <*>+ globalOptsParser kind (if isInterpreter+ then Just $ LevelOther "silent"+ else Nothing)+ where hide = kind /= OuterGlobalOpts + globalFooter = "Run 'stack --help' for global options that apply to all subcommands."++-- | fall-through to external executables in `git` style if they exist+-- (i.e. `stack something` looks for `stack-something` before+-- failing with "Invalid argument `something'") secondaryCommandHandler :: [String] -> ParserFailure ParserHelp -> IO (ParserFailure ParserHelp)---- fall-through to external executables in `git` style if they exist--- (i.e. `stack something` looks for `stack-something` before--- failing with "Invalid argument `something'") secondaryCommandHandler args f = -- don't even try when the argument looks like a path if elem pathSeparator cmd@@ -705,7 +698,7 @@ (lcProjectRoot lc) Nothing (runStackTGlobal manager (lcConfig lc) go $- Nix.reexecWithOptionalShell (lcProjectRoot lc) $+ Nix.reexecWithOptionalShell (lcProjectRoot lc) globalResolver globalCompiler $ runStackLoggingTGlobal manager go $ do (wantedCompiler, compilerCheck, mstack) <- case scoCompilerVersion of@@ -871,7 +864,7 @@ (lcProjectRoot lc) mbefore (runStackTGlobal manager (lcConfig lc) go $- Nix.reexecWithOptionalShell (lcProjectRoot lc) (inner'' lk0))+ Nix.reexecWithOptionalShell (lcProjectRoot lc) globalResolver globalCompiler (inner'' lk0)) mafter (Just $ liftIO $ do lk' <- readIORef curLk@@ -889,8 +882,8 @@ hPutStrLn stderr "See: https://github.com/commercialhaskell/stack/issues/1015" error "-prof GHC option submitted" case boptsFileWatch opts of- FileWatchPoll -> fileWatchPoll inner- FileWatch -> fileWatch inner+ FileWatchPoll -> fileWatchPoll stderr inner+ FileWatch -> fileWatch stderr inner NoFileWatch -> inner $ const $ return () where inner setLocalFiles = withBuildConfigAndLock go $ \lk ->@@ -1014,6 +1007,8 @@ menv <- liftIO $ configEnvOverride config plainEnvSettings Nix.reexecWithOptionalShell (lcProjectRoot lc)+ globalResolver+ globalCompiler (runStackTGlobal manager (lcConfig lc) go $ exec menv cmd args)) Nothing@@ -1055,11 +1050,6 @@ 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 ()) lk defaultBuildOpts- { boptsTargets = map T.pack packageTargets- } munlockFile lk -- Don't hold the lock while in the GHCI. ghci ghciOpts @@ -1086,7 +1076,7 @@ targetsCmd target go@GlobalOpts{..} = withBuildConfig go $ do let bopts = defaultBuildOpts { boptsTargets = [target] }- (_realTargets,_,pkgs) <- ghciSetup bopts False False Nothing+ (_realTargets,_,pkgs) <- ghciSetup bopts False False Nothing [] pwd <- getWorkingDir targets <- fmap@@ -1178,23 +1168,30 @@ return lc return (manager,lc) --- | Project initialization-initCmd :: InitOpts -> GlobalOpts -> IO ()-initCmd initOpts go =- withConfigAndLock go $- do pwd <- getWorkingDir+withMiniConfigAndLock+ :: GlobalOpts+ -> StackT MiniConfig (StackT Config IO) ()+ -> IO ()+withMiniConfigAndLock go inner =+ withConfigAndLock go $ do config <- asks getConfig miniConfig <- loadMiniConfig config- runReaderT (initProject pwd initOpts) miniConfig+ manager <- asks getHttpManager+ runStackTGlobal manager miniConfig go inner +-- | Project initialization+initCmd :: InitOpts -> GlobalOpts -> IO ()+initCmd initOpts go = do+ pwd <- getWorkingDir+ withMiniConfigAndLock go (initProject pwd 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- config <- asks getConfig- miniConfig <- loadMiniConfig config- runReaderT (initProject dir initOpts) miniConfig+newCmd (newOpts,initOpts) go@GlobalOpts{..} = do+ withMiniConfigAndLock go $ do+ dir <- new newOpts+ initProject dir initOpts+ -- | List the available templates. templatesCmd :: () -> GlobalOpts -> IO ()
src/test/Stack/NixSpec.hs view
@@ -63,5 +63,5 @@ it "sees that the only package asked for is glpk and adds GHC from nixpkgs mirror of LTS resolver" $ \T{..} -> inTempDir $ do writeFile (toFilePath stackDotYaml) sampleConfig lc <- loadConfig' manager- (nixPackages $ configNix $ lcConfig lc) `shouldBe` ["glpk", "haskell.packages.lts-2_10.ghc"]-+ (nixPackages $ configNix $ lcConfig lc) `shouldBe` ["glpk"]+ (nixCompiler $ configNix $ lcConfig lc) Nothing Nothing `shouldBe` "haskell.packages.lts-2_10.ghc"
stack.cabal view
@@ -1,5 +1,5 @@ name: stack-version: 1.0.0+version: 1.0.2 cabal-version: >=1.10 build-type: Simple license: BSD3@@ -40,6 +40,12 @@ default: False manual: True +flag static+ description:+ Pass -static/-pthread to ghc when linking the stack binary.+ default: False+ manual: True+ library if os(windows)@@ -127,12 +133,12 @@ Cabal >=1.18.1.5 && <1.23, aeson >=0.8.0.2 && <0.11, ansi-terminal >=0.6.2.3 && <0.7,- async >=2.0.2 && <2.1,+ async >=2.0.2 && <2.2, attoparsec >=0.12.1.5 && <0.14, base >=4.7 && <5, base16-bytestring >=0.1.1.6 && <0.2, base64-bytestring >=1.0.0.1 && <1.1,- bifunctors >=4.2.1 && <5.2,+ bifunctors >=4.2.1 && <5.3, binary ==0.7.*, binary-tagged >=0.1.1 && <0.2, blaze-builder >=0.4.0.1 && <0.5,@@ -148,7 +154,7 @@ edit-distance ==0.2.*, either >=4.4.1 && <4.5, enclosed-exceptions >=1.0.1.1 && <1.1,- errors >=2.0.1 && <2.1,+ errors >=2.0.1 && <2.2, exceptions >=0.8.0.2 && <0.9, extra >=1.4.2 && <1.5, fast-logger >=2.3.1 && <2.5,@@ -167,7 +173,7 @@ monad-loops >=0.4.2.1 && <0.5, mtl >=2.1.3.1 && <2.3, old-locale >=1.0.0.6 && <1.1,- optparse-applicative >=0.11.0.2 && <0.13,+ optparse-applicative >=0.11 && <0.13, path >=0.5.1 && <0.6, persistent >=2.1.2 && <2.3, persistent-sqlite >=2.1.4 && <2.3,@@ -181,7 +187,7 @@ split >=0.2.2 && <0.3, stm >=2.4.4 && <2.5, streaming-commons >=0.1.10.0 && <0.2,- tar >=0.4.1.0 && <0.5,+ tar >=0.4.1.0 && <0.6, template-haskell >=2.9.0.0 && <2.11, temporary >=1.2.0.3 && <1.3, text >=1.2.0.4 && <1.3,@@ -201,7 +207,6 @@ word8 >=0.1.2 && <0.2, hastache >=0.6.1 && <0.7, project-template ==0.2.*,- email-validate >=2.0 && <2.2, uuid >=1.3.11 && <1.4 default-language: Haskell2010 hs-source-dirs: src/@@ -217,10 +222,13 @@ Data.IORef.RunOnce Data.Set.Monad Distribution.Version.Extra- ghc-options: -Wall+ ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates executable stack + if flag(static)+ ld-options: -static -pthread+ if os(windows) build-depends: Win32 >=2.3.1.0 && <2.4@@ -228,14 +236,14 @@ if !flag(disable-git-info) build-depends:- gitrev ==1.1.*,+ gitrev >=1.1 && <1.3, optparse-simple >=0.0.3 && <0.1 cpp-options: -DUSE_GIT_INFO main-is: Main.hs build-depends: base >=4.7 && <5, bytestring >=0.10.4.0 && <0.11,- Cabal >=1.22.4.0 && <1.23,+ Cabal >=1.22.6.0 && <1.23, containers >=0.5.5.1 && <0.6, exceptions >=0.8.0.2 && <0.9, filepath >=1.4.0.0 && <1.5,@@ -250,46 +258,46 @@ path >=0.5.3 && <0.6, process >=1.2.3.0 && <1.3, resourcet >=1.1.4.1 && <1.2,- stack >=1.0.0 && <1.1,+ stack >=1.0.2 && <1.1, text >=1.2.0.4 && <1.3, either >=4.4.1 && <4.5, directory >=1.2.2.0 && <1.3, split >=0.2.2 && <0.3, unordered-containers >=0.2.5.1 && <0.3, hashable >=1.2.3.3 && <1.3,- conduit >=1.2.5.1 && <1.3,+ conduit >=1.2.6.1 && <1.3, transformers >=0.4.2.0 && <0.5,- http-client >=0.4.24 && <0.5+ http-client >=0.4.26.2 && <0.5 default-language: Haskell2010 hs-source-dirs: src/main other-modules: Paths_stack- ghc-options: -Wall -threaded -rtsopts+ ghc-options: -threaded -rtsopts -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates test-suite stack-test type: exitcode-stdio-1.0 main-is: Test.hs build-depends: base >=4.7 && <5,- hspec >=2.1.10 && <2.3,- attoparsec >=0.12.1.6 && <0.14,+ hspec >=2.2.1 && <2.3,+ attoparsec >=0.13.0.1 && <0.14, containers >=0.5.5.1 && <0.6, directory >=1.2.2.0 && <1.3, exceptions >=0.8.0.2 && <0.9, filepath >=1.4.0.0 && <1.5, path >=0.5.3 && <0.6, temporary >=1.2.0.3 && <1.3,- stack >=1.0.0 && <1.1,- monad-logger >=0.3.15 && <0.4,+ stack >=1.0.2 && <1.1,+ monad-logger >=0.3.16 && <0.4, http-conduit >=2.1.8 && <2.2, cryptohash >=0.11.6 && <0.12, transformers >=0.4.2.0 && <0.5,- conduit >=1.2.5.1 && <1.3,- conduit-extra >=1.1.9.1 && <1.2,- resourcet >=1.1.6 && <1.2,- Cabal >=1.22.4.0 && <1.23,- text >=1.2.1.3 && <1.3,- optparse-applicative >=0.11.0.2 && <0.13,+ conduit >=1.2.6.1 && <1.3,+ conduit-extra >=1.1.9.2 && <1.2,+ resourcet >=1.1.7 && <1.2,+ Cabal >=1.22.6.0 && <1.23,+ text >=1.2.2.0 && <1.3,+ optparse-applicative >=0.11 && <0.13, bytestring >=0.10.6.0 && <0.11, QuickCheck >=2.8.1 && <2.9, retry >=0.6 && <0.8@@ -306,7 +314,7 @@ Stack.ArgsSpec Stack.NixSpec Network.HTTP.Download.VerifiedSpec- ghc-options: -Wall -threaded+ ghc-options: -threaded -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates test-suite stack-integration-test if !flag(integration-tests)@@ -316,21 +324,21 @@ build-depends: base >=4.7 && <5, temporary >=1.2.0.3 && <1.3,- hspec >=2.1.10 && <2.3,+ hspec >=2.2.1 && <2.3, process >=1.2.3.0 && <1.3, filepath >=1.4.0.0 && <1.5, directory >=1.2.2.0 && <1.3,- text >=1.2.1.3 && <1.3,+ text >=1.2.2.0 && <1.3, unix-compat >=0.4.1.4 && <0.5, containers >=0.5.5.1 && <0.6,- conduit >=1.2.5.1 && <1.3,- conduit-extra >=1.1.9.1 && <1.2,- resourcet >=1.1.6 && <1.2,- async >=2.0.2 && <2.1,+ conduit >=1.2.6.1 && <1.3,+ conduit-extra >=1.1.9.2 && <1.2,+ resourcet >=1.1.7 && <1.2,+ async >=2.0.2 && <2.2, transformers >=0.4.2.0 && <0.5, bytestring >=0.10.6.0 && <0.11 default-language: Haskell2010 hs-source-dirs: test/integration test/integration/lib other-modules: StackTest- ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N+ ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates
stack.yaml view
@@ -1,12 +1,14 @@-resolver: lts-3.16+resolver: lts-4.0 image:- container:- base: "fpco/ubuntu-with-libgmp:14.04"- entrypoints:- - stack-+ containers:+ - base: "fpco/ubuntu-with-libgmp:14.04"+ entrypoints:+ - stack nix: # --nix on the command-line to enable. enable: false packages:- - zlib+ - zlib+extra-deps:+# Should be removed once gitrev is updated in stackage (lts-5)+- gitrev-1.2.0
test/integration/lib/StackTest.hs view
@@ -121,3 +121,9 @@ -- | Is the OS Windows? isWindows = os == "mingw32"++-- | To avoid problems with GHC version mismatch when a new LTS major+-- version is released, pass this argument to @stack@ when running in+-- a global context. The LTS major version here should match that of+-- the main @stack.yaml@.+defaultResolverArg = "--resolver=lts-4"