diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,39 @@ +## 0.1.4.0 + +Major changes: + +* You now have more control over how GHC versions are matched, e.g. "use exactly this version," "use the specified minor version, but allow patches," or "use the given minor version or any later minor in the given major release." The default has switched from allowing newer later minor versions to a specific minor version allowing patches. For more information, see [#736](https://github.com/commercialhaskell/stack/issues/736) and [#784](https://github.com/commercialhaskell/stack/pull/784). +* Support added for compiling with GHCJS +* stack can now reuse prebuilt binaries between snapshots. That means that, if you build package foo in LTS-3.1, that binary version can be reused in LTS-3.2, assuming it uses the same dependencies and flags. [#878](https://github.com/commercialhaskell/stack/issues/878) + +Other enhancements: + +* Added the `--docker-env` argument, to set environment variables in Docker container. +* Set locale environment variables to UTF-8 encoding for builds to avoid "commitBuffer: invalid argument" errors from GHC [#793](https://github.com/commercialhaskell/stack/issues/793) +* Enable translitation for encoding on stdout and stderr [#824](https://github.com/commercialhaskell/stack/issues/824) +* By default, `stack upgrade` automatically installs GHC as necessary [#797](https://github.com/commercialhaskell/stack/issues/797) +* Added the `ghc-options` field to stack.yaml [#796](https://github.com/commercialhaskell/stack/issues/796) +* Added the `extra-path` field to stack.yaml +* Code page changes on Windows only apply to the build command (and its synonyms), and can be controlled via a command line flag (still defaults to on) [#757](https://github.com/commercialhaskell/stack/issues/757) +* Implicitly add packages to extra-deps when a flag for them is set [#807](https://github.com/commercialhaskell/stack/issues/807) +* Use a precompiled Setup.hs for simple build types [#801](https://github.com/commercialhaskell/stack/issues/801) +* Set --enable-tests and --enable-benchmarks optimistically [#805](https://github.com/commercialhaskell/stack/issues/805) +* `--only-configure` option added [#820](https://github.com/commercialhaskell/stack/issues/820) +* Check for duplicate local package names +* Stop nagging people that call `stack test` [#845](https://github.com/commercialhaskell/stack/issues/845) +* `--file-watch` will ignore files that are in your VCS boring/ignore files [#703](https://github.com/commercialhaskell/stack/issues/703) +* Add `--numeric-version` option + +Bug fixes: + +* `stack init --solver` fails if `GHC_PACKAGE_PATH` is present [#860](https://github.com/commercialhaskell/stack/issues/860) +* `stack solver` and `stack init --solver` check for test suite and benchmark dependencies [#862](https://github.com/commercialhaskell/stack/issues/862) +* More intelligent logic for setting UTF-8 locale environment variables [#856](https://github.com/commercialhaskell/stack/issues/856) +* Create missing directories for `stack sdist` +* Don't ignore .cabal files with extra periods [#895](https://github.com/commercialhaskell/stack/issues/895) +* Deprecate unused `--optimizations` flag +* Truncated output on slow terminals [#413](https://github.com/commercialhaskell/stack/issues/413) + ## 0.1.3.1 Bug fixes: @@ -51,7 +87,7 @@ * Fix: stack fails on Windows with git package in stack.yaml and no git binary on path [#712](https://github.com/commercialhaskell/stack/issues/712) * Fixed GHCi issue: Specifying explicit package versions (#678) * Fixed GHCi issue: Specifying -odir and -hidir as .stack-work/odir (#529) -* Fixed GHCi issue: Specifying A instead of A.ext for modules (#498) +* Fixed GHCi issue: Specifying A instead of A.ext for modules (#498) ## 0.1.2.0 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -10,7 +10,7 @@ It features: -* Installing GHC automatically. +* Installing GHC automatically, in an isolated location. * Installing packages needed for your project. * Building your project. * Testing your project. @@ -24,11 +24,15 @@ * [OS X](https://github.com/commercialhaskell/stack/wiki/Downloads#os-x) * [Ubuntu](https://github.com/commercialhaskell/stack/wiki/Downloads#ubuntu) * [Debian](https://github.com/commercialhaskell/stack/wiki/Downloads#debian) -* [CentOS / Red Hat / Amazon Linux](https://github.com/commercialhaskell/stack/wiki/Downloads#centos--red-hat) +* [CentOS / Red Hat / Amazon Linux](https://github.com/commercialhaskell/stack/wiki/Downloads#centos--red-hat--amazon-linux) * [Fedora](https://github.com/commercialhaskell/stack/wiki/Downloads#fedora) * [Arch Linux](https://github.com/commercialhaskell/stack/wiki/Downloads#arch-linux) * [Linux (general)](https://github.com/commercialhaskell/stack/wiki/Downloads#linux) +[Upgrade instructions](https://github.com/commercialhaskell/stack/wiki/Downloads#upgrade) + +Note: if you are using cabal-install to install stack, you may need to pass a constraint to work around a [Cabal issue](https://github.com/haskell/cabal/issues/2759): `cabal install --constraint 'mono-traversable >= 0.9' stack`. + #### How to use Go into a Haskell project directory and run `stack build`. If everything is @@ -44,18 +48,20 @@ * `stack init` to create a stack configuration file for an existing project. stack will figure out what Stackage release (LTS or nightly) is appropriate for the dependencies. -* `stack setup` to download and install the correct GHC version. (For +* `stack setup` to download and install the correct GHC version in an isolated + location that won't interfere with any system-level installations. (For information on installation paths, please use the `stack path` command.) -If you just want to install a package using stack, then all you have +If you just want to install an executable using stack, then all you have to do is `stack install `. Run `stack` for a complete list of commands. -#### Architecture +#### Complete guide to stack -A full description of the architecture -[is available here](https://github.com/commercialhaskell/stack/wiki/Architecture). +This repository also contains [a complete guide to using +stack](https://github.com/commercialhaskell/stack/blob/master/GUIDE.md), +covering all of the most common use cases. #### Questions, Feedback, Discussion diff --git a/src/Data/Aeson/Extended.hs b/src/Data/Aeson/Extended.hs --- a/src/Data/Aeson/Extended.hs +++ b/src/Data/Aeson/Extended.hs @@ -26,13 +26,14 @@ import qualified Data.Aeson as A import Data.Aeson.Types hiding ((.:), (.:?)) import qualified Data.HashMap.Strict as HashMap -import Data.Monoid (Monoid (..), (<>)) +import Data.Monoid import Data.Set (Set) import qualified Data.Set as Set import Data.Text (unpack, Text) import qualified Data.Text as T -import Data.Traversable (Traversable) +import Data.Traversable import qualified Data.Traversable as Traversable +import Prelude -- Fix redundant import warnings -- | Extends @.:@ warning to include field name. (.:) :: FromJSON a => Object -> Text -> Parser a diff --git a/src/Data/Binary/VersionTagged.hs b/src/Data/Binary/VersionTagged.hs --- a/src/Data/Binary/VersionTagged.hs +++ b/src/Data/Binary/VersionTagged.hs @@ -2,6 +2,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} -- | Tag a Binary instance with the stack version number to ensure we're -- reading a compatible format. module Data.Binary.VersionTagged @@ -19,6 +20,7 @@ import Control.Exception (Exception) import Control.Monad.Catch (MonadThrow (..)) import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Logger import Data.Binary (Binary (..), encodeFile, decodeFileOrFail, putWord8, getWord8) import Data.Binary.Get (ByteOffset) import Data.Typeable (Typeable) @@ -29,6 +31,7 @@ import Data.ByteString (ByteString) import Control.Monad (forM_, when) import Data.Proxy +import qualified Data.Text as T magic :: ByteString magic = "stack" @@ -66,18 +69,22 @@ -- | Read from the given file. If the read fails, run the given action and -- write that back to the file. Always starts the file off with the version -- tag. -taggedDecodeOrLoad :: (BinarySchema a, MonadIO m) +taggedDecodeOrLoad :: (BinarySchema a, MonadIO m, MonadLogger m) => FilePath -> m a -> m a taggedDecodeOrLoad fp mx = do + $logDebug $ T.pack $ "Trying to decode " ++ fp eres <- decodeFileOrFailDeep fp case eres of Left _ -> do + $logDebug $ T.pack $ "Failure decoding " ++ fp x <- mx taggedEncodeFile fp x return x - Right (WithTag x) -> return x + Right (WithTag x) -> do + $logDebug $ T.pack $ "Success decoding " ++ fp + return x -- | Ensure that there are no lurking exceptions deep inside the parsed -- value... because that happens unfortunately. See diff --git a/src/Data/IORef/RunOnce.hs b/src/Data/IORef/RunOnce.hs new file mode 100644 --- /dev/null +++ b/src/Data/IORef/RunOnce.hs @@ -0,0 +1,16 @@ +module Data.IORef.RunOnce (runOnce) where + +import Control.Monad.IO.Class +import Data.IORef + +runOnce :: MonadIO m => m a -> m (m a) +runOnce f = do + ref <- liftIO $ newIORef Nothing + return $ do + mval <- liftIO $ readIORef ref + case mval of + Just val -> return val + Nothing -> do + val <- f + liftIO $ writeIORef ref (Just val) + return val 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 @@ -40,6 +40,7 @@ import Data.Monoid import Data.String import Data.Typeable (Typeable) +import GHC.IO.Exception (IOException(..),IOErrorType(..)) import Network.HTTP.Client.Conduit import Network.HTTP.Types.Header (hContentLength, hContentMD5) import Path @@ -200,13 +201,22 @@ liftIO $ whenM' getShouldDownload $ do createDirectoryIfMissing True dir withBinaryFile fptmp WriteMode $ \h -> do - recovering drRetryPolicy [const $ Handler alwaysRetryHttp] $ + recovering drRetryPolicy handlers $ flip runReaderT env $ withResponse req (go h) renameFile fptmp fp where + handlers = [const $ Handler alwaysRetryHttp,const $ Handler retrySomeIO] + alwaysRetryHttp :: Monad m => HttpException -> m Bool alwaysRetryHttp _ = return True + + retrySomeIO :: Monad m => IOException -> m Bool + retrySomeIO e = return $ case ioe_type e of + -- hGetBuf: resource vanished (Connection reset by peer) + ResourceVanished -> True + -- conservatively exclude all others + _ -> False whenM' mp m = do p <- mp 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 @@ -7,20 +7,25 @@ ,enableDisableFlags ,enableDisableFlagsNoDefault ,extraHelpOption - ,execExtraHelp) + ,execExtraHelp + ,textOption + ,textArgument) where import Control.Monad (when) import Options.Applicative +import Options.Applicative.Types (readerAsk) import System.Environment (withArgs) import System.FilePath (takeBaseName) +import Data.Text (Text) +import qualified Data.Text as T -- | Enable/disable flags for a @Bool@. boolFlags :: Bool -> String -> String -> Mod FlagFields Bool -> Parser Bool boolFlags defaultValue = enableDisableFlags defaultValue True False -- | Enable/disable flags for a @Bool@, without a default case (to allow chaining @<|>@s). -boolFlagsNoDefault :: String -> String -> Mod FlagFields Bool -> Parser Bool +boolFlagsNoDefault :: (Maybe Bool) -> String -> String -> Mod FlagFields Bool -> Parser Bool boolFlagsNoDefault = enableDisableFlagsNoDefault True False -- | Enable/disable flags for a @(Maybe Bool)@. @@ -28,36 +33,48 @@ maybeBoolFlags = enableDisableFlags Nothing (Just True) (Just False) -- | Enable/disable flags for any type. -enableDisableFlags :: a -> a -> a -> String -> String -> Mod FlagFields a -> Parser a +enableDisableFlags :: (Eq a) => a -> a -> a -> String -> String -> Mod FlagFields a -> Parser a enableDisableFlags defaultValue enabledValue disabledValue name helpSuffix mods = - enableDisableFlagsNoDefault enabledValue disabledValue name helpSuffix mods <|> + enableDisableFlagsNoDefault enabledValue disabledValue (Just defaultValue) name helpSuffix mods <|> pure defaultValue -- | Enable/disable flags for any type, without a default (to allow chaining @<|>@s) -enableDisableFlagsNoDefault :: a -> a -> String -> String -> Mod FlagFields a -> Parser a -enableDisableFlagsNoDefault enabledValue disabledValue name helpSuffix mods = - last <$> some (enableDisableFlagsNoDefault' enabledValue disabledValue name helpSuffix mods) +enableDisableFlagsNoDefault :: (Eq a) => a -> a -> (Maybe a) -> String -> String -> Mod FlagFields a -> Parser a +enableDisableFlagsNoDefault enabledValue disabledValue maybeHideValue name helpSuffix mods = + last <$> some (enableDisableFlagsNoDefault' enabledValue disabledValue maybeHideValue name helpSuffix mods) -enableDisableFlagsNoDefault' :: a -> a -> String -> String -> Mod FlagFields a -> Parser a -enableDisableFlagsNoDefault' enabledValue disabledValue name helpSuffix mods = - flag' enabledValue - (long name <> - help ("Enable " ++ helpSuffix) <> - mods) <|> - flag' enabledValue - (internal <> - long ("enable-" ++ name) <> - help ("Enable " ++ helpSuffix) <> - mods) <|> - flag' disabledValue - (long ("no-" ++ name) <> - help ("Disable " ++ helpSuffix) <> - mods) <|> - flag' disabledValue - (internal <> - long ("disable-" ++ name) <> - help ("Disable " ++ 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' + enabledValue + ((if hideEnabled + then hidden <> internal + else idm) <> + long name <> + help + (concat $ concat + [ ["Enable ", helpSuffix] + , [" (--no-" ++ name ++ " to disable)" | hideDisabled]]) <> + mods) <|> + flag' + enabledValue + (hidden <> internal <> long ("enable-" ++ name) <> mods) <|> + flag' + disabledValue + ((if hideDisabled + then hidden <> internal + else idm) <> + long ("no-" ++ name) <> + help + (concat $ concat + [ ["Disable ", helpSuffix] + , [" (--no-" ++ name ++ " to enable)" | hideEnabled]]) <> + mods) <|> + flag' + disabledValue + (hidden <> internal <> long ("disable-" ++ name) <> mods) -- | Show an extra help option (e.g. @--docker-help@ shows help for all @--docker*@ args). -- To actually show have that help appear, use 'execExtraHelp' before executing the main parser. @@ -71,7 +88,7 @@ -- Since optparse-applicative doesn't allow an arbirary IO action for an 'abortOption', this -- was the best way I found that doesn't require manually formatting the help. execExtraHelp :: [String] -> String -> Parser a -> String -> IO () -execExtraHelp args helpOpt parser pd = do +execExtraHelp args helpOpt parser pd = when (args == ["--" ++ helpOpt]) $ withArgs ["--help"] $ do _ <- execParser (info (hiddenHelper <*> @@ -81,3 +98,9 @@ (fullDesc <> progDesc pd)) return () where hiddenHelper = abortOption ShowHelpText (long "help" <> hidden <> internal) + +textOption :: Mod OptionFields Text -> Parser Text +textOption = option (T.pack <$> readerAsk) + +textArgument :: Mod ArgumentFields Text -> Parser Text +textArgument = argument (T.pack <$> readerAsk) diff --git a/src/Path/IO.hs b/src/Path/IO.hs --- a/src/Path/IO.hs +++ b/src/Path/IO.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ViewPatterns #-} -- | IO actions that might be put in a package at some point. @@ -30,7 +31,9 @@ ,copyFileIfExists ,copyDirectoryRecursive ,createTree - ,dropRoot) + ,dropRoot + ,parseCollapsedAbsFile + ,parseCollapsedAbsDir) where import Control.Exception hiding (catch) @@ -122,6 +125,44 @@ resolveFileMaybe :: (MonadIO m,MonadThrow m) => Path Abs Dir -> FilePath -> m (Maybe (Path Abs File)) resolveFileMaybe = resolveCheckParse D.doesFileExist parseAbsFile + +-- | Collapse intermediate "." and ".." directories from path, then parse +-- it with 'parseAbsFile'. +-- (probably should be moved to the Path module) +parseCollapsedAbsFile :: MonadThrow m => FilePath -> m (Path Abs File) +parseCollapsedAbsFile = parseAbsFile . collapseFilePath + +-- | Collapse intermediate "." and ".." directories from path, then parse +-- it with 'parseAbsDir'. +-- (probably should be moved to the Path module) +parseCollapsedAbsDir :: MonadThrow m => FilePath -> m (Path Abs Dir) +parseCollapsedAbsDir = parseAbsDir . collapseFilePath + +-- | Collapse intermediate "." and ".." directories from a path. +-- +-- > collapseFilePath "./foo" == "foo" +-- > collapseFilePath "/bar/../baz" == "/baz" +-- > collapseFilePath "/../baz" == "/../baz" +-- > collapseFilePath "parent/foo/baz/../bar" == "parent/foo/bar" +-- > collapseFilePath "parent/foo/baz/../../bar" == "parent/bar" +-- > collapseFilePath "parent/foo/.." == "parent" +-- > collapseFilePath "/parent/foo/../../bar" == "/bar" +-- +-- (borrowed from @Text.Pandoc.Shared@) +collapseFilePath :: FilePath -> FilePath +collapseFilePath = FP.joinPath . reverse . foldl go [] . FP.splitDirectories + where + go rs "." = rs + go r@(p:rs) ".." = case p of + ".." -> ("..":r) + (checkPathSeperator -> Just True) -> ("..":r) + _ -> rs + go _ (checkPathSeperator -> Just True) = [[FP.pathSeparator]] + go rs x = x:rs + isSingleton [] = Nothing + isSingleton [x] = Just x + isSingleton _ = Nothing + checkPathSeperator = fmap FP.isPathSeparator . isSingleton -- | List objects in a directory, excluding "@.@" and "@..@". Entries are not sorted. listDirectory :: (MonadIO m,MonadThrow m) => Path Abs Dir -> m ([Path Abs Dir],[Path Abs File]) diff --git a/src/Stack/Build.hs b/src/Stack/Build.hs --- a/src/Stack/Build.hs +++ b/src/Stack/Build.hs @@ -39,7 +39,7 @@ import Stack.Build.Haddock import Stack.Build.Installed import Stack.Build.Source -import Stack.Types.Build +import Stack.Build.Target import Stack.Constants import Stack.Fetch as Fetch import Stack.GhcPkg @@ -63,7 +63,7 @@ build setLocalFiles mbuildLk bopts = do menv <- getMinimalEnvOverride - (mbp, locals, extraToBuild, sourceMap) <- loadSourceMap bopts + (_, mbp, locals, extraToBuild, sourceMap) <- loadSourceMap NeedTargets bopts -- Set local files, necessary for file watching stackYaml <- asks $ bcStackYaml . getBuildConfig @@ -98,7 +98,7 @@ if boptsDryrun bopts then printPlan plan - else executePlan menv bopts baseConfigOpts locals sourceMap plan + else executePlan menv bopts baseConfigOpts locals sourceMap installedMap plan where profiling = boptsLibProfile bopts || boptsExeProfile bopts @@ -150,7 +150,7 @@ { packageConfigEnableTests = False , packageConfigEnableBenchmarks = False , packageConfigFlags = flags - , packageConfigGhcVersion = envConfigGhcVersion econfig + , packageConfigCompilerVersion = envConfigCompilerVersion econfig , packageConfigPlatform = configPlatform (getConfig econfig) } 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 @@ -26,6 +26,8 @@ , setBenchBuilt , unsetBenchBuilt , checkBenchBuilt + , writePrecompiledCache + , readPrecompiledCache ) where import Control.Exception.Enclosed (handleIO) @@ -33,9 +35,17 @@ import Control.Monad.IO.Class import Control.Monad.Logger (MonadLogger) import Control.Monad.Reader +import qualified Crypto.Hash.SHA256 as SHA256 +import qualified Data.Binary as Binary import Data.Binary.VersionTagged +import qualified Data.ByteString.Char8 as S8 +import qualified Data.ByteString.Base16 as B16 import Data.Map (Map) import Data.Maybe (fromMaybe, mapMaybe) +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Text (Text) +import qualified Data.Text as T import GHC.Generics (Generic) import Path import Path.IO @@ -271,3 +281,71 @@ liftM (fromMaybe False) (tryGetCache benchBuiltFile dir) + +-------------------------------------- +-- Precompiled Cache +-- +-- Idea is simple: cache information about packages built in other snapshots, +-- and then for identical matches (same flags, config options, dependencies) +-- just copy over the executables and reregister the libraries. +-------------------------------------- + +-- | The file containing information on the given package/configuration +-- combination. The filename contains a hash of the non-directory configure +-- options for quick lookup if there's a match. +precompiledCacheFile :: (MonadThrow m, MonadReader env m, HasEnvConfig env) + => PackageIdentifier + -> ConfigureOpts + -> m (Path Abs File) +precompiledCacheFile pkgident copts = do + ec <- asks getEnvConfig + + compiler <- parseRelDir $ T.unpack $ compilerVersionName $ envConfigCompilerVersion ec + cabal <- parseRelDir $ versionString $ envConfigCabalVersion ec + pkg <- parseRelDir $ packageIdentifierString pkgident + + -- We only pay attention to non-directory options. We don't want to avoid a + -- cache hit just because it was installed in a different directory. + copts' <- parseRelFile $ S8.unpack $ B16.encode $ SHA256.hashlazy $ Binary.encode $ coNoDirs copts + + return $ getStackRoot ec + $(mkRelDir "precompiled") + compiler + cabal + pkg + copts' + +-- | Write out information about a newly built package +writePrecompiledCache :: (MonadThrow m, MonadReader env m, HasEnvConfig env, MonadIO m) + => BaseConfigOpts + -> PackageIdentifier + -> ConfigureOpts + -> Maybe GhcPkgId -- ^ library + -> Set Text -- ^ executables + -> m () +writePrecompiledCache baseConfigOpts pkgident copts mghcPkgId exes = do + file <- precompiledCacheFile pkgident copts + createTree $ parent file + mlibpath <- + case mghcPkgId of + Nothing -> return Nothing + Just ipid -> liftM Just $ do + ipid' <- parseRelFile $ ghcPkgIdString ipid ++ ".conf" + return $ toFilePath $ bcoSnapDB baseConfigOpts ipid' + exes' <- forM (Set.toList exes) $ \exe -> do + name <- parseRelFile $ T.unpack exe + return $ toFilePath $ bcoSnapInstallRoot baseConfigOpts bindirSuffix name + liftIO $ encodeFile (toFilePath file) PrecompiledCache + { pcLibrary = mlibpath + , pcExes = exes' + } + +-- | Check the cache for a precompiled package matching the given +-- configuration. +readPrecompiledCache :: (MonadThrow m, MonadReader env m, HasEnvConfig env, MonadIO m) + => PackageIdentifier -- ^ target package + -> ConfigureOpts + -> m (Maybe PrecompiledCache) +readPrecompiledCache pkgident copts = do + file <- precompiledCacheFile pkgident copts + decodeFileOrFailDeep $ toFilePath file diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs --- a/src/Stack/Build/ConstructPlan.hs +++ b/src/Stack/Build/ConstructPlan.hs @@ -28,7 +28,7 @@ import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as T -import Data.Text.Encoding (encodeUtf8, decodeUtf8With) +import Data.Text.Encoding (decodeUtf8With) import Data.Text.Encoding.Error (lenientDecode) import Distribution.Package (Dependency (..)) import Distribution.Version (anyVersion) @@ -132,20 +132,13 @@ econfig <- asks getEnvConfig let onWanted lp = do - {- - - Arguably this is the right thing to do. However, forcing the - - library to rebuild causes the cabal_macros.h file to change, - - which makes GHC rebuild everything... - case lpExeComponents lp of Nothing -> return () - Just _ -> void $ addDep $ packageName $ lpPackage lp - -} + Just _ -> void $ addDep False $ packageName $ lpPackage lp case lpTestBench lp of Just tb -> addFinal lp tb - -- See comment above - Nothing -> void $ addDep False $ packageName $ lpPackage lp + Nothing -> return () let inner = do mapM_ onWanted $ filter lpWanted locals mapM_ (addDep False) $ Set.toList extraToBuild0 @@ -430,7 +423,7 @@ package buildOpts = bcoBuildOpts (baseConfigOpts ctx) wantConfigCache = ConfigCache - { configCacheOpts = map encodeUtf8 configOpts + { configCacheOpts = configOpts , configCacheDeps = present , configCacheComponents = case ps of @@ -445,7 +438,7 @@ case moldOpts of Nothing -> Just "old configure information not found" Just oldOpts - | oldOpts /= wantConfigCache -> Just $ describeConfigDiff oldOpts wantConfigCache + | Just reason <- describeConfigDiff oldOpts wantConfigCache -> Just reason | psDirty ps -> Just "local file changes" | otherwise -> Nothing case mreason of @@ -454,19 +447,20 @@ tell mempty { wDirty = Map.singleton (packageName package) reason } return True -describeConfigDiff :: ConfigCache -> ConfigCache -> Text +describeConfigDiff :: ConfigCache -> ConfigCache -> Maybe Text describeConfigDiff old new - | configCacheDeps old /= configCacheDeps new = "dependencies changed" - | configCacheComponents old /= configCacheComponents new = "components changed" - | configCacheHaddock old && not (configCacheHaddock new) = "no longer building haddocks" - | not (configCacheHaddock old) && configCacheHaddock new = "building haddocks" - | oldOpts /= newOpts = T.pack $ concat + | configCacheDeps old /= configCacheDeps new = Just "dependencies changed" + | not $ Set.null newComponents = + Just $ "components added: " `T.append` T.intercalate ", " + (map (decodeUtf8With lenientDecode) (Set.toList newComponents)) + | not (configCacheHaddock old) && configCacheHaddock new = Just "rebuilding with haddocks" + | oldOpts /= newOpts = Just $ T.pack $ concat [ "flags changed from " , show oldOpts , " to " , show newOpts ] - | otherwise = "unknown config cache difference" + | otherwise = Nothing where -- options set by stack isStackOpt t = any (`T.isPrefixOf` t) @@ -475,10 +469,13 @@ , "--package-db=" , "--libdir=" , "--bindir=" + , "--enable-tests" + , "--enable-benchmarks" ] userOpts = filter (not . isStackOpt) - . map (decodeUtf8With lenientDecode) + . map T.pack + . (\(ConfigureOpts x y) -> x ++ y) . configCacheOpts (oldOpts, newOpts) = removeMatching (userOpts old) (userOpts new) @@ -486,6 +483,8 @@ removeMatching (x:xs) (y:ys) | x == y = removeMatching xs ys removeMatching xs ys = (xs, ys) + + newComponents = configCacheComponents new `Set.difference` configCacheComponents old psDirty :: PackageSource -> Bool psDirty (PSLocal lp) = lpDirtyFiles lp diff --git a/src/Stack/Build/Coverage.hs b/src/Stack/Build/Coverage.hs --- a/src/Stack/Build/Coverage.hs +++ b/src/Stack/Build/Coverage.hs @@ -9,7 +9,7 @@ , generateHpcMarkupIndex ) where -import Control.Applicative ((<$>)) +import Control.Applicative import Control.Exception.Lifted import Control.Monad (liftM) import Control.Monad.Catch (MonadCatch) 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 @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -15,12 +16,12 @@ , withSingleContext ) where -import Control.Applicative ((<$>)) +import Control.Applicative import Control.Concurrent.Execute -import Control.Concurrent.Lifted (fork) +import Control.Concurrent.Async (withAsync, wait) import Control.Concurrent.MVar.Lifted import Control.Concurrent.STM -import Control.Exception.Enclosed (tryIO) +import Control.Exception.Enclosed (catchIO, tryIO) import Control.Exception.Lifted import Control.Monad (liftM, when, unless, void, join, guard) import Control.Monad.Catch (MonadCatch, MonadMask) @@ -37,6 +38,7 @@ import qualified Data.Conduit.List as CL import Data.Foldable (forM_) import Data.Function +import Data.IORef.RunOnce (runOnce) import Data.List import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map @@ -49,10 +51,10 @@ import Data.Traversable (forM) import Data.Text (Text) import qualified Data.Text as T -import Data.Text.Encoding (encodeUtf8) import Data.Word8 (_colon) import Distribution.System (OS (Windows), Platform (Platform)) +import qualified Distribution.Text import Language.Haskell.TH as TH (location) import Network.HTTP.Client.Conduit (HasHttpManager) import Path @@ -77,11 +79,16 @@ import qualified System.FilePath as FP import System.IO import System.IO.Temp (withSystemTempDirectory) -import System.Process.Internals (createProcess_) + +import System.PosixCompat.Files (createLink) import System.Process.Read import System.Process.Run import System.Process.Log (showProcessArgDebug) +#if !MIN_VERSION_process(1,2,1) +import System.Process.Internals (createProcess_) +#endif + type M env m = (MonadIO m,MonadReader env m,HasHttpManager env,HasBuildConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,MonadMask m,HasLogLevel env,HasEnvConfig env,HasTerminal env) preFetch :: M env m => Plan -> m () @@ -185,6 +192,9 @@ , eeGhcPkgIds :: !(TVar (Map PackageIdentifier Installed)) , eeTempDir :: !(Path Abs Dir) , eeSetupHs :: !(Path Abs File) + -- ^ Temporary Setup.hs for simple builds + , eeSetupExe :: !(Maybe (Path Abs File)) + -- ^ Compiled version of eeSetupHs , eeCabalPkgVer :: !Version , eeTotalWanted :: !Int , eeWanted :: !(Set PackageName) @@ -193,6 +203,71 @@ , eeGlobalDB :: !(Path Abs Dir) } +-- | Get a compiled Setup exe +getSetupExe :: M env m + => Path Abs File -- ^ Setup.hs input file + -> Path Abs Dir -- ^ temporary directory + -> m (Maybe (Path Abs File)) +getSetupExe setupHs tmpdir = do + wc <- getWhichCompiler + econfig <- asks getEnvConfig + let config = getConfig econfig + baseNameS = concat + [ "setup-Simple-Cabal-" + , versionString $ envConfigCabalVersion econfig + , "-" + , Distribution.Text.display $ configPlatform config + , "-" + , T.unpack $ compilerVersionName + $ envConfigCompilerVersion econfig + ] + exeNameS = baseNameS ++ + case configPlatform config of + Platform _ Windows -> ".exe" + _ -> "" + outputNameS = + case wc of + Ghc -> exeNameS + Ghcjs -> baseNameS ++ ".jsexe" + jsExeNameS = + baseNameS ++ ".jsexe" + setupDir = + configStackRoot config + $(mkRelDir "setup-exe-cache") + + exePath <- fmap (setupDir ) $ parseRelFile exeNameS + jsExePath <- fmap (setupDir ) $ parseRelDir jsExeNameS + + exists <- liftIO $ D.doesFileExist $ toFilePath exePath + + if exists + then return $ Just exePath + else do + tmpExePath <- fmap (setupDir ) $ parseRelFile $ "tmp-" ++ exeNameS + tmpOutputPath <- fmap (setupDir ) $ parseRelFile $ "tmp-" ++ outputNameS + tmpJsExePath <- fmap (setupDir ) $ parseRelDir $ "tmp-" ++ jsExeNameS + + liftIO $ D.createDirectoryIfMissing True $ toFilePath setupDir + + menv <- getMinimalEnvOverride + let args = + [ "-clear-package-db" + , "-global-package-db" + , "-hide-all-packages" + , "-package" + , "base" + , "-package" + , "Cabal-" ++ versionString (envConfigCabalVersion econfig) + , toFilePath setupHs + , "-o" + , toFilePath tmpOutputPath + ] ++ + ["-build-runner" | wc == Ghcjs] + runIn tmpdir (compilerExeName wc) menv args Nothing + when (wc == Ghcjs) $ renameDir tmpJsExePath jsExePath + renameFile tmpExePath exePath + return $ Just exePath + withExecuteEnv :: M env m => EnvOverride -> BuildOpts @@ -209,8 +284,9 @@ idMap <- liftIO $ newTVarIO Map.empty let setupHs = tmpdir' $(mkRelFile "Setup.hs") liftIO $ writeFile (toFilePath setupHs) "import Distribution.Simple\nmain = defaultMain" + setupExe <- getSetupExe setupHs tmpdir' cabalPkgVer <- asks (envConfigCabalVersion . getEnvConfig) - globalDB <- getGlobalDB menv + globalDB <- getGlobalDB menv =<< getWhichCompiler inner ExecuteEnv { eeEnvOverride = menv , eeBuildOpts = bopts @@ -224,6 +300,7 @@ , eeGhcPkgIds = idMap , eeTempDir = tmpdir' , eeSetupHs = setupHs + , eeSetupExe = setupExe , eeCabalPkgVer = cabalPkgVer , eeTotalWanted = length $ filter lpWanted locals , eeWanted = wantedLocalPackages locals @@ -239,10 +316,11 @@ -> BaseConfigOpts -> [LocalPackage] -> SourceMap + -> InstalledMap -> Plan -> m () -executePlan menv bopts baseConfigOpts locals sourceMap plan = do - withExecuteEnv menv bopts baseConfigOpts locals sourceMap (executePlan' plan) +executePlan menv bopts baseConfigOpts locals sourceMap installedMap plan = do + withExecuteEnv menv bopts baseConfigOpts locals sourceMap (executePlan' installedMap plan) unless (Map.null $ planInstallExes plan) $ do snapBin <- ( bindirSuffix) `liftM` installationRootDeps @@ -305,9 +383,16 @@ , ":"] forM_ executables $ \exe -> $logInfo $ T.append "- " exe + config <- asks getConfig + menv' <- liftIO $ configEnvOverride config EnvSettings + { esIncludeLocals = True + , esIncludeGhcPackagePath = True + , esStackExe = True + , esLocaleUtf8 = False + } forM_ (boptsExec bopts) $ \(cmd, args) -> do $logProcessRun cmd args - callProcess Nothing menv cmd args + callProcess Nothing menv' cmd args -- | Windows can't write over the current executable. Instead, we rename the -- current executable to something else and then do the copy. @@ -322,10 +407,12 @@ -- | Perform the actual plan (internal) executePlan' :: M env m - => Plan + => InstalledMap + -> Plan -> ExecuteEnv -> m () -executePlan' plan ee@ExecuteEnv {..} = do +executePlan' installedMap plan ee@ExecuteEnv {..} = do + wc <- getWhichCompiler case Map.toList $ planUnregisterLocal plan of [] -> return () ids -> do @@ -337,7 +424,7 @@ , reason , ")" ] - unregisterGhcPkgId eeEnvOverride localDB id' + unregisterGhcPkgId eeEnvOverride wc localDB id' -- Yes, we're explicitly discarding result values, which in general would -- be bad. monad-unlift does this all properly at the type system level, @@ -345,7 +432,7 @@ -- stack always using transformer stacks that are safe for this use case. runInBase <- liftBaseWith $ \run -> return (void . run) - let actions = concatMap (toActions runInBase ee) $ Map.elems $ Map.mergeWithKey + let actions = concatMap (toActions installedMap' runInBase ee) $ Map.elems $ Map.mergeWithKey (\_ b f -> Just (Just b, Just f)) (fmap (\b -> (Just b, Nothing))) (fmap (\f -> (Nothing, Just f))) @@ -383,17 +470,24 @@ else return () unless (null errs) $ throwM $ ExecutionFailure errs when (boptsHaddock eeBuildOpts) $ do - generateLocalHaddockIndex eeEnvOverride eeBaseConfigOpts eeLocals - generateDepsHaddockIndex eeEnvOverride eeBaseConfigOpts eeLocals - generateSnapHaddockIndex eeEnvOverride eeBaseConfigOpts eeGlobalDB + generateLocalHaddockIndex eeEnvOverride wc eeBaseConfigOpts eeLocals + generateDepsHaddockIndex eeEnvOverride wc eeBaseConfigOpts eeLocals + generateSnapHaddockIndex eeEnvOverride wc eeBaseConfigOpts eeGlobalDB when (toCoverage $ boptsTestOpts eeBuildOpts) generateHpcMarkupIndex + where + installedMap' = Map.difference installedMap + $ Map.fromList + $ map (\gid -> (packageIdentifierName $ ghcPkgIdPackageIdentifier gid, ())) + $ Map.keys + $ planUnregisterLocal plan toActions :: M env m - => (m () -> IO ()) + => InstalledMap + -> (m () -> IO ()) -> ExecuteEnv -> (Maybe Task, Maybe (Task, LocalPackageTB)) -- build and final -> [Action] -toActions runInBase ee (mbuild, mfinal) = +toActions installedMap runInBase ee (mbuild, mfinal) = abuild ++ afinal where abuild = @@ -404,7 +498,7 @@ { actionId = ActionId taskProvides ATBuild , actionDeps = (Set.map (\ident -> ActionId ident ATBuild) (tcoMissing taskConfigOpts)) - , actionDo = \ac -> runInBase $ singleBuild ac ee task + , actionDo = \ac -> runInBase $ singleBuild runInBase ac ee task installedMap } ] afinal = @@ -417,9 +511,9 @@ (Set.map (\ident -> ActionId ident ATBuild) (tcoMissing taskConfigOpts)) , actionDo = \ac -> runInBase $ do unless (Set.null $ lptbTests lptb) $ do - singleTest topts lptb ac ee task + singleTest runInBase topts lptb ac ee task installedMap unless (Set.null $ lptbBenches lptb) $ do - singleBench beopts lptb ac ee task + singleBench runInBase beopts lptb ac ee task installedMap } ] where @@ -432,17 +526,44 @@ topts = boptsTestOpts bopts beopts = boptsBenchmarkOpts bopts +-- | Generate the ConfigCache +getConfigCache :: MonadIO m + => ExecuteEnv -> Task -> [Text] + -> m ConfigCache +getConfigCache ExecuteEnv {..} Task {..} extra = do + idMap <- liftIO $ readTVarIO eeGhcPkgIds + let getMissing ident = + case Map.lookup ident idMap of + Nothing -> error "singleBuild: invariant violated, missing package ID missing" + Just (Library x) -> Just x + Just (Executable _) -> Nothing + missing' = Set.fromList $ mapMaybe getMissing $ Set.toList missing + TaskConfigOpts missing mkOpts = taskConfigOpts + opts = mkOpts missing' + allDeps = Set.union missing' taskPresent + return ConfigCache + { configCacheOpts = opts + { coNoDirs = coNoDirs opts ++ map T.unpack extra + } + , configCacheDeps = allDeps + , configCacheComponents = + case taskType of + TTLocal lp -> Set.map renderComponent $ lpComponents lp + TTUpstream _ _ -> Set.empty + , configCacheHaddock = + shouldHaddockPackage eeBuildOpts eeWanted (packageIdentifierName taskProvides) + } + -- | Ensure that the configuration for the package matches what is given ensureConfig :: M env m - => Path Abs Dir -- ^ package directory + => ConfigCache -- ^ newConfigCache + -> Path Abs Dir -- ^ package directory -> ExecuteEnv - -> Task -> m () -- ^ announce -> (Bool -> [String] -> m ()) -- ^ cabal -> Path Abs File -- ^ .cabal file - -> [Text] - -> m (ConfigCache, Bool) -ensureConfig pkgDir ExecuteEnv {..} Task {..} announce cabal cabalfp extra = do + -> m Bool +ensureConfig newConfigCache pkgDir ExecuteEnv {..} announce cabal cabalfp = do -- Determine the old and new configuration in the local directory, to -- determine if we need to reconfigure. mOldConfigCache <- tryGetConfigCache pkgDir @@ -450,40 +571,28 @@ mOldCabalMod <- tryGetCabalMod pkgDir newCabalMod <- liftIO (fmap modTime (D.getModificationTime (toFilePath cabalfp))) - idMap <- liftIO $ readTVarIO eeGhcPkgIds - let getMissing ident = - case Map.lookup ident idMap of - Nothing -> error "singleBuild: invariant violated, missing package ID missing" - Just (Library x) -> Just x - Just (Executable _) -> Nothing - missing' = Set.fromList $ mapMaybe getMissing $ Set.toList missing - TaskConfigOpts missing mkOpts = taskConfigOpts - configOpts = mkOpts missing' ++ extra - allDeps = Set.union missing' taskPresent - newConfigCache = ConfigCache - { configCacheOpts = map encodeUtf8 configOpts - , configCacheDeps = allDeps - , configCacheComponents = - case taskType of - TTLocal lp -> Set.map renderComponent $ lpComponents lp - TTUpstream _ _ -> Set.empty - , configCacheHaddock = - shouldHaddockPackage eeBuildOpts eeWanted (packageIdentifierName taskProvides) - } - let needConfig = mOldConfigCache /= Just newConfigCache || mOldCabalMod /= Just newCabalMod + ConfigureOpts dirs nodirs = configCacheOpts newConfigCache when needConfig $ withMVar eeConfigureLock $ \_ -> do deleteCaches pkgDir announce - cabal False $ "configure" : map T.unpack configOpts + cabal False $ "configure" : dirs ++ nodirs writeConfigCache pkgDir newConfigCache writeCabalMod pkgDir newCabalMod - return (newConfigCache, needConfig) + return needConfig +announceTask :: MonadLogger m => Task -> Text -> m () +announceTask task x = $logInfo $ T.concat + [ T.pack $ packageIdentifierString $ taskProvides task + , ": " + , x + ] + withSingleContext :: M env m - => ActionContext + => (m () -> IO ()) + -> ActionContext -> ExecuteEnv -> Task -> Maybe String @@ -496,17 +605,13 @@ -> Maybe (Path Abs File, Handle) -> m a) -> m a -withSingleContext ActionContext {..} ExecuteEnv {..} task@Task {..} msuffix inner0 = +withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} msuffix inner0 = withPackage $ \package cabalfp pkgDir -> withLogFile package $ \mlogFile -> withCabal package pkgDir mlogFile $ \cabal -> inner0 package cabalfp pkgDir cabal announce console mlogFile where - announce x = $logInfo $ T.concat - [ T.pack $ packageIdentifierString taskProvides - , ": " - , x - ] + announce = announceTask task wanted = case taskType of @@ -549,18 +654,20 @@ { esIncludeLocals = taskLocation task == Local , esIncludeGhcPackagePath = False , esStackExe = False + , esLocaleUtf8 = True } - exeName <- liftIO $ join $ findExecutable menv "runhaskell" + getRunhaskellPath <- runOnce $ liftIO $ join $ findExecutable menv "runhaskell" + getGhcjsPath <- runOnce $ liftIO $ join $ findExecutable menv "ghcjs" distRelativeDir' <- distRelativeDir - setuphs <- + esetupexehs <- -- Avoid broken Setup.hs files causing problems for simple build -- types, see: -- https://github.com/commercialhaskell/stack/issues/370 - if packageSimpleType package - then return eeSetupHs - else liftIO $ getSetupHs pkgDir + case (packageSimpleType package, eeSetupExe) of + (True, Just setupExe) -> return $ Left setupExe + _ -> liftIO $ fmap Right $ getSetupHs pkgDir inner $ \stripTHLoading args -> do - let fullArgs = + let packageArgs = ("-package=" ++ packageIdentifierString (PackageIdentifier cabalPackageName @@ -583,57 +690,87 @@ -- -hide-all-packages and explicitly list which packages -- can be used by Setup.hs, and have that based on the -- dependencies of the package itself. - : ("-package-db=" ++ toFilePath (bcoSnapDB eeBaseConfigOpts)) + : ["-package-db=" ++ toFilePath (bcoSnapDB eeBaseConfigOpts)] + setupArgs = ("--builddir=" ++ toFilePath distRelativeDir') : args + runExe exeName fullArgs = do + $logProcessRun (toFilePath exeName) fullArgs - : toFilePath setuphs - : ("--builddir=" ++ toFilePath distRelativeDir') - : args - 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 = - case mlogFile of - Nothing -> CreatePipe - Just (_, h) -> UseHandle h - } - $logProcessRun (toFilePath exeName) fullArgs + -- Use createProcess_ to avoid the log file being closed afterwards + (Nothing, moutH, merrH, ph) <- liftIO $ createProcess_ "singleBuild" cp - -- 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 - let makeAbsolute = stripTHLoading -- If users want control, we should add a config option for this + ec <- + liftIO $ + withAsync (runInBase $ maybePrintBuildOutput stripTHLoading makeAbsolute LevelInfo mlogFile moutH) $ \outThreadID -> + withAsync (runInBase $ maybePrintBuildOutput False makeAbsolute LevelWarn mlogFile merrH) $ \errThreadID -> do + ec <- waitForProcess ph + wait errThreadID + wait outThreadID + return ec + case ec of + ExitSuccess -> return () + _ -> do + bs <- liftIO $ + case mlogFile of + Nothing -> return "" + Just (logFile, h) -> do + hClose h + S.readFile $ toFilePath logFile + throwM $ CabalExitedUnsuccessfully + ec + taskProvides + exeName + fullArgs + (fmap fst mlogFile) + bs + 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 = + case mlogFile of + Nothing -> CreatePipe + Just (_, h) -> UseHandle h + } - maybePrintBuildOutput stripTHLoading makeAbsolute LevelInfo mlogFile moutH - maybePrintBuildOutput False makeAbsolute LevelWarn mlogFile merrH - ec <- liftIO $ waitForProcess ph - case ec of - ExitSuccess -> return () - _ -> do - bs <- liftIO $ - case mlogFile of - Nothing -> return "" - Just (logFile, h) -> do - hClose h - S.readFile $ toFilePath logFile - throwM $ CabalExitedUnsuccessfully - ec - taskProvides - exeName - fullArgs - (fmap fst mlogFile) - bs + wc <- getWhichCompiler + (exeName, fullArgs) <- case (esetupexehs, wc) of + (Left setupExe, _) -> return (setupExe, setupArgs) + (Right setuphs, Ghc) -> do + exeName <- getRunhaskellPath + let fullArgs = packageArgs ++ (toFilePath setuphs : setupArgs) + return (exeName, fullArgs) + (Right setuphs, Ghcjs) -> do + distDir <- distDirFromDir pkgDir + let setupDir = distDir $(mkRelDir "setup") + outputFile = setupDir $(mkRelFile "setup") + createTree setupDir + ghcjsPath <- getGhcjsPath + runExe ghcjsPath $ + [ "--make" + , "-odir", toFilePath setupDir + , "-hidir", toFilePath setupDir + , "-i", "-i." + ] ++ packageArgs ++ + [ toFilePath setuphs + , "-o", toFilePath outputFile + , "-build-runner" + ] + return (outputFile, setupArgs) + runExe exeName fullArgs maybePrintBuildOutput stripTHLoading makeAbsolute level mlogFile mh = case mh of @@ -644,86 +781,199 @@ Nothing -> return () singleBuild :: M env m - => ActionContext + => (m () -> IO ()) + -> ActionContext -> ExecuteEnv -> Task + -> InstalledMap -> m () -singleBuild ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} = - withSingleContext ac ee task Nothing $ \package cabalfp pkgDir cabal announce console _mlogFile -> do - (cache, _neededConfig) <- ensureConfig pkgDir ee task (announce "configure") cabal cabalfp [] +singleBuild runInBase ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} installedMap = do + cache <- getCache + mprecompiled <- getPrecompiled cache + minstalled <- + case mprecompiled of + Just precompiled -> copyPreCompiled precompiled + Nothing -> realConfigAndBuild cache + case minstalled of + Nothing -> return () + Just installed -> do + writeFlagCache installed cache + liftIO $ atomically $ modifyTVar eeGhcPkgIds $ Map.insert taskProvides installed + where + pname = packageIdentifierName taskProvides + shouldHaddockPackage' = shouldHaddockPackage eeBuildOpts eeWanted pname + doHaddock package = shouldHaddockPackage' && + -- Works around haddock failing on bytestring-builder since it has no modules + -- when bytestring is new enough. + packageHasExposedModules package - markExeNotInstalled (taskLocation task) taskProvides - case taskType of - TTLocal lp -> writeBuildCache pkgDir $ lpNewBuildCache lp - TTUpstream _ _ -> return () + getCache = do + let extra = + -- We enable tests if the test suite dependencies are already + -- installed, so that we avoid unnecessary recompilation based on + -- cabal_macros.h changes when switching between 'stack build' and + -- 'stack test'. See: + -- https://github.com/commercialhaskell/stack/issues/805 + case taskType of + TTLocal lp -> concat + [ ["--enable-tests" | depsPresent installedMap $ lpTestDeps lp] + , ["--enable-benchmarks" | depsPresent installedMap $ lpBenchDeps lp] + ] + _ -> [] + getConfigCache ee task extra - announce "build" - config <- asks getConfig - extraOpts <- extraBuildOptions - cabal (console && configHideTHLoading config) $ - (case taskType of - TTLocal lp -> "build" - -- Cabal... There doesn't seem to be a way to call out the library component... - -- : "lib" - : map (T.unpack . T.append "exe:") - (maybe [] Set.toList $ lpExeComponents lp) - TTUpstream _ _ -> ["build"]) ++ extraOpts + getPrecompiled cache = + case taskLocation task of + Snap | not shouldHaddockPackage' -> do + mpc <- readPrecompiledCache taskProvides $ configCacheOpts cache + case mpc of + Nothing -> return Nothing + Just pc -> do + let allM _ [] = return True + allM f (x:xs) = do + b <- f x + if b then allM f xs else return False + b <- liftIO $ allM D.doesFileExist $ maybe id (:) (pcLibrary pc) $ pcExes pc + return $ if b then Just pc else Nothing + _ -> return Nothing - let doHaddock = shouldHaddockPackage eeBuildOpts eeWanted (packageName package) && - -- Works around haddock failing on bytestring-builder since it has no modules - -- when bytestring is new enough. - packageHasExposedModules package - when doHaddock $ do - announce "haddock" - hscolourExists <- doesExecutableExist eeEnvOverride "HsColour" - unless hscolourExists $ $logWarn - ("Warning: haddock not generating hyperlinked sources because 'HsColour' not\n" <> - "found on PATH (use 'stack build hscolour --copy-bins' to install).") - cabal False (concat [["haddock", "--html", "--hoogle", "--html-location=../$pkg-$version/"] - ,["--hyperlink-source" | hscolourExists]]) + copyPreCompiled (PrecompiledCache mlib exes) = do + announceTask task "copying precompiled package" + forM_ mlib $ \libpath -> do + menv <- getMinimalEnvOverride + withMVar eeInstallLock $ \() -> + readProcessNull Nothing menv "ghc-pkg" + [ "register" + , "--no-user-package-db" + , "--package-db=" ++ toFilePath (bcoSnapDB eeBaseConfigOpts) + , "--force" + , libpath + ] + liftIO $ forM_ exes $ \exe -> do + D.createDirectoryIfMissing True bindir + let dst = bindir FP. FP.takeFileName exe + createLink exe dst `catchIO` \_ -> D.copyFile exe bindir - withMVar eeInstallLock $ \() -> do - announce "install" - cabal False ["install"] + -- Find the package in the database + wc <- getWhichCompiler + let pkgDbs = [bcoSnapDB eeBaseConfigOpts] + mpkgid <- findGhcPkgId eeEnvOverride wc pkgDbs pname - let pkgDbs = - case taskLocation task of - Snap -> [bcoSnapDB eeBaseConfigOpts] - Local -> - [ bcoSnapDB eeBaseConfigOpts - , bcoLocalDB eeBaseConfigOpts + return $ Just $ + case mpkgid of + Nothing -> Executable taskProvides + Just pkgid -> Library pkgid + where + bindir = toFilePath $ bcoSnapInstallRoot eeBaseConfigOpts bindirSuffix + + realConfigAndBuild cache = withSingleContext runInBase ac ee task Nothing + $ \package cabalfp pkgDir cabal announce console _mlogFile -> do + _neededConfig <- ensureConfig cache pkgDir ee (announce "configure") cabal cabalfp + + if boptsOnlyConfigure eeBuildOpts + then return Nothing + else liftM Just $ realBuild cache package pkgDir cabal announce console + + realBuild cache package pkgDir cabal announce console = do + wc <- getWhichCompiler + + markExeNotInstalled (taskLocation task) taskProvides + case taskType of + TTLocal lp -> writeBuildCache pkgDir $ lpNewBuildCache lp + TTUpstream _ _ -> return () + + () <- announce "build" + config <- asks getConfig + extraOpts <- extraBuildOptions + cabal (console && configHideTHLoading config) $ + (case taskType of + TTLocal lp -> concat + [ ["build"] + , ["lib:" ++ packageNameString (packageName package) + -- TODO: get this information from target parsing instead, + -- which will allow users to turn off library building if + -- desired + | packageHasLibrary package] + , map (T.unpack . T.append "exe:") + (maybe [] Set.toList $ lpExeComponents lp) ] - mpkgid <- findGhcPkgId eeEnvOverride pkgDbs (packageName package) - mpkgid' <- case (packageHasLibrary package, mpkgid) of - (False, _) -> assert (isNothing mpkgid) $ do - markExeInstalled (taskLocation task) taskProvides -- TODO unify somehow with writeFlagCache? - return $ Executable $ PackageIdentifier - (packageName package) - (packageVersion package) - (True, Nothing) -> throwM $ Couldn'tFindPkgId $ packageName package - (True, Just pkgid) -> return $ Library pkgid - writeFlagCache mpkgid' cache - liftIO $ atomically $ modifyTVar eeGhcPkgIds $ Map.insert taskProvides mpkgid' + TTUpstream _ _ -> ["build"]) ++ extraOpts - when (doHaddock && shouldHaddockDeps eeBuildOpts) $ - withMVar eeInstallLock $ \() -> - copyDepHaddocks - eeEnvOverride - eeBaseConfigOpts - (pkgDbs ++ [eeGlobalDB]) - (PackageIdentifier (packageName package) (packageVersion package)) - Set.empty + when (doHaddock package) $ do + announce "haddock" + hscolourExists <- doesExecutableExist eeEnvOverride "HsColour" + unless hscolourExists $ $logWarn + ("Warning: haddock not generating hyperlinked sources because 'HsColour' not\n" <> + "found on PATH (use 'stack build hscolour --copy-bins' to install).") + cabal False (concat [["haddock", "--html", "--hoogle", "--html-location=../$pkg-$version/"] + ,["--hyperlink-source" | hscolourExists] + ,["--ghcjs" | wc == Ghcjs]]) + withMVar eeInstallLock $ \() -> do + announce "install" + cabal False ["install"] + + let pkgDbs = + case taskLocation task of + Snap -> [bcoSnapDB eeBaseConfigOpts] + Local -> + [ bcoSnapDB eeBaseConfigOpts + , bcoLocalDB eeBaseConfigOpts + ] + mpkgid <- findGhcPkgId eeEnvOverride wc pkgDbs (packageName package) + mpkgid' <- case (packageHasLibrary package, mpkgid) of + (False, _) -> assert (isNothing mpkgid) $ do + markExeInstalled (taskLocation task) taskProvides -- TODO unify somehow with writeFlagCache? + return $ Executable $ PackageIdentifier + (packageName package) + (packageVersion package) + (True, Nothing) -> throwM $ Couldn'tFindPkgId $ packageName package + (True, Just pkgid) -> return $ Library pkgid + + when (doHaddock package && shouldHaddockDeps eeBuildOpts) $ + withMVar eeInstallLock $ \() -> + copyDepHaddocks + eeEnvOverride + wc + eeBaseConfigOpts + (pkgDbs ++ [eeGlobalDB]) + (PackageIdentifier (packageName package) (packageVersion package)) + Set.empty + + case taskLocation task of + Snap -> writePrecompiledCache eeBaseConfigOpts taskProvides (configCacheOpts cache) mpkgid (packageExes package) + Local -> return () + + return mpkgid' + +-- | Determine if all of the dependencies given are installed +depsPresent :: InstalledMap -> Map PackageName VersionRange -> Bool +depsPresent installedMap deps = all + (\(name, range) -> + case Map.lookup name installedMap of + Just (version, _, _) -> version `withinRange` range + Nothing -> False) + (Map.toList deps) + singleTest :: M env m - => TestOpts + => (m () -> IO ()) + -> TestOpts -> LocalPackageTB -> ActionContext -> ExecuteEnv -> Task + -> InstalledMap -> m () -singleTest topts lptb ac ee task = - withSingleContext ac ee task (Just "test") $ \package cabalfp pkgDir cabal announce console mlogFile -> do - (_cache, neededConfig) <- ensureConfig pkgDir ee task (announce "configure (test)") cabal cabalfp ["--enable-tests"] +singleTest runInBase topts lptb ac ee task installedMap = + withSingleContext runInBase ac ee task (Just "test") $ \package cabalfp pkgDir cabal announce console mlogFile -> do + cache <- getConfigCache ee task $ + case taskType task of + TTLocal lp -> concat + [ ["--enable-tests"] + , ["--enable-benchmarks" | depsPresent installedMap $ lpBenchDeps lp] + ] + _ -> [] + neededConfig <- ensureConfig cache pkgDir ee (announce "configure (test)") cabal cabalfp config <- asks getConfig testBuilt <- checkTestBuilt pkgDir @@ -786,6 +1036,7 @@ { esIncludeLocals = taskLocation task == Local , esIncludeGhcPackagePath = True , esStackExe = True + , esLocaleUtf8 = False } if exists then do @@ -856,15 +1107,24 @@ setTestSuccess pkgDir singleBench :: M env m - => BenchmarkOpts + => (m () -> IO ()) + -> BenchmarkOpts -> LocalPackageTB -> ActionContext -> ExecuteEnv -> Task + -> InstalledMap -> m () -singleBench beopts _lptb ac ee task = - withSingleContext ac ee task (Just "bench") $ \_package cabalfp pkgDir cabal announce console _mlogFile -> do - (_cache, neededConfig) <- ensureConfig pkgDir ee task (announce "configure (benchmarks)") cabal cabalfp ["--enable-benchmarks"] +singleBench runInBase beopts _lptb ac ee task installedMap = + withSingleContext runInBase ac ee task (Just "bench") $ \_package cabalfp pkgDir cabal announce console _mlogFile -> do + cache <- getConfigCache ee task $ + case taskType task of + TTLocal lp -> concat + [ ["--enable-tests" | depsPresent installedMap $ lpTestDeps lp] + , ["--enable-benchmarks"] + ] + _ -> [] + neededConfig <- ensureConfig cache pkgDir ee (announce "configure (benchmarks)") cabal cabalfp benchBuilt <- checkBenchBuilt pkgDir @@ -886,9 +1146,19 @@ let args = maybe [] ((:[]) . ("--benchmark-options=" <>)) (beoAdditionalArgs beopts) - announce "benchmarks" - cabal False ("bench" : args) + toRun <- + if beoDisableRun beopts + then do + announce "Benchmark running disabled by --no-run-benchmarks flag." + return False + else do + return True + + when toRun $ do + announce "benchmarks" + cabal False ("bench" : args) + -- | Grab all output from the given @Handle@ and print it to stdout, stripping -- Template Haskell "Loading package" lines. Does work in a separate thread. printBuildOutput :: (MonadIO m, MonadBaseControl IO m, MonadLogger m) @@ -896,7 +1166,7 @@ -> Bool -- ^ convert paths to absolute? -> LogLevel -> Handle -> m () -printBuildOutput excludeTHLoading makeAbsolute level outH = void $ fork $ +printBuildOutput excludeTHLoading makeAbsolute level outH = void $ CB.sourceHandle outH $$ CB.lines =$ CL.map stripCarriageReturn diff --git a/src/Stack/Build/Haddock.hs b/src/Stack/Build/Haddock.hs --- a/src/Stack/Build/Haddock.hs +++ b/src/Stack/Build/Haddock.hs @@ -60,22 +60,23 @@ -- available where viewing the docs (e.g. if building in a Docker container). copyDepHaddocks :: (MonadIO m, MonadLogger m, MonadThrow m, MonadCatch m, MonadBaseControl IO m) => EnvOverride + -> WhichCompiler -> BaseConfigOpts -> [Path Abs Dir] -> PackageIdentifier -> Set (Path Abs Dir) -> m () -copyDepHaddocks envOverride bco pkgDbs pkgId extraDestDirs = do - mpkgHtmlDir <- findGhcPkgHaddockHtml envOverride pkgDbs pkgId +copyDepHaddocks envOverride wc bco pkgDbs pkgId extraDestDirs = do + mpkgHtmlDir <- findGhcPkgHaddockHtml envOverride wc pkgDbs pkgId case mpkgHtmlDir of Nothing -> return () Just pkgHtmlDir -> do - depGhcIds <- findGhcPkgDepends envOverride pkgDbs pkgId + depGhcIds <- findGhcPkgDepends envOverride wc pkgDbs pkgId forM_ (map ghcPkgIdPackageIdentifier depGhcIds) $ copyDepWhenNeeded pkgHtmlDir where copyDepWhenNeeded pkgHtmlDir depId = do - mDepOrigDir <- findGhcPkgHaddockHtml envOverride pkgDbs depId + mDepOrigDir <- findGhcPkgHaddockHtml envOverride wc pkgDbs depId case mDepOrigDir of Nothing -> return () Just depOrigDir -> do @@ -97,7 +98,7 @@ when needCopy $ doCopy depOrigDir depCopyDir return needCopy when (or copied) $ - copyDepHaddocks envOverride bco pkgDbs depId destDirs + copyDepHaddocks envOverride wc bco pkgDbs depId destDirs getNeedCopy depOrigDir depCopyDir = do let depOrigIndex = haddockIndexFile depOrigDir depCopyIndex = haddockIndexFile depCopyDir @@ -118,8 +119,8 @@ -- | Generate Haddock index and contents for local packages. generateLocalHaddockIndex :: (MonadIO m, MonadCatch m, MonadThrow m, MonadLogger m, MonadBaseControl IO m) - => EnvOverride -> BaseConfigOpts -> [LocalPackage] -> m () -generateLocalHaddockIndex envOverride bco locals = do + => EnvOverride -> WhichCompiler -> BaseConfigOpts -> [LocalPackage] -> m () +generateLocalHaddockIndex envOverride wc bco locals = do let packageIDs = map (\LocalPackage{lpPackage = Package{..}} -> @@ -128,6 +129,7 @@ generateHaddockIndex "local packages" envOverride + wc packageIDs "." (localDocDir bco) @@ -135,19 +137,21 @@ -- | Generate Haddock index and contents for local packages and their dependencies. generateDepsHaddockIndex :: (MonadIO m, MonadCatch m, MonadThrow m, MonadLogger m, MonadBaseControl IO m) - => EnvOverride -> BaseConfigOpts -> [LocalPackage] -> m () -generateDepsHaddockIndex envOverride bco locals = do + => EnvOverride -> WhichCompiler -> BaseConfigOpts -> [LocalPackage] -> m () +generateDepsHaddockIndex envOverride wc bco locals = do depSets <- mapM (\LocalPackage{lpPackage = Package{..}} -> findTransitiveGhcPkgDepends envOverride + wc [bcoSnapDB bco, bcoLocalDB bco] (PackageIdentifier packageName packageVersion)) locals generateHaddockIndex "local packages and dependencies" envOverride + wc (Set.toList (Set.unions depSets)) ".." (localDocDir bco $(mkRelDir "all")) @@ -155,12 +159,13 @@ -- | Generate Haddock index and contents for all snapshot packages. generateSnapHaddockIndex :: (MonadIO m, MonadCatch m, MonadThrow m, MonadLogger m, MonadBaseControl IO m) - => EnvOverride -> BaseConfigOpts -> Path Abs Dir -> m () -generateSnapHaddockIndex envOverride bco globalDB = do - pkgIds <- listGhcPkgDbs envOverride [globalDB, bcoSnapDB bco] + => EnvOverride -> WhichCompiler -> BaseConfigOpts -> Path Abs Dir -> m () +generateSnapHaddockIndex envOverride wc bco globalDB = do + pkgIds <- listGhcPkgDbs envOverride wc [globalDB, bcoSnapDB bco] generateHaddockIndex "snapshot packages" envOverride + wc pkgIds "." (snapDocDir bco) @@ -170,11 +175,12 @@ :: (MonadIO m, MonadCatch m, MonadThrow m, MonadLogger m, MonadBaseControl IO m) => Text -> EnvOverride + -> WhichCompiler -> [PackageIdentifier] -> FilePath -> Path Abs Dir -> m () -generateHaddockIndex descr envOverride packageIDs docRelDir destDir = do +generateHaddockIndex descr envOverride wc packageIDs docRelDir destDir = do createTree destDir interfaceOpts <- liftIO $ fmap catMaybes (mapM toInterfaceOpt packageIDs) case maximumMay (map snd interfaceOpts) of @@ -197,7 +203,7 @@ readProcessNull (Just destDir) envOverride - "haddock" + (haddockExeName wc) (["--gen-contents", "--gen-index"] ++ concatMap fst interfaceOpts) where toInterfaceOpt pid@(PackageIdentifier name _) = do diff --git a/src/Stack/Build/Installed.hs b/src/Stack/Build/Installed.hs --- a/src/Stack/Build/Installed.hs +++ b/src/Stack/Build/Installed.hs @@ -124,7 +124,8 @@ -> [LoadHelper] -- ^ from parent databases -> m ([LoadHelper], Set GhcPkgId) loadDatabase menv opts mcache sourceMap mdb lhs0 = do - (lhs1, gids) <- ghcPkgDump menv (fmap snd mdb) + wc <- getWhichCompiler + (lhs1, gids) <- ghcPkgDump menv wc (fmap snd mdb) $ conduitDumpPackage =$ sink let lhs = pruneDeps (packageIdentifierName . ghcPkgIdPackageIdentifier) diff --git a/src/Stack/Build/Source.hs b/src/Stack/Build/Source.hs --- a/src/Stack/Build/Source.hs +++ b/src/Stack/Build/Source.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} @@ -12,9 +13,11 @@ , localFlags , getLocalPackageViews , loadLocalPackage + , parseTargetsFromBuildOpts ) where -import Control.Applicative ((<$>), (<*>)) + +import Control.Applicative import Control.Arrow ((&&&)) import Control.Exception (assert, catch) import Control.Monad @@ -36,8 +39,9 @@ import Data.List import qualified Data.Map as Map import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M import Data.Maybe -import Data.Monoid ((<>), Any (..), mconcat, mempty) +import Data.Monoid import Data.Set (Set) import qualified Data.Set as Set import Data.Text (Text) @@ -51,48 +55,30 @@ import Prelude import Stack.Build.Cache import Stack.Build.Target -import Stack.Types.Build import Stack.BuildPlan (loadMiniBuildPlan, shadowMiniBuildPlan, parseCustomMiniBuildPlan) import Stack.Constants (wiredInPackages) import Stack.Package import Stack.PackageIndex import Stack.Types + import System.Directory import System.IO (withBinaryFile, IOMode (ReadMode)) import System.IO.Error (isDoesNotExistError) loadSourceMap :: (MonadIO m, MonadCatch m, MonadReader env m, HasBuildConfig env, MonadBaseControl IO m, HasHttpManager env, MonadLogger m, HasEnvConfig env) - => BuildOpts - -> m ( MiniBuildPlan + => NeedTargets + -> BuildOpts + -> m ( Map PackageName SimpleTarget + , MiniBuildPlan , [LocalPackage] , Set PackageName -- non-local targets , SourceMap ) -loadSourceMap bopts = do +loadSourceMap needTargets bopts = do bconfig <- asks getBuildConfig - mbp0 <- case bcResolver bconfig of - ResolverSnapshot snapName -> do - $logDebug $ "Checking resolver: " <> renderSnapName snapName - loadMiniBuildPlan snapName - ResolverGhc ghc -> return MiniBuildPlan - { mbpGhcVersion = fromMajorVersion ghc - , mbpPackages = Map.empty - } - ResolverCustom _ url -> do - stackYamlFP <- asks $ bcStackYaml . getBuildConfig - parseCustomMiniBuildPlan stackYamlFP url - rawLocals <- getLocalPackageViews - workingDir <- getWorkingDir - (cliExtraDeps, targets) <- - parseTargets - (bcImplicitGlobal bconfig) - (mpiVersion <$> mbpPackages mbp0) - (bcExtraDeps bconfig) - (fst <$> rawLocals) - workingDir - (boptsTargets bopts) + (mbp0, cliExtraDeps, targets) <- parseTargetsFromBuildOpts needTargets bopts menv <- getMinimalEnvOverride caches <- getPackageCaches menv @@ -107,7 +93,7 @@ latestVersion locals <- mapM (loadLocalPackage bopts targets) $ Map.toList rawLocals - checkFlagsUsed bopts locals + checkFlagsUsed bopts locals extraDeps0 (mbpPackages mbp0) let -- loadLocals returns PackageName (foo) and PackageIdentifier (bar-1.2.3) targets separately; @@ -133,7 +119,22 @@ -- Overwrite any flag settings with those from the config file extraDeps3 = Map.mapWithKey - (\n (v, f) -> PSUpstream v Local $ fromMaybe f $ Map.lookup n $ bcFlags bconfig) + (\n (v, f) -> PSUpstream v Local $ + case ( Map.lookup (Just n) $ boptsFlags bopts + , Map.lookup Nothing $ boptsFlags bopts + , Map.lookup n $ bcFlags bconfig + ) of + -- Didn't have any flag overrides, fall back to the flags + -- defined in the snapshot. + (Nothing, Nothing, Nothing) -> f + -- Either command line flag for this package, general + -- command line flag, or flag in stack.yaml is defined. + -- Take all of those and ignore the snapshot flags. + (x, y, z) -> Map.unions + [ fromMaybe Map.empty x + , fromMaybe Map.empty y + , fromMaybe Map.empty z + ]) extraDeps2 let sourceMap = Map.unions @@ -145,21 +146,88 @@ (PSUpstream (mpiVersion mpi) Snap (mpiFlags mpi)) ] `Map.difference` Map.fromList (map (, ()) (HashSet.toList wiredInPackages)) - return (mbp, locals, nonLocalTargets, sourceMap) + return (targets, mbp, locals, nonLocalTargets, sourceMap) +-- | Use the build options and environment to parse targets. +parseTargetsFromBuildOpts + :: (MonadIO m, MonadCatch m, MonadReader env m, HasBuildConfig env, MonadBaseControl IO m, HasHttpManager env, MonadLogger m, HasEnvConfig env) + => NeedTargets + -> BuildOpts + -> m (MiniBuildPlan, M.Map PackageName Version, M.Map PackageName SimpleTarget) +parseTargetsFromBuildOpts needTargets bopts = do + bconfig <- asks getBuildConfig + mbp0 <- + case bcResolver bconfig of + ResolverSnapshot snapName -> do + $logDebug $ "Checking resolver: " <> renderSnapName snapName + loadMiniBuildPlan snapName + ResolverCompiler _ -> do + -- We ignore the resolver version, as it might be + -- GhcMajorVersion, and we want the exact version + -- we're using. + version <- asks (envConfigCompilerVersion . getEnvConfig) + return MiniBuildPlan + { mbpCompilerVersion = version + , mbpPackages = Map.empty + } + ResolverCustom _ url -> do + stackYamlFP <- asks $ bcStackYaml . getBuildConfig + parseCustomMiniBuildPlan stackYamlFP url + rawLocals <- getLocalPackageViews + workingDir <- getWorkingDir + + let snapshot = mpiVersion <$> mbpPackages mbp0 + flagExtraDeps <- convertSnapshotToExtra + snapshot + (bcExtraDeps bconfig) + (catMaybes $ Map.keys $ boptsFlags bopts) + + (cliExtraDeps, targets) <- + parseTargets + needTargets + (bcImplicitGlobal bconfig) + snapshot + (flagExtraDeps <> bcExtraDeps bconfig) + (fst <$> rawLocals) + workingDir + (boptsTargets bopts) + return (mbp0, cliExtraDeps <> flagExtraDeps, targets) + +-- | For every package in the snapshot which is referenced by a flag, give the +-- user a warning and then add it to extra-deps. +convertSnapshotToExtra + :: MonadLogger m + => Map PackageName Version -- ^ snapshot + -> Map PackageName Version -- ^ extra-deps + -> [PackageName] -- ^ packages referenced by a flag + -> m (Map PackageName Version) +convertSnapshotToExtra snapshot extra0 flags0 = + go Map.empty flags0 + where + go !extra [] = return extra + go extra (flag:flags) + | Just _ <- Map.lookup flag extra0 = go extra flags + | otherwise = case Map.lookup flag snapshot of + Nothing -> go extra flags + Just version -> do + $logWarn $ T.concat + [ "- Implicitly adding " + , T.pack $ packageNameString flag + , " to extra-deps based on command line flag" + ] + go (Map.insert flag version extra) flags + -- | Parse out the local package views for the current project getLocalPackageViews :: (MonadThrow m, MonadIO m, MonadReader env m, HasEnvConfig env) => m (Map PackageName (LocalPackageView, GenericPackageDescription)) getLocalPackageViews = do econfig <- asks getEnvConfig - -- TODO ensure that there are no overlapping package names - liftM Map.fromList $ forM (Map.toList $ envConfigPackages econfig) $ \(dir, validWanted) -> do + locals <- forM (Map.toList $ envConfigPackages econfig) $ \(dir, validWanted) -> do cabalfp <- getCabalFileName dir gpkg <- readPackageUnresolved cabalfp let cabalID = package $ packageDescription gpkg - name <- parsePackageNameFromFilePath cabalfp - when (fromCabalPackageName (pkgName $ cabalID) /= name) - $ throwM $ MismatchedCabalName cabalfp name + name = fromCabalPackageName $ pkgName $ cabalID + checkCabalFileName name cabalfp let lpv = LocalPackageView { lpvVersion = fromCabalVersion $ pkgVersion cabalID , lpvRoot = dir @@ -168,6 +236,8 @@ , lpvComponents = getNamedComponents gpkg } return (name, (lpv, gpkg)) + checkDuplicateNames locals + return $ Map.fromList locals where getNamedComponents gpkg = Set.fromList $ concat [ maybe [] (const [CLib]) (C.condLibrary gpkg) @@ -178,6 +248,18 @@ where go wrapper f = map (wrapper . T.pack . fst) $ f gpkg +-- | Check if there are any duplicate package names and, if so, throw an +-- exception. +checkDuplicateNames :: MonadThrow m => [(PackageName, (LocalPackageView, gpd))] -> m () +checkDuplicateNames locals = + case filter hasMultiples $ Map.toList $ Map.fromListWith (++) $ map toPair locals of + [] -> return () + x -> throwM $ DuplicateLocalPackageNames x + where + toPair (pn, (lpv, _)) = (pn, [lpvRoot lpv]) + hasMultiples (_, _:_:_) = True + hasMultiples _ = False + splitComponents :: [NamedComponent] -> (Set Text, Set Text, Set Text) splitComponents = @@ -206,7 +288,7 @@ { packageConfigEnableTests = False , packageConfigEnableBenchmarks = False , packageConfigFlags = localFlags (boptsFlags bopts) bconfig name - , packageConfigGhcVersion = envConfigGhcVersion econfig + , packageConfigCompilerVersion = envConfigCompilerVersion econfig , packageConfigPlatform = configPlatform $ getConfig bconfig } pkg = resolvePackage config gpkg @@ -232,6 +314,15 @@ { packageConfigEnableTests = not $ Set.null tests , packageConfigEnableBenchmarks = not $ Set.null benches } + testconfig = config + { packageConfigEnableTests = True + , packageConfigEnableBenchmarks = False + } + benchconfig = config + { packageConfigEnableTests = False + , packageConfigEnableBenchmarks = True + } + btpkg | Set.null tests && Set.null benches = Nothing | otherwise = Just $ LocalPackageTB @@ -239,14 +330,23 @@ , lptbTests = tests , lptbBenches = benches } + testpkg = resolvePackage testconfig gpkg + benchpkg = resolvePackage benchconfig gpkg mbuildCache <- tryGetBuildCache $ lpvRoot lpv - files <- getPackageFiles (packageFiles pkg) (lpvCabalFP lpv) + (_,modFiles,otherFiles,mainFiles,extraFiles) <- getPackageFiles (packageFiles pkg) (lpvCabalFP lpv) + let files = + mconcat (M.elems modFiles) <> + mconcat (M.elems otherFiles) <> + Set.map mainIsFile (mconcat (M.elems mainFiles)) <> + extraFiles (isDirty, newBuildCache) <- checkBuildCache (fromMaybe Map.empty mbuildCache) (map toFilePath $ Set.toList files) return LocalPackage { lpPackage = pkg + , lpTestDeps = packageDeps $ testpkg + , lpBenchDeps = packageDeps $ benchpkg , lpExeComponents = case mtarget of Nothing -> Nothing @@ -269,8 +369,10 @@ checkFlagsUsed :: (MonadThrow m, MonadReader env m, HasBuildConfig env) => BuildOpts -> [LocalPackage] + -> Map PackageName extraDeps -- ^ extra deps + -> Map PackageName snapshot -- ^ snapshot, for error messages -> m () -checkFlagsUsed bopts lps = do +checkFlagsUsed bopts lps extraDeps snapshot = do bconfig <- asks getBuildConfig -- Check if flags specified in stack.yaml and the command line are @@ -283,9 +385,12 @@ case Map.lookup name localNameMap of -- Package is not available locally Nothing -> - case Map.lookup name $ bcExtraDeps bconfig of + case Map.lookup name extraDeps of -- Also not in extra-deps, it's an error - Nothing -> Just $ UFNoPackage source name + Nothing -> + case Map.lookup name snapshot of + Nothing -> Just $ UFNoPackage source name + Just _ -> Just $ UFSnapshot name -- We don't check for flag presence for extra deps Just _ -> Nothing -- Package exists locally, let's check if the flags are defined diff --git a/src/Stack/Build/Target.hs b/src/Stack/Build/Target.hs --- a/src/Stack/Build/Target.hs +++ b/src/Stack/Build/Target.hs @@ -13,6 +13,7 @@ , RawTarget (..) , LocalPackageView (..) , SimpleTarget (..) + , NeedTargets (..) -- * Parsers , parseRawTarget , parseTargets @@ -26,13 +27,14 @@ import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe (mapMaybe) -import Data.Monoid (mconcat) +import Data.Monoid import Data.Set (Set) import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as T import Path import Path.IO +import Prelude -- Fix redundant import warnings import Stack.Types -- | The name of a component, which applies to executables, test suites, and benchmarks @@ -53,7 +55,7 @@ RTPackageComponent :: !PackageName -> !UnresolvedComponent -> RawTarget a RTComponent :: !ComponentName -> RawTarget a RTPackage :: !PackageName -> RawTarget a - RTPackageIdentifier :: !PackageIdentifier -> RawTarget HasIdents + RTPackageIdentifier :: !PackageIdentifier -> RawTarget 'HasIdents deriving instance Show (RawTarget a) deriving instance Eq (RawTarget a) @@ -63,7 +65,7 @@ -- | If this function returns @Nothing@, the input should be treated as a -- directory. -parseRawTarget :: Text -> Maybe (RawTarget HasIdents) +parseRawTarget :: Text -> Maybe (RawTarget 'HasIdents) parseRawTarget t = (RTPackageIdentifier <$> parsePackageIdentifierFromString s) <|> (RTPackage <$> parsePackageNameFromString s) @@ -107,7 +109,7 @@ => Path Abs Dir -- ^ current directory -> Map PackageName LocalPackageView -> Text - -> m (Either Text [(RawInput, RawTarget HasIdents)]) + -> m (Either Text [(RawInput, RawTarget 'HasIdents)]) parseRawTargetDirs root locals t = case parseRawTarget t of Just rt -> return $ Right [(ri, rt)] @@ -139,8 +141,8 @@ resolveIdents :: Map PackageName Version -- ^ snapshot -> Map PackageName Version -- ^ extra deps -> Map PackageName LocalPackageView - -> (RawInput, RawTarget HasIdents) - -> Either Text ((RawInput, RawTarget NoIdents), Map PackageName Version) + -> (RawInput, RawTarget 'HasIdents) + -> Either Text ((RawInput, RawTarget 'NoIdents), Map PackageName Version) resolveIdents _ _ _ (ri, RTPackageComponent x y) = Right ((ri, RTPackageComponent x y), Map.empty) resolveIdents _ _ _ (ri, RTComponent x) = Right ((ri, RTComponent x), Map.empty) resolveIdents _ _ _ (ri, RTPackage x) = Right $ ((ri, RTPackage x), Map.empty) @@ -174,7 +176,7 @@ resolveRawTarget :: Map PackageName Version -- ^ snapshot -> Map PackageName Version -- ^ extra deps -> Map PackageName LocalPackageView - -> (RawInput, RawTarget NoIdents) + -> (RawInput, RawTarget 'NoIdents) -> Either Text (PackageName, (RawInput, SimpleTarget)) resolveRawTarget snap extras locals (ri, rt) = go rt @@ -266,15 +268,21 @@ getLocalComp (STLocalComps comps) = Right comps getLocalComp _ = Left () +-- | Need targets, e.g. `stack build` or allow none? +data NeedTargets + = NeedTargets + | AllowNoTargets + parseTargets :: (MonadThrow m, MonadIO m) - => Bool -- ^ using implicit global? + => NeedTargets -- ^ need at least one target + -> Bool -- ^ using implicit global? -> Map PackageName Version -- ^ snapshot -> Map PackageName Version -- ^ extra deps -> Map PackageName LocalPackageView -> Path Abs Dir -- ^ current directory -> [Text] -- ^ command line targets -> m (Map PackageName Version, Map PackageName SimpleTarget) -parseTargets implicitGlobal snap extras locals currDir textTargets' = do +parseTargets needTargets implicitGlobal snap extras locals currDir textTargets' = do let textTargets = if null textTargets' then map (T.pack . packageNameString) $ Map.keys $ Map.filter (not . lpvExtraDep) locals @@ -291,9 +299,13 @@ if null errs then if Map.null targets - then throwM $ TargetParseException - $ if implicitGlobal - then ["The specified targets matched no packages.\nPerhaps you need to run 'stack init'?"] - else ["The specified targets matched no packages"] + then case needTargets of + AllowNoTargets -> + return (Map.empty, Map.empty) + NeedTargets -> + throwM $ TargetParseException + $ if implicitGlobal + then ["The specified targets matched no packages.\nPerhaps you need to run 'stack init'?"] + else ["The specified targets matched no packages"] else return (Map.unions newExtras, targets) else throwM $ TargetParseException errs diff --git a/src/Stack/BuildPlan.hs b/src/Stack/BuildPlan.hs --- a/src/Stack/BuildPlan.hs +++ b/src/Stack/BuildPlan.hs @@ -51,7 +51,7 @@ import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe (fromMaybe, mapMaybe) -import Data.Monoid ((<>), Monoid (..)) +import Data.Monoid import Data.Set (Set) import qualified Data.Set as Set import qualified Data.Text as T @@ -208,11 +208,11 @@ } toMiniBuildPlan :: (MonadIO m, MonadLogger m, MonadReader env m, HasHttpManager env, MonadThrow m, HasConfig env, MonadBaseControl IO m, MonadCatch m) - => Version -- ^ GHC version + => CompilerVersion -- ^ Compiler version -> Map PackageName Version -- ^ cores -> Map PackageName (Version, Map FlagName Bool) -- ^ non-core packages -> m MiniBuildPlan -toMiniBuildPlan ghcVersion corePackages packages = do +toMiniBuildPlan compilerVersion corePackages packages = do $logInfo "Caching build plan" -- Determine the dependencies of all of the packages in the build plan. We @@ -220,13 +220,13 @@ -- package index. For those, we allow missing packages to exist, and then -- remove those from the list of dependencies, since there's no way we'll -- ever reinstall them anyway. - (cores, missingCores) <- addDeps True ghcVersion + (cores, missingCores) <- addDeps True compilerVersion $ fmap (, Map.empty) corePackages - (extras, missing) <- addDeps False ghcVersion packages + (extras, missing) <- addDeps False compilerVersion packages assert (Set.null missing) $ return MiniBuildPlan - { mbpGhcVersion = ghcVersion + { mbpCompilerVersion = compilerVersion , mbpPackages = Map.unions [ fmap (removeMissingDeps (Map.keysSet cores)) cores , extras @@ -250,10 +250,10 @@ -- | Add in the resolved dependencies from the package index addDeps :: (MonadIO m, MonadLogger m, MonadReader env m, HasHttpManager env, MonadThrow m, HasConfig env, MonadBaseControl IO m, MonadCatch m) => Bool -- ^ allow missing - -> Version -- ^ GHC version + -> CompilerVersion -- ^ Compiler version -> Map PackageName (Version, Map FlagName Bool) -> m (Map PackageName MiniPackageInfo, Set PackageIdentifier) -addDeps allowMissing ghcVersion toCalc = do +addDeps allowMissing compilerVersion toCalc = do menv <- getMinimalEnvOverride platform <- asks $ configPlatform . getConfig (resolvedMap, missingIdents) <- @@ -280,7 +280,7 @@ { packageConfigEnableTests = False , packageConfigEnableBenchmarks = False , packageConfigFlags = flags - , packageConfigGhcVersion = ghcVersion + , packageConfigCompilerVersion = compilerVersion , packageConfigPlatform = platform } name = packageIdentifierName ident @@ -438,7 +438,7 @@ taggedDecodeOrLoad fp $ liftM buildPlanFixes $ do bp <- loadBuildPlan name toMiniBuildPlan - (siGhcVersion $ bpSystemInfo bp) + (siCompilerVersion $ bpSystemInfo bp) (siCorePackages $ bpSystemInfo bp) (fmap goPP $ bpPackages bp) where @@ -526,11 +526,11 @@ { packageConfigEnableTests = True , packageConfigEnableBenchmarks = True , packageConfigFlags = flags - , packageConfigGhcVersion = ghcVersion + , packageConfigCompilerVersion = compilerVersion , packageConfigPlatform = platform } - ghcVersion = mbpGhcVersion mbp + compilerVersion = mbpCompilerVersion mbp flagName' = fromCabalFlagName . flagName @@ -638,8 +638,8 @@ shadowMiniBuildPlan :: MiniBuildPlan -> Set PackageName -> (MiniBuildPlan, Map PackageName MiniPackageInfo) -shadowMiniBuildPlan (MiniBuildPlan ghc pkgs0) shadowed = - (MiniBuildPlan ghc $ Map.fromList met, Map.fromList unmet) +shadowMiniBuildPlan (MiniBuildPlan cv pkgs0) shadowed = + (MiniBuildPlan cv $ Map.fromList met, Map.fromList unmet) where pkgs1 = Map.difference pkgs0 $ Map.fromSet (\_ -> ()) shadowed @@ -699,7 +699,7 @@ addFlags (PackageIdentifier name ver) = (name, (ver, fromMaybe Map.empty $ Map.lookup name $ csFlags cs)) toMiniBuildPlan - (csGhcVersion cs) + (csCompilerVersion cs) Map.empty (Map.fromList $ map addFlags $ Set.toList $ csPackages cs) where @@ -728,14 +728,15 @@ parseAbsFile fp data CustomSnapshot = CustomSnapshot - { csGhcVersion :: !Version + { csCompilerVersion :: !CompilerVersion , csPackages :: !(Set PackageIdentifier) , csFlags :: !(Map PackageName (Map FlagName Bool)) } instance FromJSON CustomSnapshot where parseJSON = withObject "CustomSnapshot" $ \o -> CustomSnapshot - <$> ((o .: "compiler") >>= (\t -> maybe (fail $ "Invalid compiler: " ++ T.unpack t) return $ do - t' <- T.stripPrefix "ghc-" t - parseVersionFromString $ T.unpack t')) + <$> ((o .: "compiler") >>= \t -> + case parseCompilerVersion t of + Nothing -> fail $ "Invalid compiler: " ++ T.unpack t + Just compilerVersion -> return compilerVersion) <*> o .: "packages" <*> o .:? "flags" .!= Map.empty diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -29,6 +29,7 @@ import qualified Codec.Archive.Tar as Tar import qualified Codec.Compression.GZip as GZip import Control.Applicative +import Control.Arrow ((***)) import Control.Exception (IOException) import Control.Monad import Control.Monad.Catch (Handler(..), MonadCatch, MonadThrow, catches, throwM) @@ -67,7 +68,7 @@ import System.Directory (getAppUserDataDirectory, createDirectoryIfMissing, canonicalizePath) import System.Environment import System.IO -import System.Process.Read (getEnvOverride, EnvOverride, unEnvOverride, readInNull) +import System.Process.Read -- | Get the latest snapshot resolver available. getLatestResolver @@ -137,7 +138,13 @@ configImage = Image.imgOptsFromMonoid configMonoidImageOpts - origEnv <- getEnvOverride configPlatform + configCompilerCheck = fromMaybe MatchMinor configMonoidCompilerCheck + + rawEnv <- liftIO getEnvironment + origEnv <- mkEnvOverride configPlatform + $ augmentPathMap (map toFilePath configMonoidExtraPath) + $ Map.fromList + $ map (T.pack *** T.pack) rawEnv let configEnvOverride _ = return origEnv platform <- runReaderT platformRelDir configPlatform @@ -166,9 +173,9 @@ Just i -> return i let configConcurrentTests = fromMaybe True configMonoidConcurrentTests - let configAuthorEmail = configMonoidAuthorEmail - configAuthorName = configMonoidAuthorName + let configTemplateParams = configMonoidTemplateParameters configScmInit = configMonoidScmInit + configGhcOptions = configMonoidGhcOptions return Config {..} @@ -282,20 +289,20 @@ (MiniConfig manager config) let project = project' { projectResolver = resolver } - ghcVersion <- + wantedCompiler <- case projectResolver project of ResolverSnapshot snapName -> do mbp <- runReaderT (loadMiniBuildPlan snapName) miniConfig - return $ mbpGhcVersion mbp - ResolverGhc m -> return $ fromMajorVersion m + return $ mbpCompilerVersion mbp ResolverCustom _name url -> do mbp <- runReaderT (parseCustomMiniBuildPlan stackYamlFP url) miniConfig - return $ mbpGhcVersion mbp + return $ mbpCompilerVersion mbp + ResolverCompiler wantedCompiler -> return wantedCompiler return BuildConfig { bcConfig = config , bcResolver = projectResolver project - , bcGhcVersionExpected = ghcVersion + , bcWantedCompiler = wantedCompiler , bcPackageEntries = projectPackages project , bcExtraDeps = projectExtraDeps project , bcStackYaml = stackYamlFP diff --git a/src/Stack/Constants.hs b/src/Stack/Constants.hs --- a/src/Stack/Constants.hs +++ b/src/Stack/Constants.hs @@ -32,12 +32,8 @@ ,dotHpc ,objectInterfaceDir ,templatesDir - ,defaultAuthorEmail - ,defaultAuthorName ,globalConfigPath - ,authorEmailKey - ,authorNameKey - ,scmInitKey) + ) where import Control.Monad.Catch (MonadThrow) @@ -299,14 +295,6 @@ -- | Where .mix files go. dotHpc :: Path Rel Dir dotHpc = $(mkRelDir ".hpc") - --- | Default author email. -defaultAuthorEmail :: Text -defaultAuthorEmail = "example@example.com" - --- | Default author name. -defaultAuthorName :: Text -defaultAuthorName = "Example Author Name" -- | Global config path. globalConfigPath :: Config -> Path Abs File diff --git a/src/Stack/Docker.hs b/src/Stack/Docker.hs --- a/src/Stack/Docker.hs +++ b/src/Stack/Docker.hs @@ -31,7 +31,7 @@ import Data.ByteString.Builder (stringUtf8,charUtf8,toLazyByteString) import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as LBS -import Data.Char (isSpace,toUpper,isAscii) +import Data.Char (isSpace,toUpper,isAscii,isDigit) import Data.List (dropWhileEnd,find,intercalate,intersperse,isPrefixOf,isInfixOf,foldl',sortBy) import Data.List.Extra (trim) import Data.Map.Strict (Map) @@ -45,6 +45,7 @@ import Data.Typeable (Typeable) import Path import Path.IO (getWorkingDir,listDirectory,createTree,removeFile,removeTree,dirExists) +import Prelude -- Fix redundant import warnings import Stack.Constants (projectDockerSandboxDir,stackProgName,stackDotYaml,stackRootEnvVar) import Stack.Types import Stack.Types.Internal @@ -60,7 +61,7 @@ import System.Process (CreateProcess(delegate_ctlc)) import Text.Printf (printf) -#ifndef mingw32_HOST_OS +#ifndef WINDOWS import Control.Monad.Trans.Control (liftBaseWith) import System.Posix.Signals #endif @@ -246,6 +247,7 @@ ,concatMap (\(k,v) -> ["-e", k ++ "=" ++ v]) envVars ,concatMap sandboxSubdirArg sandboxSubdirs ,concatMap mountArg (dockerMount docker) + ,concatMap (\nv -> ["-e", nv]) (dockerEnv docker) ,case dockerContainerName docker of Just name -> ["--name=" ++ name] Nothing -> [] @@ -256,7 +258,7 @@ ,[cmnd] ,args]) before -#ifndef mingw32_HOST_OS +#ifndef WINDOWS runInBase <- liftBaseWith $ \run -> return (void . run) oldHandlers <- forM (concat [[(sigINT,sigTERM) | not keepStdinOpen] ,[(sigTERM,sigTERM)]]) $ \(sigIn,sigOut) -> do @@ -274,7 +276,7 @@ ,["-a" | not (dockerDetach docker)] ,["-i" | keepStdinOpen] ,[containerID]])) -#ifndef mingw32_HOST_OS +#ifndef WINDOWS forM_ oldHandlers $ \(sig,oldHandler) -> liftIO $ installHandler sig oldHandler Nothing #endif @@ -586,7 +588,7 @@ dockerVersionOut <- readDockerProcess envOverride ["--version"] case words (decodeUtf8 dockerVersionOut) of (_:_:v:_) -> - case parseVersionFromString (dropWhileEnd (== ',') v) of + case parseVersionFromString (dropWhileEnd (not . isDigit) v) of Just v' | v' < minimumDockerVersion -> throwM (DockerTooOldException minimumDockerVersion v') @@ -676,6 +678,7 @@ ,dockerContainerName = emptyToNothing dockerMonoidContainerName ,dockerRunArgs = dockerMonoidRunArgs ,dockerMount = dockerMonoidMount + ,dockerEnv = dockerMonoidEnv ,dockerDatabasePath = case dockerMonoidDatabasePath of Nothing -> stackRoot $(mkRelFile "docker.db") diff --git a/src/Stack/Dot.hs b/src/Stack/Dot.hs --- a/src/Stack/Dot.hs +++ b/src/Stack/Dot.hs @@ -29,9 +29,11 @@ import qualified Data.Text.IO as Text import qualified Data.Traversable as T import Network.HTTP.Client.Conduit (HasHttpManager) +import Prelude -- Fix redundant import warnings import Stack.Build (withLoadPackage) import Stack.Build.Installed (getInstalled, GetInstalledOpts(..)) import Stack.Build.Source +import Stack.Build.Target import Stack.Constants import Stack.Package import Stack.Types @@ -87,7 +89,7 @@ => DotOpts -> m (Map PackageName (Set PackageName, Maybe Version)) createDependencyGraph dotOpts = do - (_,locals,_,sourceMap) <- loadSourceMap defaultBuildOpts + (_,_,locals,_,sourceMap) <- loadSourceMap NeedTargets defaultBuildOpts let graph = Map.fromList (localDependencies dotOpts locals) menv <- getMinimalEnvOverride installedMap <- fmap thrd . fst <$> getInstalled menv diff --git a/src/Stack/Exec.hs b/src/Stack/Exec.hs --- a/src/Stack/Exec.hs +++ b/src/Stack/Exec.hs @@ -15,7 +15,7 @@ import Stack.Types import System.Process.Log -#ifdef mingw32_HOST_OS +#ifdef WINDOWS import Control.Exception.Lifted import Data.Streaming.Process (ProcessExitedUnsuccessfully(..)) import System.Exit @@ -31,6 +31,7 @@ { esIncludeLocals = True , esIncludeGhcPackagePath = True , esStackExe = True + , esLocaleUtf8 = False } -- | Environment settings which do not embellish the environment @@ -39,6 +40,7 @@ { esIncludeLocals = False , esIncludeGhcPackagePath = False , esStackExe = False + , esLocaleUtf8 = False } -- | Execute a process within the Stack configured environment. @@ -48,7 +50,7 @@ config <- asks getConfig menv <- liftIO (configEnvOverride config envSettings) $logProcessRun cmd0 args -#ifdef mingw32_HOST_OS +#ifdef WINDOWS e <- try (callProcess Nothing menv cmd0 args) liftIO $ case e of Left (ProcessExitedUnsuccessfully _ ec) -> exitWith ec diff --git a/src/Stack/Fetch.hs b/src/Stack/Fetch.hs --- a/src/Stack/Fetch.hs +++ b/src/Stack/Fetch.hs @@ -335,14 +335,14 @@ if null sameMajor then Nothing else Just (map fst sameMajor) where sameMajor = filter (\(PackageIdentifier _ v, _) -> - getMajorVersion ver == getMajorVersion v) + toMajorVersion ver == toMajorVersion v) sameIdentCaches sameIdentCaches = maybe biggerFiltered (\z -> (zeroIdent, z) : biggerFiltered) zeroVer biggerFiltered = takeWhile (\(PackageIdentifier n _, _) -> name == n) (Map.toList bigger) - zeroIdent = PackageIdentifier name (fromMajorVersion (MajorVersion 0 0)) + zeroIdent = PackageIdentifier name $(mkVersion "0.0") (_, zeroVer, bigger) = Map.splitLookup zeroIdent caches -- | Figure out where to fetch from. diff --git a/src/Stack/FileWatch.hs b/src/Stack/FileWatch.hs --- a/src/Stack/FileWatch.hs +++ b/src/Stack/FileWatch.hs @@ -19,6 +19,7 @@ import qualified Data.Set as Set import Data.String (fromString) import Data.Traversable (forM) +import Ignore import Path import System.FSNotify import System.IO (stderr) @@ -32,11 +33,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. -fileWatch :: ((Set (Path Abs File) -> IO ()) -> IO ()) +fileWatch :: IO (Path Abs Dir) + -> ((Set (Path Abs File) -> IO ()) -> IO ()) -> IO () -fileWatch inner = withManager $ \manager -> do +fileWatch getProjectRoot inner = withManager $ \manager -> do dirtyVar <- newTVarIO True watchVar <- newTVarIO Map.empty + projRoot <- getProjectRoot + mChecker <- findIgnoreFiles [VCSGit, VCSMercurial, VCSDarcs] projRoot >>= buildChecker + (FileIgnoredChecker isFileIgnored) <- + case mChecker of + Left err -> + do putStrLn $ "Failed to parse VCS's ignore file: " ++ err + return $ FileIgnoredChecker (const False) + Right chk -> return chk let onChange = atomically $ writeTVar dirtyVar True @@ -67,7 +77,7 @@ return Nothing startListening = Map.mapWithKey $ \dir () -> do let dir' = fromString $ toFilePath dir - listen <- watchDir manager dir' (const True) (const onChange) + listen <- watchDir manager dir' (not . isFileIgnored . eventPath) (const onChange) return $ Just listen let watchInput = do @@ -84,7 +94,11 @@ "watched" -> do watch <- readTVarIO watchVar mapM_ (putStrLn . toFilePath) (Map.keys watch) - _ -> putStrLn $ "Unknown command: " ++ show line + _ -> putStrLn $ concat + [ "Unknown command: " + , show line + , ". Try 'help'" + ] watchInput @@ -92,9 +106,17 @@ atomically $ do dirty <- readTVar dirtyVar check dirty - writeTVar dirtyVar False eres <- tryAny $ inner setWatched + + -- Clear dirtiness flag after the build to avoid an infinite + -- loop caused by the build itself triggering dirtiness. This + -- could be viewed as a bug, since files changed during the + -- build will not trigger an extra rebuild, but overall seems + -- like better behavior. See + -- https://github.com/commercialhaskell/stack/issues/822 + atomically $ writeTVar dirtyVar False + case eres of Left e -> printExceptionStderr e Right () -> putStrLn "Success! Waiting for next file change." diff --git a/src/Stack/GhcPkg.hs b/src/Stack/GhcPkg.hs --- a/src/Stack/GhcPkg.hs +++ b/src/Stack/GhcPkg.hs @@ -18,7 +18,8 @@ ,findGhcPkgHaddockHtml ,findGhcPkgDepends ,findTransitiveGhcPkgDepends - ,listGhcPkgDbs) + ,listGhcPkgDbs + ,ghcPkgExeName) where import Control.Monad @@ -45,11 +46,11 @@ -- | Get the global package database getGlobalDB :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadThrow m) - => EnvOverride -> m (Path Abs Dir) -getGlobalDB menv = do + => EnvOverride -> WhichCompiler -> m (Path Abs Dir) +getGlobalDB menv wc = do -- This seems like a strange way to get the global package database -- location, but I don't know of a better one - bs <- ghcPkg menv [] ["list", "--global"] >>= either throwM return + bs <- ghcPkg menv wc [] ["list", "--global"] >>= either throwM return let fp = S8.unpack $ stripTrailingColon $ firstLine bs liftIO (canonicalizePath fp) >>= parseAbsDir where @@ -62,34 +63,40 @@ -- | Run the ghc-pkg executable ghcPkg :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadThrow m) => EnvOverride + -> WhichCompiler -> [Path Abs Dir] -> [String] -> m (Either ReadProcessException S8.ByteString) -ghcPkg menv pkgDbs args = do +ghcPkg menv wc pkgDbs args = do eres <- go r <- case eres of Left _ -> do - mapM_ (createDatabase menv) pkgDbs + mapM_ (createDatabase menv wc) pkgDbs go Right _ -> return eres return r where - go = tryProcessStdout Nothing menv "ghc-pkg" args' + go = tryProcessStdout Nothing menv (ghcPkgExeName wc) args' args' = packageDbFlags pkgDbs ++ args -- | Create a package database in the given directory, if it doesn't exist. createDatabase :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadThrow m) - => EnvOverride -> Path Abs Dir -> m () -createDatabase menv db = do + => EnvOverride -> WhichCompiler -> Path Abs Dir -> m () +createDatabase menv wc db = do exists <- dirExists db unless exists $ do -- Creating the parent doesn't seem necessary, as ghc-pkg -- seems to be sufficiently smart. But I don't feel like -- finding out it isn't the hard way createTree (parent db) - _ <- tryProcessStdout Nothing menv "ghc-pkg" ["init", toFilePath db] + _ <- tryProcessStdout Nothing menv (ghcPkgExeName wc) ["init", toFilePath db] return () +-- | Get the name to use for "ghc-pkg", given the compiler version. +ghcPkgExeName :: WhichCompiler -> String +ghcPkgExeName Ghc = "ghc-pkg" +ghcPkgExeName Ghcjs = "ghcjs-pkg" + -- | Get the necessary ghc-pkg flags for setting up the given package database packageDbFlags :: [Path Abs Dir] -> [String] packageDbFlags pkgDbs = @@ -100,14 +107,16 @@ findGhcPkgField :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadThrow m) => EnvOverride + -> WhichCompiler -> [Path Abs Dir] -- ^ package databases -> Text -> Text -> m (Maybe Text) -findGhcPkgField menv pkgDbs name field = do +findGhcPkgField menv wc pkgDbs name field = do result <- ghcPkg menv + wc pkgDbs ["field", "--simple-output", T.unpack name, T.unpack field] return $ @@ -121,11 +130,12 @@ -- | Get the id of the package e.g. @foo-0.0.0-9c293923c0685761dcff6f8c3ad8f8ec@. findGhcPkgId :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadThrow m) => EnvOverride + -> WhichCompiler -> [Path Abs Dir] -- ^ package databases -> PackageName -> m (Maybe GhcPkgId) -findGhcPkgId menv pkgDbs name = do - mpid <- findGhcPkgField menv pkgDbs (packageNameText name) "id" +findGhcPkgId menv wc pkgDbs name = do + mpid <- findGhcPkgField menv wc pkgDbs (packageNameText name) "id" case mpid of Just !pid -> return (parseGhcPkgId (T.encodeUtf8 pid)) _ -> return Nothing @@ -133,11 +143,12 @@ -- | Get the Haddock HTML documentation path of the package. findGhcPkgHaddockHtml :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadThrow m) => EnvOverride + -> WhichCompiler -> [Path Abs Dir] -- ^ package databases -> PackageIdentifier -> m (Maybe (Path Abs Dir)) -findGhcPkgHaddockHtml menv pkgDbs pkgId = do - mpath <- findGhcPkgField menv pkgDbs (packageIdentifierText pkgId) "haddock-html" +findGhcPkgHaddockHtml menv wc pkgDbs pkgId = do + mpath <- findGhcPkgField menv wc pkgDbs (packageIdentifierText pkgId) "haddock-html" case mpath of Just !path0 -> do let path = T.unpack path0 @@ -152,14 +163,15 @@ findTransitiveGhcPkgDepends :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadThrow m) => EnvOverride + -> WhichCompiler -> [Path Abs Dir] -- ^ package databases -> PackageIdentifier -> m (Set PackageIdentifier) -findTransitiveGhcPkgDepends menv pkgDbs pkgId0 = +findTransitiveGhcPkgDepends menv wc pkgDbs pkgId0 = go pkgId0 Set.empty where go pkgId res = do - deps <- findGhcPkgDepends menv pkgDbs pkgId + deps <- findGhcPkgDepends menv wc pkgDbs pkgId loop (map ghcPkgIdPackageIdentifier deps) res loop [] res = return res loop (dep:deps) res = do @@ -172,22 +184,24 @@ -- | Get the dependencies of the package. findGhcPkgDepends :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadThrow m) => EnvOverride + -> WhichCompiler -> [Path Abs Dir] -- ^ package databases -> PackageIdentifier -> m [GhcPkgId] -findGhcPkgDepends menv pkgDbs pkgId = do - mdeps <- findGhcPkgField menv pkgDbs (packageIdentifierText pkgId) "depends" +findGhcPkgDepends menv wc pkgDbs pkgId = do + mdeps <- findGhcPkgField menv wc pkgDbs (packageIdentifierText pkgId) "depends" case mdeps of Just !deps -> return (mapMaybe (parseGhcPkgId . T.encodeUtf8) (T.words deps)) _ -> return [] unregisterGhcPkgId :: (MonadIO m, MonadLogger m, MonadThrow m, MonadCatch m, MonadBaseControl IO m) => EnvOverride + -> WhichCompiler -> Path Abs Dir -- ^ package database -> GhcPkgId -> m () -unregisterGhcPkgId menv pkgDb gid = do - eres <- ghcPkg menv [pkgDb] args +unregisterGhcPkgId menv wc pkgDb gid = do + eres <- ghcPkg menv wc [pkgDb] args case eres of Left e -> $logWarn $ T.pack $ show e Right _ -> return () @@ -197,10 +211,11 @@ -- | Get the version of Cabal from the global package database. getCabalPkgVer :: (MonadThrow m, MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) - => EnvOverride -> m Version -getCabalPkgVer menv = + => EnvOverride -> WhichCompiler -> m Version +getCabalPkgVer menv wc = findGhcPkgId menv + wc [] -- global DB cabalPackageName >>= maybe @@ -209,11 +224,12 @@ listGhcPkgDbs :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadThrow m) - => EnvOverride -> [Path Abs Dir] -> m [PackageIdentifier] -listGhcPkgDbs menv pkgDbs = do + => EnvOverride -> WhichCompiler -> [Path Abs Dir] -> m [PackageIdentifier] +listGhcPkgDbs menv wc pkgDbs = do result <- ghcPkg menv + wc pkgDbs ["list", "--simple-output"] return $ diff --git a/src/Stack/Ghci.hs b/src/Stack/Ghci.hs --- a/src/Stack/Ghci.hs +++ b/src/Stack/Ghci.hs @@ -7,14 +7,16 @@ -- | Run a GHCi configured with the user's project(s). -module Stack.Ghci where +module Stack.Ghci (GhciOpts(..),GhciPkgInfo(..), ghciSetup, ghci) where import Control.Monad.Catch import Control.Monad.IO.Class import Control.Monad.Logger import Control.Monad.Reader -import Control.Monad.Trans.Control (MonadBaseControl) +import Control.Monad.Trans.Resource +import Data.Function import Data.List +import Data.Map.Strict (Map) import qualified Data.Map.Strict as M import Data.Maybe import Data.Monoid @@ -22,114 +24,256 @@ import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T -import Data.Typeable import Distribution.ModuleName (ModuleName) import Distribution.Text (display) import Network.HTTP.Client.Conduit import Path -import Path.IO +import Prelude +import Stack.Build import Stack.Build.Source +import Stack.Build.Target import Stack.Constants import Stack.Exec import Stack.Package import Stack.Types +import Stack.Types.Internal +-- | Command-line options for GHC. data GhciOpts = GhciOpts - {ghciTargets :: [Text] - ,ghciArgs :: [String] - ,ghciGhcCommand :: FilePath - ,ghciNoLoadModules :: Bool - ,ghciAdditionalPackages :: [String] + {ghciTargets :: ![Text] + ,ghciArgs :: ![String] + ,ghciGhcCommand :: !(Maybe FilePath) + ,ghciNoLoadModules :: !Bool + ,ghciAdditionalPackages :: ![String] + ,ghciMainIs :: !(Maybe Text) } deriving (Show,Eq) +-- | Necessary information to load a package or its components. +data GhciPkgInfo = GhciPkgInfo + { ghciPkgName :: PackageName + , ghciPkgOpts :: [String] + , ghciPkgDir :: Path Abs Dir + , ghciPkgModules :: Set ModuleName + , ghciPkgModFiles :: Set (Path Abs File) -- ^ Module file paths. + , ghciPkgMainIs :: Map NamedComponent (Set (Path Abs File)) + } + -- | Launch a GHCi session for the given local project targets with the -- given options and configure it with the load paths and extensions -- of those targets. -ghci :: (HasConfig r, HasBuildConfig r, HasHttpManager r, HasEnvConfig r, MonadReader r m, MonadIO m, MonadThrow m, MonadLogger m, MonadCatch m, MonadBaseControl IO m) - => GhciOpts - -> m () +ghci + :: (HasConfig r, HasBuildConfig r, HasHttpManager r, MonadMask m, HasLogLevel r, HasTerminal r, HasEnvConfig r, MonadReader r m, MonadIO m, MonadThrow m, MonadLogger m, MonadCatch m, MonadBaseControl IO m) + => GhciOpts -> m () ghci GhciOpts{..} = do - pkgs <- ghciSetup ghciTargets - config <- asks getBuildConfig + (targets,mainIsTargets,pkgs) <- ghciSetup ghciMainIs ghciTargets + bconfig <- asks getBuildConfig + mainFile <- figureOutMainFile mainIsTargets targets pkgs + wc <- getWhichCompiler let pkgopts = concatMap ghciPkgOpts pkgs srcfiles | ghciNoLoadModules = [] - | otherwise = concatMap (map display . S.toList . ghciPkgModules) pkgs - odir = ["-odir=" <> toFilePath (objectInterfaceDir config) - ,"-hidir=" <> toFilePath (objectInterfaceDir config)] + | otherwise = + nub (maybe [] (return . toFilePath) mainFile <> + concatMap (map display . S.toList . ghciPkgModules) pkgs) + odir = + [ "-odir=" <> toFilePath (objectInterfaceDir bconfig) + , "-hidir=" <> toFilePath (objectInterfaceDir bconfig)] $logInfo ("Configuring GHCi with the following packages: " <> T.intercalate ", " (map (packageNameText . ghciPkgName) pkgs)) exec defaultEnvSettings - ghciGhcCommand + (fromMaybe (compilerExeName wc) ghciGhcCommand) ("--interactive" : odir <> pkgopts <> srcfiles <> ghciArgs) -data GhciPkgInfo = GhciPkgInfo - { ghciPkgName :: PackageName - , ghciPkgOpts :: [String] - , ghciPkgDir :: Path Abs Dir - , ghciPkgModules :: Set ModuleName - } +-- | Figure out the main-is file to load based on the targets. Sometimes there +-- is none, sometimes it's unambiguous, sometimes it's +-- ambiguous. Warns and returns nothing if it's ambiguous. +figureOutMainFile + :: (Monad m, MonadLogger m) + => Maybe (Map PackageName SimpleTarget) + -> Map PackageName SimpleTarget + -> [GhciPkgInfo] + -> m (Maybe (Path Abs File)) +figureOutMainFile mainIsTargets targets0 packages = do + case candidates of + [] -> return Nothing + [c@(_,_,fp)] -> do $logInfo ("Using main module: " <> renderCandidate c) + return (Just fp) + candidate:_ -> do + let border = $logWarn "* * * * * * * *" + border + $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: " + $logWarn + (" 1) Specifying targets to stack ghci e.g. stack ghci " <> + sampleTargetArg candidate) + $logWarn + (" 2) Specifying what the main is e.g. stack ghci " <> + sampleMainIsArg candidate) + border + return Nothing + where + targets = fromMaybe targets0 mainIsTargets + candidates = do + pkg <- packages + case M.lookup (ghciPkgName pkg) targets of + Nothing -> [] + Just target -> do + (component,mains) <- + M.toList + (M.filterWithKey wantedComponent (ghciPkgMainIs pkg)) + main <- S.toList mains + return (ghciPkgName pkg, component, main) + where wantedComponent namedC _ = + case target of + STLocalAll -> True + STLocalComps cs -> S.member namedC cs + _ -> False + renderCandidate (pkgName,namedComponent,mainIs) = + "Package `" <> packageNameText pkgName <> "' component " <> + renderComp namedComponent <> + " with main-is file: " <> + T.pack (toFilePath mainIs) + renderComp c = + case c of + CLib -> "lib" + CExe name -> "exe:" <> name + CTest name -> "test:" <> name + CBench name -> "bench:" <> name + sampleTargetArg (pkg,comp,_) = + packageNameText pkg <> ":" <> renderComp comp + sampleMainIsArg (pkg,comp,_) = + "--main-is " <> packageNameText pkg <> ":" <> renderComp comp +-- | Create a list of infos for each target containing necessary +-- information to load that package/components. ghciSetup - :: (HasConfig r, HasHttpManager r, HasBuildConfig r, HasEnvConfig r, MonadReader r m, MonadIO m, MonadThrow m, MonadLogger m, MonadCatch m, MonadBaseControl IO m) - => [Text] -> m [GhciPkgInfo] -ghciSetup targets = do + :: (HasConfig r, HasHttpManager r, HasBuildConfig r, MonadMask m, HasTerminal r, HasLogLevel r, HasEnvConfig r, MonadReader r m, MonadIO m, MonadThrow m, MonadLogger m, MonadCatch m, MonadBaseControl IO m) + => Maybe Text + -> [Text] + -> m (Map PackageName SimpleTarget, Maybe (Map PackageName SimpleTarget), [GhciPkgInfo]) +ghciSetup mainIs stringTargets = do + (_,_,targets) <- + parseTargetsFromBuildOpts + AllowNoTargets + defaultBuildOpts + { boptsTargets = stringTargets + } + mainIsTargets <- + case mainIs of + Nothing -> return Nothing + Just target -> do + (_,_,targets') <- + parseTargetsFromBuildOpts + AllowNoTargets + defaultBuildOpts + { boptsTargets = [target] + } + return (Just targets') + let bopts = makeBuildOpts targets econfig <- asks getEnvConfig - bconfig <- asks getBuildConfig - pwd <- getWorkingDir - (_,_,_,sourceMap) <- loadSourceMap defaultBuildOpts + (realTargets,_,_,_,sourceMap) <- loadSourceMap AllowNoTargets bopts locals <- liftM catMaybes $ forM (M.toList (envConfigPackages econfig)) $ \(dir,validWanted) -> do cabalfp <- getCabalFileName dir name <- parsePackageNameFromFilePath cabalfp - if validWanted && wanted pwd cabalfp name - then return (Just (name, cabalfp)) + if validWanted + then case M.lookup name targets of + Just simpleTargets -> + return (Just (name, (cabalfp, simpleTargets))) + Nothing -> return Nothing else return Nothing - let findTarget x = find ((x ==) . packageNameText . fst) locals - unmetTargets = filter (isNothing . findTarget) targets - when (not (null unmetTargets)) $ throwM (TargetsNotFound unmetTargets) - forM locals $ - \(name,cabalfp) -> - do let config = - PackageConfig - { packageConfigEnableTests = True - , packageConfigEnableBenchmarks = True - , packageConfigFlags = localFlags mempty bconfig name - , packageConfigGhcVersion = envConfigGhcVersion econfig - , packageConfigPlatform = configPlatform - (getConfig bconfig) - } - pkg <- readPackage config cabalfp - pkgOpts <- - getPackageOpts (packageOpts pkg) sourceMap (map fst locals) cabalfp - modules <- getPackageModules (packageModules pkg) cabalfp - return - GhciPkgInfo - { ghciPkgName = packageName pkg - , ghciPkgOpts = filter (not . badForGhci) pkgOpts - , ghciPkgDir = parent cabalfp - , ghciPkgModules = modules - } + infos <- + forM locals $ + \(name,(cabalfp,components)) -> + makeGhciPkgInfo sourceMap (map fst locals) name cabalfp components + unless (M.null realTargets) (build (const (return ())) Nothing bopts) + return (realTargets, mainIsTargets, infos) where - wanted pwd cabalfp name = isInWantedList || targetsEmptyAndInDir + makeBuildOpts targets = + base + { boptsTargets = stringTargets + , boptsTests = any (hasLocalComp isCTest) elems + , boptsBenchmarks = any (hasLocalComp isCBench) elems + , boptsTestOpts = (boptsTestOpts base) + { toDisableRun = True + , toRerunTests = False + } + , boptsBenchmarkOpts = (boptsBenchmarkOpts base) + { beoDisableRun = True + } + , boptsBuildSubset = BSOnlyDependencies + } where - isInWantedList = elem (packageNameText name) targets - targetsEmptyAndInDir = null targets || isParentOf (parent cabalfp) pwd + base = defaultBuildOpts + elems = M.elems targets + hasLocalComp p t = + case t of + STLocalComps s -> any p (S.toList s) + STLocalAll -> True + _ -> False + isCTest nc = + case nc of + CTest{} -> True + _ -> False + isCBench nc = + case nc of + CBench{} -> True + _ -> False + +-- | Make information necessary to load the given package in GHCi. +makeGhciPkgInfo + :: (MonadReader r m, HasEnvConfig r, MonadLogger m, MonadIO m, MonadCatch m) + => SourceMap + -> [PackageName] + -> PackageName + -> Path Abs File + -> SimpleTarget + -> m GhciPkgInfo +makeGhciPkgInfo sourceMap locals name cabalfp components = do + econfig <- asks getEnvConfig + bconfig <- asks getBuildConfig + let config = + PackageConfig + { packageConfigEnableTests = True + , packageConfigEnableBenchmarks = True + , packageConfigFlags = localFlags mempty bconfig name + , packageConfigCompilerVersion = envConfigCompilerVersion econfig + , packageConfigPlatform = configPlatform (getConfig bconfig) + } + pkg <- readPackage config cabalfp + (componentsOpts,generalOpts) <- + getPackageOpts (packageOpts pkg) sourceMap locals cabalfp + (componentsModules,componentModFiles,_,mainIsFiles,_) <- + getPackageFiles (packageFiles pkg) cabalfp + let filterWithinWantedComponents m = + M.elems + (M.filterWithKey + (\k _ -> + case components of + STLocalComps cs -> S.member k cs + _ -> True) + m) + return + GhciPkgInfo + { ghciPkgName = packageName pkg + , ghciPkgOpts = filter + (not . badForGhci) + (generalOpts <> + concat (filterWithinWantedComponents componentsOpts)) + , ghciPkgDir = parent cabalfp + , ghciPkgModules = mconcat + (filterWithinWantedComponents componentsModules) + , ghciPkgModFiles = mconcat + (filterWithinWantedComponents componentModFiles) + , ghciPkgMainIs = M.map (S.map mainIsFile) mainIsFiles + } + where badForGhci :: String -> Bool badForGhci x = isPrefixOf "-O" x || elem x (words "-debug -threaded -ticky") - -data GhciSetupException = - TargetsNotFound [Text] - deriving Typeable - -instance Exception GhciSetupException -instance Show GhciSetupException where - show (TargetsNotFound targets) = unlines - [ "Couldn't find targets: " ++ T.unpack (T.unwords targets) - , "(expecting package names)" - ] diff --git a/src/Stack/Ide.hs b/src/Stack/Ide.hs --- a/src/Stack/Ide.hs +++ b/src/Stack/Ide.hs @@ -26,7 +26,6 @@ import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T -import Distribution.Text (display) import Network.HTTP.Client.Conduit import Path import Path.IO @@ -35,6 +34,7 @@ import Stack.Ghci (GhciPkgInfo(..), ghciSetup) import Stack.Package import Stack.Types +import Stack.Types.Internal import System.Directory (doesFileExist) import System.Environment (lookupEnv) import System.Exit @@ -46,12 +46,12 @@ -- given options and configure it with the load paths and extensions -- of those targets. ide - :: (HasConfig r, HasBuildConfig r, HasEnvConfig r, MonadReader r m, MonadIO m, MonadThrow m, MonadLogger m, MonadCatch m, MonadBaseControl IO m, HasHttpManager r) + :: (HasConfig r, HasBuildConfig r, HasTerminal r, HasLogLevel r, MonadMask m, HasEnvConfig r, MonadReader r m, MonadIO m, MonadThrow m, MonadLogger m, MonadCatch m, MonadBaseControl IO m, HasHttpManager r) => [Text] -- ^ Targets. -> [String] -- ^ GHC options. -> m () ide targets useropts = do - pkgs <- ghciSetup targets + (_realTargets,_,pkgs) <- ghciSetup Nothing targets pwd <- getWorkingDir (pkgopts,srcfiles) <- liftM mconcat $ @@ -69,12 +69,12 @@ return ( ["--dist-dir=" <> toFilePath dist] ++ map ("--ghc-option=" ++) (ghciPkgOpts pkg) - , (map display (S.toList (ghciPkgModules pkg)) <> - (mapMaybe - (fmap toFilePath . stripDir pwd) - (if paths_foo_exists - then [paths_foo] - else [])))) + , mapMaybe + (fmap toFilePath . stripDir pwd) + (S.toList (ghciPkgModFiles pkg) <> + if paths_foo_exists + then [paths_foo] + else [])) localdb <- packageDatabaseLocal depsdb <- packageDatabaseDeps mpath <- liftIO $ lookupEnv "PATH" diff --git a/src/Stack/Init.hs b/src/Stack/Init.hs --- a/src/Stack/Init.hs +++ b/src/Stack/Init.hs @@ -148,16 +148,16 @@ mpair <- case resolver of ResolverSnapshot name -> findBuildPlan gpds [name] - ResolverGhc _ -> return Nothing + 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 - (ghcVersion, extraDeps) <- cabalSolver (map parent cabalfps) Map.empty [] + (compilerVersion, extraDeps) <- cabalSolver Ghc (map parent cabalfps) Map.empty [] return - ( ResolverGhc ghcVersion + ( ResolverCompiler compilerVersion , Map.filter (not . Map.null) $ fmap snd extraDeps , fmap fst extraDeps ) diff --git a/src/Stack/New.hs b/src/Stack/New.hs --- a/src/Stack/New.hs +++ b/src/Stack/New.hs @@ -58,8 +58,12 @@ -- | Options for creating a new project. data NewOpts = NewOpts - { newOptsProjectName :: PackageName -- ^ Name of the project to create. - , newOptsTemplate :: TemplateName -- ^ Name of the template to use. + { newOptsProjectName :: PackageName + -- ^ Name of the project to create. + , newOptsTemplate :: TemplateName + -- ^ Name of the template to use. + , newOptsNonceParams :: Map Text Text + -- ^ Nonce parameters specified just for this invocation. } -- | Create a new project with the given options. @@ -76,7 +80,13 @@ else do logUsing relDir templateText <- loadTemplate template - files <- applyTemplate project absDir templateText + files <- + applyTemplate + project + template + (newOptsNonceParams opts) + absDir + templateText writeTemplateFiles files runTemplateInits absDir return absDir @@ -110,15 +120,26 @@ -- | Apply and unpack a template into a directory. applyTemplate :: (MonadIO m, MonadThrow m, MonadReader r m, HasConfig r, MonadLogger m) - => PackageName -> Path Abs Dir -> Text -> m (Map (Path Abs File) LB.ByteString) -applyTemplate project dir template = do + => PackageName + -> TemplateName + -> Map Text Text + -> Path Abs Dir + -> Text + -> m (Map (Path Abs File) LB.ByteString) +applyTemplate project template nonceParams dir templateText = do config <- asks getConfig - displayContext config - applied <- - hastacheStr - defaultConfig - template - (mkStrContext (contextFunction config)) + let context = M.union (M.union nonceParams name) configParams + where + name = M.fromList [("name", packageNameText project)] + configParams = configTemplateParams config + (applied,missingKeys) <- + runWriterT + (hastacheStr + defaultConfig + templateText + (mkStrContextM (contextFunction context))) + when (not (S.null missingKeys)) + ($logInfo (T.pack (show (MissingParameters project template config missingKeys)))) files :: Map FilePath LB.ByteString <- execWriterT $ yield (T.encodeUtf8 (LT.toStrict applied)) $$ @@ -131,30 +152,20 @@ return (dir path, bytes)) (M.toList files)) where - context config = - [ ("name", packageNameText project) - , ( authorEmailKey - , fromMaybe defaultAuthorEmail (configAuthorEmail config)) - , (authorNameKey, fromMaybe defaultAuthorName (configAuthorName config))] - contextFunction :: Config -> String -> MuType m - contextFunction config key = - case lookup (T.pack key) (context config) of - Nothing -> MuNothing - Just value -> MuVariable value - --- | Display the context being used for the template. -displayContext :: MonadLogger m => Config -> m () -displayContext config = do - $logInfo "Using the following authorship configuration:" - $logInfo - (authorEmailKey <> ": " <> - fromMaybe defaultAuthorEmail (configAuthorEmail config)) - $logInfo - (authorNameKey <> ": " <> - fromMaybe defaultAuthorName (configAuthorName config)) - $logInfo - ("Copy these to " <> T.pack (toFilePath (globalConfigPath config)) <> - " and edit to use different values.") + -- | Does a lookup in the context and returns a moustache value, + -- on the side, writes out a set of keys that were requested but + -- not found. + contextFunction + :: Monad m + => Map Text Text + -> String + -> WriterT (Set String) m (MuType (WriterT (Set String) m)) + contextFunction context key = do + case M.lookup (T.pack key) context of + Nothing -> do + tell (S.singleton key) + return MuNothing + Just value -> return (MuVariable value) -- | Write files to the new project directory. writeTemplateFiles @@ -260,6 +271,7 @@ | BadTemplatesResponse !Int | BadTemplatesJSON !String !LB.ByteString | AlreadyExists !(Path Abs Dir) + | MissingParameters !PackageName !TemplateName !Config !(Set String) deriving (Typeable) instance Exception NewException @@ -289,3 +301,28 @@ show (BadTemplatesJSON err bytes) = "Github returned some JSON that couldn't be parsed: " <> err <> "\n\n" <> L8.unpack bytes + show (MissingParameters name template config missingKeys) = + intercalate + "\n" + [ "The following parameters were needed by the template but not provided: " <> + intercalate ", " (S.toList missingKeys) + , "You can provide them in " <> + toFilePath (globalConfigPath config) <> + ", like this:" + , "templates:" + , " params:" + , intercalate + "\n" + (map + (\key -> + " " <> key <> ": value") + (S.toList missingKeys)) + , "Or you can pass each one as parameters like this:" + , "stack new " <> packageNameString name <> " " <> + T.unpack (templateName template) <> + " " <> + unwords + (map + (\key -> + "-p \"" <> key <> ":value\"") + (S.toList missingKeys))] diff --git a/src/Stack/Options.hs b/src/Stack/Options.hs --- a/src/Stack/Options.hs +++ b/src/Stack/Options.hs @@ -24,6 +24,7 @@ import Data.List.Split (splitOn) import qualified Data.Map as Map import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M import Data.Maybe import Data.Monoid import qualified Data.Set as Set @@ -41,6 +42,7 @@ import Stack.Init import Stack.New import Stack.Types +import Stack.Types.TemplateName -- | Command sum type for conditional arguments. data Command @@ -58,6 +60,10 @@ metavar "BENCH_ARGS" <> help ("Forward BENCH_ARGS to the benchmark suite. " <> "Supports templates from `cabal bench`"))) + <*> flag False + True + (long "no-run-benchmarks" <> + help "Disable running of benchmarks. (Benchmarks will still be built.)") addCoverageFlags :: BuildOpts -> BuildOpts addCoverageFlags bopts @@ -71,20 +77,19 @@ buildOptsParser cmd = fmap addCoverageFlags $ BuildOpts <$> target <*> libProfiling <*> exeProfiling <*> - optimize <*> haddock <*> haddockDeps <*> dryRun <*> ghcOpts <*> + (optimize *> haddock) <*> haddockDeps <*> dryRun <*> ghcOpts <*> flags <*> copyBins <*> preFetch <*> buildSubset <*> fileWatch' <*> keepGoing <*> forceDirty <*> tests <*> testOptsParser <*> benches <*> benchOptsParser <*> - many exec + many exec <*> onlyConfigure where optimize = - maybeBoolFlags "optimizations" "optimizations for TARGETs and all its dependencies" idm + maybeBoolFlags "optimizations" "DEPRECATED: This flag is no longer used, and has no effect. Please use --ghc-options=-O?" idm target = - fmap (map T.pack) - (many (strArgument - (metavar "TARGET" <> - help "If none specified, use all packages"))) + many (textArgument + (metavar "TARGET" <> + help "If none specified, use all packages")) libProfiling = boolFlags False "library-profiling" @@ -120,18 +125,16 @@ ( long "pedantic" <> help "Turn on -Wall and -Werror (note: option name may change in the future" ) - <*> many (fmap T.pack - (strOption (long "ghc-options" <> - metavar "OPTION" <> - help "Additional options passed to GHC"))) + <*> many (textOption (long "ghc-options" <> + metavar "OPTION" <> + help "Additional options passed to GHC")) - flags = - fmap (Map.unionsWith Map.union) $ many - (option readFlag - ( long "flag" - <> metavar "PACKAGE:[-]FLAG" - <> help "Override flags set in stack.yaml (applies to local packages and extra-deps)" - )) + flags = Map.unionsWith Map.union <$> many + (option readFlag + (long "flag" <> + metavar "PACKAGE:[-]FLAG" <> + help ("Override flags set in stack.yaml " <> + "(applies to local packages and extra-deps)"))) preFetch = flag False True (long "prefetch" <> @@ -144,11 +147,14 @@ <|> flag' BSOnlyDependencies (long "only-dependencies" <> help "Only build packages that are dependencies of targets on the command line") + <|> flag' BSOnlyDependencies + (long "dependencies-only" <> + help "A synonym for --only-dependencies") <|> pure BSAll fileWatch' = flag False True (long "file-watch" <> - help "Watch for changes in local files and automatically rebuild") + help "Watch for changes in local files and automatically rebuild. Ignores files in VCS boring/ignore file") keepGoing = maybeBoolFlags "keep-going" @@ -175,6 +181,10 @@ metavar "CMD [ARGS]" <> help "Command and arguments to run after a successful build" ) + onlyConfigure = flag False True + (long "only-configure" <> + help "Only perform the configure step, not any builds. Intended for tool usage, may break when used on multiple packages at once!") + -- | Parser for package:[-]flag readFlag :: ReadM (Map (Maybe PackageName) (Map FlagName Bool)) readFlag = do @@ -239,16 +249,16 @@ <> metavar "JOBS" <> help "Number of concurrent jobs to run" )) - <*> fmap (Set.fromList . map T.pack) (many $ strOption + <*> fmap Set.fromList (many (textOption ( long "extra-include-dirs" <> metavar "DIR" <> help "Extra directories to check for C header files" - )) - <*> fmap (Set.fromList . map T.pack) (many $ strOption + ))) + <*> fmap Set.fromList (many (textOption ( long "extra-lib-dirs" <> metavar "DIR" <> help "Extra directories to check for libraries" - )) + ))) <*> maybeBoolFlags "skip-ghc-check" "skipping the GHC version and architecture check" @@ -313,7 +323,12 @@ hide <> metavar "(PATH | HOST-PATH:CONTAINER-PATH)" <> help ("Mount volumes from host in container " ++ - "(may specify mutliple times)"))) + "(may specify multiple times)"))) + <*> many (option str (long (dockerOptName dockerEnvArgName) <> + hide <> + metavar "NAME=VALUE" <> + help ("Set environment variable in container " ++ + "(may specify multiple times)"))) <*> maybeStrOption (long (dockerOptName dockerDatabasePathArgName) <> hide <> metavar "PATH" <> @@ -403,23 +418,27 @@ ghciOptsParser :: Parser GhciOpts ghciOptsParser = GhciOpts - <$> fmap (map T.pack) - (many (strArgument - (metavar "TARGET" <> - help ("If none specified, " <> - "use all packages defined in current directory")))) + <$> many (textArgument + (metavar "TARGET" <> + help ("If none specified, " <> + "use all packages defined in current directory"))) <*> fmap concat (many (argsOption (long "ghc-options" <> - metavar "OPTION" <> - help "Additional options passed to GHCi"))) - <*> strOption (long "with-ghc" <> - metavar "GHC" <> - help "Use this command for the GHC to run" <> - value "ghc" <> - showDefault) + metavar "OPTION" <> + help "Additional options passed to GHCi"))) + <*> optional + (strOption (long "with-ghc" <> + metavar "GHC" <> + help "Use this command for the GHC to run")) <*> flag False True (long "no-load" <> help "Don't load modules on start-up") <*> packagesParser - + <*> optional + (textOption + (long "main-is" <> + metavar "TARGET" <> + help "Specify which target should contain the main \ + \module to load, such as for an executable for \ + \test suite or benchmark.")) -- | Parser for exec command execOptsParser :: Maybe String -- ^ command @@ -450,6 +469,7 @@ "stack-exe" "setting the STACK_EXE environment variable to the path for the stack executable" idm + <*> pure False eoPackagesParser :: Parser [String] eoPackagesParser = many (strOption (long "package" <> help "Additional packages that must be installed")) @@ -476,10 +496,14 @@ (long "no-terminal" <> help "Override terminal detection in the case of running in a false terminal") <*> - (optional (strOption - (long "stack-yaml" <> - metavar "STACK-YAML" <> - help "Override project stack.yaml file (overrides any STACK_YAML environment variable)"))) + optional (strOption (long "stack-yaml" <> + metavar "STACK-YAML" <> + help ("Override project stack.yaml file " <> + "(overrides any STACK_YAML environment variable)"))) <*> + boolFlags True + "modify-code-page" + "setting the codepage to support UTF-8 (Windows only)" + idm initOptsParser :: Parser InitOpts initOptsParser = @@ -603,5 +627,12 @@ templateNameArgument (metavar "TEMPLATE_NAME" <> help "Name of a template, for example: foo or foo.hsfiles" <> - value defaultTemplateName) <* + value defaultTemplateName) <*> + fmap + M.fromList + (many + (templateParamArgument + (short 'p' <> long "param" <> metavar "KEY:VALUE" <> + help + "Parameter for the template in the format key:value"))) <* abortOption ShowHelpText (long "help" <> help "Show help text.") diff --git a/src/Stack/Package.hs b/src/Stack/Package.hs --- a/src/Stack/Package.hs +++ b/src/Stack/Package.hs @@ -8,6 +8,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE CPP #-} -- | Dealing with Cabal. @@ -29,10 +30,10 @@ ,packageToolDependencies ,packageDependencies ,packageIdentifier - ,autogenDir) + ,autogenDir + ,checkCabalFileName) where -import Control.Arrow ((***)) import Control.Exception hiding (try,catch) import Control.Monad import Control.Monad.Catch @@ -68,7 +69,7 @@ import Path as FL import Path.Find import Path.IO -import Prelude hiding (FilePath) +import Prelude import Safe (headDef, tailSafe) import Stack.Constants import Stack.Types @@ -133,58 +134,82 @@ readPackageDir packageConfig dir = do cabalfp <- getCabalFileName dir pkg <- readPackage packageConfig cabalfp - name <- parsePackageNameFromFilePath cabalfp - when (packageName pkg /= name) - $ throwM $ MismatchedCabalName cabalfp name + checkCabalFileName (packageName pkg) cabalfp + return (cabalfp, pkg) +-- | Check if the given name in the @Package@ matches the name of the .cabal file +checkCabalFileName :: MonadThrow m => PackageName -> Path Abs File -> m () +checkCabalFileName name cabalfp = do + -- Previously, we just use parsePackageNameFromFilePath. However, that can + -- lead to confusing error messages. See: + -- https://github.com/commercialhaskell/stack/issues/895 + let expected = packageNameString name ++ ".cabal" + when (expected /= toFilePath (filename cabalfp)) + $ throwM $ MismatchedCabalName cabalfp name + -- | Resolve a parsed cabal file into a 'Package'. resolvePackage :: PackageConfig -> GenericPackageDescription -> Package -resolvePackage packageConfig gpkg = Package +resolvePackage packageConfig gpkg = + Package { packageName = name , packageVersion = fromCabalVersion (pkgVersion pkgId) , packageDeps = deps - , packageFiles = GetPackageFiles $ \cabalfp -> do - distDir <- distDirFromDir (parent cabalfp) - (_,files) <- runReaderT (packageDescModulesAndFiles pkg) - (cabalfp, buildDir distDir) - return $ S.insert cabalfp files - - , packageModules = GetPackageModules $ \cabalfp -> do - distDir <- distDirFromDir (parent cabalfp) - (modules,_) <- runReaderT (packageDescModulesAndFiles pkg) - (cabalfp, buildDir distDir) - return modules + , packageFiles = GetPackageFiles $ + \cabalfp -> + do distDir <- distDirFromDir (parent cabalfp) + (modules,moduleFiles,files,mains,extra) <- + runReaderT + (packageDescModulesAndFiles pkg) + (cabalfp, buildDir distDir) + return + ( modules + , moduleFiles + , files + , mains + , S.singleton cabalfp <> extra) , packageTools = packageDescTools pkg , packageFlags = packageConfigFlags packageConfig , packageAllDeps = S.fromList (M.keys deps) , packageHasLibrary = maybe False (buildable . libBuildInfo) (library pkg) - , packageTests = S.fromList $ [ T.pack (testName t) | t <- testSuites pkg, buildable (testBuildInfo t)] - , packageBenchmarks = S.fromList $ [ T.pack (benchmarkName b) | b <- benchmarks pkg, buildable (benchmarkBuildInfo b)] - , packageExes = S.fromList $ [ T.pack (exeName b) | b <- executables pkg, buildable (buildInfo b)] - , packageOpts = GetPackageOpts $ \sourceMap locals cabalfp -> - generatePkgDescOpts sourceMap locals cabalfp pkg - , packageHasExposedModules = maybe False (not . null . exposedModules) (library pkg) + , packageTests = S.fromList $ + [T.pack (testName t) | t <- testSuites pkg + , buildable (testBuildInfo t)] + , packageBenchmarks = S.fromList $ + [T.pack (benchmarkName b) | b <- benchmarks pkg + , buildable (benchmarkBuildInfo b)] + , packageExes = S.fromList $ + [T.pack (exeName b) | b <- executables pkg + , buildable (buildInfo b)] + , packageOpts = GetPackageOpts $ + \sourceMap locals cabalfp -> + generatePkgDescOpts sourceMap locals cabalfp pkg + , packageHasExposedModules = maybe + False + (not . null . exposedModules) + (library pkg) , packageSimpleType = buildType (packageDescription gpkg) == Just Simple - , packageDefinedFlags = S.fromList $ map (fromCabalFlagName . flagName) $ genPackageFlags gpkg + , packageDefinedFlags = S.fromList $ + map (fromCabalFlagName . flagName) $ genPackageFlags gpkg } - where pkgId = package (packageDescription gpkg) name = fromCabalPackageName (pkgName pkgId) pkg = resolvePackageDescription packageConfig gpkg deps = M.filterWithKey (const . (/= name)) (packageDependencies pkg) --- | Generate GHC options for the package. +-- | Generate GHC options for the package's components, and a list of +-- options which apply generally to the package, not one specific +-- component. generatePkgDescOpts :: (HasEnvConfig env, HasPlatform env, MonadThrow m, MonadReader env m, MonadIO m) => SourceMap -> [PackageName] -> Path Abs File -> PackageDescription - -> m [String] + -> m (Map NamedComponent [String],[String]) generatePkgDescOpts sourceMap locals cabalfp pkg = do distDir <- distDirFromDir cabalDir let cabalmacros = autogenDir distDir $(mkRelFile "cabal_macros.h") @@ -193,16 +218,36 @@ if exists then Just cabalmacros else Nothing + let generate = + generateBuildInfoOpts + sourceMap + mcabalmacros + cabalDir + distDir + locals return - (nubOrd - (["-hide-all-packages"] ++ - concatMap - (concatMap - (generateBuildInfoOpts sourceMap mcabalmacros cabalDir distDir locals)) - [ maybe [] (return . libBuildInfo) (library pkg) - , map buildInfo (executables pkg) - , map benchmarkBuildInfo (benchmarks pkg) - , map testBuildInfo (testSuites pkg)])) + ( M.fromList + (concat + [ maybe + [] + (return . (CLib, ) . generate . libBuildInfo) + (library pkg) + , map + (\exe -> + ( CExe (T.pack (exeName exe)) + , generate (buildInfo exe))) + (executables pkg) + , map + (\bench -> + ( CBench (T.pack (benchmarkName bench)) + , generate (benchmarkBuildInfo bench))) + (benchmarks pkg) + , map + (\test -> + ( CBench (T.pack (testName test)) + , generate (testBuildInfo test))) + (testSuites pkg)]) + , ["-hide-all-packages"]) where cabalDir = parent cabalfp @@ -322,34 +367,53 @@ -- | Get all files referenced by the package. packageDescModulesAndFiles :: (MonadLogger m, MonadIO m, MonadThrow m, MonadReader (Path Abs File, Path Abs Dir) m, MonadCatch m) - => PackageDescription -> m (Set ModuleName,Set (Path Abs File)) + => PackageDescription + -> m (Map NamedComponent (Set ModuleName), Map NamedComponent (Set (Path Abs File)), Map NamedComponent (Set (Path Abs File)), Map NamedComponent (Set MainIs), Set (Path Abs File)) packageDescModulesAndFiles pkg = do - libfiles <- - liftM concat2 (mapM libraryFiles (maybe [] return (library pkg))) - exefiles <- liftM concat2 (mapM executableFiles (executables pkg)) - benchfiles <- liftM concat2 (mapM benchmarkFiles (benchmarks pkg)) - testfiles <- liftM concat2 (mapM testFiles (testSuites pkg)) - dfiles <- + (libraryMods,libModFiles,libOtherFiles,_) <- + maybe + (return (M.empty, M.empty, M.empty, M.empty)) + (asModuleAndFileMap libComponent libraryFiles) + (library pkg) + (executableMods,exeModFiles,exeOtherFiles,exeMainIs) <- liftM - (mempty, ) - (resolveGlobFiles (map (dataDir pkg FilePath.) (dataFiles pkg))) - srcfiles <- liftM (mempty, ) (resolveGlobFiles (extraSrcFiles pkg)) - -- extraTmpFiles purposely not included here, as those are files generated - -- by the build script. Another possible implementation: include them, but - -- don't error out if not present - docfiles <- liftM (mempty, ) (resolveGlobFiles (extraDocFiles pkg)) - return - (concat2 - [ libfiles - , exefiles - , dfiles - , srcfiles - , docfiles - , benchfiles - , testfiles]) + foldTriples + (mapM + (asModuleAndFileMap exeComponent executableFiles) + (executables pkg)) + (testMods,testModFps,testOtherFps,testMainIs) <- + liftM + foldTriples + (mapM (asModuleAndFileMap testComponent testFiles) (testSuites pkg)) + (benchModules,benchModFiles,benchOtherFiles,benchMainIs) <- + liftM + foldTriples + (mapM + (asModuleAndFileMap benchComponent benchmarkFiles) + (benchmarks pkg)) + dfiles <- resolveGlobFiles (map (dataDir pkg FilePath.) (dataFiles pkg)) + let modules = libraryMods <> executableMods <> testMods <> benchModules + moduleFiles = libModFiles <> exeModFiles <> testModFps <> benchModFiles + otherFiles = libOtherFiles <> exeOtherFiles <> testOtherFps <> benchOtherFiles + mains = exeMainIs <> benchMainIs <> testMainIs + return (modules, moduleFiles, otherFiles, mains, dfiles) where - concat2 :: (Ord a,Ord b) => [(Set a, Set b)] -> (Set a, Set b) - concat2 = (mconcat *** mconcat) . unzip + libComponent = const CLib + exeComponent = CExe . T.pack . exeName + testComponent = CTest . T.pack . testName + benchComponent = CBench . T.pack . benchmarkName + asModuleAndFileMap label f lib = do + (a,b,c, d) <- f lib + return + ( M.singleton (label lib) a + , M.singleton (label lib) b + , M.singleton (label lib) c + , M.singleton (label lib) d) + foldTriples = + foldl' + (\(a,b,c,d) (x,y,z,k) -> + (a <> x, b <> y, c <> z, d <> k)) + (M.empty, M.empty, M.empty, M.empty) -- | Resolve globbing of files (e.g. data files) to absolute paths. resolveGlobFiles :: (MonadLogger m,MonadIO m,MonadThrow m,MonadReader (Path Abs File, Path Abs Dir) m,MonadCatch m) @@ -415,92 +479,86 @@ -- | Get all files referenced by the benchmark. benchmarkFiles :: (MonadLogger m, MonadIO m, MonadThrow m, MonadReader (Path Abs File, Path Abs Dir) m) - => Benchmark -> m (Set ModuleName,Set (Path Abs File)) + => Benchmark -> m (Set ModuleName,Set (Path Abs File),Set (Path Abs File),Set MainIs) benchmarkFiles bench = do dirs <- mapMaybeM resolveDirOrWarn (hsSourceDirs build) dir <- asks (parent . fst) - (rmodules,rfiles) <- resolveFilesAndDeps - (Just $ benchmarkName bench) - (dirs ++ [dir]) - names - haskellModuleExts + (rmodules,modFiles,thFiles) <- + resolveFilesAndDeps + (Just $ benchmarkName bench) + (dirs ++ [dir]) + bnames + haskellModuleExts + mainFiles <- resolveFiles (dirs ++ [dir]) exposed haskellModuleExts cfiles <- buildCSources build - return (rmodules,rfiles <> cfiles) + return (rmodules, modFiles, cfiles <> thFiles, S.map MainIs (S.fromList mainFiles)) where - names = - concat [bnames,exposed] exposed = case benchmarkInterface bench of - BenchmarkExeV10 _ fp -> - [Right fp] - BenchmarkUnsupported _ -> - [] + BenchmarkExeV10 _ fp -> [Right fp] + BenchmarkUnsupported _ -> [] bnames = map Left (otherModules build) build = benchmarkBuildInfo bench -- | Get all files referenced by the test. -testFiles :: (MonadLogger m, MonadIO m, MonadThrow m, MonadReader (Path Abs File, Path Abs Dir) m) - => TestSuite -> m (Set ModuleName,Set (Path Abs File)) +testFiles + :: (MonadLogger m, MonadIO m, MonadThrow m, MonadReader (Path Abs File, Path Abs Dir) m) + => TestSuite + -> m (Set ModuleName, Set (Path Abs File), Set (Path Abs File), Set MainIs) testFiles test = do dirs <- mapMaybeM resolveDirOrWarn (hsSourceDirs build) dir <- asks (parent . fst) - (modules,rfiles) <- resolveFilesAndDeps - (Just $ testName test) - (dirs ++ [dir]) - names - haskellModuleExts + (modules,modFiles,thFiles) <- + resolveFilesAndDeps + (Just $ testName test) + (dirs ++ [dir]) + bnames + haskellModuleExts + mainFiles <- resolveFiles (dirs ++ [dir]) exposed haskellModuleExts cfiles <- buildCSources build - return (modules,rfiles <> cfiles) + return (modules, modFiles, cfiles <> thFiles, S.map MainIs (S.fromList mainFiles)) where - names = - concat [bnames,exposed] exposed = case testInterface test of - TestSuiteExeV10 _ fp -> - [Right fp] - TestSuiteLibV09 _ mn -> - [Left mn] - TestSuiteUnsupported _ -> - [] + TestSuiteExeV10 _ fp -> [Right fp] + TestSuiteLibV09 _ mn -> [Left mn] + TestSuiteUnsupported _ -> [] bnames = map Left (otherModules build) build = testBuildInfo test -- | Get all files referenced by the executable. -executableFiles :: (MonadLogger m,MonadIO m,MonadThrow m,MonadReader (Path Abs File, Path Abs Dir) m) - => Executable -> m (Set ModuleName,Set (Path Abs File)) -executableFiles exe = - do dirs <- mapMaybeM resolveDirOrWarn (hsSourceDirs build) - dir <- asks (parent . fst) - (modules,rfiles) <- resolveFilesAndDeps - (Just $ exeName exe) - (dirs ++ [dir]) - names - haskellModuleExts - cfiles <- buildCSources build - return (modules,rfiles <> cfiles) +executableFiles + :: (MonadLogger m, MonadIO m, MonadThrow m, MonadReader (Path Abs File, Path Abs Dir) m) + => Executable + -> m (Set ModuleName, Set (Path Abs File), Set (Path Abs File), Set MainIs) +executableFiles exe = do + dirs <- mapMaybeM resolveDirOrWarn (hsSourceDirs build) + dir <- asks (parent . fst) + (modules,modFiles,thFiles) <- + resolveFilesAndDeps + (Just $ exeName exe) + (dirs ++ [dir]) + (map Left (otherModules build)) + haskellModuleExts + mainFiles <- + resolveFiles (dirs ++ [dir]) [Right (modulePath exe)] haskellModuleExts + cfiles <- buildCSources build + return (modules, modFiles, cfiles <> thFiles, S.map MainIs (S.fromList mainFiles)) where - names = - concat [bnames,exposed] - bnames = map Left (otherModules build) - exposed = [Right (modulePath exe)] build = buildInfo exe -- | Get all files referenced by the library. libraryFiles :: (MonadLogger m,MonadIO m,MonadThrow m,MonadReader (Path Abs File, Path Abs Dir) m) - => Library -> m (Set ModuleName,Set (Path Abs File)) -libraryFiles lib = - do dirs <- mapMaybeM resolveDirOrWarn (hsSourceDirs build) - dir <- asks (parent . fst) - (modules,rfiles) <- resolveFilesAndDeps - Nothing - (dirs ++ [dir]) - names - haskellModuleExts - cfiles <- buildCSources build - return (modules,rfiles <> cfiles) + => Library -> m (Set ModuleName,Set (Path Abs File),Set (Path Abs File), Set MainIs) +libraryFiles lib = do + dirs <- mapMaybeM resolveDirOrWarn (hsSourceDirs build) + dir <- asks (parent . fst) + (modules,modFiles,thFiles) <- + resolveFilesAndDeps Nothing (dirs ++ [dir]) names haskellModuleExts + cfiles <- buildCSources build + return (modules, modFiles, cfiles <> thFiles, mempty) where - names = - concat [bnames,exposed] + names = concat [bnames, exposed] exposed = map Left (exposedModules lib) bnames = map Left (otherModules build) build = libBuildInfo lib @@ -533,7 +591,7 @@ (flagMap defaultFlags) rc = mkResolveConditions - (packageConfigGhcVersion packageConfig) + (packageConfigCompilerVersion packageConfig) (packageConfigPlatform packageConfig) flags @@ -563,19 +621,19 @@ data ResolveConditions = ResolveConditions { rcFlags :: Map FlagName Bool - , rcGhcVersion :: Version + , rcCompilerVersion :: CompilerVersion , rcOS :: OS , rcArch :: Arch } -- | Generic a @ResolveConditions@ using sensible defaults. -mkResolveConditions :: Version -- ^ GHC version +mkResolveConditions :: CompilerVersion -- ^ Compiler version -> Platform -- ^ installation target platform -> Map FlagName Bool -- ^ enabled flags -> ResolveConditions -mkResolveConditions ghcVersion (Platform arch os) flags = ResolveConditions +mkResolveConditions compilerVersion (Platform arch os) flags = ResolveConditions { rcFlags = flags - , rcGhcVersion = ghcVersion + , rcCompilerVersion = compilerVersion , rcOS = if isWindows os then Windows else os , rcArch = arch } @@ -608,16 +666,24 @@ OS os -> os == rcOS rc Arch arch -> arch == rcArch rc Flag flag -> - case M.lookup (fromCabalFlagName flag) (rcFlags rc) of - Just x -> x - Nothing -> - -- NOTE: This should never happen, as all flags - -- which are used must be declared. Defaulting - -- to False - False + case M.lookup (fromCabalFlagName flag) (rcFlags rc) of + Just x -> x + Nothing -> + -- NOTE: This should never happen, as all flags + -- which are used must be declared. Defaulting + -- to False + False Impl flavor range -> - flavor == GHC && - withinRange (rcGhcVersion rc) range + case (flavor, rcCompilerVersion rc) of + (GHC, GhcVersion vghc) -> vghc `withinRange` range + (GHC, GhcjsVersion _ vghc) -> vghc `withinRange` range +#if MIN_VERSION_Cabal(1, 22, 0) + (GHCJS, GhcjsVersion vghcjs _) -> +#else + (OtherCompiler "ghcjs", GhcjsVersion vghcjs _) -> +#endif + vghcjs `withinRange` range + _ -> False -- | Get the name of a dependency. depName :: Dependency -> PackageName @@ -637,12 +703,34 @@ -> [Path Abs Dir] -- ^ Directories to look in. -> [Either ModuleName String] -- ^ Base names. -> [Text] -- ^ Extentions. - -> m (Set ModuleName,Set (Path Abs File)) + -> m (Set ModuleName,Set (Path Abs File),Set (Path Abs File)) resolveFilesAndDeps component dirs names0 exts = do (moduleFiles,thFiles,foundModules) <- loop names0 S.empty + warnUnlisted component (lefts names0) foundModules + return (foundModules, moduleFiles, S.fromList thFiles) + where + loop [] doneModules = return (S.empty, [], doneModules) + loop names doneModules0 = do + resolvedFiles <- resolveFiles dirs names exts + pairs <- mapM (getDependencies component) resolvedFiles + let doneModules' = S.union doneModules0 (S.fromList (lefts names)) + moduleDeps = S.unions (map fst pairs) + thDepFiles = concatMap snd pairs + modulesRemaining = S.difference moduleDeps doneModules' + (moduleDepFiles',thDepFiles',doneModules'') <- + loop (map Left (S.toList modulesRemaining)) doneModules' + return + ( S.union (S.fromList resolvedFiles) moduleDepFiles' + , thDepFiles ++ thDepFiles' + , doneModules'') + +-- | Warn about modules which are used but not listed in the cabal +-- file. +warnUnlisted + :: (MonadLogger m, MonadReader (Path Abs File, void) m) + => Maybe String -> [ModuleName] -> Set ModuleName -> m () +warnUnlisted component names0 foundModules = do cabalfp <- asks fst - let unlistedModules = - foundModules `S.difference` (S.fromList (lefts names0)) unless (S.null unlistedModules) $ $(logWarn) $ T.pack $ @@ -657,65 +745,59 @@ Just c -> " for '" ++ c ++ "'") ++ " component (add to other-modules):\n " ++ intercalate "\n " (map display (S.toList unlistedModules)) - return (foundModules,moduleFiles <> S.fromList thFiles) where - loop [] doneModules = return (S.empty, [], doneModules) - loop names doneModules0 = do - resolvedFiles <- resolveFiles dirs names exts - pairs <- mapM getDependencies resolvedFiles - let doneModules' = S.union doneModules0 (S.fromList (lefts names)) - moduleDeps = S.unions (map fst pairs) - thDepFiles = concatMap snd pairs - modulesRemaining = S.difference moduleDeps doneModules' - (moduleDepFiles',thDepFiles',doneModules'') <- - loop (map Left (S.toList modulesRemaining)) doneModules' - return - ( S.union (S.fromList resolvedFiles) moduleDepFiles' - , thDepFiles ++ thDepFiles' - , doneModules'') - getDependencies resolvedFile = do - dir <- asks (parent . fst) - dumpHIDir <- getDumpHIDir - case stripDir dir resolvedFile of - Nothing -> return (S.empty, []) - Just fileRel -> do - let dumpHIPath = - FilePath.replaceExtension - (toFilePath (dumpHIDir fileRel)) - ".dump-hi" - dumpHIExists <- liftIO $ doesFileExist dumpHIPath - if dumpHIExists - then parseDumpHI dumpHIPath - else return (S.empty, []) - parseDumpHI dumpHIPath = do - dir <- asks (parent . fst) - dumpHI <- liftIO $ fmap C8.lines (C8.readFile dumpHIPath) - let startModuleDeps = - dropWhile - (not . ("module dependencies:" `C8.isPrefixOf`)) - dumpHI - moduleDeps = - S.fromList $ - mapMaybe (simpleParse . T.unpack . decodeUtf8) $ - C8.words $ - C8.concat $ - C8.dropWhile (/= ' ') (headDef "" startModuleDeps) : - takeWhile (" " `C8.isPrefixOf`) (tailSafe startModuleDeps) - thDeps = - -- The dependent file path is surrounded by quotes but is not escaped. - -- It can be an absolute or relative path. - mapMaybe - (parseAbsOrRelFile dir <=< - (fmap T.unpack . - (T.stripSuffix "\"" <=< T.stripPrefix "\"") . - T.dropWhileEnd (== '\r') . - decodeUtf8 . C8.dropWhile (/= '"'))) $ - filter ("addDependentFile \"" `C8.isPrefixOf`) dumpHI - return - (moduleDeps, thDeps) - getDumpHIDir = do - bld <- asks snd - return $ maybe bld (bld ) (getBuildComponentDir component) + unlistedModules = + foundModules `S.difference` (S.fromList names0) + +-- | Get the dependencies of a Haskell module file. +getDependencies + :: (MonadReader (Path Abs File, Path Abs Dir) m, MonadIO m) + => Maybe String -> Path Abs File -> m (Set ModuleName, [Path Abs File]) +getDependencies component resolvedFile = do + dir <- asks (parent . fst) + dumpHIDir <- getDumpHIDir + case stripDir dir resolvedFile of + Nothing -> return (S.empty, []) + Just fileRel -> do + let dumpHIPath = + FilePath.replaceExtension + (toFilePath (dumpHIDir fileRel)) + ".dump-hi" + dumpHIExists <- liftIO $ doesFileExist dumpHIPath + if dumpHIExists + then parseDumpHI dumpHIPath + else return (S.empty, []) + where getDumpHIDir = do + bld <- asks snd + return $ maybe bld (bld ) (getBuildComponentDir component) + +-- | Parse a .dump-hi file into a set of modules and files. +parseDumpHI + :: (MonadReader (Path Abs File, void) m, MonadIO m) + => FilePath -> m (Set ModuleName, [Path Abs File]) +parseDumpHI dumpHIPath = do + dir <- asks (parent . fst) + dumpHI <- liftIO $ fmap C8.lines (C8.readFile dumpHIPath) + let startModuleDeps = + dropWhile (not . ("module dependencies:" `C8.isPrefixOf`)) dumpHI + moduleDeps = + S.fromList $ + mapMaybe (simpleParse . T.unpack . decodeUtf8) $ + C8.words $ + C8.concat $ + C8.dropWhile (/= ' ') (headDef "" startModuleDeps) : + takeWhile (" " `C8.isPrefixOf`) (tailSafe startModuleDeps) + thDeps = + -- The dependent file path is surrounded by quotes but is not escaped. + -- It can be an absolute or relative path. + mapMaybe + (parseAbsOrRelFile dir <=< + (fmap T.unpack . + (T.stripSuffix "\"" <=< T.stripPrefix "\"") . + T.dropWhileEnd (== '\r') . decodeUtf8 . C8.dropWhile (/= '"'))) $ + filter ("addDependentFile \"" `C8.isPrefixOf`) dumpHI + return (moduleDeps, thDeps) + where parseAbsOrRelFile dir fp = case parseRelFile fp of Just rel -> Just (dir rel) @@ -765,15 +847,22 @@ -> IO [Either ResolveException (Path Abs File)] makeDirCandidates dir = case name of - Right fp -> liftM return (try (resolveFile dir fp)) + Right fp -> liftM return (try (resolveFile' dir fp)) Left mn -> mapM (\ext -> try - (resolveFile + (resolveFile' dir (Cabal.toFilePath mn ++ "." ++ ext))) (map T.unpack exts) + resolveFile' :: (MonadIO m, MonadThrow m) => Path Abs Dir -> FilePath.FilePath -> m (Path Abs File) + resolveFile' x y = do + p <- parseCollapsedAbsFile (toFilePath x FilePath. y) + exists <- fileExists p + if exists + then return p + else throwM $ ResolveFileFailed x y (toFilePath p) -- | Warn the user that multiple candidates are available for an -- entry, but that we picked one anyway and continued. @@ -809,9 +898,9 @@ T.pack (display mn) <> "\", but did find: " <> T.intercalate ", " (map (T.pack . toFilePath) possibilities) <> - ". If you are using a custom preprocessor for this module \ - \with its own file extension, consider adding the file(s) \ - \to your .cabal under extra-source-files.") + ". If you are using a custom preprocessor for this module " <> + "with its own file extension, consider adding the file(s) " <> + "to your .cabal under extra-source-files.") where makePossibilities name = mapM @@ -843,7 +932,7 @@ [] -> throwM $ PackageNoCabalFileFound pkgDir [x] -> return x _:_ -> throwM $ PackageMultipleCabalFilesFound pkgDir files - where hasExtension fp x = FilePath.takeExtensions fp == "." ++ x + where hasExtension fp x = FilePath.takeExtension fp == "." ++ x -- | Path for the package's build log. buildLogPath :: (MonadReader env m, HasBuildConfig env, MonadThrow m) diff --git a/src/Stack/PackageDump.hs b/src/Stack/PackageDump.hs --- a/src/Stack/PackageDump.hs +++ b/src/Stack/PackageDump.hs @@ -79,12 +79,13 @@ ghcPkgDump :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadThrow m) => EnvOverride + -> WhichCompiler -> Maybe (Path Abs Dir) -- ^ if Nothing, use global -> Sink ByteString IO a -> m a -ghcPkgDump menv mpkgDb sink = do - F.mapM_ (createDatabase menv) mpkgDb -- TODO maybe use some retry logic instead? - a <- sinkProcessStdout Nothing menv "ghc-pkg" args sink +ghcPkgDump menv wc mpkgDb sink = do + F.mapM_ (createDatabase menv wc) mpkgDb -- TODO maybe use some retry logic instead? + a <- sinkProcessStdout Nothing menv (ghcPkgExeName wc) args sink return a where args = concat @@ -100,7 +101,7 @@ -- | Load a @InstalledCache@ from disk, swallowing any errors and returning an -- empty cache. -loadInstalledCache :: MonadIO m => Path Abs File -> m InstalledCache +loadInstalledCache :: (MonadLogger m, MonadIO m) => Path Abs File -> m InstalledCache loadInstalledCache path = do m <- taggedDecodeOrLoad (toFilePath path) (return $ InstalledCacheInner Map.empty) liftIO $ fmap InstalledCache $ newIORef m diff --git a/src/Stack/SDist.hs b/src/Stack/SDist.hs --- a/src/Stack/SDist.hs +++ b/src/Stack/SDist.hs @@ -10,13 +10,14 @@ import qualified Codec.Archive.Tar as Tar import qualified Codec.Archive.Tar.Entry as Tar import qualified Codec.Compression.GZip as GZip -import Control.Applicative ((<$>)) +import Control.Applicative import Control.Concurrent.Execute (ActionContext(..)) -import Control.Monad (when) +import Control.Monad (when, void) import Control.Monad.Catch (MonadCatch, MonadMask) import Control.Monad.IO.Class import Control.Monad.Logger import Control.Monad.Reader (MonadReader, asks) +import Control.Monad.Trans.Control (liftBaseWith) import Control.Monad.Trans.Resource import qualified Data.ByteString.Lazy as L import Data.Either (partitionEithers) @@ -27,10 +28,11 @@ import qualified Data.Text as T import Network.HTTP.Client.Conduit (HasHttpManager) import Path +import Prelude -- Fix redundant import warnings import Stack.Build (mkBaseConfigOpts) import Stack.Build.Execute import Stack.Build.Source (loadSourceMap, localFlags) -import Stack.Types.Build +import Stack.Build.Target import Stack.Constants import Stack.Package import Stack.Types @@ -83,7 +85,7 @@ { packageConfigEnableTests = False , packageConfigEnableBenchmarks = False , packageConfigFlags = localFlags Map.empty bconfig name - , packageConfigGhcVersion = envConfigGhcVersion econfig + , packageConfigCompilerVersion = envConfigCompilerVersion econfig , packageConfigPlatform = configPlatform $ getConfig bconfig } package <- readPackage config cabalfp @@ -94,6 +96,8 @@ , lpCabalFile = cabalfp -- NOTE: these aren't the 'correct values, but aren't used in -- the usage of this function in this module. + , lpTestDeps = Map.empty + , lpBenchDeps = Map.empty , lpTestBench = Nothing , lpDirtyFiles = True , lpNewBuildCache = Map.empty @@ -107,9 +111,10 @@ menv <- getMinimalEnvOverride let bopts = defaultBuildOpts baseConfigOpts <- mkBaseConfigOpts bopts - (_mbp, locals, _extraToBuild, sourceMap) <- loadSourceMap bopts + (_, _mbp, locals, _extraToBuild, sourceMap) <- loadSourceMap NeedTargets bopts + runInBase <- liftBaseWith $ \run -> return (void . run) withExecuteEnv menv bopts baseConfigOpts locals sourceMap $ \ee -> do - withSingleContext ac ee task (Just "sdist") $ \_package _cabalfp _pkgDir cabal _announce _console _mlogFile -> do + withSingleContext runInBase ac ee task (Just "sdist") $ \_package _cabalfp _pkgDir cabal _announce _console _mlogFile -> do let outFile = tmpdir FP. "source-files-list" cabal False ["sdist", "--list-sources", outFile] liftIO (readFile outFile) @@ -121,7 +126,7 @@ , taskType = TTLocal lp , taskConfigOpts = TaskConfigOpts { tcoMissing = Set.empty - , tcoOpts = \_ -> [] + , tcoOpts = \_ -> ConfigureOpts [] [] } , taskPresent = Set.empty } diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs --- a/src/Stack/Setup.hs +++ b/src/Stack/Setup.hs @@ -8,6 +8,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TupleSections #-} module Stack.Setup ( setupEnv @@ -16,7 +17,7 @@ ) where import Control.Applicative -import Control.Exception.Enclosed (catchIO) +import Control.Exception.Enclosed (catchIO, tryAny) import Control.Monad (liftM, when, join, void, unless) import Control.Monad.Catch import Control.Monad.IO.Class (MonadIO, liftIO) @@ -33,12 +34,15 @@ import Data.Conduit.Lift (evalStateC) import qualified Data.Conduit.List as CL import Data.Either +import Data.Foldable hiding (concatMap, or) import Data.IORef -import Data.List (intercalate) +import Data.IORef.RunOnce (runOnce) +import Data.List hiding (concat, elem, maximumBy) import Data.Map (Map) import qualified Data.Map as Map -import Data.Maybe (mapMaybe, catMaybes, fromMaybe) +import Data.Maybe import Data.Monoid +import Data.Ord (comparing) import Data.Set (Set) import qualified Data.Set as Set import Data.Text (Text) @@ -48,20 +52,21 @@ import Data.Time.Clock (NominalDiffTime, diffUTCTime, getCurrentTime) import Data.Typeable (Typeable) import qualified Data.Yaml as Yaml -import Distribution.System (OS (..), Arch (..), Platform (..)) +import Distribution.System (OS, Arch (..), Platform (..)) +import qualified Distribution.System as Cabal import Distribution.Text (simpleParse) import Network.HTTP.Client.Conduit import Network.HTTP.Download.Verified import Path import Path.IO -import Prelude -- Fix AMP warning +import Prelude hiding (concat, elem) -- Fix AMP warning import Safe (headMay, readMay) import Stack.Types.Build import Stack.Config (resolvePackageEntry) import Stack.Constants (distRelativeDir) import Stack.Fetch import Stack.GhcPkg (createDatabase, getCabalPkgVer, getGlobalDB) -import Stack.Solver (getGhcVersion) +import Stack.Solver (getCompilerVersion) import Stack.Types import Stack.Types.StackT import System.Environment (getExecutablePath) @@ -77,7 +82,8 @@ data SetupOpts = SetupOpts { soptsInstallIfMissing :: !Bool , soptsUseSystem :: !Bool - , soptsExpected :: !Version + , soptsWantedCompiler :: !CompilerVersion + , soptsCompilerCheck :: !VersionCheck , soptsStackYaml :: !(Maybe (Path Abs File)) -- ^ If we got the desired GHC version from that file , soptsForceReinstall :: !Bool @@ -90,11 +96,13 @@ , soptsUpgradeCabal :: !Bool -- ^ Upgrade the global Cabal library in the database to the newest -- version. Only works reliably with a stack-managed installation. + , soptsResolveMissingGHC :: !(Maybe Text) + -- ^ Message shown to user for how to resolve the missing GHC } deriving Show data SetupException = UnsupportedSetupCombo OS Arch | MissingDependencies [String] - | UnknownGHCVersion Text Version (Set MajorVersion) + | UnknownCompilerVersion Text CompilerVersion (Set Version) | UnknownOSKey Text | GHCSanityCheckCompileFailed ReadProcessException (Path Abs File) deriving Typeable @@ -108,10 +116,10 @@ show (MissingDependencies tools) = "The following executables are missing and must be installed: " ++ intercalate ", " tools - show (UnknownGHCVersion oskey version known) = concat - [ "No information found for GHC version " - , versionString version - , ".\nSupported GHC major versions for OS key '" ++ T.unpack oskey ++ "': " + show (UnknownCompilerVersion oskey wanted known) = concat + [ "No information found for " + , T.unpack (compilerVersionName wanted) + , ".\nSupported versions for OS key '" ++ T.unpack oskey ++ "': " , intercalate ", " (map show $ Set.toList known) ] show (UnknownOSKey oskey) = @@ -128,46 +136,45 @@ -- | Modify the environment variables (like PATH) appropriately, possibly doing installation too setupEnv :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasBuildConfig env, HasHttpManager env, MonadBaseControl IO m) - => m EnvConfig -setupEnv = do + => Maybe Text -- ^ Message to give user when necessary GHC is not available + -> m EnvConfig +setupEnv mResolveMissingGHC = do bconfig <- asks getBuildConfig let platform = getPlatform bconfig + wc = whichCompiler (bcWantedCompiler bconfig) sopts = SetupOpts { soptsInstallIfMissing = configInstallGHC $ bcConfig bconfig , soptsUseSystem = configSystemGHC $ bcConfig bconfig - , soptsExpected = bcGhcVersionExpected bconfig + , soptsWantedCompiler = bcWantedCompiler bconfig + , soptsCompilerCheck = configCompilerCheck $ bcConfig bconfig , soptsStackYaml = Just $ bcStackYaml bconfig , soptsForceReinstall = False , soptsSanityCheck = False , soptsSkipGhcCheck = configSkipGHCCheck $ bcConfig bconfig , soptsSkipMsys = configSkipMsys $ bcConfig bconfig , soptsUpgradeCabal = False + , soptsResolveMissingGHC = mResolveMissingGHC } + mghcBin <- ensureGHC sopts - menv0 <- getMinimalEnvOverride -- Modify the initial environment to include the GHC path, if a local GHC -- is being used - let env = removeHaskellEnvVars $ case mghcBin of - Nothing -> unEnvOverride menv0 - Just ghcBin -> - let x = unEnvOverride menv0 - mpath = Map.lookup "PATH" x - path = T.intercalate (T.singleton searchPathSeparator) - $ map (stripTrailingSlashT . T.pack) ghcBin - ++ maybe [] return mpath - in Map.insert "PATH" path x + menv0 <- getMinimalEnvOverride + let env = removeHaskellEnvVars + $ augmentPathMap (fromMaybe [] mghcBin) + $ unEnvOverride menv0 menv <- mkEnvOverride platform env - ghcVer <- getGhcVersion menv - cabalVer <- getCabalPkgVer menv + compilerVer <- getCompilerVersion menv wc + cabalVer <- getCabalPkgVer menv wc packages <- mapM (resolvePackageEntry menv (bcRoot bconfig)) (bcPackageEntries bconfig) let envConfig0 = EnvConfig { envConfigBuildConfig = bconfig , envConfigCabalVersion = cabalVer - , envConfigGhcVersion = ghcVer + , envConfigCompilerVersion = compilerVer , envConfigPackages = Map.fromList $ concat packages } @@ -179,10 +186,10 @@ localsPath = augmentPath (mkDirs' True) mpath deps <- runReaderT packageDatabaseDeps envConfig0 - createDatabase menv deps + createDatabase menv wc deps localdb <- runReaderT packageDatabaseLocal envConfig0 - createDatabase menv localdb - globalDB <- getGlobalDB menv + createDatabase menv wc localdb + globalDB <- getGlobalDB menv wc let mkGPP locals = T.pack $ intercalate [searchPathSeparator] $ concat [ [toFilePathNoTrailingSlash localdb | locals] , [toFilePathNoTrailingSlash deps] @@ -193,6 +200,8 @@ executablePath <- liftIO getExecutablePath + utf8EnvVars <- getUtf8LocaleVars menv + envRef <- liftIO $ newIORef Map.empty let getEnvOverride' es = do m <- readIORef envRef @@ -209,6 +218,10 @@ then Map.insert "STACK_EXE" (T.pack executablePath) else id) + $ (if esLocaleUtf8 es + then Map.union utf8EnvVars + else id) + -- For reasoning and duplication, see: https://github.com/fpco/stack/issues/70 $ Map.insert "HASKELL_PACKAGE_SANDBOX" (T.pack $ toFilePathNoTrailingSlash deps) $ Map.insert "HASKELL_PACKAGE_SANDBOXES" @@ -233,29 +246,20 @@ { bcConfig = (bcConfig bconfig) { configEnvOverride = getEnvOverride' } } , envConfigCabalVersion = cabalVer - , envConfigGhcVersion = ghcVer + , envConfigCompilerVersion = compilerVer , envConfigPackages = envConfigPackages envConfig0 } --- | Augment the PATH environment variable with the given extra paths -augmentPath :: [FilePath] -> Maybe Text -> Text -augmentPath dirs mpath = - T.pack $ intercalate [searchPathSeparator] - (map stripTrailingSlashS dirs ++ maybe [] (return . T.unpack) mpath) - where - stripTrailingSlashS = T.unpack . stripTrailingSlashT . T.pack - -stripTrailingSlashT :: Text -> Text -stripTrailingSlashT t = fromMaybe t $ T.stripSuffix - (T.singleton FP.pathSeparator) - t - -- | Ensure GHC is installed and provide the PATHs to add if necessary ensureGHC :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m) => SetupOpts -> m (Maybe [FilePath]) ensureGHC sopts = do - when (getMajorVersion expected < MajorVersion 7 8) $ do + let wc = whichCompiler (soptsWantedCompiler sopts) + ghcVersion = case soptsWantedCompiler sopts of + GhcVersion v -> v + GhcjsVersion _ v -> v + when (ghcVersion < $(mkVersion "7.8")) $ do $logWarn "stack will almost certainly fail with GHC below version 7.8" $logWarn "Valiantly attempting to run anyway, but I know this is doomed" $logWarn "For more information, see: https://github.com/commercialhaskell/stack/issues/648" @@ -266,7 +270,7 @@ msystem <- if soptsUseSystem sopts - then getSystemGHC menv0 + then getSystemCompiler menv0 wc else return Nothing Platform expectedArch _ <- asks getPlatform @@ -275,41 +279,53 @@ Nothing -> True Just _ | soptsSkipGhcCheck sopts -> False Just (system, arch) -> - -- we allow a newer version of GHC within the same major series - getMajorVersion system /= getMajorVersion expected || - expected > system || + not (isWanted system) || arch /= expectedArch + isWanted = isWantedCompiler (soptsCompilerCheck sopts) (soptsWantedCompiler sopts) -- If we need to install a GHC, try to do so mpaths <- if needLocal then do + getSetupInfo' <- runOnce (getSetupInfo =<< asks getHttpManager) + config <- asks getConfig - let tools = - case configPlatform config of - Platform _ os | isWindows os -> - ($(mkPackageName "ghc"), Just expected) - : (if soptsSkipMsys sopts - then [] - else [($(mkPackageName "git"), Nothing)]) - _ -> - [ ($(mkPackageName "ghc"), Just expected) - ] + installed <- runReaderT listInstalled config - -- Avoid having to load it twice - siRef <- liftIO $ newIORef Nothing - manager <- asks getHttpManager - let getSetupInfo' = liftIO $ do - msi <- readIORef siRef - case msi of - Just si -> return si - Nothing -> do - si <- getSetupInfo manager - writeIORef siRef $ Just si - return si + -- Install GHC + ghcIdent <- case getInstalledTool installed $(mkPackageName "ghc") (isWanted . GhcVersion) of + Just ident -> return ident + Nothing + | soptsInstallIfMissing sopts -> do + si <- getSetupInfo' + downloadAndInstallGHC menv0 si (soptsWantedCompiler sopts) (soptsCompilerCheck sopts) + | otherwise -> do + Platform arch _ <- asks getPlatform + throwM $ CompilerVersionMismatch + msystem + (soptsWantedCompiler sopts, arch) + (soptsCompilerCheck sopts) + (soptsStackYaml sopts) + (fromMaybe + "Try running stack setup to locally install the correct GHC" + $ soptsResolveMissingGHC sopts) - installed <- runReaderT listInstalled config - idents <- mapM (ensureTool menv0 sopts installed getSetupInfo' msystem) tools - paths <- runReaderT (mapM binDirs $ catMaybes idents) config + -- Install git on windows, if necessary + mgitIdent <- case configPlatform config of + Platform _ os | isWindows os && not (soptsSkipMsys sopts) -> + case getInstalledTool installed $(mkPackageName "git") (const True) of + Just ident -> return (Just ident) + Nothing + | soptsInstallIfMissing sopts -> do + si <- getSetupInfo' + let VersionedDownloadInfo version info = siPortableGit si + Just <$> downloadAndInstallTool si info $(mkPackageName "git") version installGitWindows + | otherwise -> do + $logWarn "Continuing despite missing tool: git" + return Nothing + _ -> return Nothing + + let idents = catMaybes [Just ghcIdent, mgitIdent] + paths <- runReaderT (mapM binDirs idents) config return $ Just $ map toFilePathNoTrailingSlash $ concat paths else return Nothing @@ -329,19 +345,18 @@ $logWarn "Trying to upgrade Cabal library on a GHC not installed by stack." $logWarn "This may fail, caveat emptor!" - upgradeCabal menv + upgradeCabal menv wc when (soptsSanityCheck sopts) $ sanityCheck menv return mpaths - where - expected = soptsExpected sopts -- | Install the newest version of Cabal globally upgradeCabal :: (MonadIO m, MonadLogger m, MonadReader env m, HasHttpManager env, HasConfig env, MonadBaseControl IO m, MonadMask m) => EnvOverride + -> WhichCompiler -> m () -upgradeCabal menv = do +upgradeCabal menv wc = do let name = $(mkPackageName "Cabal") rmap <- resolvePackages menv Set.empty (Set.singleton name) newest <- @@ -350,7 +365,7 @@ [PackageIdentifier name' version] | name == name' -> return version x -> error $ "Unexpected results for resolvePackages: " ++ show x - installed <- getCabalPkgVer menv + installed <- getCabalPkgVer menv wc if installed >= newest then $logInfo $ T.concat [ "Currently installed Cabal is " @@ -370,9 +385,9 @@ let ident = PackageIdentifier name newest m <- unpackPackageIdents menv tmpdir' Nothing (Set.singleton ident) - ghcPath <- join $ findExecutable menv "ghc" + compilerPath <- join $ findExecutable menv (compilerExeName wc) newestDir <- parseRelDir $ versionString newest - let installRoot = toFilePath $ parent (parent ghcPath) + let installRoot = toFilePath $ parent (parent compilerPath) $(mkRelDir "new-cabal") newestDir @@ -381,7 +396,7 @@ Nothing -> error $ "upgradeCabal: Invariant violated, dir missing" Just dir -> return dir - runIn dir "ghc" menv ["Setup.hs"] Nothing + runIn dir (compilerExeName wc) menv ["Setup.hs"] Nothing let setupExe = toFilePath $ dir $(mkRelFile "Setup") dirArgument name' = concat [ "--" @@ -398,19 +413,30 @@ runIn dir setupExe menv ["install"] Nothing $logInfo "New Cabal library installed" --- | Get the major version of the system GHC, if available -getSystemGHC :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) => EnvOverride -> m (Maybe (Version, Arch)) -getSystemGHC menv = do - exists <- doesExecutableExist menv "ghc" +-- | Get the version of the system compiler, if available +getSystemCompiler :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) => EnvOverride -> WhichCompiler -> m (Maybe (CompilerVersion, Arch)) +getSystemCompiler menv wc = do + let exeName = case wc of + Ghc -> "ghc" + Ghcjs -> "ghcjs" + exists <- doesExecutableExist menv exeName if exists then do - eres <- tryProcessStdout Nothing menv "ghc" ["--info"] - return $ 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 (/= '-') - Just (version, arch) + 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 (/= '-') + return (version, arch) + case (wc, minfo) of + (Ghc, Just (version, arch)) -> return (Just (GhcVersion version, arch)) + (Ghcjs, Just (_, arch)) -> do + eversion <- tryAny $ getCompilerVersion menv Ghcjs + case eversion of + Left _ -> return Nothing + Right version -> return (Just (version, arch)) + (_, Nothing) -> return Nothing else return Nothing data DownloadInfo = DownloadInfo @@ -452,7 +478,7 @@ { siSevenzExe :: DownloadInfo , siSevenzDll :: DownloadInfo , siPortableGit :: VersionedDownloadInfo - , siGHCs :: Map Text (Map MajorVersion VersionedDownloadInfo) + , siGHCs :: Map Text (Map Version DownloadInfo) } deriving Show instance FromJSON SetupInfo where @@ -470,7 +496,7 @@ let bs = S8.concat bss either throwM return $ Yaml.decodeEither' bs where - req = "https://raw.githubusercontent.com/fpco/stackage-content/master/stack/stack-setup.yaml" + req = "https://raw.githubusercontent.com/fpco/stackage-content/master/stack/stack-setup-2.yaml" markInstalled :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m) => PackageIdentifier -- ^ e.g., ghc-7.8.4, git-2.4.0.1 @@ -531,93 +557,83 @@ $logWarn $ "binDirs: unexpected OS/tool combo: " <> T.pack (show (x, tool)) return [] -ensureTool :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m) - => EnvOverride - -> SetupOpts - -> [PackageIdentifier] -- ^ already installed - -> m SetupInfo - -> Maybe (Version, Arch) -- ^ installed GHC - -> (PackageName, Maybe Version) - -> m (Maybe PackageIdentifier) -ensureTool menv sopts installed getSetupInfo' msystem (name, mversion) - | not $ null available = return $ Just $ PackageIdentifier name $ maximum available - | not $ soptsInstallIfMissing sopts = - if name == $(mkPackageName "ghc") - then do - Platform arch _ <- asks getPlatform - throwM $ GHCVersionMismatch msystem (soptsExpected sopts, arch) (soptsStackYaml sopts) - else do - $logWarn $ "Continuing despite missing tool: " <> T.pack (packageNameString name) - return Nothing - | otherwise = do - si <- getSetupInfo' - (VersionedDownloadInfo version downloadInfo, installer) <- - case packageNameString name of - "git" -> do - let pair = siPortableGit si - return (pair, installGitWindows) - "ghc" -> do - osKey <- getOSKey menv - pairs <- - case Map.lookup osKey $ siGHCs si of - Nothing -> throwM $ UnknownOSKey osKey - Just pairs -> return pairs - version <- - case mversion of - Nothing -> error "invariant violated: ghc must have a version" - Just version -> return version - pair <- - case Map.lookup (getMajorVersion version) pairs of - Nothing -> throwM $ UnknownGHCVersion osKey version (Map.keysSet pairs) - Just pair -> return pair - platform <- asks $ configPlatform . getConfig - let installer = - case platform of - Platform _ os | isWindows os -> installGHCWindows - _ -> installGHCPosix - return (pair, installer) - x -> error $ "Invariant violated: ensureTool on " ++ x - let ident = PackageIdentifier name version - - (file, at) <- downloadFromInfo downloadInfo ident - dir <- installDir ident - unmarkInstalled ident - installer si file at dir ident - - markInstalled ident - return $ Just ident +getInstalledTool :: [PackageIdentifier] -- ^ already installed + -> PackageName -- ^ package to find + -> (Version -> Bool) -- ^ which versions are acceptable + -> Maybe PackageIdentifier +getInstalledTool installed name goodVersion = + if null available + then Nothing + else Just $ maximumBy (comparing packageIdentifierVersion) available where - available - | soptsForceReinstall sopts = [] - | otherwise = filter goodVersion - $ map packageIdentifierVersion - $ filter (\pi' -> packageIdentifierName pi' == name) installed + available = filter goodPackage installed + goodPackage pi' = + packageIdentifierName pi' == name && + goodVersion (packageIdentifierVersion pi') - goodVersion = - case mversion of - Nothing -> const True - Just expected -> \actual -> - getMajorVersion expected == getMajorVersion actual && - actual >= expected +downloadAndInstallTool :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m) + => SetupInfo + -> DownloadInfo + -> PackageName + -> Version + -> (SetupInfo -> Path Abs File -> ArchiveType -> Path Abs Dir -> PackageIdentifier -> m ()) + -> m PackageIdentifier +downloadAndInstallTool si downloadInfo name version installer = do + let ident = PackageIdentifier name version + (file, at) <- downloadFromInfo downloadInfo ident + dir <- installDir ident + unmarkInstalled ident + installer si file at dir ident + markInstalled ident + return ident +downloadAndInstallGHC :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m) + => EnvOverride + -> SetupInfo + -> CompilerVersion + -> VersionCheck + -> m PackageIdentifier +downloadAndInstallGHC menv si wanted versionCheck = do + osKey <- getOSKey menv + pairs <- + case Map.lookup osKey $ siGHCs si of + Nothing -> throwM $ UnknownOSKey osKey + Just pairs -> return pairs + let mpair = + listToMaybe $ + sortBy (flip (comparing fst)) $ + filter (\(v, _) -> isWantedCompiler versionCheck wanted (GhcVersion v)) (Map.toList pairs) + (selectedVersion, downloadInfo) <- + case mpair of + Just pair -> return pair + Nothing -> throwM $ UnknownCompilerVersion osKey wanted (Map.keysSet pairs) + platform <- asks $ configPlatform . getConfig + let installer = + case platform of + Platform _ os | isWindows os -> installGHCWindows + _ -> installGHCPosix + $logInfo "Preparing to install GHC to an isolated location." + $logInfo "This will not interfere with any system-level installation." + downloadAndInstallTool si downloadInfo $(mkPackageName "ghc") selectedVersion installer + getOSKey :: (MonadReader env m, MonadThrow m, HasConfig env, MonadLogger m, MonadIO m, MonadCatch m, MonadBaseControl IO m) => EnvOverride -> m Text getOSKey menv = do platform <- asks $ configPlatform . getConfig case platform of - Platform I386 Linux -> ("linux32" <>) <$> getLinuxSuffix - Platform X86_64 Linux -> ("linux64" <>) <$> getLinuxSuffix - Platform I386 OSX -> return "macosx" - Platform X86_64 OSX -> return "macosx" - Platform I386 FreeBSD -> return "freebsd32" - Platform X86_64 FreeBSD -> return "freebsd64" - Platform I386 OpenBSD -> return "openbsd32" - Platform X86_64 OpenBSD -> return "openbsd64" - Platform I386 Windows -> return "windows32" - Platform X86_64 Windows -> return "windows64" + Platform I386 Cabal.Linux -> ("linux32" <>) <$> getLinuxSuffix + Platform X86_64 Cabal.Linux -> ("linux64" <>) <$> getLinuxSuffix + Platform I386 Cabal.OSX -> return "macosx" + Platform X86_64 Cabal.OSX -> return "macosx" + Platform I386 Cabal.FreeBSD -> return "freebsd32" + Platform X86_64 Cabal.FreeBSD -> return "freebsd64" + Platform I386 Cabal.OpenBSD -> return "openbsd32" + Platform X86_64 Cabal.OpenBSD -> return "openbsd64" + Platform I386 Cabal.Windows -> return "windows32" + Platform X86_64 Cabal.Windows -> return "windows64" - Platform I386 (OtherOS "windowsintegersimple") -> return "windowsintegersimple32" - Platform X86_64 (OtherOS "windowsintegersimple") -> return "windowsintegersimple64" + Platform I386 (Cabal.OtherOS "windowsintegersimple") -> return "windowsintegersimple32" + Platform X86_64 (Cabal.OtherOS "windowsintegersimple") -> return "windowsintegersimple64" Platform arch os -> throwM $ UnsupportedSetupCombo os arch where @@ -973,3 +989,137 @@ Map.delete "HASKELL_PACKAGE_SANDBOX" . 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 + :: 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 isWindows os + 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 = + or $ + map + (`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) + where + -- Determines whether an environment variable is locale-related and, if so, whether it needs to + -- be adjusted. + checkVar + :: (Text, Text) -> ([Text], Set Text) + checkVar (k,v) = + if k `elem` ["LANG", "LANGUAGE"] || "LC_" `T.isPrefixOf` k + then if isUtf8Locale v + then ([], Set.singleton k) + else ([k], Set.singleton k) + else ([], Set.empty) + -- Adjusted value of an existing locale variable. Looks for valid UTF-8 encodings with + -- same language /and/ territory, then with same language, and finally the first UTF-8 locale + -- returned by @locale -a@. + adjustedVarValue + :: [Text] -> Maybe Text -> Text -> Map Text Text + adjustedVarValue utf8Locales mfallback k = + case Map.lookup k (eoTextMap menv) of + Nothing -> Map.empty + Just v -> + case concatMap + (matchingLocales utf8Locales) + [ T.takeWhile (/= '.') v <> "." + , T.takeWhile (/= '_') v <> "_"] of + (v':_) -> Map.singleton k v' + [] -> + case mfallback of + Just fallback -> Map.singleton k fallback + Nothing -> Map.empty + -- Determine the fallback locale, by looking for any UTF-8 locale prefixed with the list in + -- @fallbackPrefixes@, and if not found, picking the first UTF-8 encoding returned by @locale + -- -a@. + getFallbackLocale + :: [Text] -> Maybe Text + getFallbackLocale utf8Locales = do + case concatMap (matchingLocales utf8Locales) fallbackPrefixes of + (v:_) -> Just v + [] -> + case utf8Locales of + [] -> Nothing + (v:_) -> Just v + -- Filter the list of locales for any with the given prefixes (case-insitive). + matchingLocales + :: [Text] -> Text -> [Text] + matchingLocales utf8Locales prefix = + filter + (\v -> + (T.toLower prefix) `T.isPrefixOf` T.toLower v) + utf8Locales + -- Does the locale have one of the encodings in @utf8Suffixes@ (case-insensitive)? + isUtf8Locale locale = + or $ + map + (\v -> + T.toLower v `T.isSuffixOf` T.toLower locale) + utf8Suffixes + -- Prefixes of fallback locales (case-insensitive) + fallbackPrefixes = ["C.", "en_US.", "en_"] + -- Suffixes of UTF-8 locales (case-insensitive) + utf8Suffixes = [".UTF-8", ".utf8"] diff --git a/src/Stack/Solver.hs b/src/Stack/Solver.hs --- a/src/Stack/Solver.hs +++ b/src/Stack/Solver.hs @@ -4,10 +4,11 @@ {-# LANGUAGE TemplateHaskell #-} module Stack.Solver ( cabalSolver - , getGhcVersion + , getCompilerVersion , solveExtraDeps ) where +import Control.Applicative import Control.Exception.Enclosed (tryIO) import Control.Monad.Catch import Control.Monad.IO.Class @@ -27,6 +28,7 @@ import qualified Data.Yaml as Yaml import Network.HTTP.Client.Conduit (HasHttpManager) import Path +import Prelude import Stack.BuildPlan import Stack.Types import System.Directory (copyFile, @@ -37,17 +39,18 @@ import System.Process.Read cabalSolver :: (MonadIO m, MonadLogger m, MonadMask m, MonadBaseControl IO m, MonadReader env m, HasConfig env) - => [Path Abs Dir] -- ^ cabal files + => WhichCompiler + -> [Path Abs Dir] -- ^ cabal files -> Map PackageName Version -- ^ constraints -> [String] -- ^ additional arguments - -> m (MajorVersion, Map PackageName (Version, Map FlagName Bool)) -cabalSolver cabalfps constraints cabalArgs = withSystemTempDirectory "cabal-solver" $ \dir -> do + -> m (CompilerVersion, Map PackageName (Version, Map FlagName Bool)) +cabalSolver wc cabalfps constraints cabalArgs = withSystemTempDirectory "cabal-solver" $ \dir -> do configLines <- getCabalConfig dir constraints let configFile = dir FP. "cabal.config" liftIO $ S.writeFile configFile $ encodeUtf8 $ T.unlines configLines menv <- getMinimalEnvOverride - ghcMajorVersion <- getGhcMajorVersion menv + compilerVersion <- getCompilerVersion menv wc -- Run from a temporary directory to avoid cabal getting confused by any -- sandbox files, see: @@ -59,6 +62,8 @@ let args = ("--config-file=" ++ configFile) : "install" + : "--enable-tests" + : "--enable-benchmarks" : "-v" : "--dry-run" : "--only-dependencies" @@ -67,18 +72,22 @@ : "--package-db=clear" : "--package-db=global" : cabalArgs ++ - (map toFilePath cabalfps) + (map toFilePath cabalfps) ++ + ["--ghcjs" | wc == Ghcjs] $logInfo "Asking cabal to calculate a build plan, please wait" - bs <- readProcessStdout (Just tmpdir) menv "cabal" args + platform <- asks getPlatform + menv' <- mkEnvOverride platform + $ 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 (ghcMajorVersion, Map.fromList pairs) + then return (compilerVersion, Map.fromList pairs) else error $ "Could not parse cabal-install output: " ++ show errs where parseLine t0 = maybe (Left t0) Right $ do @@ -100,20 +109,26 @@ Just x -> (x, True) Just x -> (x, False) -getGhcVersion :: (MonadLogger m, MonadCatch m, MonadBaseControl IO m, MonadIO m) - => EnvOverride -> m Version -getGhcVersion menv = do - bs <- readProcessStdout Nothing menv "ghc" ["--numeric-version"] - parseVersion $ S8.takeWhile isValid bs +getCompilerVersion :: (MonadLogger m, MonadCatch m, MonadBaseControl IO m, MonadIO m) + => EnvOverride -> WhichCompiler -> m CompilerVersion +getCompilerVersion menv wc = + case wc of + Ghc -> do + bs <- readProcessStdout Nothing menv "ghc" ["--numeric-version"] + let (_, ghcVersion) = versionFromEnd bs + GhcVersion <$> parseVersion ghcVersion + Ghcjs -> do + -- Output looks like + -- + -- The Glorious Glasgow Haskell Compilation System for JavaScript, version 0.1.0 (GHC 7.10.2) + bs <- readProcessStdout Nothing menv "ghcjs" ["--version"] + let (rest, ghcVersion) = versionFromEnd bs + (_, ghcjsVersion) = versionFromEnd rest + GhcjsVersion <$> parseVersion ghcjsVersion <*> parseVersion ghcVersion where + versionFromEnd = S8.spanEnd isValid . fst . S8.breakEnd isValid isValid c = c == '.' || ('0' <= c && c <= '9') -getGhcMajorVersion :: (MonadLogger m, MonadCatch m, MonadBaseControl IO m, MonadIO m) - => EnvOverride -> m MajorVersion -getGhcMajorVersion menv = do - version <- getGhcVersion menv - return $ getMajorVersion version - getCabalConfig :: (MonadReader env m, HasConfig env, MonadIO m, MonadThrow m) => FilePath -- ^ temp dir -> Map PackageName Version -- ^ constraints @@ -156,7 +171,7 @@ snapshot <- case bcResolver bconfig of ResolverSnapshot snapName -> liftM mbpPackages $ loadMiniBuildPlan snapName - ResolverGhc _ -> return Map.empty + ResolverCompiler _ -> return Map.empty ResolverCustom _ url -> liftM mbpPackages $ parseCustomMiniBuildPlan (bcStackYaml bconfig) url @@ -165,7 +180,9 @@ (bcExtraDeps bconfig) (fmap mpiVersion snapshot) - (_ghc, extraDeps) <- cabalSolver + wc <- getWhichCompiler + (_compilerVersion, extraDeps) <- cabalSolver + wc (Map.keys $ envConfigPackages econfig) packages [] diff --git a/src/Stack/Types.hs b/src/Stack/Types.hs --- a/src/Stack/Types.hs +++ b/src/Stack/Types.hs @@ -15,3 +15,4 @@ import Stack.Types.Image as X import Stack.Types.Build as X import Stack.Types.Package as X +import Stack.Types.Compiler as X 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 @@ -35,12 +35,15 @@ ,configureOpts ,BadDependency(..) ,wantedLocalPackages - ,FileCacheInfo (..)) + ,FileCacheInfo (..) + ,ConfigureOpts (..) + ,PrecompiledCache (..)) where import Control.DeepSeq import Control.Exception +import Data.Binary (getWord8, putWord8, gput, gget) import Data.Binary.VersionTagged import qualified Data.ByteString as S import Data.Char (isSpace) @@ -66,6 +69,7 @@ import Prelude import Stack.Types.FlagName import Stack.Types.GhcPkgId +import Stack.Types.Compiler import Stack.Types.Config import Stack.Types.Package import Stack.Types.PackageIdentifier @@ -78,7 +82,12 @@ -- Exceptions data StackBuildException = Couldn'tFindPkgId PackageName - | GHCVersionMismatch (Maybe (Version, Arch)) (Version, Arch) (Maybe (Path Abs File)) + | CompilerVersionMismatch + (Maybe (CompilerVersion, Arch)) + (CompilerVersion, Arch) + VersionCheck + (Maybe (Path Abs File)) + Text -- recommended resolution -- ^ Path to the stack.yaml file | Couldn'tParseTargets [Text] | UnknownTargets @@ -104,6 +113,7 @@ | NoSetupHsFound (Path Abs Dir) | InvalidFlagSpecification (Set UnusedFlags) | TargetParseException [Text] + | DuplicateLocalPackageNames [(PackageName, [Path Abs Dir])] deriving Typeable data FlagSource = FSCommandLine | FSStackYaml @@ -111,6 +121,7 @@ data UnusedFlags = UFNoPackage FlagSource PackageName | UFFlagsNotDefined FlagSource Package (Set FlagName) + | UFSnapshot PackageName deriving (Show, Eq, Ord) instance Show StackBuildException where @@ -119,25 +130,30 @@ ", the package id couldn't be found " <> "(via ghc-pkg describe " <> packageNameString name <> "). This shouldn't happen, " <> "please report as a bug") - show (GHCVersionMismatch mactual (expected, earch) mstack) = concat + show (CompilerVersionMismatch mactual (expected, earch) check mstack resolution) = concat [ case mactual of - Nothing -> "No GHC found, expected version " + Nothing -> "No compiler found, expected " Just (actual, arch) -> concat - [ "GHC version mismatched, found " - , versionString actual + [ "Compiler version mismatched, found " + , T.unpack (compilerVersionName actual) , " (" , display arch , ")" - , ", but expected version " + , ", but expected " ] - , versionString expected + , case check of + MatchMinor -> "minor version match with " + MatchExact -> "exact version " + NewerMinor -> "minor version match or newer with " + , T.unpack (compilerVersionName expected) , " (" , display earch , ") (based on " , case mstack of Nothing -> "command line arguments" Just stack -> "resolver setting in " ++ toFilePath stack - , "). Try running stack setup" + , "). " + , T.unpack resolution ] show (Couldn'tParseTargets targets) = unlines $ "The following targets could not be parsed as package names or directories:" @@ -214,7 +230,7 @@ go _ = Map.empty -- Supressing duplicate output show (CabalExitedUnsuccessfully exitCode taskProvides' execName fullArgs logFiles bs) = - let fullCmd = (dropQuotes (show execName) ++ " " ++ (unwords fullArgs)) + let fullCmd = (dropQuotes (toFilePath execName) ++ " " ++ (unwords fullArgs)) logLocations = maybe "" (\fp -> "\n Logs have been written to: " ++ toFilePath fp) logFiles in "\n-- While building package " ++ dropQuotes (show taskProvides') ++ " using:\n" ++ " " ++ fullCmd ++ "\n" ++ @@ -271,11 +287,26 @@ ] where name = packageNameString (packageName pkg) pkgFlags = packageDefinedFlags pkg + go (UFSnapshot name) = concat + [ "- Attempted to set flag on snapshot package " + , packageNameString name + , ", please add to extra-deps" + ] show (TargetParseException [err]) = "Error parsing targets: " ++ T.unpack err show (TargetParseException errs) = unlines $ "The following errors occurred while parsing the build targets:" : map (("- " ++) . T.unpack) errs + show (DuplicateLocalPackageNames pairs) = concat + $ "The same package name is used in multiple local packages\n" + : map go pairs + where + go (name, dirs) = unlines + $ "" + : (packageNameString name ++ " used in:") + : map goDir dirs + goDir dir = "- " ++ toFilePath dir + instance Exception StackBuildException data ConstructPlanException @@ -318,14 +349,21 @@ , ": needed (" , display range , ")" - , case mlatest of - Nothing -> "" - Just latest -> ", latest is " ++ versionString latest - , ", but " - , case badDep of - NotInBuildPlan -> "not present in build plan" - Couldn'tResolveItsDependencies -> "couldn't resolve its dependencies" - DependencyMismatch version -> versionString version ++ " found" + , ", " + , let latestStr = + case mlatest of + Nothing -> "" + Just latest -> " (latest is " ++ versionString latest ++ ")" + in case badDep of + NotInBuildPlan -> "not present in build plan" ++ latestStr + Couldn'tResolveItsDependencies -> "couldn't resolve its dependencies" + DependencyMismatch version -> + case mlatest of + Just latest + | latest == version -> + versionString version ++ + " found (latest version available)" + _ -> versionString version ++ " found" ++ latestStr ] {- TODO Perhaps change the showDep function to look more like this: dropQuotes = filter ((/=) '\"') @@ -354,7 +392,6 @@ BuildOpts {boptsTargets :: ![Text] ,boptsLibProfile :: !Bool ,boptsExeProfile :: !Bool - ,boptsEnableOptimizations :: !(Maybe Bool) ,boptsHaddock :: !Bool -- ^ Build haddocks? ,boptsHaddockDeps :: !(Maybe Bool) @@ -385,6 +422,8 @@ -- ^ Additional test arguments ,boptsExec :: ![(String, [String])] -- ^ Commands (with arguments) to run after a successful build + ,boptsOnlyConfigure :: !Bool + -- ^ Only perform the configure step when building } deriving (Show) @@ -393,7 +432,6 @@ { boptsTargets = [] , boptsLibProfile = False , boptsExeProfile = False - , boptsEnableOptimizations = Nothing , boptsHaddock = False , boptsHaddockDeps = Nothing , boptsDryrun = False @@ -410,6 +448,7 @@ , boptsBenchmarks = False , boptsBenchmarkOpts = defaultBenchmarkOpts , boptsExec = [] + , boptsOnlyConfigure = False } -- | Options for the 'FinalAction' 'DoTests' @@ -431,11 +470,13 @@ -- | Options for the 'FinalAction' 'DoBenchmarks' data BenchmarkOpts = BenchmarkOpts {beoAdditionalArgs :: !(Maybe String) -- ^ Arguments passed to the benchmark program + ,beoDisableRun :: !Bool -- ^ Disable running of benchmarks } deriving (Eq,Show) defaultBenchmarkOpts :: BenchmarkOpts defaultBenchmarkOpts = BenchmarkOpts { beoAdditionalArgs = Nothing + , beoDisableRun = False } -- | Package dependency oracle. @@ -446,7 +487,7 @@ -- | Stored on disk to know whether the flags have changed or any -- files have changed. data ConfigCache = ConfigCache - { configCacheOpts :: ![S.ByteString] + { configCacheOpts :: !ConfigureOpts -- ^ All options used for this package. , configCacheDeps :: !(Set GhcPkgId) -- ^ The GhcPkgIds of all of the dependencies. Since Cabal doesn't take @@ -461,7 +502,20 @@ -- ^ Are haddocks to be built? } deriving (Generic,Eq,Show) -instance Binary ConfigCache +instance Binary ConfigCache where + put x = do + -- magic string + putWord8 1 + putWord8 3 + putWord8 4 + putWord8 8 + gput $ from x + get = do + 1 <- getWord8 + 3 <- getWord8 + 4 <- getWord8 + 8 <- getWord8 + fmap to gget instance NFData ConfigCache where rnf = genericRnf @@ -478,7 +532,7 @@ data TaskConfigOpts = TaskConfigOpts { tcoMissing :: !(Set PackageIdentifier) -- ^ Dependencies for which we don't yet have an GhcPkgId - , tcoOpts :: !(Set GhcPkgId -> [Text]) + , tcoOpts :: !(Set GhcPkgId -> ConfigureOpts) -- ^ Produce the list of options given the missing @GhcPkgId@s } instance Show TaskConfigOpts where @@ -529,19 +583,54 @@ -> Bool -- ^ wanted? -> InstallLocation -> Package - -> [Text] -configureOpts econfig bco deps wanted loc package = map T.pack $ concat + -> ConfigureOpts +configureOpts econfig bco deps wanted loc package = ConfigureOpts + { coDirs = configureOptsDirs bco loc package + , coNoDirs = configureOptsNoDir econfig bco deps wanted package + } + +configureOptsDirs :: BaseConfigOpts + -> InstallLocation + -> Package + -> [String] +configureOptsDirs bco loc package = concat [ ["--user", "--package-db=clear", "--package-db=global"] , map (("--package-db=" ++) . toFilePath) $ case loc of Snap -> [bcoSnapDB bco] Local -> [bcoSnapDB bco, bcoLocalDB bco] - , depOptions , [ "--libdir=" ++ toFilePathNoTrailingSlash (installRoot $(mkRelDir "lib")) , "--bindir=" ++ toFilePathNoTrailingSlash (installRoot bindirSuffix) , "--datadir=" ++ toFilePathNoTrailingSlash (installRoot $(mkRelDir "share")) + , "--libexecdir=" ++ toFilePathNoTrailingSlash (installRoot $(mkRelDir "libexec")) + , "--sysconfdir=" ++ toFilePathNoTrailingSlash (installRoot $(mkRelDir "etc")) , "--docdir=" ++ toFilePathNoTrailingSlash docDir , "--htmldir=" ++ toFilePathNoTrailingSlash docDir , "--haddockdir=" ++ toFilePathNoTrailingSlash docDir] + ] + where + toFilePathNoTrailingSlash = dropTrailingPathSeparator . toFilePath + installRoot = + case loc of + Snap -> bcoSnapInstallRoot bco + Local -> bcoLocalInstallRoot bco + docDir = + case pkgVerDir of + Nothing -> installRoot docDirSuffix + Just dir -> installRoot docDirSuffix dir + pkgVerDir = + parseRelDir (packageIdentifierString (PackageIdentifier (packageName package) + (packageVersion package)) ++ + [pathSeparator]) + +-- | Same as 'configureOpts', but does not include directory path options +configureOptsNoDir :: EnvConfig + -> BaseConfigOpts + -> Set GhcPkgId -- ^ dependencies + -> Bool -- ^ wanted? + -> Package + -> [String] +configureOptsNoDir econfig bco deps wanted package = concat + [ depOptions , ["--enable-library-profiling" | boptsLibProfile bopts || boptsExeProfile bopts] , ["--enable-executable-profiling" | boptsExeProfile bopts] , map (\(name,enabled) -> @@ -551,29 +640,16 @@ else "-") <> flagNameString name) (Map.toList (packageFlags package)) - -- FIXME Chris: where does this come from now? , ["--ghc-options=-O2" | gconfigOptimize gconfig] - , if wanted - then concatMap (\x -> ["--ghc-options", T.unpack x]) (boptsGhcOptions bopts) - else [] + , concatMap (\x -> ["--ghc-options", T.unpack x]) allGhcOptions , map (("--extra-include-dirs=" ++) . T.unpack) (Set.toList (configExtraIncludeDirs config)) , map (("--extra-lib-dirs=" ++) . T.unpack) (Set.toList (configExtraLibDirs config)) + , if whichCompiler (envConfigCompilerVersion econfig) == Ghcjs + then ["--ghcjs"] + else [] ] where config = getConfig econfig bopts = bcoBuildOpts bco - toFilePathNoTrailingSlash = dropTrailingPathSeparator . toFilePath - docDir = - case pkgVerDir of - Nothing -> installRoot docDirSuffix - Just dir -> installRoot docDirSuffix dir - installRoot = - case loc of - Snap -> bcoSnapInstallRoot bco - Local -> bcoLocalInstallRoot bco - pkgVerDir = - parseRelDir (packageIdentifierString (PackageIdentifier (packageName package) - (packageVersion package)) ++ - [pathSeparator]) depOptions = map toDepOption $ Set.toList deps where @@ -598,6 +674,15 @@ where PackageIdentifier name version = ghcPkgIdPackageIdentifier gid + ghcOptionsMap = configGhcOptions $ getConfig econfig + allGhcOptions = concat + [ fromMaybe [] $ Map.lookup Nothing ghcOptionsMap + , fromMaybe [] $ Map.lookup (Just $ packageName package) ghcOptionsMap + , if wanted + then boptsGhcOptions bopts + else [] + ] + -- | Get set of wanted package names from locals. wantedLocalPackages :: [LocalPackage] -> Set PackageName wantedLocalPackages = Set.fromList . map (packageName . lpPackage) . filter lpWanted @@ -613,3 +698,30 @@ data Installed = Library GhcPkgId | Executable PackageIdentifier deriving (Show, Eq, Ord) + +-- | Configure options to be sent to Setup.hs configure +data ConfigureOpts = ConfigureOpts + { coDirs :: ![String] + -- ^ Options related to various paths. We separate these out since they do + -- not have an impact on the contents of the compiled binary for checking + -- if we can use an existing precompiled cache. + , coNoDirs :: ![String] + } + deriving (Show, Eq, Generic) +instance Binary ConfigureOpts +instance NFData ConfigureOpts where + rnf = genericRnf + +-- | Information on a compiled package: the library conf file (if relevant), +-- and all of the executable paths. +data PrecompiledCache = PrecompiledCache + -- Use FilePath instead of Path Abs File for Binary instances + { pcLibrary :: !(Maybe FilePath) + -- ^ .conf file inside the package database + , pcExes :: ![FilePath] + -- ^ Full paths to executables + } + deriving (Show, Eq, Generic) +instance Binary PrecompiledCache +instance NFData PrecompiledCache where + rnf = genericRnf 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 @@ -57,6 +57,7 @@ import GHC.Generics (Generic) import Prelude -- Fix AMP warning import Safe (readMay) +import Stack.Types.Compiler import Stack.Types.FlagName import Stack.Types.PackageName import Stack.Types.Version @@ -210,7 +211,7 @@ $ map (\x -> (testStateToText x, x)) [minBound..maxBound] data SystemInfo = SystemInfo - { siGhcVersion :: Version + { siCompilerVersion :: CompilerVersion , siOS :: OS , siArch :: Arch , siCorePackages :: Map PackageName Version @@ -218,9 +219,11 @@ } deriving (Show, Eq, Ord) instance ToJSON SystemInfo where - toJSON SystemInfo {..} = object - [ "ghc-version" .= siGhcVersion - , "os" .= display siOS + toJSON SystemInfo {..} = object $ + (case siCompilerVersion of + GhcVersion version -> "ghc-version" .= version + _ -> "compiler-version" .= siCompilerVersion) : + [ "os" .= display siOS , "arch" .= display siArch , "core-packages" .= siCorePackages , "core-executables" .= siCoreExecutables @@ -228,7 +231,14 @@ instance FromJSON SystemInfo where parseJSON = withObject "SystemInfo" $ \o -> do let helper name = (o .: name) >>= either (fail . show) return . simpleParse - siGhcVersion <- o .: "ghc-version" + ghcVersion <- o .:? "ghc-version" + compilerVersion <- o .:? "compiler-version" + siCompilerVersion <- + case (ghcVersion, compilerVersion) of + (Just _, Just _) -> fail "can't have both compiler-version and ghc-version fields" + (Just ghc, _) -> return (GhcVersion ghc) + (_, Just compiler) -> return compiler + _ -> fail "expected field \"ghc-version\" or \"compiler-version\" not present" siOS <- helper "os" siArch <- helper "arch" siCorePackages <- o .: "core-packages" @@ -360,7 +370,7 @@ -- | A simplified version of the 'BuildPlan' + cabal file. data MiniBuildPlan = MiniBuildPlan - { mbpGhcVersion :: !Version + { mbpCompilerVersion :: !CompilerVersion , mbpPackages :: !(Map PackageName MiniPackageInfo) } deriving (Generic, Show, Eq) @@ -369,7 +379,7 @@ rnf = genericRnf instance BinarySchema MiniBuildPlan where -- Don't forget to update this if you change the datatype in any way! - binarySchema _ = 1 + binarySchema _ = 2 -- | Information on a single package for the 'MiniBuildPlan'. data MiniPackageInfo = MiniPackageInfo diff --git a/src/Stack/Types/Compiler.hs b/src/Stack/Types/Compiler.hs new file mode 100644 --- /dev/null +++ b/src/Stack/Types/Compiler.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ViewPatterns #-} + +module Stack.Types.Compiler where + +import Control.DeepSeq +import Control.DeepSeq.Generics (genericRnf) +import Data.Aeson +import Data.Binary (Binary) +import Data.Monoid ((<>)) +import qualified Data.Text as T +import GHC.Generics (Generic) +import Stack.Types.Version + +-- | Variety of compiler to use. +data WhichCompiler + = Ghc + | Ghcjs + deriving (Show, Eq, Ord) + +-- | Specifies a compiler and its version number(s). +-- +-- Note that despite having this datatype, stack isn't in a hurry to +-- support compilers other than GHC. +-- +-- NOTE: updating this will change its binary serialization. The +-- version number in the 'BinarySchema' instance for 'MiniBuildPlan' +-- should be updated. +data CompilerVersion + = GhcVersion {-# UNPACK #-} !Version + | GhcjsVersion + {-# UNPACK #-} !Version -- ^ GHCJS version + {-# UNPACK #-} !Version -- ^ GHC version + deriving (Generic, Show, Eq, Ord) +instance Binary CompilerVersion +instance NFData CompilerVersion where + rnf = genericRnf +instance ToJSON CompilerVersion where + toJSON = toJSON . compilerVersionName +instance FromJSON CompilerVersion where + parseJSON (String t) = maybe (fail "Failed to parse compiler version") return (parseCompilerVersion t) + parseJSON _ = fail "Invalid CompilerVersion, must be String" + +parseCompilerVersion :: T.Text -> Maybe CompilerVersion +parseCompilerVersion t + | Just t' <- T.stripPrefix "ghc-" t + , Just v <- parseVersionFromString $ T.unpack t' + = Just (GhcVersion v) + | Just t' <- T.stripPrefix "ghcjs-" t + , [tghcjs, tghc] <- T.splitOn "_ghc-" t' + , Just vghcjs <- parseVersionFromString $ T.unpack tghcjs + , Just vghc <- parseVersionFromString $ T.unpack tghc + = Just (GhcjsVersion vghcjs vghc) + | otherwise + = Nothing + +compilerVersionName :: CompilerVersion -> T.Text +compilerVersionName (GhcVersion vghc) = + "ghc-" <> versionText vghc +compilerVersionName (GhcjsVersion vghcjs vghc) = + "ghcjs-" <> versionText vghcjs <> "_ghc-" <> versionText vghc + +whichCompiler :: CompilerVersion -> WhichCompiler +whichCompiler GhcVersion {} = Ghc +whichCompiler GhcjsVersion {} = Ghcjs + +isWantedCompiler :: VersionCheck -> CompilerVersion -> CompilerVersion -> Bool +isWantedCompiler check (GhcVersion wanted) (GhcVersion actual) = + checkVersion check wanted actual +isWantedCompiler check (GhcjsVersion wanted wantedGhc) (GhcjsVersion actual actualGhc) = + checkVersion check wanted actual && checkVersion check wantedGhc actualGhc +isWantedCompiler _ _ _ = False + +compilerExeName :: WhichCompiler -> String +compilerExeName Ghc = "ghc" +compilerExeName Ghcjs = "ghcjs" + +haddockExeName :: WhichCompiler -> String +haddockExeName Ghc = "haddock" +haddockExeName Ghcjs = "haddock-ghcjs" 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 @@ -11,9 +11,9 @@ module Stack.Types.Config where -import Control.Applicative ((<|>), (<$>), (<*>), pure) +import Control.Applicative import Control.Exception -import Control.Monad (liftM, mzero) +import Control.Monad (liftM, mzero, forM) import Control.Monad.Catch (MonadThrow, throwM) import Control.Monad.Logger (LogLevel(..)) import Control.Monad.Reader (MonadReader, ask, asks, MonadIO, liftIO) @@ -22,6 +22,7 @@ (.=), (.:), (..:), (..:?), (..!=), Value(String, Object), withObjectWarnings, WarningParser, Object, jsonSubWarnings, JSONWarning, jsonSubWarningsMT) +import Data.Attoparsec.Args import Data.Binary (Binary) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as S8 @@ -29,6 +30,9 @@ import Data.Hashable (Hashable) import Data.Map (Map) import qualified Data.Map as Map + +import qualified Data.Map.Strict as M +import Data.Maybe import Data.Monoid import Data.Set (Set) import qualified Data.Set as Set @@ -44,6 +48,7 @@ import Path import qualified Paths_stack as Meta import Stack.Types.BuildPlan (SnapName, renderSnapName, parseSnapName) +import Stack.Types.Compiler import Stack.Types.Docker import Stack.Types.FlagName import Stack.Types.Image @@ -96,6 +101,8 @@ -- ^ Don't bother checking the GHC version or architecture. ,configSkipMsys :: !Bool -- ^ On Windows: don't use a locally installed MSYS + ,configCompilerCheck :: !VersionCheck + -- ^ Specifies which versions of the compiler are acceptable. ,configLocalBin :: !(Path Abs Dir) -- ^ Directory we should install executables into ,configRequireStackVersion :: !VersionRange @@ -111,12 +118,13 @@ ,configConcurrentTests :: !Bool -- ^ Run test suites concurrently ,configImage :: !ImageOpts - ,configAuthorEmail :: !(Maybe Text) - -- ^ Email of the author using stack. - ,configAuthorName :: !(Maybe Text) - -- ^ Name of the author using stack. + ,configTemplateParams :: !(Map Text Text) + -- ^ Parameters for templates. ,configScmInit :: !(Maybe SCM) -- ^ Initialize SCM (e.g. git) when creating new projects. + ,configGhcOptions :: !(Map (Maybe PackageName) [Text]) + -- ^ Additional GHC options to apply to either all packages (Nothing) + -- or a specific package (Just). } -- | Information on a single package index @@ -182,6 +190,8 @@ -- ^ include the GHC_PACKAGE_PATH variable , esStackExe :: !Bool -- ^ set the STACK_EXE variable to the current executable name + , esLocaleUtf8 :: !Bool + -- ^ set the locale to C.UTF-8 } deriving (Show, Eq, Ord) @@ -205,6 +215,7 @@ , globalResolver :: !(Maybe AbstractResolver) -- ^ Resolver override , globalTerminal :: !Bool -- ^ We're in a terminal? , globalStackYaml :: !(Maybe FilePath) -- ^ Override project stack.yaml + , globalModifyCodePage :: !Bool -- ^ Force the code page to UTF-8 on Windows } deriving (Show) -- | Either an actual resolver value, or an abstract description of one (e.g., @@ -229,8 +240,8 @@ , bcResolver :: !Resolver -- ^ How we resolve which dependencies to install given a set of -- packages. - , bcGhcVersionExpected :: !Version - -- ^ Version of GHC we expected for this build + , bcWantedCompiler :: !CompilerVersion + -- ^ Compiler version wanted for this build , bcPackageEntries :: ![PackageEntry] -- ^ Local packages identified by a path, Bool indicates whether it is -- a non-dependency (the opposite of 'peExtraDep') @@ -263,7 +274,7 @@ data EnvConfig = EnvConfig {envConfigBuildConfig :: !BuildConfig ,envConfigCabalVersion :: !Version - ,envConfigGhcVersion :: !Version + ,envConfigCompilerVersion :: !CompilerVersion ,envConfigPackages :: !(Map (Path Abs Dir) Bool)} instance HasBuildConfig EnvConfig where getBuildConfig = envConfigBuildConfig @@ -388,9 +399,9 @@ -- ^ Use an official snapshot from the Stackage project, either an LTS -- Haskell or Stackage Nightly - | ResolverGhc {-# UNPACK #-} !MajorVersion - -- ^ Require a specific GHC major version, but otherwise provide no build - -- plan. Intended for use cases where end user wishes to specify all upstream + | ResolverCompiler !CompilerVersion + -- ^ Require a specific compiler version, but otherwise provide no build plan. + -- Intended for use cases where end user wishes to specify all upstream -- dependencies manually, such as using a dependency solver. | ResolverCustom !Text !Text @@ -399,12 +410,11 @@ deriving (Show) instance ToJSON Resolver where - toJSON (ResolverSnapshot name) = toJSON $ renderSnapName name - toJSON (ResolverGhc (MajorVersion x y)) = toJSON $ T.pack $ concat ["ghc-", show x, ".", show y] toJSON (ResolverCustom name location) = object [ "name" .= name , "location" .= location ] + toJSON x = toJSON $ resolverName x instance FromJSON Resolver where -- Strange structuring is to give consistent error messages parseJSON v@(Object _) = withObject "Resolver" (\o -> ResolverCustom @@ -419,16 +429,14 @@ -- directory names resolverName :: Resolver -> Text resolverName (ResolverSnapshot name) = renderSnapName name -resolverName (ResolverGhc (MajorVersion x y)) = T.pack $ concat ["ghc-", show x, ".", show y] +resolverName (ResolverCompiler v) = compilerVersionName v resolverName (ResolverCustom name _) = "custom-" <> name -- | Try to parse a @Resolver@ from a @Text@. Won't work for complex resolvers (like custom). parseResolverText :: MonadThrow m => Text -> m Resolver parseResolverText t | Right x <- parseSnapName t = return $ ResolverSnapshot x - | Just t' <- T.stripPrefix "ghc-" t - , Just v <- parseMajorVersionFromString $ T.unpack t' - = return $ ResolverGhc v + | Just v <- parseCompilerVersion t = return $ ResolverCompiler v | otherwise = throwM $ ParseResolverException t -- | Class for environment values which have access to the stack root @@ -491,6 +499,8 @@ -- ^ See: 'configSkipGHCCheck' ,configMonoidSkipMsys :: !(Maybe Bool) -- ^ See: 'configSkipMsys' + ,configMonoidCompilerCheck :: !(Maybe VersionCheck) + -- ^ See: 'configCompilerCheck' ,configMonoidRequireStackVersion :: !VersionRange -- ^ See: 'configRequireStackVersion' ,configMonoidOS :: !(Maybe String) @@ -509,12 +519,14 @@ -- ^ Used to override the binary installation dir ,configMonoidImageOpts :: !ImageOptsMonoid -- ^ Image creation options. - ,configMonoidAuthorEmail :: !(Maybe Text) - -- ^ Author's email address. - ,configMonoidAuthorName :: !(Maybe Text) - -- ^ Author's name. + ,configMonoidTemplateParameters :: !(Map Text Text) + -- ^ Template parameters. ,configMonoidScmInit :: !(Maybe SCM) -- ^ Initialize SCM (e.g. git init) when making new projects? + ,configMonoidGhcOptions :: !(Map (Maybe PackageName) [Text]) + -- ^ See 'configGhcOptions' + ,configMonoidExtraPath :: ![Path Abs Dir] + -- ^ Additional paths to search for executables in } deriving Show @@ -538,9 +550,11 @@ , configMonoidConcurrentTests = Nothing , configMonoidLocalBinPath = Nothing , configMonoidImageOpts = mempty - , configMonoidAuthorEmail = mempty - , configMonoidAuthorName = mempty + , configMonoidTemplateParameters = mempty , configMonoidScmInit = Nothing + , configMonoidCompilerCheck = Nothing + , configMonoidGhcOptions = mempty + , configMonoidExtraPath = [] } mappend l r = ConfigMonoid { configMonoidDockerOpts = configMonoidDockerOpts l <> configMonoidDockerOpts r @@ -562,9 +576,11 @@ , configMonoidConcurrentTests = configMonoidConcurrentTests l <|> configMonoidConcurrentTests r , configMonoidLocalBinPath = configMonoidLocalBinPath l <|> configMonoidLocalBinPath r , configMonoidImageOpts = configMonoidImageOpts l <> configMonoidImageOpts r - , configMonoidAuthorName = configMonoidAuthorName l <|> configMonoidAuthorName r - , configMonoidAuthorEmail = configMonoidAuthorEmail l <|> configMonoidAuthorEmail r + , configMonoidTemplateParameters = configMonoidTemplateParameters l <> configMonoidTemplateParameters r , configMonoidScmInit = configMonoidScmInit l <|> configMonoidScmInit r + , configMonoidCompilerCheck = configMonoidCompilerCheck l <|> configMonoidCompilerCheck r + , configMonoidGhcOptions = Map.unionWith (++) (configMonoidGhcOptions l) (configMonoidGhcOptions r) + , configMonoidExtraPath = configMonoidExtraPath l ++ configMonoidExtraPath r } instance FromJSON (ConfigMonoid, [JSONWarning]) where @@ -595,11 +611,41 @@ configMonoidConcurrentTests <- obj ..:? "concurrent-tests" configMonoidLocalBinPath <- obj ..:? "local-bin-path" configMonoidImageOpts <- jsonSubWarnings (obj ..:? "image" ..!= mempty) - configMonoidAuthorName <- obj ..:? authorNameKey - configMonoidAuthorEmail <- obj ..:? authorEmailKey - configMonoidScmInit <- obj ..:? scmInitKey + templates <- obj ..:? "templates" + (configMonoidScmInit,configMonoidTemplateParameters) <- + case templates of + Nothing -> return (Nothing,M.empty) + Just tobj -> do + scmInit <- tobj ..:? "scm-init" + params <- tobj ..:? "params" + return (scmInit,fromMaybe M.empty params) + configMonoidCompilerCheck <- obj ..:? "compiler-check" + + mghcoptions <- obj ..:? "ghc-options" + configMonoidGhcOptions <- + case mghcoptions of + Nothing -> return mempty + Just m -> fmap Map.fromList $ mapM handleGhcOptions $ Map.toList m + + extraPath <- obj ..:? "extra-path" ..!= [] + configMonoidExtraPath <- forM extraPath $ + either (fail . show) return . parseAbsDir . T.unpack + return ConfigMonoid {..} + where + handleGhcOptions :: Monad m => (Text, Text) -> m (Maybe PackageName, [Text]) + handleGhcOptions (name', vals') = do + name <- + if name' == "*" + then return Nothing + else case parsePackageNameFromString $ T.unpack name' of + Left e -> fail $ show e + Right x -> return $ Just x + case parseArgs Escaping vals' of + Left e -> fail e + Right vals -> return (name, map T.pack vals) + -- | Newtype for non-orphan FromJSON instance. newtype VersionRangeJSON = VersionRangeJSON { unVersionRangeJSON :: VersionRange } @@ -630,7 +676,7 @@ show (ParseResolverException t) = concat [ "Invalid resolver value: " , T.unpack t - , ". Possible valid values include lts-2.12, nightly-YYYY-MM-DD, and ghc-7.10. " + , ". Possible valid values include lts-2.12, nightly-YYYY-MM-DD, ghc-7.10.2, and ghcjs-0.1.0-ghc-7.10.2. " , "See https://www.stackage.org/snapshots for a complete list." ] show (NoProjectConfigFound dir mcmd) = concat @@ -746,21 +792,26 @@ installationRootDeps = do snapshots <- snapshotsDir bc <- asks getBuildConfig - ec <- asks getEnvConfig name <- parseRelDir $ T.unpack $ resolverName $ bcResolver bc - ghc <- parseRelDir $ versionString $ envConfigGhcVersion ec + ghc <- compilerVersionDir return $ snapshots name ghc -- | Installation root for locals installationRootLocal :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Path Abs Dir) installationRootLocal = do bc <- asks getBuildConfig - ec <- asks getEnvConfig name <- parseRelDir $ T.unpack $ resolverName $ bcResolver bc - ghc <- parseRelDir $ versionString $ envConfigGhcVersion ec + ghc <- compilerVersionDir platform <- platformRelDir return $ configProjectWorkDir bc $(mkRelDir "install") platform name ghc +compilerVersionDir :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Path Rel Dir) +compilerVersionDir = do + compilerVersion <- asks (envConfigCompilerVersion . getEnvConfig) + parseRelDir $ case compilerVersion of + GhcVersion version -> versionString version + GhcjsVersion {} -> T.unpack (compilerVersionName compilerVersion) + -- | Package database for installing dependencies into packageDatabaseDeps :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Path Abs Dir) packageDatabaseDeps = do @@ -823,8 +874,12 @@ { esIncludeLocals = False , esIncludeGhcPackagePath = False , esStackExe = False + , esLocaleUtf8 = False } +getWhichCompiler :: (MonadReader env m, HasEnvConfig env) => m WhichCompiler +getWhichCompiler = asks (whichCompiler . envConfigCompilerVersion . getEnvConfig) + data ProjectAndConfigMonoid = ProjectAndConfigMonoid !Project !ConfigMonoid @@ -887,15 +942,3 @@ instance ToJSON SCM where toJSON Git = toJSON ("git" :: Text) - --- | Key used for the YAML file and templates. -authorEmailKey :: Text -authorEmailKey = "author-email" - --- | Key used for the YAML file and templates. -authorNameKey :: Text -authorNameKey = "author-name" - --- | Key used for the YAML file and templates. -scmInitKey :: Text -scmInitKey = "scm-init" diff --git a/src/Stack/Types/Docker.hs b/src/Stack/Types/Docker.hs --- a/src/Stack/Types/Docker.hs +++ b/src/Stack/Types/Docker.hs @@ -36,6 +36,8 @@ -- ^ Arguments to pass directly to @docker run@. ,dockerMount :: ![Mount] -- ^ Volumes to mount in the container. + ,dockerEnv :: ![String] + -- ^ Environment variables to set in the container. ,dockerDatabasePath :: !(Path Abs File) -- ^ Location of image usage database. } @@ -70,6 +72,8 @@ -- ^ Arguments to pass directly to @docker run@ ,dockerMonoidMount :: ![Mount] -- ^ Volumes to mount in the container + ,dockerMonoidEnv :: ![String] + -- ^ Environment variables to set in the container ,dockerMonoidDatabasePath :: !(Maybe String) -- ^ Location of image usage database. } @@ -92,6 +96,7 @@ dockerMonoidContainerName <- o ..:? dockerContainerNameArgName dockerMonoidRunArgs <- o ..:? dockerRunArgsArgName ..!= [] dockerMonoidMount <- o ..:? dockerMountArgName ..!= [] + dockerMonoidEnv <- o ..:? dockerEnvArgName ..!= [] dockerMonoidDatabasePath <- o ..:? dockerDatabasePathArgName return DockerOptsMonoid{..}) @@ -110,6 +115,7 @@ ,dockerMonoidContainerName = Nothing ,dockerMonoidRunArgs = [] ,dockerMonoidMount = [] + ,dockerMonoidEnv = [] ,dockerMonoidDatabasePath = Nothing } mappend l r = DockerOptsMonoid @@ -125,6 +131,7 @@ ,dockerMonoidContainerName = dockerMonoidContainerName l <|> dockerMonoidContainerName r ,dockerMonoidRunArgs = dockerMonoidRunArgs r <> dockerMonoidRunArgs l ,dockerMonoidMount = dockerMonoidMount r <> dockerMonoidMount l + ,dockerMonoidEnv = dockerMonoidEnv r <> dockerMonoidEnv l ,dockerMonoidDatabasePath = dockerMonoidDatabasePath l <|> dockerMonoidDatabasePath r } @@ -194,6 +201,10 @@ -- | Docker mount argument name. dockerMountArgName :: Text dockerMountArgName = "mount" + +-- | Docker environment variable argument name. +dockerEnvArgName :: Text +dockerEnvArgName = "env" -- | Docker container name argument name. dockerContainerNameArgName :: Text 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 @@ -9,6 +9,7 @@ import Data.Monoid import Data.Map (Map) import Data.Text (Text) +import Prelude -- Fix redundant import warnings -- | Image options. Currently only Docker image options. data ImageOpts = ImageOpts diff --git a/src/Stack/Types/Internal.hs b/src/Stack/Types/Internal.hs --- a/src/Stack/Types/Internal.hs +++ b/src/Stack/Types/Internal.hs @@ -15,7 +15,8 @@ ,envTerminal :: !Bool ,envReExec :: !Bool ,envManager :: !Manager - ,envSticky :: !Sticky} + ,envSticky :: !Sticky + ,envSupportsUnicode :: !Bool} instance HasStackRoot config => HasStackRoot (Env config) where getStackRoot = getStackRoot . envConfig @@ -51,6 +52,12 @@ instance HasReExec (Env config) where getReExec = envReExec + +class HasSupportsUnicode r where + getSupportsUnicode :: r -> Bool + +instance HasSupportsUnicode (Env config) where + getSupportsUnicode = envSupportsUnicode newtype Sticky = Sticky { unSticky :: Maybe (MVar (Maybe Text)) 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 @@ -32,6 +32,7 @@ import GHC.Generics import Path as FL import Prelude +import Stack.Types.Compiler import Stack.Types.Config import Stack.Types.FlagName import Stack.Types.PackageName @@ -62,10 +63,13 @@ ": " ++ intercalate ", " (map (toFilePath . filename) files) show (MismatchedCabalName fp name) = concat - [ "cabal file " + [ "cabal file path " , toFilePath fp - , " has a mismatched package name: " + , " does not match the package name it defines.\n" + , "Please rename the file to: " , packageNameString name + , ".cabal\n" + , "For more information, see: https://github.com/commercialhaskell/stack/issues/317" ] -- | Some package info. @@ -73,7 +77,6 @@ Package {packageName :: !PackageName -- ^ Name of the package. ,packageVersion :: !Version -- ^ Version of the package ,packageFiles :: !GetPackageFiles -- ^ Get all files of the package. - ,packageModules :: !GetPackageModules -- ^ Get the modules of the package. ,packageDeps :: !(Map PackageName VersionRange) -- ^ Packages that the package depends on. ,packageTools :: ![Dependency] -- ^ A build tool name. ,packageAllDeps :: !(Set PackageName) -- ^ Original dependencies (not sieved). @@ -96,37 +99,43 @@ => SourceMap -> [PackageName] -> Path Abs File - -> m [String] + -> m (Map NamedComponent [String],[String]) } instance Show GetPackageOpts where show _ = "" +-- | Files to get for a cabal package. +data CabalFileType + = AllFiles + | Modules + -- | Files that the package depends on, relative to package directory. -- Argument is the location of the .cabal file newtype GetPackageFiles = GetPackageFiles { getPackageFiles :: forall m env. (MonadIO m, MonadLogger m, MonadThrow m, MonadCatch m, MonadReader env m, HasPlatform env, HasEnvConfig env) => Path Abs File - -> m (Set (Path Abs File)) + -> m (Map NamedComponent (Set ModuleName) + ,Map NamedComponent (Set (Path Abs File)) + ,Map NamedComponent (Set (Path Abs File)) + ,Map NamedComponent (Set MainIs) + ,Set (Path Abs File)) } instance Show GetPackageFiles where show _ = "" --- | Modules in the package. -newtype GetPackageModules = GetPackageModules - { getPackageModules :: forall m env. (MonadIO m, MonadLogger m, MonadThrow m, MonadCatch m, MonadReader env m, HasPlatform env, HasEnvConfig env) - => Path Abs File - -> m (Set ModuleName) +-- | A file specified as @main-is@ in a .cabal file. +newtype MainIs = MainIs + { mainIsFile :: Path Abs File } -instance Show GetPackageModules where - show _ = "" + deriving (Ord,Eq) -- | Package build configuration data PackageConfig = - PackageConfig {packageConfigEnableTests :: !Bool -- ^ Are tests enabled? - ,packageConfigEnableBenchmarks :: !Bool -- ^ Are benchmarks enabled? - ,packageConfigFlags :: !(Map FlagName Bool) -- ^ Package config flags. - ,packageConfigGhcVersion :: !Version -- ^ GHC version - ,packageConfigPlatform :: !Platform -- ^ host platform + PackageConfig {packageConfigEnableTests :: !Bool -- ^ Are tests enabled? + ,packageConfigEnableBenchmarks :: !Bool -- ^ Are benchmarks enabled? + ,packageConfigFlags :: !(Map FlagName Bool) -- ^ Package config flags. + ,packageConfigCompilerVersion :: !CompilerVersion -- ^ GHC version + ,packageConfigPlatform :: !Platform -- ^ host platform } deriving (Show,Typeable) @@ -176,6 +185,10 @@ -- | Information on a locally available package of source code data LocalPackage = LocalPackage { lpPackage :: !Package -- ^ The @Package@ info itself, after resolution with package flags, not including any tests or benchmarks + , lpTestDeps :: !(Map PackageName VersionRange) + -- ^ Used for determining if we can use --enable-tests in a normal build + , lpBenchDeps :: !(Map PackageName VersionRange) + -- ^ Used for determining if we can use --enable-benchmarks in a normal build , lpExeComponents :: !(Maybe (Set Text)) -- ^ Executable components to build, Nothing if not a target , lpTestBench :: !(Maybe LocalPackageTB) diff --git a/src/Stack/Types/PackageName.hs b/src/Stack/Types/PackageName.hs --- a/src/Stack/Types/PackageName.hs +++ b/src/Stack/Types/PackageName.hs @@ -52,11 +52,13 @@ data PackageNameParseFail = PackageNameParseFail ByteString | CabalFileNameParseFail FilePath + | CabalFileNameInvalidPackageName FilePath deriving (Typeable) instance Exception PackageNameParseFail instance Show PackageNameParseFail where show (PackageNameParseFail bs) = "Invalid package name: " ++ show bs - show (CabalFileNameParseFail fp) = "Invalid file path for cabal file: " ++ fp + show (CabalFileNameParseFail fp) = "Invalid file path for cabal file, must have a .cabal extension: " ++ fp + show (CabalFileNameInvalidPackageName fp) = "cabal file names must use valid package names followed by a .cabal extension, the following is invalid: " ++ fp -- | A package name. newtype PackageName = @@ -138,8 +140,11 @@ -- | Parse a package name from a file path. parsePackageNameFromFilePath :: MonadThrow m => Path a File -> m PackageName -parsePackageNameFromFilePath fp = - clean (toFilePath (filename fp)) >>= parsePackageNameFromString +parsePackageNameFromFilePath fp = do + base <- clean $ toFilePath $ filename fp + case parsePackageNameFromString base of + Nothing -> throwM $ CabalFileNameInvalidPackageName $ toFilePath fp + Just x -> return x where clean = liftM reverse . strip . reverse strip ('l':'a':'b':'a':'c':'.':xs) = return xs strip _ = throwM (CabalFileNameParseFail (toFilePath fp)) 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 @@ -41,8 +41,10 @@ import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T +import qualified Data.Text.Encoding.Error as T import qualified Data.Text.IO as T import Data.Time +import GHC.Foreign (withCString, peekCString) import Language.Haskell.TH import Network.HTTP.Client.Conduit (HasHttpManager(..)) import Network.HTTP.Conduit @@ -92,14 +94,25 @@ -- | Run a Stack action. runStackT :: (MonadIO m,MonadBaseControl IO m) => Manager -> LogLevel -> config -> Bool -> Bool -> StackT config m a -> m a -runStackT manager logLevel config terminal reExec m = +runStackT manager logLevel config terminal reExec m = do + canUseUnicode <- liftIO getCanUseUnicode withSticky terminal (\sticky -> runReaderT (unStackT m) - (Env config logLevel terminal reExec manager sticky)) + (Env config logLevel terminal reExec manager sticky canUseUnicode)) +-- | Taken from GHC: determine if we should use Unicode syntax +getCanUseUnicode :: IO Bool +getCanUseUnicode = do + let enc = localeEncoding + str = "\x2018\x2019" + test = withCString enc str $ \cstr -> do + str' <- peekCString enc cstr + return (str == str') + test `catchIOError` \_ -> return False + -------------------------------------------------------------------------------- -- Logging only StackLoggingT monad transformer @@ -110,6 +123,7 @@ , lenvReExec :: !Bool , lenvManager :: !Manager , lenvSticky :: !Sticky + , lenvSupportsUnicode :: !Bool } -- | The monad used for logging in the executable @stack@ before @@ -149,6 +163,9 @@ instance HasReExec LoggingEnv where getReExec = lenvReExec +instance HasSupportsUnicode LoggingEnv where + getSupportsUnicode = lenvSupportsUnicode + -- | Run the logging monad, using global options. runStackLoggingTGlobal :: MonadIO m => Manager -> GlobalOpts -> StackLoggingT m a -> m a @@ -158,7 +175,8 @@ -- | Run the logging monad. runStackLoggingT :: MonadIO m => Manager -> LogLevel -> Bool -> Bool -> StackLoggingT m a -> m a -runStackLoggingT manager logLevel terminal reExec m = +runStackLoggingT manager logLevel terminal reExec m = do + canUseUnicode <- liftIO getCanUseUnicode withSticky terminal (\sticky -> @@ -170,15 +188,16 @@ , lenvSticky = sticky , lenvTerminal = terminal , lenvReExec = reExec + , lenvSupportsUnicode = canUseUnicode }) -- | Convenience for getting a 'Manager' newTLSManager :: MonadIO m => m Manager -newTLSManager = liftIO $ newManager conduitManagerSettings +newTLSManager = liftIO $ newManager tlsManagerSettings -------------------------------------------------------------------------------- -- Logging functionality -stickyLoggerFunc :: (HasSticky r, HasLogLevel r, ToLogStr msg, MonadReader r (t m), MonadTrans t, MonadIO (t m)) +stickyLoggerFunc :: (HasSticky r, HasLogLevel r, HasSupportsUnicode r, ToLogStr msg, MonadReader r (t m), MonadTrans t, MonadIO (t m)) => Loc -> LogSource -> LogLevel -> msg -> t m () stickyLoggerFunc loc src level msg = do Sticky mref <- asks getSticky @@ -206,24 +225,27 @@ repeating ' ' <> repeating backSpaceChar)) maxLogLevel <- asks getLogLevel + + -- Convert some GHC-generated Unicode characters as necessary + supportsUnicode <- asks getSupportsUnicode + let msgText + | supportsUnicode = msgTextRaw + | otherwise = T.map replaceUnicode msgTextRaw + newState <- case level of LevelOther "sticky-done" -> do clear - let text = - T.decodeUtf8 msgBytes - liftIO (T.putStrLn text) + liftIO (T.putStrLn msgText) return Nothing LevelOther "sticky" -> do clear - let text = - T.decodeUtf8 msgBytes - liftIO (T.putStr text) - return (Just text) + liftIO (T.putStr msgText) + return (Just msgText) _ | level >= maxLogLevel -> do clear - loggerFunc loc src level msg + loggerFunc loc src level $ toLogStr msgText case sticky of Nothing -> return Nothing @@ -234,10 +256,15 @@ return sticky liftIO (putMVar ref newState) where - msgBytes = - fromLogStr - (toLogStr msg) + msgTextRaw = T.decodeUtf8With T.lenientDecode msgBytes + msgBytes = fromLogStr (toLogStr msg) +-- | Replace Unicode characters with non-Unicode equivalents +replaceUnicode :: Char -> Char +replaceUnicode '\x2018' = '`' +replaceUnicode '\x2019' = '\'' +replaceUnicode c = c + -- | Logging function takes the log level into account. loggerFunc :: (MonadIO m,ToLogStr msg,MonadReader r m,HasLogLevel r) => Loc -> Text -> LogLevel -> msg -> m () @@ -245,13 +272,13 @@ do maxLogLevel <- asks getLogLevel when (level >= maxLogLevel) (liftIO (do out <- getOutput maxLogLevel - S8.hPutStrLn outputChannel (S8.pack out))) + T.hPutStrLn outputChannel out)) where outputChannel = stderr getOutput maxLogLevel = do date <- getDate l <- getLevel lc <- getLoc - return (date ++ l ++ S8.unpack (fromLogStr (toLogStr msg)) ++ lc) + return (T.pack date <> T.pack l <> T.decodeUtf8 (fromLogStr (toLogStr msg)) <> T.pack lc) where getDate | maxLogLevel <= LevelDebug = do now <- getCurrentTime diff --git a/src/Stack/Types/TemplateName.hs b/src/Stack/Types/TemplateName.hs --- a/src/Stack/Types/TemplateName.hs +++ b/src/Stack/Types/TemplateName.hs @@ -28,6 +28,20 @@ (do string <- O.str either O.readerError return (parseTemplateNameFromString string)) +-- | An argument which accepts a @key:value@ pair for specifying parameters. +templateParamArgument :: O.Mod O.OptionFields (Text,Text) + -> O.Parser (Text,Text) +templateParamArgument = + O.option + (do string <- O.str + either O.readerError return (parsePair string)) + where + parsePair :: String -> Either String (Text, Text) + parsePair s = + case break (==':') s of + (key,':':value@(_:_)) -> Right (T.pack key, T.pack value) + _ -> Left ("Expected key:value format for argument: " <> s) + -- | Parse a template name from a string. parseTemplateNameFromString :: String -> Either String TemplateName parseTemplateNameFromString fname = @@ -40,7 +54,6 @@ Nothing -> Left expected Just fp -> return (TemplateName prefix fp) expected = "Expected a template filename like: foo or foo.hsfiles" - -- | Make a template name. mkTemplateName :: String -> Q Exp diff --git a/src/Stack/Types/Version.hs b/src/Stack/Types/Version.hs --- a/src/Stack/Types/Version.hs +++ b/src/Stack/Types/Version.hs @@ -11,10 +11,7 @@ module Stack.Types.Version (Version ,Cabal.VersionRange -- TODO in the future should have a newtype wrapper - ,MajorVersion (..) - ,getMajorVersion - ,fromMajorVersion - ,parseMajorVersionFromString + ,VersionCheck(..) ,versionParser ,parseVersion ,parseVersionFromString @@ -25,7 +22,9 @@ ,mkVersion ,versionRangeText ,withinRange - ,Stack.Types.Version.intersectVersionRanges) + ,Stack.Types.Version.intersectVersionRanges + ,toMajorVersion + ,checkVersion) where import Control.Applicative @@ -58,64 +57,17 @@ -- | A parse fail. data VersionParseFail = VersionParseFail ByteString - | NotAMajorVersion Version deriving (Typeable) instance Exception VersionParseFail instance Show VersionParseFail where show (VersionParseFail bs) = "Invalid version: " ++ show bs - show (NotAMajorVersion v) = concat - [ "Not a major version: " - , versionString v - , ", expecting exactly two numbers (e.g. 7.10)" - ] -- | A package version. newtype Version = Version {unVersion :: Vector Word} deriving (Eq,Ord,Typeable,Data,Generic,Binary,NFData) --- | The first two components of a version. -data MajorVersion = MajorVersion !Word !Word - deriving (Typeable, Eq, Ord) -instance Show MajorVersion where - show (MajorVersion x y) = concat [show x, ".", show y] -instance ToJSON MajorVersion where - toJSON = toJSON . fromMajorVersion --- | Parse major version from @String@ -parseMajorVersionFromString :: MonadThrow m => String -> m MajorVersion -parseMajorVersionFromString s = do - Version v <- parseVersionFromString s - if V.length v == 2 - then return $ getMajorVersion (Version v) - else throwM $ NotAMajorVersion (Version v) - -instance FromJSON MajorVersion where - parseJSON = withText "MajorVersion" - $ either (fail . show) return - . parseMajorVersionFromString - . T.unpack -instance FromJSON a => FromJSON (Map MajorVersion a) where - parseJSON val = do - m <- parseJSON val - fmap Map.fromList $ mapM go $ Map.toList m - where - go (k, v) = do - k' <- either (fail . show) return $ parseMajorVersionFromString k - return (k', v) - --- | Returns the first two components, defaulting to 0 if not present -getMajorVersion :: Version -> MajorVersion -getMajorVersion (Version v) = - case V.length v of - 0 -> MajorVersion 0 0 - 1 -> MajorVersion (V.head v) 0 - _ -> MajorVersion (V.head v) (v V.! 1) - --- | Convert a two-component version into a @Version@ -fromMajorVersion :: MajorVersion -> Version -fromMajorVersion (MajorVersion x y) = Version $ V.fromList [x, y] - instance Hashable Version where hashWithSalt i = hashWithSalt i . V.toList . unVersion @@ -140,6 +92,14 @@ Nothing -> fail ("Couldn't parse package version: " ++ s) Just ver -> return ver +instance FromJSON a => FromJSON (Map Version a) where + parseJSON val = do + m <- parseJSON val + fmap Map.fromList $ mapM go $ Map.toList m + where + go (k, v) = do + k' <- either (fail . show) return $ parseVersionFromString k + return (k', v) -- | Attoparsec parser for a package version from bytestring. versionParser :: Parser Version @@ -206,3 +166,44 @@ -- | A modified intersection which also simplifies, for better display. intersectVersionRanges :: Cabal.VersionRange -> Cabal.VersionRange -> Cabal.VersionRange intersectVersionRanges x y = Cabal.simplifyVersionRange $ Cabal.intersectVersionRanges x y + +-- | Returns the first two components, defaulting to 0 if not present +toMajorVersion :: Version -> Version +toMajorVersion (Version v) = + case V.length v of + 0 -> Version (V.fromList [0, 0]) + 1 -> Version (V.fromList [V.head v, 0]) + _ -> Version (V.fromList [V.head v, v V.! 1]) + +data VersionCheck + = MatchMinor + | MatchExact + | NewerMinor + deriving (Show, Eq, Ord) +instance ToJSON VersionCheck where + toJSON MatchMinor = String "match-minor" + toJSON MatchExact = String "match-exact" + toJSON NewerMinor = String "newer-minor" +instance FromJSON VersionCheck where + parseJSON = withText expected $ \t -> + case t of + "match-minor" -> return MatchMinor + "match-exact" -> return MatchExact + "newer-minor" -> return NewerMinor + _ -> fail ("Expected " ++ expected ++ ", but got " ++ show t) + where + expected = "VersionCheck value (match-minor, match-exact, or newer-minor)" + +checkVersion :: VersionCheck -> Version -> Version -> Bool +checkVersion check (Version wanted) (Version actual) = + case check of + MatchMinor -> V.and (V.take 3 matching) + MatchExact -> V.length wanted == V.length actual && V.and matching + NewerMinor -> V.and (V.take 2 matching) && newerMinor + where + matching = V.zipWith (==) wanted actual + newerMinor = + case (wanted V.!? 2, actual V.!? 2) of + (Nothing, _) -> True + (Just _, Nothing) -> False + (Just w, Just a) -> a >= w diff --git a/src/Stack/Upgrade.hs b/src/Stack/Upgrade.hs --- a/src/Stack/Upgrade.hs +++ b/src/Stack/Upgrade.hs @@ -11,6 +11,8 @@ import Control.Monad.Trans.Control import Data.Foldable (forM_) import qualified Data.Map as Map +import Data.Monoid ((<>)) +import qualified Data.Monoid import qualified Data.Set as Set import Network.HTTP.Client.Conduit (HasHttpManager, getHttpManager) import Path @@ -28,49 +30,48 @@ import System.Process.Run upgrade :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, HasTerminal env, HasReExec env, HasLogLevel env, MonadBaseControl IO m) - => Bool -- ^ use Git? + => Maybe String -- ^ git repository to use -> Maybe AbstractResolver -> m () -upgrade fromGit mresolver = withSystemTempDirectory "stack-upgrade" $ \tmp' -> do +upgrade gitRepo mresolver = withSystemTempDirectory "stack-upgrade" $ \tmp' -> do menv <- getMinimalEnvOverride tmp <- parseAbsDir tmp' - mdir <- - if fromGit - then do - $logInfo "Cloning stack" - runIn tmp "git" menv - [ "clone" - , "https://github.com/commercialhaskell/stack" -- TODO allow to be configured - , "stack" - , "--depth" - , "1" - ] - Nothing - return $ Just $ tmp $(mkRelDir "stack") - else do - updateAllIndices menv - caches <- getPackageCaches menv - let latest = Map.fromListWith max - $ map toTuple - $ Map.keys + mdir <- case gitRepo of + Just repo -> do + $logInfo "Cloning stack" + runIn tmp "git" menv + [ "clone" + , repo + , "stack" + , "--depth" + , "1" + ] + Nothing + return $ Just $ tmp $(mkRelDir "stack") + Nothing -> do + updateAllIndices menv + caches <- getPackageCaches menv + let latest = Map.fromListWith max + $ map toTuple + $ Map.keys - -- Mistaken upload to Hackage, just ignore it - $ Map.delete (PackageIdentifier - $(mkPackageName "stack") - $(mkVersion "9.9.9")) + -- Mistaken upload to Hackage, just ignore it + $ Map.delete (PackageIdentifier + $(mkPackageName "stack") + $(mkVersion "9.9.9")) - caches - case Map.lookup $(mkPackageName "stack") latest of - Nothing -> error "No stack found in package indices" - Just version | version <= fromCabalVersion Paths.version -> do - $logInfo "Already at latest version, no upgrade required" - return Nothing - Just version -> do - let ident = PackageIdentifier $(mkPackageName "stack") version - paths <- unpackPackageIdents menv tmp Nothing $ Set.singleton ident - case Map.lookup ident paths of - Nothing -> error "Stack.Upgrade.upgrade: invariant violated, unpacked directory not found" - Just path -> return $ Just path + caches + case Map.lookup $(mkPackageName "stack") latest of + Nothing -> error "No stack found in package indices" + Just version | version <= fromCabalVersion Paths.version -> do + $logInfo "Already at latest version, no upgrade required" + return Nothing + Just version -> do + let ident = PackageIdentifier $(mkPackageName "stack") version + paths <- unpackPackageIdents menv tmp Nothing $ Set.singleton ident + case Map.lookup ident paths of + Nothing -> error "Stack.Upgrade.upgrade: invariant violated, unpacked directory not found" + Just path -> return $ Just path manager <- asks getHttpManager logLevel <- asks getLogLevel @@ -81,10 +82,13 @@ forM_ mdir $ \dir -> liftIO $ do bconfig <- runStackLoggingT manager logLevel terminal reExec $ do lc <- loadConfig - configMonoid + (configMonoid <> Data.Monoid.mempty + { configMonoidInstallGHC = Just True + }) (Just $ dir $(mkRelFile "stack.yaml")) lcLoadBuildConfig lc mresolver - envConfig1 <- runStackT manager logLevel bconfig terminal reExec setupEnv + envConfig1 <- runStackT manager logLevel bconfig terminal reExec $ setupEnv $ Just + "Try rerunning with --install-ghc to install the appropriate GHC" runStackT manager logLevel envConfig1 terminal reExec $ build (const $ return ()) Nothing defaultBuildOpts { boptsTargets = ["stack"] diff --git a/src/Stack/Upload.hs b/src/Stack/Upload.hs --- a/src/Stack/Upload.hs +++ b/src/Stack/Upload.hs @@ -27,7 +27,7 @@ , fromMemory ) where -import Control.Applicative ((<$>), (<*>)) +import Control.Applicative import Control.Exception (bracket) import qualified Control.Exception as E import Control.Monad (when) @@ -57,6 +57,7 @@ import Network.HTTP.Client.TLS (tlsManagerSettings) import Network.HTTP.Types (statusCode) import Path (toFilePath) +import Prelude -- Fix redundant import warnings import Stack.Types import System.Directory (createDirectoryIfMissing, removeFile) 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 @@ -27,6 +27,8 @@ ,readInNull ,logProcessRun ,ReadProcessException (..) + ,augmentPath + ,augmentPathMap ) where @@ -49,7 +51,7 @@ import Data.IORef import Data.Map (Map) import qualified Data.Map as Map -import Data.Maybe (isJust) +import Data.Maybe (fromMaybe, isJust) import Data.Monoid import Data.Text (Text) import qualified Data.Text as T @@ -59,7 +61,7 @@ import Data.Typeable (Typeable) import Distribution.System (OS (Windows, OtherOS), Platform (Platform)) import Path (Path, Abs, Dir, toFilePath, File, parseAbsFile) -import Path.IO (createTree) +import Path.IO (createTree, parseRelAsAbsFile) import Prelude -- Fix AMP warning import System.Directory (doesFileExist, getCurrentDirectory) import System.Environment (getEnvironment) @@ -180,6 +182,7 @@ = ReadProcessException CreateProcess ExitCode L.ByteString L.ByteString | NoPathFound | ExecutableNotFound String [FilePath] + | ExecutableNotFoundAt FilePath deriving Typeable instance Show ReadProcessException where show (ReadProcessException cp ec out err) = concat @@ -205,6 +208,8 @@ , " not found on path: " , show path ] + show (ExecutableNotFoundAt name) = + "Did not find executable at specified path: " ++ name instance Exception ReadProcessException -- | Consume the stdout of a process feeding strict 'S.ByteString's to a consumer. @@ -268,11 +273,7 @@ -- executable path. preProcess :: (MonadIO m) => Maybe (Path Abs Dir) -> EnvOverride -> String -> m FilePath preProcess wd menv name = do - exists <- liftIO $ doesFileExist name - name' <- - if exists - then return name - else liftIO $ liftM toFilePath $ join $ findExecutable menv name + name' <- liftIO $ liftM toFilePath $ join $ findExecutable menv name maybe (return ()) createTree wd return name' @@ -293,6 +294,13 @@ -- | Find the complete path for the executable 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 name = liftIO $ do m <- readIORef $ eoExeCache eo epath <- case Map.lookup name m of @@ -327,3 +335,23 @@ getEnvironment >>= mkEnvOverride platform . Map.fromList . map (T.pack *** T.pack) + +-- | Augment the PATH environment variable with the given extra paths +augmentPath :: [FilePath] -> Maybe Text -> Text +augmentPath dirs mpath = + T.intercalate (T.singleton FP.searchPathSeparator) + $ map (stripTrailingSlashT . T.pack) dirs + ++ maybe [] return mpath + +stripTrailingSlashT :: Text -> Text +stripTrailingSlashT t = fromMaybe t $ T.stripSuffix + (T.singleton FP.pathSeparator) + t + +-- | Apply 'augmentPath' on the PATH value in the given Map. +augmentPathMap :: [FilePath] -> Map Text Text -> Map Text Text +augmentPathMap paths origEnv = + Map.insert "PATH" path origEnv + where + mpath = Map.lookup "PATH" origEnv + path = augmentPath paths mpath diff --git a/src/main/Main.hs b/src/main/Main.hs --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -12,7 +12,8 @@ import Control.Exception import qualified Control.Exception.Lifted as EL -import Control.Monad +import Control.Monad hiding (mapM, forM) +import qualified Control.Monad.Catch as Catch import Control.Monad.IO.Class import Control.Monad.Logger import Control.Monad.Reader (ask, asks) @@ -21,7 +22,6 @@ import qualified Data.ByteString.Lazy as L import Data.IORef import Data.List -import qualified Data.List as List import qualified Data.Map as Map import qualified Data.Map.Strict as M import Data.Maybe @@ -30,7 +30,11 @@ import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as T -import Data.Traversable (sequenceA) +import Data.Traversable +import Data.Version (showVersion) +import Distribution.System (buildArch) +import Development.GitRev (gitCommitCount) +import GHC.IO.Encoding (mkTextEncoding, textEncodingName) import Network.HTTP.Client import Options.Applicative.Args import Options.Applicative.Builder.Extra @@ -39,8 +43,7 @@ import Path import Path.IO import qualified Paths_stack as Meta -import Plugins -import Prelude hiding (pi) +import Prelude hiding (pi, mapM) import Stack.Build import Stack.Types.Build import Stack.Config @@ -67,44 +70,38 @@ import Stack.Upgrade import qualified Stack.Upload as Upload import System.Directory (canonicalizePath, doesFileExist, doesDirectoryExist, createDirectoryIfMissing) -import System.Environment (getArgs, getProgName) +import System.Environment (getProgName) import System.Exit import System.FileLock (lockFile, tryLockFile, unlockFile, SharedExclusive(Exclusive), FileLock) -import System.FilePath (dropTrailingPathSeparator) -import System.IO (hIsTerminalDevice, stderr, stdin, stdout, hSetBuffering, BufferMode(..)) +import System.FilePath (dropTrailingPathSeparator, searchPathSeparator) +import System.IO (hIsTerminalDevice, stderr, stdin, stdout, hSetBuffering, BufferMode(..), hPutStrLn, Handle, hGetEncoding, hSetEncoding) import System.Process.Read -#if WINDOWS +#ifdef WINDOWS import System.Win32.Console (setConsoleCP, setConsoleOutputCP, getConsoleCP, getConsoleOutputCP) -import System.IO (hSetEncoding, utf8, hPutStrLn) #endif -- | Set the code page for this process as necessary. Only applies to Windows. -- See: https://github.com/commercialhaskell/stack/issues/738 -fixCodePage :: IO a -> IO a -#if WINDOWS +fixCodePage :: (MonadIO m, Catch.MonadMask m, MonadLogger m) => m a -> m a +#ifdef WINDOWS fixCodePage inner = do - origCPI <- getConsoleCP - origCPO <- getConsoleOutputCP + origCPI <- liftIO getConsoleCP + origCPO <- liftIO getConsoleOutputCP let setInput = origCPI /= expected setOutput = origCPO /= expected fixInput - | setInput = bracket_ - (do - setConsoleCP expected - hSetEncoding stdin utf8 - ) - (setConsoleCP origCPI) + | setInput = Catch.bracket_ + (liftIO $ do + setConsoleCP expected) + (liftIO $ setConsoleCP origCPI) | otherwise = id fixOutput - | setInput = bracket_ - (do - setConsoleOutputCP expected - hSetEncoding stdout utf8 - hSetEncoding stderr utf8 - ) - (setConsoleOutputCP origCPO) + | setInput = Catch.bracket_ + (liftIO $ do + setConsoleOutputCP expected) + (liftIO $ setConsoleOutputCP origCPO) | otherwise = id case (setInput, setOutput) of @@ -116,7 +113,7 @@ fixInput $ fixOutput inner where expected = 65001 -- UTF-8 - warn typ = hPutStrLn stderr $ concat + warn typ = $logInfo $ T.concat [ "Setting" , typ , " codepage to UTF-8 (65001) to ensure correct output from GHC" @@ -125,6 +122,18 @@ fixCodePage = id #endif +-- | Change the character encoding of the given Handle to transliterate +-- on unsupported characters instead of throwing an exception +hSetTranslit :: Handle -> IO () +hSetTranslit h = do + menc <- hGetEncoding h + case fmap textEncodingName menc of + Just name + | '/' `notElem` name -> do + enc' <- mkTextEncoding $ name ++ "//TRANSLIT" + hSetEncoding h enc' + _ -> return () + -- | Commandline dispatcher. main :: IO () main = withInterpreterArgs stackProgName $ \args isInterpreter -> do @@ -132,31 +141,44 @@ -- See https://github.com/commercialhaskell/stack/pull/360 hSetBuffering stdout LineBuffering hSetBuffering stdin LineBuffering - hSetBuffering stderr NoBuffering - when False $ do -- https://github.com/commercialhaskell/stack/issues/322 - plugins <- findPlugins (T.pack stackProgName) - tryRunPlugin plugins + hSetBuffering stderr LineBuffering + hSetTranslit stdout + hSetTranslit stderr progName <- getProgName isTerminal <- hIsTerminalDevice stdout execExtraHelp args dockerHelpOptName (dockerOptsParser True) ("Only showing --" ++ Docker.dockerCmdName ++ "* options.") - let versionString' = $(simpleVersion Meta.version) + let versionString' = concat $ concat + [ [$(simpleVersion Meta.version)] + -- Leave out number of commits for --depth=1 clone + -- See https://github.com/commercialhaskell/stack/issues/792 + , [" (" ++ $gitCommitCount ++ " commits)" | $gitCommitCount /= ("1"::String)] + , [" ", show buildArch] + ] + + let numericVersion :: Parser (a -> a) + numericVersion = + infoOption + (showVersion Meta.version) + (long "numeric-version" <> + help "Show only version number") + eGlobalRun <- try $ simpleOptions versionString' "stack - The Haskell Tool Stack" "" - (extraHelpOption progName (Docker.dockerCmdName ++ "*") dockerHelpOptName <*> + (numericVersion <*> extraHelpOption progName (Docker.dockerCmdName ++ "*") dockerHelpOptName <*> globalOptsParser isTerminal) (do addCommand "build" "Build the project(s) in this directory/configuration" - (buildCmd Nothing) + buildCmd (buildOptsParser Build) addCommand "install" "Shortcut for 'build --copy-bins'" - (buildCmd $ Just ("install", "copy-bins")) + buildCmd (buildOptsParser Install) addCommand "uninstall" "DEPRECATED: This command performs no actions, and is present for documentation only" @@ -164,15 +186,15 @@ (many $ strArgument $ metavar "IGNORED") addCommand "test" "Shortcut for 'build --test'" - (buildCmd $ Just ("test", "test")) + buildCmd (buildOptsParser Test) addCommand "bench" "Shortcut for 'build --bench'" - (buildCmd $ Just ("bench", "bench")) + buildCmd (buildOptsParser Bench) addCommand "haddock" "Shortcut for 'build --haddock'" - (buildCmd $ Just ("haddock", "haddock")) + buildCmd (buildOptsParser Haddock) addCommand "new" "Create a new project from a template. Run `stack templates' to see available templates." @@ -218,10 +240,16 @@ addCommand "upgrade" "Upgrade to the latest stack (experimental)" upgradeCmd - (switch - ( long "git" - <> help "Clone from Git instead of downloading from Hackage (more dangerous)" - )) + ((,) <$> (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 @@ -243,7 +271,7 @@ execCmd (execOptsParser $ Just "ghc") addCommand "ghci" - "Run ghci in the context of project(s)" + "Run ghci in the context of project(s) (experimental)" ghciCmd ghciOptsParser addCommand "runghc" @@ -257,12 +285,12 @@ addCommand "list-dependencies" "List the dependencies" listDependenciesCmd - (T.pack <$> strOption (long "separator" <> - metavar "SEP" <> - help ("Separator between package name " <> - "and package version.") <> - value " " <> - showDefault)) + (textOption (long "separator" <> + metavar "SEP" <> + help ("Separator between package name " <> + "and package version.") <> + value " " <> + showDefault)) addSubCommands "ide" "IDE-specific commands" @@ -270,15 +298,14 @@ "start" "Start the ide-backend service" ideCmd - (((,) <$> - fmap (map T.pack) - (many (strArgument - (metavar "TARGET" <> - help "If none specified, use all packages defined in current directory"))) <*> - argsOption (long "ghc-options" <> - metavar "OPTION" <> - help "Additional options passed to GHCi" <> - value []))) + ((,) <$> 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" @@ -307,11 +334,10 @@ "Build a Docker image for the project" imgDockerCmd (pure ()))) - -- commandsFromPlugins plugins pluginShouldHaveRun) https://github.com/commercialhaskell/stack/issues/322 case eGlobalRun of Left (exitCode :: ExitCode) -> do when isInterpreter $ - putStrLn $ concat + hPutStrLn stderr $ concat [ "\nIf you are trying to use " , stackProgName , " as a script interpreter, a\n'-- " @@ -320,8 +346,8 @@ , "\nSee https://github.com/commercialhaskell/stack/wiki/Script-interpreter" ] throwIO exitCode Right (global,run) -> do - when (globalLogLevel global == LevelDebug) $ putStrLn versionString' - fixCodePage $ run global `catch` \e -> do + when (globalLogLevel global == LevelDebug) $ hPutStrLn stderr versionString' + run global `catch` \e -> do -- This special handler stops "stack: " from being printed before the -- exception case fromException e of @@ -332,29 +358,6 @@ where dockerHelpOptName = Docker.dockerCmdName ++ "-help" --- Try to run a plugin -tryRunPlugin :: Plugins -> IO () -tryRunPlugin plugins = do - args <- getArgs - case dropWhile (List.isPrefixOf "-") args of - ((T.pack -> name):args') - | isJust (lookupPlugin plugins name) -> do - callPlugin plugins name args' `catch` onPluginErr - exitSuccess - _ -> return () --- TODO(danburton): use logger -onPluginErr :: PluginException -> IO () -onPluginErr (PluginNotFound _ name) = do - T.hPutStr stderr $ "Stack plugin not found: " <> name - exitFailure -onPluginErr (PluginExitFailure _ i) = do - exitWith (ExitFailure i) - --- TODO(danburton): improve this, although it should never happen -pluginShouldHaveRun :: Plugin -> GlobalOpts -> IO () -pluginShouldHaveRun _plugin _globalOpts = do - fail "Plugin should have run" - -- | Print out useful path information in a human-readable format (and -- support others later). pathCmd :: [Text] -> GlobalOpts -> IO () @@ -428,7 +431,7 @@ , ( "PATH environment variable" , "bin-path" , \pi -> - T.pack (intercalate ":" (eoPath (piEnvOverride pi)))) + T.pack (intercalate [searchPathSeparator] (eoPath (piEnvOverride pi)))) , ( "Installed GHCs (unpacked and archives)" , "ghc-paths" , \pi -> @@ -478,7 +481,7 @@ where toFilePathNoTrailing = dropTrailingPathSeparator . toFilePath data SetupCmdOpts = SetupCmdOpts - { scoGhcVersion :: !(Maybe Version) + { scoCompilerVersion :: !(Maybe CompilerVersion) , scoForceReinstall :: !Bool , scoUpgradeCabal :: !Bool } @@ -487,7 +490,7 @@ setupParser = SetupCmdOpts <$> (optional $ argument readVersion (metavar "GHC_MAJOR_VERSION" <> - help ("Major version of GHC to install, e.g. 7.10. " ++ + help ("Version of GHC to install, e.g. 7.10.2. " ++ "The default is to install the version implied by the resolver."))) <*> boolFlags False "reinstall" @@ -500,7 +503,7 @@ where readVersion = do s <- readerAsk - case parseVersionFromString s of + case parseCompilerVersion ("ghc-" <> T.pack s) of Nothing -> readerError $ "Invalid version: " ++ s Just x -> return x @@ -513,25 +516,30 @@ (lcProjectRoot lc) Nothing (runStackLoggingTGlobal manager go $ do - (ghc, mstack) <- - case scoGhcVersion of - Just v -> return (v, Nothing) + (wantedCompiler, compilerCheck, mstack) <- + case scoCompilerVersion of + Just v -> return (v, MatchMinor, Nothing) Nothing -> do bc <- lcLoadBuildConfig lc globalResolver - return (bcGhcVersionExpected bc, Just $ bcStackYaml bc) + return ( bcWantedCompiler bc + , configCompilerCheck (lcConfig lc) + , Just $ bcStackYaml bc + ) mpaths <- runStackTGlobal manager (lcConfig lc) go $ ensureGHC SetupOpts { soptsInstallIfMissing = True , soptsUseSystem = (configSystemGHC $ lcConfig lc) && not scoForceReinstall - , soptsExpected = ghc + , soptsWantedCompiler = wantedCompiler + , soptsCompilerCheck = compilerCheck , soptsStackYaml = mstack , soptsForceReinstall = scoForceReinstall , soptsSanityCheck = True , soptsSkipGhcCheck = False , soptsSkipMsys = configSkipMsys $ lcConfig lc , soptsUpgradeCabal = scoUpgradeCabal + , soptsResolveMissingGHC = Nothing } case mpaths of Nothing -> $logInfo "stack will use the GHC on your PATH" @@ -566,12 +574,12 @@ case fstTry of Just lk -> EL.finally (act lk) (liftIO $ unlockFile lk) Nothing -> - do liftIO $ putStrLn $ "Failed to grab lock ("++show pth++ + do liftIO $ hPutStrLn stderr $ "Failed to grab lock ("++show pth++ "); other stack instance running. Waiting..." EL.bracket (liftIO $ lockFile (toFilePath pth) Exclusive) (liftIO . unlockFile) (\lk -> do - liftIO $ putStrLn "Lock acquired, proceeding." + liftIO $ hPutStrLn stderr "Lock acquired, proceeding." act lk)) withConfigAndLock :: GlobalOpts @@ -641,7 +649,7 @@ envConfig <- runStackTGlobal manager bconfig go - setupEnv + (setupEnv Nothing) runStackTGlobal manager envConfig @@ -658,24 +666,29 @@ cleanCmd () go = withBuildConfigAndLock go (\_ -> clean) -- | Helper for build and install commands -buildCmd :: Maybe (Text, Text) -- ^ option synonym - -> BuildOpts -> GlobalOpts -> IO () -buildCmd moptionSynonym opts go - | boptsFileWatch opts = fileWatch inner +buildCmd :: BuildOpts -> GlobalOpts -> IO () +buildCmd opts go + | boptsFileWatch opts = + let getProjectRoot = + do (manager, lc) <- loadConfigWithOpts go + bconfig <- + runStackLoggingTGlobal manager go $ + lcLoadBuildConfig lc (globalResolver go) + return (bcRoot bconfig) + in fileWatch getProjectRoot inner | otherwise = inner $ const $ return () where - inner setLocalFiles = withBuildConfigAndLock go $ \lk -> do - case moptionSynonym of - Nothing -> return () - Just (cmd, opt) -> $logInfo $ T.concat - [ "NOTE: the " - , cmd - , " command is functionally equivalent to 'build --" - , opt - , "'" - ] - Stack.Build.build setLocalFiles (Just lk) opts + inner setLocalFiles = withBuildConfigAndLock go $ \lk -> + globalFixCodePage go $ Stack.Build.build setLocalFiles (Just lk) opts +globalFixCodePage :: (Catch.MonadMask m, MonadIO m, MonadLogger m) + => GlobalOpts + -> m a + -> m a +globalFixCodePage go + | globalModifyCodePage go = fixCodePage + | otherwise = id + uninstallCmd :: [String] -> GlobalOpts -> IO () uninstallCmd _ go = withConfigAndLock go $ do $logError "stack does not manage installations in global locations" @@ -693,9 +706,9 @@ updateCmd () go = withConfigAndLock go $ getMinimalEnvOverride >>= Stack.PackageIndex.updateAllIndices -upgradeCmd :: Bool -> GlobalOpts -> IO () -upgradeCmd fromGit go = withConfigAndLock go $ - upgrade fromGit (globalResolver go) +upgradeCmd :: (Bool, String) -> GlobalOpts -> IO () +upgradeCmd (fromGit, repo) go = withConfigAndLock go $ globalFixCodePage go $ + upgrade (if fromGit then Just repo else Nothing) (globalResolver go) -- | Upload to Hackage uploadCmd :: [String] -> GlobalOpts -> IO () @@ -742,6 +755,7 @@ (tarName, tarBytes) <- getSDistTarball dir distDir <- distDirFromDir dir tarPath <- fmap (distDir ) $ parseRelFile tarName + liftIO $ createTree $ parent tarPath liftIO $ L.writeFile (toFilePath tarPath) tarBytes $logInfo $ "Wrote sdist tarball to " <> T.pack (toFilePath tarPath) @@ -765,7 +779,7 @@ ExecOptsEmbellished {..} -> withBuildConfigAndLock go $ \lk -> do let targets = concatMap words eoPackages - unless (null targets) $ + unless (null targets) $ globalFixCodePage go $ Stack.Build.build (const $ return ()) (Just lk) defaultBuildOpts { boptsTargets = map T.pack targets } @@ -777,7 +791,7 @@ ghciCmd ghciOpts go@GlobalOpts{..} = withBuildConfigAndLock go $ \lk -> do let packageTargets = concatMap words (ghciAdditionalPackages ghciOpts) - unless (null packageTargets) $ + unless (null packageTargets) $ globalFixCodePage go $ Stack.Build.build (const $ return ()) (Just lk) defaultBuildOpts { boptsTargets = map T.pack packageTargets } @@ -836,11 +850,12 @@ go Nothing (\lk -> - do Stack.Build.build - (const (return ())) - (Just lk) - defaultBuildOpts - Image.stageContainerImageArtifacts) + do globalFixCodePage go $ + Stack.Build.build + (const (return ())) + (Just lk) + defaultBuildOpts + Image.stageContainerImageArtifacts) (Just Image.createContainerImageFromStage) -- | Load the configuration with a manager. Convenience function used diff --git a/src/main/Plugins.hs b/src/main/Plugins.hs deleted file mode 100644 --- a/src/main/Plugins.hs +++ /dev/null @@ -1,212 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE DeriveDataTypeable #-} - --- | Dynamically look up available executables. -module Plugins - ( Plugin - , pluginPrefix - , pluginName - , pluginSummary - , pluginProc - - , Plugins - , findPlugins - , listPlugins - , lookupPlugin - , callPlugin - - , PluginException (..) - ) where - -import Control.Exception (Exception) -import Control.Monad -import Control.Monad.Catch (MonadThrow, throwM) -import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.State.Strict (StateT, get, put) -import Data.Conduit -import Data.Hashable (Hashable) -import Data.HashSet (HashSet) -import Data.HashMap.Strict (HashMap) -import qualified Data.HashSet as HashSet -import qualified Data.HashMap.Strict as HashMap -import qualified Data.Conduit.List as CL -import Data.Conduit.Lift (evalStateC) -import qualified Data.List as L -import Data.Text (Text, pack, unpack) -import qualified Data.Text as T -import Data.Typeable (Typeable) -import Data.Monoid -import System.Directory -import System.Process (CreateProcess, proc, readProcessWithExitCode, createProcess, waitForProcess) -import System.FilePath ((), getSearchPath, splitExtension) -import System.Exit (ExitCode (..)) - --- | Represents a runnable plugin. --- Plugins must be discovered via `findPlugins`. -data Plugin = Plugin - { _pluginPrefix :: !Text - , _pluginName :: !Text - , _pluginSummary :: !Text - } - deriving (Show) - --- | The program being plugged into. -pluginPrefix :: Plugin -> Text -pluginPrefix = _pluginPrefix - --- | The name of this plugin (without the prefix). -pluginName :: Plugin -> Text -pluginName = _pluginName - --- | A summary of what this plugin does -pluginSummary :: Plugin -> Text -pluginSummary = _pluginSummary - --- | Describes how to create a process out of a plugin and arguments. --- You may use Data.Process and Data.Conduit.Process --- to manage the process's stdin, stdout, and stderr in various ways. -pluginProc :: Plugin -> [String] -> CreateProcess -pluginProc = proc . pluginProcessName - --- Not exported -pluginProcessName :: Plugin -> String -pluginProcessName p = unpack $ pluginPrefix p <> "-" <> pluginName p - - --- | Represents the plugins available to a given program. --- See: `findPlugins`. -data Plugins = Plugins - { _pluginsPrefix :: !Text - , _pluginsMap :: !(HashMap Text Plugin) - } - deriving (Show) - - --- | Find the plugins for a given program by inspecting everything on the PATH. --- Any program that is prefixed with the given name and responds --- to the `--summary` flag by writing one line to stdout --- is considered a plugin. -findPlugins :: Text -> IO Plugins -findPlugins t = fmap (Plugins t) - $ discoverPlugins t - $$ awaitForever (toPlugin t) - =$ CL.fold insertPlugin HashMap.empty - where - insertPlugin m p = HashMap.insert (pluginName p) p m - -toPlugin :: (MonadIO m) => Text -> Text -> Producer m Plugin -toPlugin prefix name = do - let proc' = unpack $ prefix <> "-" <> name - (exit, out, _err) <- liftIO $ readProcessWithExitCode proc' ["--summary"] "" - case exit of - ExitSuccess -> case T.lines (pack out) of - [summary] -> yield $ Plugin - { _pluginPrefix = prefix - , _pluginName = name - , _pluginSummary = summary - } - _ -> return () - _ -> return () - - --- | Things that can go wrong when using `callPlugin`. --- Note: it may be wiser to catch PluginExitFailure, rather than display it. -data PluginException - = PluginNotFound !Plugins !Text - | PluginExitFailure !Plugin !Int - deriving (Typeable) -instance Show PluginException where - show (PluginNotFound plugins requestedPlugin) - = "Plugin not found for '" ++ unpack (_pluginsPrefix plugins) - ++ "': '" ++ unpack requestedPlugin ++ "'" - show (PluginExitFailure plugin exitCode) - = "Plugin '" ++ unpack (_pluginName plugin) - ++ "' for '" ++ unpack (_pluginPrefix plugin) - ++ "' failed with exit code: " - ++ show exitCode -instance Exception PluginException - --- | Look up a particular plugin by name. -lookupPlugin :: Plugins -> Text -> Maybe Plugin -lookupPlugin ps t = HashMap.lookup t $ _pluginsMap ps - --- | List the available plugins. -listPlugins :: Plugins -> [Plugin] -listPlugins = HashMap.elems . _pluginsMap - --- | A convenience wrapper around lookupPlugin and pluginProc. --- Handles stdin, stdout, and stderr are all inherited by the plugin. --- Throws PluginException. -callPlugin :: (MonadIO m, MonadThrow m) - => Plugins -> Text -> [String] -> m () -callPlugin ps name args = case lookupPlugin ps name of - Nothing -> throwM $ PluginNotFound ps name - Just plugin -> do - exit <- liftIO $ do - (_, _, _, process) <- createProcess $ pluginProc plugin args - waitForProcess process - case exit of - ExitFailure i -> throwM $ PluginExitFailure plugin i - ExitSuccess -> return () - - -discoverPlugins :: MonadIO m => Text -> Producer m Text -discoverPlugins t - = getPathDirs - $= clNub -- unique dirs on path - $= awaitForever (executablesPrefixed $ unpack $ t <> "-") - $= CL.map pack - $= clNub -- unique executables - -executablesPrefixed :: (MonadIO m) => FilePath -> FilePath -> Producer m FilePath -executablesPrefixed prefix dir - = pathToContents dir - $= CL.filter (L.isPrefixOf prefix) - $= clFilterM (fileExistsIn dir) - $= clFilterM (isExecutableIn dir) - $= CL.mapMaybe (L.stripPrefix prefix . dropExeExt) - --- | Drop the .exe extension if present -dropExeExt :: FilePath -> FilePath -dropExeExt fp - | y == ".exe" = x - | otherwise = fp - where - (x, y) = splitExtension fp - -getPathDirs :: (MonadIO m) => Producer m FilePath -getPathDirs = liftIO getSearchPath >>= mapM_ yield - -pathToContents :: (MonadIO m) => FilePath -> Producer m FilePath -pathToContents dir = do - exists <- liftIO $ doesDirectoryExist dir - when exists $ do - contents <- liftIO $ getDirectoryContents dir - CL.sourceList contents - -fileExistsIn :: (MonadIO m) => FilePath -> FilePath -> m Bool -fileExistsIn dir file = liftIO $ doesFileExist $ dir file - -isExecutableIn :: (MonadIO m) => FilePath -> FilePath -> m Bool -isExecutableIn dir file = liftIO $ do - perms <- getPermissions $ dir file - return (executable perms) - -clFilterM :: Monad m => (a -> m Bool) -> Conduit a m a -clFilterM pred' = awaitForever $ \a -> do - predPassed <- lift $ pred' a - when predPassed $ yield a - -clNub :: (Monad m, Eq a, Hashable a) - => Conduit a m a -clNub = evalStateC HashSet.empty clNubState - -clNubState :: (Monad m, Eq a, Hashable a) - => Conduit a (StateT (HashSet a) m) a -clNubState = awaitForever $ \a -> do - seen <- lift get - unless (HashSet.member a seen) $ do - lift $ put $ HashSet.insert a seen - yield a diff --git a/src/main/Plugins/Commands.hs b/src/main/Plugins/Commands.hs deleted file mode 100644 --- a/src/main/Plugins/Commands.hs +++ /dev/null @@ -1,27 +0,0 @@ --- | Using Plugins with SimpleOptions -module Plugins.Commands - ( commandsFromPlugins - , commandFromPlugin - , findPlugins - , PluginException(..) - ) where - -import Control.Monad.Trans.Either (EitherT) -import Control.Monad.Trans.Writer (Writer) -import Data.Text (unpack) -import Plugins -import Options.Applicative.Simple - --- | Generate the "commands" argument to simpleOptions --- based on available plugins. -commandsFromPlugins :: Plugins -> (Plugin -> a) -> EitherT a (Writer (Mod CommandFields a)) () -commandsFromPlugins plugins f = - mapM_ (\p -> commandFromPlugin p (f p)) (listPlugins plugins) - --- | Convert a single plugin into a command. -commandFromPlugin :: Plugin -> a -> EitherT a (Writer (Mod CommandFields a)) () -commandFromPlugin plugin a = addCommand - (unpack $ pluginName plugin) - (unpack $ pluginSummary plugin) - (const a) - (pure ()) diff --git a/src/test/Stack/Build/ExecuteSpec.hs b/src/test/Stack/Build/ExecuteSpec.hs --- a/src/test/Stack/Build/ExecuteSpec.hs +++ b/src/test/Stack/Build/ExecuteSpec.hs @@ -1,8 +1,6 @@ module Stack.Build.ExecuteSpec (main, spec) where -import Stack.Build.Execute import Test.Hspec -import qualified Data.Text as T main :: IO () main = hspec spec diff --git a/src/test/Stack/BuildPlanSpec.hs b/src/test/Stack/BuildPlanSpec.hs --- a/src/test/Stack/BuildPlanSpec.hs +++ b/src/test/Stack/BuildPlanSpec.hs @@ -12,6 +12,7 @@ import qualified Data.Map as Map import qualified Data.Set as Set import Network.HTTP.Conduit (Manager) +import Prelude -- Fix redundant import warnings import System.Directory import System.IO.Temp import System.Environment @@ -97,7 +98,7 @@ attoparsec = go "attoparsec" "text" aeson = go "aeson" "text attoparsec" mkMBP pkgs = MiniBuildPlan - { mbpGhcVersion = version + { mbpCompilerVersion = GhcVersion version , mbpPackages = Map.fromList pkgs } mbpAll = mkMBP [resourcet, conduit, conduitExtra, text, attoparsec, aeson] diff --git a/src/test/Stack/ConfigSpec.hs b/src/test/Stack/ConfigSpec.hs --- a/src/test/Stack/ConfigSpec.hs +++ b/src/test/Stack/ConfigSpec.hs @@ -11,6 +11,7 @@ import Network.HTTP.Conduit (Manager) import Path --import System.FilePath +import Prelude -- Fix redundant import warnings import System.Directory import System.IO.Temp import System.Environment diff --git a/src/test/Stack/PackageDumpSpec.hs b/src/test/Stack/PackageDumpSpec.hs --- a/src/test/Stack/PackageDumpSpec.hs +++ b/src/test/Stack/PackageDumpSpec.hs @@ -149,7 +149,7 @@ menv' <- getEnvOverride buildPlatform menv <- mkEnvOverride buildPlatform $ Map.delete "GHC_PACKAGE_PATH" $ unEnvOverride menv' icache <- newInstalledCache - ghcPkgDump menv Nothing + ghcPkgDump menv Ghc Nothing $ conduitDumpPackage =$ addProfiling icache =$ addHaddock icache @@ -159,7 +159,7 @@ menv' <- getEnvOverride buildPlatform menv <- mkEnvOverride buildPlatform $ Map.delete "GHC_PACKAGE_PATH" $ unEnvOverride menv' icache <- newInstalledCache - m <- runNoLoggingT $ ghcPkgDump menv Nothing + m <- runNoLoggingT $ ghcPkgDump menv Ghc Nothing $ conduitDumpPackage =$ addProfiling icache =$ addHaddock icache diff --git a/stack.cabal b/stack.cabal --- a/stack.cabal +++ b/stack.cabal @@ -1,5 +1,5 @@ name: stack -version: 0.1.3.1 +version: 0.1.4.0 synopsis: The Haskell Tool Stack description: Please see the README.md for usage information, and the wiki on Github for more details. Also, note that @@ -60,6 +60,7 @@ Stack.Types Stack.Types.Internal Stack.Types.BuildPlan + Stack.Types.Compiler Stack.Types.Config Stack.Types.Docker Stack.Types.FlagName @@ -97,8 +98,9 @@ Data.Aeson.Extended Data.Attoparsec.Combinators Data.Binary.VersionTagged - Data.Set.Monad + Data.IORef.RunOnce Data.Maybe.Extra + Data.Set.Monad build-depends: Cabal >= 1.18.1.5 , aeson >= 0.8.0.2 , async >= 2.0.2 @@ -125,12 +127,13 @@ , fast-logger >= 2.3.1 , filelock >= 0.1.0.1 , filepath >= 1.3.0.2 - , fsnotify + , fsnotify >= 0.2.1 , hashable >= 1.2.3.2 - , http-client >= 0.4.9 + , http-client >= 0.4.17 , http-client-tls >= 0.2.2 - , http-conduit + , http-conduit >= 2.1.7 , http-types >= 0.8.6 + , ignore >= 0.1.1 , lifted-base , monad-control , monad-logger >= 0.3.13.1 @@ -170,24 +173,26 @@ , word8 , hastache , project-template >= 0.2 - if !os(windows) + if os(windows) + cpp-options: -DWINDOWS + else build-depends: unix >= 2.7.0.1 - default-language: Haskell2010 + default-language: Haskell2010 executable stack hs-source-dirs: src/main main-is: Main.hs ghc-options: -Wall -threaded -rtsopts - other-modules: Plugins - Plugins.Commands - Paths_stack + other-modules: Paths_stack build-depends: base >=4.7 && < 5 , bytestring >= 0.10.4.0 + , Cabal , containers , exceptions , filepath , filelock >= 0.1.0.1 + , gitrev >= 1.1 , http-conduit >= 2.1.5 , lifted-base , monad-control @@ -255,7 +260,7 @@ test-suite stack-integration-test type: exitcode-stdio-1.0 hs-source-dirs: test/integration - main-is: Spec.hs + main-is: IntegrationSpec.hs ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N if flag(integration-tests) diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -1,12 +1,9 @@ -packages: -- . +resolver: lts-3.0 extra-deps: -- path-0.5.2 -- Win32-notify-0.3.0.1 -- hfsevents-0.1.5 -- project-template-0.2.0 -- filelock-0.1.0.1 -resolver: lts-2.17 +- ignore-0.1.1.0 +flags: + ignore: + without-pcre: true image: container: base: "fpco/ubuntu-with-libgmp:14.04" diff --git a/test/integration/IntegrationSpec.hs b/test/integration/IntegrationSpec.hs new file mode 100644 --- /dev/null +++ b/test/integration/IntegrationSpec.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ScopedTypeVariables #-} + +import Control.Applicative +import Control.Arrow +import Control.Concurrent.Async +import Control.Exception +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Resource +import qualified Data.ByteString.Lazy as L +import Data.Char +import Data.Conduit +import Data.Conduit.Binary (sinkLbs) +import Data.Conduit.Filesystem (sourceDirectoryDeep) +import qualified Data.Conduit.List as CL +import Data.Conduit.Process +import Data.List (isSuffixOf, stripPrefix) +import qualified Data.Map as Map +import Data.Text.Encoding.Error (lenientDecode) +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TL +import Data.Typeable +import Prelude -- Fix redundant import warnings +import System.Directory +import System.Environment +import System.Exit +import System.FilePath +import System.IO.Temp +import System.PosixCompat.Files +import Test.Hspec + +main :: IO () +main = do + currDir <- canonicalizePath "test/integration" + + let findExe name = do + mexe <- findExecutable name + case mexe of + Nothing -> error $ name ++ " not found on PATH" + Just exe -> return exe + runghc <- findExe "runghc" + stack <- findExe "stack" + + let testDir = currDir "tests" + tests <- getDirectoryContents testDir >>= filterM (hasTest testDir) + + envOrig <- getEnvironment + + withSystemTempDirectory ("stack-integration-home") $ \newHome -> do + let env' = Map.toList + $ Map.insert "STACK_EXE" stack + $ Map.insert "HOME" newHome + $ Map.insert "APPDATA" newHome + $ Map.delete "GHC_PACKAGE_PATH" + $ Map.fromList + $ map (first (map toUpper)) envOrig + + origStackRoot <- getAppUserDataDirectory "stack" + + hspec $ mapM_ (test runghc env' currDir origStackRoot newHome) tests + +hasTest :: FilePath -> FilePath -> IO Bool +hasTest root dir = doesFileExist $ root dir "Main.hs" + +test :: FilePath -- ^ runghc + -> [(String, String)] -- ^ env + -> FilePath -- ^ currdir + -> FilePath -- ^ origStackRoot + -> FilePath -- ^ newHome + -> String + -> Spec +test runghc env' currDir origStackRoot newHome name = it name $ withDir $ \dir -> do + removeDirectoryRecursive newHome + copyTree toCopyRoot origStackRoot (newHome takeFileName origStackRoot) + let testDir = currDir "tests" name + mainFile = testDir "Main.hs" + libDir = currDir "lib" + cp = (proc runghc + [ "-clear-package-db" + , "-global-package-db" + , "-i" ++ libDir + , mainFile + ]) + { cwd = Just dir + , env = Just env' + } + + copyTree (const True) (testDir "files") dir + + (ClosedStream, outSrc, errSrc, sph) <- streamingProcess cp + (out, err, ec) <- runConcurrently $ (,,) + <$> Concurrently (outSrc $$ sinkLbs) + <*> Concurrently (errSrc $$ sinkLbs) + <*> Concurrently (waitForStreamingProcess sph) + when (ec /= ExitSuccess) $ throwIO $ TestFailure out err ec + where + withDir = withSystemTempDirectory ("stack-integration-" ++ name) + +data TestFailure = TestFailure L.ByteString L.ByteString ExitCode + deriving Typeable +instance Show TestFailure where + show (TestFailure out err ec) = concat + [ "Exited with " ++ show ec + , "\n\nstdout:\n" + , toStr out + , "\n\nstderr:\n" + , toStr err + ] + where + toStr = TL.unpack . TL.decodeUtf8With lenientDecode +instance Exception TestFailure + +copyTree :: (FilePath -> Bool) -> FilePath -> FilePath -> IO () +copyTree toCopy src dst = + runResourceT (sourceDirectoryDeep False src $$ CL.mapM_ go) + `catch` \(_ :: IOException) -> return () + where + go srcfp = when (toCopy srcfp) $ liftIO $ do + Just suffix <- return $ stripPrefix src srcfp + let dstfp = dst ++ "/" ++ suffix + createDirectoryIfMissing True $ takeDirectory dstfp + createSymbolicLink srcfp dstfp `catch` \(_ :: IOException) -> + copyFile srcfp dstfp -- for Windows + +toCopyRoot :: FilePath -> Bool +toCopyRoot srcfp = any (`isSuffixOf` srcfp) + -- FIXME command line parameters to control how many of these get + -- copied, trade-off of runtime/bandwidth vs isolation of tests + [ ".tar" + , ".xz" + -- , ".gz" + , ".7z.exe" + , "00-index.cache" + ] diff --git a/test/integration/Spec.hs b/test/integration/Spec.hs deleted file mode 100644 --- a/test/integration/Spec.hs +++ /dev/null @@ -1,134 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE ScopedTypeVariables #-} - -import Control.Applicative -import Control.Arrow -import Control.Concurrent.Async -import Control.Exception -import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Trans.Resource -import qualified Data.ByteString.Lazy as L -import Data.Char -import Data.Conduit -import Data.Conduit.Binary (sinkLbs) -import Data.Conduit.Filesystem (sourceDirectoryDeep) -import qualified Data.Conduit.List as CL -import Data.Conduit.Process -import Data.List (isSuffixOf, stripPrefix) -import qualified Data.Map as Map -import Data.Text.Encoding.Error (lenientDecode) -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.Encoding as TL -import Data.Typeable -import System.Directory -import System.Environment -import System.Exit -import System.FilePath -import System.IO.Temp -import System.PosixCompat.Files -import Test.Hspec - -main :: IO () -main = do - currDir <- canonicalizePath "test/integration" - - let findExe name = do - mexe <- findExecutable name - case mexe of - Nothing -> error $ name ++ " not found on PATH" - Just exe -> return exe - runghc <- findExe "runghc" - stack <- findExe "stack" - - let testDir = currDir "tests" - tests <- getDirectoryContents testDir >>= filterM (hasTest testDir) - - envOrig <- getEnvironment - - withSystemTempDirectory ("stack-integration-home") $ \newHome -> do - let env' = Map.toList - $ Map.insert "STACK_EXE" stack - $ Map.insert "HOME" newHome - $ Map.insert "APPDATA" newHome - $ Map.delete "GHC_PACKAGE_PATH" - $ Map.fromList - $ map (first (map toUpper)) envOrig - - origStackRoot <- getAppUserDataDirectory "stack" - - hspec $ mapM_ (test runghc env' currDir origStackRoot newHome) tests - -hasTest :: FilePath -> FilePath -> IO Bool -hasTest root dir = doesFileExist $ root dir "Main.hs" - -test :: FilePath -- ^ runghc - -> [(String, String)] -- ^ env - -> FilePath -- ^ currdir - -> FilePath -- ^ origStackRoot - -> FilePath -- ^ newHome - -> String - -> Spec -test runghc env' currDir origStackRoot newHome name = it name $ withDir $ \dir -> do - removeDirectoryRecursive newHome - copyTree toCopyRoot origStackRoot (newHome takeFileName origStackRoot) - let testDir = currDir "tests" name - mainFile = testDir "Main.hs" - libDir = currDir "lib" - cp = (proc runghc - [ "-clear-package-db" - , "-global-package-db" - , "-i" ++ libDir - , mainFile - ]) - { cwd = Just dir - , env = Just env' - } - - copyTree (const True) (testDir "files") dir - - (ClosedStream, outSrc, errSrc, sph) <- streamingProcess cp - (out, err, ec) <- runConcurrently $ (,,) - <$> Concurrently (outSrc $$ sinkLbs) - <*> Concurrently (errSrc $$ sinkLbs) - <*> Concurrently (waitForStreamingProcess sph) - when (ec /= ExitSuccess) $ throwIO $ TestFailure out err ec - where - withDir = withSystemTempDirectory ("stack-integration-" ++ name) - -data TestFailure = TestFailure L.ByteString L.ByteString ExitCode - deriving Typeable -instance Show TestFailure where - show (TestFailure out err ec) = concat - [ "Exited with " ++ show ec - , "\n\nstdout:\n" - , toStr out - , "\n\nstderr:\n" - , toStr err - ] - where - toStr = TL.unpack . TL.decodeUtf8With lenientDecode -instance Exception TestFailure - -copyTree :: (FilePath -> Bool) -> FilePath -> FilePath -> IO () -copyTree toCopy src dst = - runResourceT (sourceDirectoryDeep False src $$ CL.mapM_ go) - `catch` \(_ :: IOException) -> return () - where - go srcfp = when (toCopy srcfp) $ liftIO $ do - Just suffix <- return $ stripPrefix src srcfp - let dstfp = dst ++ "/" ++ suffix - createDirectoryIfMissing True $ takeDirectory dstfp - createSymbolicLink srcfp dstfp `catch` \(_ :: IOException) -> - copyFile srcfp dstfp -- for Windows - -toCopyRoot :: FilePath -> Bool -toCopyRoot srcfp = any (`isSuffixOf` srcfp) - -- FIXME command line parameters to control how many of these get - -- copied, trade-off of runtime/bandwidth vs isolation of tests - [ ".tar" - , ".xz" - -- , ".gz" - , ".7z.exe" - , "00-index.cache" - ]