diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -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. diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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: diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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 diff --git a/src/Network/HTTP/Download/Verified.hs b/src/Network/HTTP/Download/Verified.hs --- a/src/Network/HTTP/Download/Verified.hs +++ b/src/Network/HTTP/Download/Verified.hs @@ -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 diff --git a/src/Options/Applicative/Builder/Extra.hs b/src/Options/Applicative/Builder/Extra.hs --- a/src/Options/Applicative/Builder/Extra.hs +++ b/src/Options/Applicative/Builder/Extra.hs @@ -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). -- diff --git a/src/Stack/Build.hs b/src/Stack/Build.hs --- a/src/Stack/Build.hs +++ b/src/Stack/Build.hs @@ -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 diff --git a/src/Stack/Build/Cache.hs b/src/Stack/Build/Cache.hs --- a/src/Stack/Build/Cache.hs +++ b/src/Stack/Build/Cache.hs @@ -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 diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -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. diff --git a/src/Stack/BuildPlan.hs b/src/Stack/BuildPlan.hs --- a/src/Stack/BuildPlan.hs +++ b/src/Stack/BuildPlan.hs @@ -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 diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -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 diff --git a/src/Stack/Config/Nix.hs b/src/Stack/Config/Nix.hs --- a/src/Stack/Config/Nix.hs +++ b/src/Stack/Config/Nix.hs @@ -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 diff --git a/src/Stack/ConfigCmd.hs b/src/Stack/ConfigCmd.hs --- a/src/Stack/ConfigCmd.hs +++ b/src/Stack/ConfigCmd.hs @@ -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 diff --git a/src/Stack/Constants.hs b/src/Stack/Constants.hs --- a/src/Stack/Constants.hs +++ b/src/Stack/Constants.hs @@ -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 diff --git a/src/Stack/Coverage.hs b/src/Stack/Coverage.hs --- a/src/Stack/Coverage.hs +++ b/src/Stack/Coverage.hs @@ -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")))) diff --git a/src/Stack/Docker.hs b/src/Stack/Docker.hs --- a/src/Stack/Docker.hs +++ b/src/Stack/Docker.hs @@ -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 diff --git a/src/Stack/FileWatch.hs b/src/Stack/FileWatch.hs --- a/src/Stack/FileWatch.hs +++ b/src/Stack/FileWatch.hs @@ -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." diff --git a/src/Stack/Ghci.hs b/src/Stack/Ghci.hs --- a/src/Stack/Ghci.hs +++ b/src/Stack/Ghci.hs @@ -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 () diff --git a/src/Stack/Ide.hs b/src/Stack/Ide.hs --- a/src/Stack/Ide.hs +++ b/src/Stack/Ide.hs @@ -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 diff --git a/src/Stack/Image.hs b/src/Stack/Image.hs --- a/src/Stack/Image.hs +++ b/src/Stack/Image.hs @@ -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 = diff --git a/src/Stack/Init.hs b/src/Stack/Init.hs --- a/src/Stack/Init.hs +++ b/src/Stack/Init.hs @@ -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 diff --git a/src/Stack/Nix.hs b/src/Stack/Nix.hs --- a/src/Stack/Nix.hs +++ b/src/Stack/Nix.hs @@ -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 {});" ,"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) diff --git a/src/Stack/Options.hs b/src/Stack/Options.hs --- a/src/Stack/Options.hs +++ b/src/Stack/Options.hs @@ -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. diff --git a/src/Stack/Package.hs b/src/Stack/Package.hs --- a/src/Stack/Package.hs +++ b/src/Stack/Package.hs @@ -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 diff --git a/src/Stack/PackageIndex.hs b/src/Stack/PackageIndex.hs --- a/src/Stack/PackageIndex.hs +++ b/src/Stack/PackageIndex.hs @@ -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) diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs --- a/src/Stack/Setup.hs +++ b/src/Stack/Setup.hs @@ -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 diff --git a/src/Stack/Setup/Installed.hs b/src/Stack/Setup/Installed.hs --- a/src/Stack/Setup/Installed.hs +++ b/src/Stack/Setup/Installed.hs @@ -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 diff --git a/src/Stack/Solver.hs b/src/Stack/Solver.hs --- a/src/Stack/Solver.hs +++ b/src/Stack/Solver.hs @@ -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" + ] diff --git a/src/Stack/Types/Build.hs b/src/Stack/Types/Build.hs --- a/src/Stack/Types/Build.hs +++ b/src/Stack/Types/Build.hs @@ -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 " ++ diff --git a/src/Stack/Types/BuildPlan.hs b/src/Stack/Types/BuildPlan.hs --- a/src/Stack/Types/BuildPlan.hs +++ b/src/Stack/Types/BuildPlan.hs @@ -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 diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -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) diff --git a/src/Stack/Types/Config.hs-boot b/src/Stack/Types/Config.hs-boot new file mode 100644 --- /dev/null +++ b/src/Stack/Types/Config.hs-boot @@ -0,0 +1,5 @@ +module Stack.Types.Config where + +data AbstractResolver +data Resolver +data Config diff --git a/src/Stack/Types/Image.hs b/src/Stack/Types/Image.hs --- a/src/Stack/Types/Image.hs +++ b/src/Stack/Types/Image.hs @@ -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" diff --git a/src/Stack/Types/Nix.hs b/src/Stack/Types/Nix.hs --- a/src/Stack/Types/Nix.hs +++ b/src/Stack/Types/Nix.hs @@ -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) diff --git a/src/Stack/Types/Package.hs b/src/Stack/Types/Package.hs --- a/src/Stack/Types/Package.hs +++ b/src/Stack/Types/Package.hs @@ -105,6 +105,7 @@ => SourceMap -> InstalledMap -> [PackageName] + -> [PackageName] -> Path Abs File -> m (Map NamedComponent (Set ModuleName) ,Map NamedComponent (Set DotCabalPath) diff --git a/src/Stack/Types/StackT.hs b/src/Stack/Types/StackT.hs --- a/src/Stack/Types/StackT.hs +++ b/src/Stack/Types/StackT.hs @@ -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 diff --git a/src/Stack/Upgrade.hs b/src/Stack/Upgrade.hs --- a/src/Stack/Upgrade.hs +++ b/src/Stack/Upgrade.hs @@ -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 diff --git a/src/System/Process/Read.hs b/src/System/Process/Read.hs --- a/src/System/Process/Read.hs +++ b/src/System/Process/Read.hs @@ -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 diff --git a/src/main/Main.hs b/src/main/Main.hs --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -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 () diff --git a/src/test/Stack/NixSpec.hs b/src/test/Stack/NixSpec.hs --- a/src/test/Stack/NixSpec.hs +++ b/src/test/Stack/NixSpec.hs @@ -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" diff --git a/stack.cabal b/stack.cabal --- a/stack.cabal +++ b/stack.cabal @@ -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 diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -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 diff --git a/test/integration/lib/StackTest.hs b/test/integration/lib/StackTest.hs --- a/test/integration/lib/StackTest.hs +++ b/test/integration/lib/StackTest.hs @@ -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"