stack 0.1.0.0 → 0.1.1.0
raw patch · 32 files changed
+1143/−425 lines, 32 filesdep +blaze-builderdep ~text
Dependencies added: blaze-builder
Dependency ranges changed: text
Files
- ChangeLog.md +25/−0
- README.md +3/−0
- src/Data/Set/Monad.hs +1/−1
- src/Path/IO.hs +82/−18
- src/Stack/Build/Cache.hs +14/−3
- src/Stack/Build/ConstructPlan.hs +77/−17
- src/Stack/Build/Execute.hs +108/−13
- src/Stack/Build/Source.hs +7/−4
- src/Stack/Build/Types.hs +14/−4
- src/Stack/BuildPlan.hs +90/−49
- src/Stack/Config.hs +33/−15
- src/Stack/Constants.hs +14/−1
- src/Stack/Dot.hs +69/−0
- src/Stack/Exec.hs +10/−7
- src/Stack/GhcPkg.hs +9/−3
- src/Stack/Init.hs +2/−1
- src/Stack/Package.hs +133/−118
- src/Stack/PackageIndex.hs +1/−1
- src/Stack/Repl.hs +29/−38
- src/Stack/Setup.hs +33/−9
- src/Stack/Types/Config.hs +44/−10
- src/Stack/Types/FlagName.hs +8/−1
- src/Stack/Types/StackT.hs +28/−12
- src/Stack/Upgrade.hs +91/−0
- src/Stack/Upload.hs +5/−7
- src/System/Process/Read.hs +14/−7
- src/main/Main.hs +158/−83
- src/test/Stack/Build/ExecuteSpec.hs +24/−0
- src/test/Stack/BuildPlanSpec.hs +1/−1
- src/test/Stack/ConfigSpec.hs +1/−1
- stack.cabal +8/−1
- stack.yaml +7/−0
ChangeLog.md view
@@ -1,3 +1,28 @@+## 0.1.1.0++* Remove GHC uncompressed tar file after installation [#376](https://github.com/commercialhaskell/stack/issues/376)+* Put stackage snapshots JSON on S3 [#380](https://github.com/commercialhaskell/stack/issues/380)+* Specifying flags for multiple packages [#335](https://github.com/commercialhaskell/stack/issues/335)+* single test suite failure should show entire log [#388](https://github.com/commercialhaskell/stack/issues/388)+* valid-wanted is a confusing option name [#386](https://github.com/commercialhaskell/stack/issues/386)+* stack init in multi-package project should use local packages for dependency checking [#384](https://github.com/commercialhaskell/stack/issues/384)+* Display information on why a snapshot was rejected [#381](https://github.com/commercialhaskell/stack/issues/381)+* Give a reason for unregistering packages [#389](https://github.com/commercialhaskell/stack/issues/389)+* `stack exec` accepts the `--no-ghc-package-path` parameter+* Don't require build plan to upload [#400](https://github.com/commercialhaskell/stack/issues/400)+* Specifying test components only builds/runs those tests [#398](https://github.com/commercialhaskell/stack/issues/398)+* `STACK_EXE` environment variable+* Add the `stack dot` command+* `stack upgrade` added [#237](https://github.com/commercialhaskell/stack/issues/237)+* `--stack-yaml` command line flag [#378](https://github.com/commercialhaskell/stack/issues/378)+* `--skip-ghc-check` command line flag [#423](https://github.com/commercialhaskell/stack/issues/423)++Bug fixes:++* Haddock links to global packages no longer broken on Windows [#375](https://github.com/commercialhaskell/stack/issues/375)+* Make flags case-insensitive [#397](https://github.com/commercialhaskell/stack/issues/397)+* Mark packages uninstalled before rebuilding [#365](https://github.com/commercialhaskell/stack/issues/365)+ ## 0.1.0.0 * Fall back to cabal dependency solver when a snapshot can't be found
README.md view
@@ -43,6 +43,9 @@ * `stack setup` to download and install the correct GHC version. (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+to do is `stack install <package-name>`.+ Run `stack` for a complete list of commands. #### Architecture
src/Data/Set/Monad.hs view
@@ -22,7 +22,7 @@ => (a -> m b) -> Set a -> m () mapM_ f = L.mapM_ f . S.toList --- | Map over a 'Set' in a monad.+-- | Filter elements of a 'Set' in a monad. filterM :: (Ord a,Monad m) => (a -> m Bool) -> Set a -> m (Set a) filterM f = liftM S.fromList . L.filterM f . S.toList
src/Path/IO.hs view
@@ -14,8 +14,13 @@ ,removeTree ,removeTreeIfExists ,fileExists+ ,renameFileIfExists+ ,renameDirIfExists+ ,moveFileIfExists+ ,moveDirIfExists ,dirExists- ,copyDirectoryRecursive)+ ,copyDirectoryRecursive+ ,createTree) where import Control.Exception hiding (catch)@@ -67,33 +72,35 @@ where fp = toFilePath x FP.</> y Just fp -> return fp +-- Internal helper to define resolveDirMaybe and resolveFileMaybe in one+resolveCheckParse :: (MonadIO m)+ => (FilePath -> IO Bool) -- check if file/dir does exist+ -> (FilePath -> m a) -- parse into absolute file/dir+ -> Path Abs Dir+ -> FilePath+ -> m (Maybe a)+resolveCheckParse check parse x y = do+ let fp = toFilePath x FP.</> y+ exists <- liftIO $ check fp+ if exists+ then do+ canonic <- liftIO $ canonicalizePath fp+ liftM Just (parse canonic)+ else return Nothing+ -- | Appends a stringly-typed relative path to an absolute path, and then -- canonicalizes it. If the path doesn't exist (and therefore cannot -- be canonicalized, 'Nothing' is returned). resolveDirMaybe :: (MonadIO m,MonadThrow m) => Path Abs Dir -> FilePath -> m (Maybe (Path Abs Dir))-resolveDirMaybe x y = do- let fp = toFilePath x FP.</> y- exists <- liftIO $ doesDirectoryExist fp- if exists- then do- dir <- liftIO $ canonicalizePath fp- liftM Just (parseAbsDir dir)- else return Nothing+resolveDirMaybe = resolveCheckParse doesDirectoryExist parseAbsDir -- | Appends a stringly-typed relative path to an absolute path, and then -- canonicalizes it. If the path doesn't exist (and therefore cannot -- be canonicalized, 'Nothing' is returned). resolveFileMaybe :: (MonadIO m,MonadThrow m) => Path Abs Dir -> FilePath -> m (Maybe (Path Abs File))-resolveFileMaybe x y = do- let fp = toFilePath x FP.</> y- exists <- liftIO $ doesFileExist fp- if exists- then do- file <- liftIO $ canonicalizePath fp- liftM Just (parseAbsFile file)- else return Nothing+resolveFileMaybe = resolveCheckParse doesFileExist parseAbsFile -- | List objects in a directory, excluding "@.@" and "@..@". Entries are not sorted. listDirectory :: (MonadIO m,MonadThrow m) => Path Abs Dir -> m ([Path Abs Dir],[Path Abs File])@@ -129,6 +136,63 @@ then return () else throwIO e)) +-- | Move the given file. Optimistically assumes it exists. If it+-- doesn't, doesn't complain.+renameFileIfExists :: MonadIO m => Path b File -> Path b File -> m ()+renameFileIfExists from to =+ liftIO+ (catch+ (renameFile (toFilePath from)+ (toFilePath to))+ (\e ->+ if isDoesNotExistError e+ then return ()+ else throwIO e))++-- | Rename the directory. Optimistically assumes it exists. If it+-- doesn't, doesn't complain.+renameDirIfExists :: MonadIO m => Path b Dir -> Path b Dir -> m ()+renameDirIfExists from to =+ liftIO+ (catch+ (renameDirectory (toFilePath from)+ (toFilePath to))+ (\e ->+ if isDoesNotExistError e+ then return ()+ else throwIO e))++-- | Make a directory tree, creating parents if needed.+createTree :: MonadIO m => Path b Dir -> m ()+createTree = liftIO . createDirectoryIfMissing True . toFilePath++-- | Move the given file. Optimistically assumes it exists. If it+-- doesn't, doesn't complain.+moveFileIfExists :: MonadIO m => Path b File -> Path b Dir -> m ()+moveFileIfExists from to =+ liftIO+ (catch+ (renameFile (toFilePath from)+ (toFilePath (to </> filename from)))+ (\e ->+ if isDoesNotExistError e+ then return ()+ else throwIO e))++-- | Move the given dir. Optimistically assumes it exists. If it+-- doesn't, doesn't complain.+moveDirIfExists :: MonadIO m => Path b Dir -> Path b Dir -> m ()+moveDirIfExists from to =+ liftIO+ (catch+ (renameDirectory+ (toFilePath from)+ (toFilePath (to </> dirname from)))+ (\e ->+ if isDoesNotExistError e+ then return ()+ else throwIO e))+ -- | Remove the given tree. Bails out if the directory doesn't exist. removeTree :: MonadIO m => Path b Dir -> m () removeTree =@@ -150,7 +214,7 @@ -- | Does the given directory exist? dirExists :: MonadIO m => Path b Dir -> m Bool dirExists =- liftIO . doesFileExist . toFilePath+ liftIO . doesDirectoryExist . toFilePath -- | Copy a directory recursively. This just uses 'copyFile', so it is not smart about symbolic -- links or other special files.
src/Stack/Build/Cache.hs view
@@ -13,13 +13,14 @@ , tryGetFlagCache , deleteCaches , markExeInstalled+ , markExeNotInstalled , writeFlagCache , writeBuildCache , writeConfigCache , writeCabalMod ) where -import Control.Exception.Enclosed (handleIO, tryIO)+import Control.Exception.Enclosed (catchIO, handleIO, tryIO) import Control.Monad.Catch (MonadCatch, MonadThrow, catch, throwM) import Control.Monad.IO.Class@@ -42,7 +43,8 @@ import Stack.Types import System.Directory (createDirectoryIfMissing, getDirectoryContents,- getModificationTime)+ getModificationTime,+ removeFile) import System.IO.Error (isDoesNotExistError) -- | Directory containing files to mark an executable as installed@@ -72,6 +74,15 @@ -- longer exist liftIO $ writeFile fp "Installed" +-- | Mark the given executable as not installed+markExeNotInstalled :: (MonadReader env m, HasEnvConfig env, MonadIO m, MonadThrow m)+ => InstallLocation -> PackageIdentifier -> m ()+markExeNotInstalled loc ident = do+ dir <- exeInstalledDir loc+ ident' <- parseRelFile $ packageIdentifierString ident+ let fp = toFilePath $ dir </> ident'+ liftIO $ catchIO (removeFile fp) (\_ -> return ())+ -- | Stored on disk to know whether the flags have changed or any -- files have changed. data BuildCache = BuildCache@@ -202,7 +213,7 @@ -> Path Abs File -- ^ cabal file -> m (Map FilePath ModTime) getPackageFileModTimes pkg cabalfp = do- files <- getPackageFiles (packageFiles pkg) cabalfp+ files <- getPackageFiles (packageFiles pkg) AllFiles cabalfp liftM (Map.fromList . catMaybes) $ mapM getModTimeMaybe $ Set.toList files
src/Stack/Build/ConstructPlan.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-}@@ -26,7 +27,9 @@ import Data.Set (Set) import qualified Data.Set as Set import Data.Text (Text)-import Data.Text.Encoding (encodeUtf8)+import qualified Data.Text as T+import Data.Text.Encoding (encodeUtf8, decodeUtf8With)+import Data.Text.Encoding.Error (lenientDecode) import Distribution.Package (Dependency (..)) import Distribution.Version (anyVersion, intersectVersionRanges)@@ -76,6 +79,7 @@ Ctx ( Map PackageName (Either ConstructPlanException Task) -- finals , Map Text InstallLocation -- executable to be installed, and location where the binary is placed+ , Map PackageName Text -- why a local package is considered dirty ) (Map PackageName (Either ConstructPlanException AddDepRes)) IO@@ -125,7 +129,7 @@ let inner = do mapM_ onWanted $ filter lpWanted locals mapM_ addDep $ Set.toList extraToBuild0- ((), m, (efinals, installExes)) <- liftIO $ runRWST inner (ctx econfig latest) M.empty+ ((), m, (efinals, installExes, dirtyReason)) <- liftIO $ runRWST inner (ctx econfig latest) M.empty let toEither (_, Left e) = Left e toEither (k, Right v) = Right (k, v) (errlibs, adrs) = partitionEithers $ map toEither $ M.toList m@@ -143,7 +147,7 @@ return $ maybeStripLocals Plan { planTasks = tasks , planFinals = M.fromList finals- , planUnregisterLocal = mkUnregisterLocal tasks locallyRegistered+ , planUnregisterLocal = mkUnregisterLocal tasks dirtyReason locallyRegistered , planInstallExes = if boptsInstallExes $ bcoBuildOpts baseConfigOpts0 then installExes@@ -165,18 +169,26 @@ , latestVersions = latest , wanted = wantedLocalPackages locals }+ -- TODO Currently, this will only consider and install tools from the+ -- snapshot. It will not automatically install build tools from extra-deps+ -- or local packages. toolMap = getToolMap mbp0 -- | Determine which packages to unregister based on the given tasks and -- already registered local packages-mkUnregisterLocal :: Map PackageName Task -> Set GhcPkgId -> Set GhcPkgId-mkUnregisterLocal tasks locallyRegistered =- Set.filter toUnregister locallyRegistered+mkUnregisterLocal :: Map PackageName Task+ -> Map PackageName Text+ -> Set GhcPkgId+ -> Map GhcPkgId Text+mkUnregisterLocal tasks dirtyReason locallyRegistered =+ Map.unions $ map toUnregisterMap $ Set.toList locallyRegistered where- toUnregister gid =+ toUnregisterMap gid = case M.lookup name tasks of- Nothing -> False- Just _ -> True+ Nothing -> Map.empty+ Just _ -> Map.singleton gid+ $ fromMaybe "likely unregistering due to a version change"+ $ Map.lookup name dirtyReason where ident = ghcPkgIdPackageIdentifier gid name = packageIdentifierName ident@@ -204,7 +216,7 @@ , taskPresent = present , taskType = TTLocal lp }- tell (Map.singleton (packageName package) res, mempty)+ tell (Map.singleton (packageName package) res, mempty, mempty) where package = lpPackageFinal lp @@ -263,7 +275,7 @@ tellExecutablesPackage :: InstallLocation -> Package -> M () tellExecutablesPackage loc p =- tell (Map.empty, m)+ tell (Map.empty, m, Map.empty) where m = Map.fromList $ map (, loc) $ Set.toList $ packageExes p @@ -309,7 +321,14 @@ Left _e -> return True -- installPackage will find the error again Right (missing, present, _loc) | Set.null missing -> checkDirtiness ps installed package present wanted- | otherwise -> return True+ | otherwise -> do+ tell (Map.empty, Map.empty, Map.singleton name $+ let t = T.intercalate ", " $ map (T.pack . packageNameString . packageIdentifierName) (Set.toList missing)+ in T.append "missing dependencies: " $+ if T.length t < 100+ then t+ else T.take 97 t <> "...")+ return True addPackageDeps :: Package -> M (Either ConstructPlanException (Set PackageIdentifier, Set GhcPkgId, InstallLocation)) addPackageDeps package = do@@ -373,11 +392,52 @@ -- Disabling haddocks when old config had haddocks doesn't make dirty. maybe False configCacheHaddock moldOpts }- case moldOpts of- Nothing -> return True- Just oldOpts -> return $ oldOpts /= wantConfigCache ||- psDirty ps+ let mreason =+ case moldOpts of+ Nothing -> Just "old configure information not found"+ Just oldOpts+ | oldOpts /= wantConfigCache -> Just $ describeConfigDiff oldOpts wantConfigCache+ | psDirty ps -> Just "local file changes"+ | otherwise -> Nothing+ case mreason of+ Nothing -> return False+ Just reason -> do+ tell (Map.empty, Map.empty, Map.singleton (packageName package) reason)+ return True +describeConfigDiff :: ConfigCache -> ConfigCache -> 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+ [ "flags changed from "+ , show oldOpts+ , " to "+ , show newOpts+ ]+ | otherwise = "unknown config cache difference"+ where+ -- options set by stack+ isStackOpt t = any (`T.isPrefixOf` t)+ [ "--dependency="+ , "--constraint="+ , "--package-db="+ , "--libdir="+ , "--bindir="+ ]++ userOpts = filter (not . isStackOpt)+ . map (decodeUtf8With lenientDecode)+ . configCacheOpts++ (oldOpts, newOpts) = removeMatching (userOpts old) (userOpts new)++ removeMatching (x:xs) (y:ys)+ | x == y = removeMatching xs ys+ removeMatching xs ys = (xs, ys)+ psDirty :: PackageSource -> Bool psDirty (PSLocal lp) = lpDirtyFiles lp psDirty (PSUpstream _ _ _) = False -- files never change in an upstream package@@ -406,7 +466,7 @@ stripLocals plan = plan { planTasks = Map.filter checkTask $ planTasks plan , planFinals = Map.empty- , planUnregisterLocal = Set.empty+ , planUnregisterLocal = Map.empty , planInstallExes = Map.filter (/= Local) $ planInstallExes plan } where
src/Stack/Build/Execute.hs view
@@ -9,6 +9,8 @@ ( printPlan , preFetch , executePlan+ -- TESTING+ , compareTestsComponents ) where import Control.Applicative ((<$>), (<*>))@@ -45,6 +47,7 @@ import Data.Text.Encoding (encodeUtf8) import Distribution.System (OS (Windows), Platform (Platform))+import Language.Haskell.TH (Loc(..)) import Network.HTTP.Client.Conduit (HasHttpManager) import Path import Path.IO@@ -98,11 +101,16 @@ -> Plan -> m () printPlan finalAction plan = do- case Set.toList $ planUnregisterLocal plan of+ case Map.toList $ planUnregisterLocal plan of [] -> $logInfo "Nothing to unregister" xs -> do $logInfo "Would unregister locally:"- mapM_ ($logInfo . T.pack . ghcPkgIdString) xs+ forM_ xs $ \(gid, reason) -> $logInfo $ T.concat+ [ T.pack $ ghcPkgIdString gid+ , " ("+ , reason+ , ")"+ ] $logInfo "" @@ -299,14 +307,16 @@ -> ExecuteEnv -> m () executePlan' plan ee@ExecuteEnv {..} = do- case Set.toList $ planUnregisterLocal plan of+ case Map.toList $ planUnregisterLocal plan of [] -> return () ids -> do localDB <- packageDatabaseLocal- forM_ ids $ \id' -> do+ forM_ ids $ \(id', reason) -> do $logInfo $ T.concat [ T.pack $ ghcPkgIdString id'- , ": unregistering"+ , ": unregistering ("+ , reason+ , ")" ] unregisterGhcPkgId eeEnvOverride localDB id' @@ -511,6 +521,7 @@ menv <- liftIO $ configEnvOverride config EnvSettings { esIncludeLocals = taskLocation task == Local , esIncludeGhcPackagePath = False+ , esStackExe = False } exeName <- liftIO $ join $ findExecutable menv "runhaskell" distRelativeDir' <- distRelativeDir@@ -608,6 +619,7 @@ (cache, _neededConfig) <- ensureConfig pkgDir ee task (announce "configure") cabal cabalfp [] fileModTimes <- getPackageFileModTimes package cabalfp+ markExeNotInstalled (taskLocation task) taskProvides writeBuildCache pkgDir fileModTimes announce "build"@@ -672,31 +684,51 @@ TTLocal lp -> lpDirtyFiles lp _ -> assert False True) || True -- FIXME above logic is incorrect, see: https://github.com/commercialhaskell/stack/issues/319+ needHpc = boptsCoverage (eeBuildOpts ee)++ componentsRaw =+ case taskType task of+ TTLocal lp -> Set.toList $ lpComponents lp+ TTUpstream _ _ -> assert False []+ testsToRun = compareTestsComponents componentsRaw $ Set.toList $ packageTests package+ components = map (T.unpack . T.append "test:") testsToRun+ when needBuild $ do announce "build (test)" fileModTimes <- getPackageFileModTimes package cabalfp writeBuildCache pkgDir fileModTimes- cabal (console && configHideTHLoading config) ["build"]+ cabal (console && configHideTHLoading config) $ "build" : components bconfig <- asks getBuildConfig- distRelativeDir' <- distRelativeDir- let buildDir = pkgDir </> distRelativeDir'- let exeExtension =+ buildDir <- distDirFromDir pkgDir+ hpcDir <- hpcDirFromDir pkgDir+ when needHpc (createTree hpcDir)+ let dotHpcDir = pkgDir </> dotHpc+ exeExtension = case configPlatform $ getConfig bconfig of Platform _ Windows -> ".exe" _ -> "" - errs <- liftM Map.unions $ forM (Set.toList $ packageTests package) $ \testName -> do- nameDir <- liftIO $ parseRelDir $ T.unpack testName- nameExe <- liftIO $ parseRelFile $ T.unpack testName ++ exeExtension+ errs <- liftM Map.unions $ forM testsToRun $ \testName -> do+ nameDir <- parseRelDir $ T.unpack testName+ nameExe <- parseRelFile $ T.unpack testName ++ exeExtension+ nameTix <- liftM (pkgDir </>) $ parseRelFile $ T.unpack testName ++ ".tix" let exeName = buildDir </> $(mkRelDir "build") </> nameDir </> nameExe exists <- fileExists exeName menv <- liftIO $ configEnvOverride config EnvSettings { esIncludeLocals = taskLocation task == Local , esIncludeGhcPackagePath = True+ , esStackExe = True } if exists then do+ -- We clear out the .tix files before doing a run.+ when needHpc $ do+ tixexists <- fileExists nameTix+ when tixexists $+ $logWarn ("Removing HPC file " <> T.pack (toFilePath nameTix))+ removeFileIfExists nameTix+ let args = boptsTestArgs (eeBuildOpts ee) argsDisplay = case args of@@ -721,6 +753,10 @@ (Just inH, Nothing, Nothing, ph) <- liftIO $ createProcess_ "singleBuild.runTests" cp liftIO $ hClose inH ec <- liftIO $ waitForProcess ph+ -- Move the .tix file out of the package directory+ -- into the hpc work dir, for tidiness.+ when needHpc $+ moveFileIfExists nameTix hpcDir return $ case ec of ExitSuccess -> Map.empty _ -> Map.singleton testName $ Just ec@@ -732,11 +768,70 @@ , T.pack $ packageNameString $ packageName package ] return $ Map.singleton testName Nothing+ when needHpc $ do+ createTree (hpcDir </> dotHpc)+ exists <- dirExists dotHpcDir+ when exists $ do+ copyDirectoryRecursive dotHpcDir (hpcDir </> dotHpc)+ removeTree dotHpcDir+ (_,files) <- listDirectory hpcDir+ let tixes =+ filter (isSuffixOf ".tix" . toFilePath . filename) files+ generateHpcReport pkgDir hpcDir (hpcDir </> dotHpc) tixes++ bs <- liftIO $+ case mlogFile of+ Nothing -> return ""+ Just (logFile, h) -> do+ hClose h+ S.readFile $ toFilePath logFile+ unless (Map.null errs) $ throwM $ TestSuiteFailure (taskProvides task) errs (fmap fst mlogFile)+ bs +-- | Determine the tests to be run based on the list of components.+compareTestsComponents :: [Text] -- ^ components+ -> [Text] -- ^ all test names+ -> [Text] -- ^ tests to be run+compareTestsComponents [] tests = tests -- no components -- all tests+compareTestsComponents comps tests2 =+ Set.toList $ Set.intersection tests1 $ Set.fromList tests2+ where+ tests1 = Set.unions $ map toSet comps++ toSet x =+ case T.break (== ':') x of+ (y, "") -> assert (x == y) (Set.singleton x)+ ("test", y) -> Set.singleton $ T.drop 1 y+ _ -> Set.empty++-- | Generate the HTML report and+generateHpcReport+ :: M env m+ => Path Abs Dir -> Path Abs Dir -> Path Abs Dir -> [Path Abs File] -> m ()+generateHpcReport _ _ _ [] = return ()+generateHpcReport pkgDir hpcDir dotHpcDir tixes = do+ menv <- getMinimalEnvOverride+ $logInfo "Generating HPC HTML ..."+ subdir <- stripDir pkgDir dotHpcDir+ _ <- readProcessStdout (Just hpcDir) menv "hpc" ("markup" : args subdir)+ output <-+ readProcessStdout (Just hpcDir) menv "hpc" ("report" : args subdir)+ forM_ (S8.lines output) ($logInfo . T.decodeUtf8)+ $logInfo+ ("The HTML report is available at " <>+ T.pack (toFilePath (hpcDir </> $(mkRelFile "hpc_index.html"))))+ where+ args subdir =+ concat+ [ map (toFilePath . filename) tixes+ , ["--srcdir", toFilePath pkgDir]+ , ["--hpcdir", toFilePath subdir]+ , ["--reset-hpcdirs"]]+ singleBench :: M env m => ActionContext -> ExecuteEnv@@ -769,7 +864,7 @@ CB.sourceHandle outH $$ CB.lines =$ CL.filter (not . isTHLoading)- =$ CL.mapM_ (logOtherN level . T.decodeUtf8)+ =$ CL.mapM_ (monadLoggerLog (Loc "<unknown>" "<unknown>" "<unknown>" (0,0) (0,0)) "" level) where -- | Is this line a Template Haskell "Loading package" line -- ByteString
src/Stack/Build/Source.hs view
@@ -10,6 +10,7 @@ , SourceMap , PackageSource (..) , localFlags+ , loadLocals ) where import Network.HTTP.Client.Conduit (HasHttpManager)@@ -266,13 +267,15 @@ TSDir dir:ts -> loop (dirs . (dir:)) names idents ts -- | All flags for a local package-localFlags :: (Map PackageName (Map FlagName Bool))+localFlags :: (Map (Maybe PackageName) (Map FlagName Bool)) -> BuildConfig -> PackageName -> Map FlagName Bool-localFlags boptsflags bconfig name = Map.union- (fromMaybe Map.empty $ Map.lookup name $ boptsflags)- (fromMaybe Map.empty $ Map.lookup name $ bcFlags bconfig)+localFlags boptsflags bconfig name = Map.unions+ [ fromMaybe Map.empty $ Map.lookup (Just name) $ boptsflags+ , fromMaybe Map.empty $ Map.lookup Nothing $ boptsflags+ , fromMaybe Map.empty $ Map.lookup name $ bcFlags bconfig+ ] -- | Add in necessary packages to extra dependencies --
src/Stack/Build/Types.hs view
@@ -73,7 +73,7 @@ (Set PackageName) -- no known version (Map PackageName Version) -- not in snapshot, here's the most recent version in the index (Path Abs File) -- stack.yaml- | TestSuiteFailure PackageIdentifier (Map Text (Maybe ExitCode)) (Maybe (Path Abs File))+ | TestSuiteFailure PackageIdentifier (Map Text (Maybe ExitCode)) (Maybe (Path Abs File)) S.ByteString | ConstructPlanExceptions [ConstructPlanException] (Path Abs File) -- stack.yaml@@ -137,7 +137,7 @@ (\(name, version) -> "- " ++ packageIdentifierString (PackageIdentifier name version)) (Map.toList notInSnapshot)- show (TestSuiteFailure ident codes mlogFile) = unlines $ concat+ show (TestSuiteFailure ident codes mlogFile bs) = unlines $ concat [ ["Test suite failure for package " ++ packageIdentifierString ident] , flip map (Map.toList codes) $ \(name, mcode) -> concat [ " "@@ -151,7 +151,13 @@ Nothing -> "Logs printed to console" -- TODO Should we load up the full error output and print it here? Just logFile -> "Full log available at " ++ toFilePath logFile+ , if S.null bs+ then []+ else ["", "", doubleIndent $ T.unpack $ decodeUtf8With lenientDecode bs] ]+ where+ indent = dropWhileEnd isSpace . unlines . fmap (\line -> " " ++ line) . lines+ doubleIndent = indent . indent show (ConstructPlanExceptions exceptions stackYaml) = "While constructing the BuildPlan the following exceptions were encountered:" ++ appendExceptions exceptions' ++@@ -272,7 +278,7 @@ ,boptsFinalAction :: !FinalAction ,boptsDryrun :: !Bool ,boptsGhcOptions :: ![Text]- ,boptsFlags :: !(Map PackageName (Map FlagName Bool))+ ,boptsFlags :: !(Map (Maybe PackageName) (Map FlagName Bool)) ,boptsInstallExes :: !Bool -- ^ Install executables to user path after building? ,boptsPreFetch :: !Bool@@ -282,6 +288,9 @@ ,boptsOnlySnapshot :: !Bool -- ^ Only install packages in the snapshot database, skipping -- packages intended for the local database.+ ,boptsCoverage :: !Bool+ -- ^ Enable code coverage report generation for test+ -- suites. } deriving (Show) @@ -379,7 +388,8 @@ { planTasks :: !(Map PackageName Task) , planFinals :: !(Map PackageName Task) -- ^ Final actions to be taken (test, benchmark, etc)- , planUnregisterLocal :: !(Set GhcPkgId)+ , planUnregisterLocal :: !(Map GhcPkgId Text)+ -- ^ Text is reason we're unregistering, for display only , planInstallExes :: !(Map Text InstallLocation) -- ^ Executables that should be installed after successful building }
src/Stack/BuildPlan.hs view
@@ -47,10 +47,9 @@ import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe (mapMaybe)-import Data.Monoid ((<>))+import Data.Monoid ((<>), Monoid (..)) import Data.Set (Set) import qualified Data.Set as Set-import Data.Text (Text) import qualified Data.Text as T import Data.Time (Day) import qualified Data.Traversable as Tr@@ -62,6 +61,8 @@ executables, exeName, library, libBuildInfo, buildable) import qualified Distribution.Package as C import qualified Distribution.PackageDescription as C+import qualified Distribution.Version as C+import Distribution.Text (display) import Network.HTTP.Download import Path import Prelude -- Fix AMP warning@@ -478,20 +479,25 @@ -- only modify non-manual flags, and will prefer default values for flags. -- Returns @Nothing@ if no combination exists. checkBuildPlan :: (MonadLogger m, MonadThrow m, MonadIO m, MonadReader env m, HasConfig env, MonadCatch m)- => MiniBuildPlan+ => Map PackageName Version -- ^ locally available packages+ -> MiniBuildPlan -> GenericPackageDescription- -> m (Maybe (Map FlagName Bool))-checkBuildPlan mbp gpd = do+ -> m (Either DepErrors (Map PackageName (Map FlagName Bool)))+checkBuildPlan locals mbp gpd = do platform <- asks (configPlatform . getConfig)- loop platform flagOptions+ return $ loop platform flagOptions where- loop _ [] = return Nothing- loop platform (flags:rest) = do- passes <- checkDeps flags (packageDeps pkg) (mbpPackages mbp)- if passes- then return $ Just flags- else loop platform rest+ packages = Map.union locals $ fmap mpiVersion $ mbpPackages mbp+ loop _ [] = assert False $ Left Map.empty+ loop platform (flags:rest)+ | Map.null errs = Right $+ if Map.null flags+ then Map.empty+ else Map.singleton (packageName pkg) flags+ | null rest = Left errs+ | otherwise = loop platform rest where+ errs = checkDeps (packageName pkg) (packageDeps pkg) packages pkg = resolvePackage pkgConfig gpd pkgConfig = PackageConfig { packageConfigEnableTests = True@@ -520,34 +526,38 @@ -- | Checks if the given package dependencies can be satisfied by the given set -- of packages. Will fail if a package is either missing or has a version -- outside of the version range.-checkDeps :: MonadLogger m- => Map FlagName Bool -- ^ used only for debugging purposes+checkDeps :: PackageName -- ^ package using dependencies, for constructing DepErrors -> Map PackageName VersionRange- -> Map PackageName MiniPackageInfo- -> m Bool-checkDeps flags deps packages = do- let errs = mapMaybe go $ Map.toList deps- if null errs- then return True- else do- $logDebug $ "Checked against following flags: " <> T.pack (show flags)- mapM_ $logDebug errs- return False+ -> Map PackageName Version+ -> DepErrors+checkDeps myName deps packages =+ Map.unionsWith mappend $ map go $ Map.toList deps where- go :: (PackageName, VersionRange) -> Maybe Text+ go :: (PackageName, VersionRange) -> DepErrors go (name, range) =- case fmap mpiVersion $ Map.lookup name packages of- Nothing -> Just $ "Package not present: " <> packageNameText name+ case Map.lookup name packages of+ Nothing -> Map.singleton name DepError+ { deVersion = Nothing+ , deNeededBy = Map.singleton myName range+ } Just v- | withinRange v range -> Nothing- | otherwise -> Just $ T.concat- [ packageNameText name- , " version available: "- , versionText v- , " does not match "- , versionRangeText range- ]+ | withinRange v range -> Map.empty+ | otherwise -> Map.singleton name DepError+ { deVersion = Just v+ , deNeededBy = Map.singleton myName range+ } +type DepErrors = Map PackageName DepError+data DepError = DepError+ { deVersion :: !(Maybe Version)+ , deNeededBy :: !(Map PackageName VersionRange)+ }+instance Monoid DepError where+ mempty = DepError Nothing Map.empty+ mappend (DepError a x) (DepError b y) = DepError+ (maybe a Just b)+ (Map.unionWith C.intersectVersionRanges x y)+ -- | Find a snapshot and set of flags that is compatible with the given -- 'GenericPackageDescription'. Returns 'Nothing' if no such snapshot is found. findBuildPlan :: (MonadIO m, MonadCatch m, MonadLogger m, MonadReader env m, HasHttpManager env, HasConfig env, MonadBaseControl IO m)@@ -561,20 +571,43 @@ loop (name:names') = do mbp <- loadMiniBuildPlan name $logInfo $ "Checking against build plan " <> renderSnapName name- let checkGPDs flags [] = return $ Just (name, flags)- checkGPDs flags (gpd:gpds) = do- let C.PackageIdentifier pname' _ = C.package $ C.packageDescription gpd- pname = fromCabalPackageName pname'- mflags <- checkBuildPlan mbp gpd- case mflags of- Nothing -> loop names'- Just flags' -> checkGPDs- (if Map.null flags'- then flags- else Map.insert pname flags' flags)- gpds- checkGPDs Map.empty gpds0+ res <- mapM (checkBuildPlan localNames mbp) gpds0+ case partitionEithers res of+ ([], flags) -> return $ Just (name, Map.unions flags)+ (errs, _) -> do+ $logInfo ""+ $logInfo "* Build plan did not match your requirements:"+ displayDepErrors $ Map.unionsWith mappend errs+ $logInfo ""+ loop names' + localNames = Map.fromList $ map (fromCabalIdent . C.package . C.packageDescription) gpds0++ fromCabalIdent (C.PackageIdentifier name version) =+ (fromCabalPackageName name, fromCabalVersion version)++displayDepErrors :: MonadLogger m => DepErrors -> m ()+displayDepErrors errs =+ F.forM_ (Map.toList errs) $ \(depName, DepError mversion neededBy) -> do+ $logInfo $ T.concat+ [ " "+ , T.pack $ packageNameString depName+ , case mversion of+ Nothing -> " not found"+ Just version -> T.concat+ [ " version "+ , T.pack $ versionString version+ , " found"+ ]+ ]+ F.forM_ (Map.toList neededBy) $ \(user, range) -> $logInfo $ T.concat+ [ " - "+ , T.pack $ packageNameString user+ , " requires "+ , T.pack $ display range+ ]+ $logInfo ""+ shadowMiniBuildPlan :: MiniBuildPlan -> Set PackageName -> (MiniBuildPlan, Map PackageName MiniPackageInfo)@@ -594,7 +627,15 @@ Just x -> return x Nothing -> case Map.lookup name pkgs1 of- Nothing -> assert (name `Set.member` shadowed) (return False)+ Nothing+ | name `Set.member` shadowed -> return False++ -- In this case, we have to assume that we're+ -- constructing a build plan on a different OS or+ -- architecture, and therefore different packages+ -- are being chosen. The common example of this is+ -- the Win32 package.+ | otherwise -> return True Just mpi -> do let visited' = Set.insert name visited ress <- mapM (check visited') (Set.toList $ mpiPackageDeps mpi)
src/Stack/Config.hs view
@@ -62,6 +62,7 @@ import qualified Stack.Docker as Docker import Stack.Init import Stack.Types+import Stack.Types.Internal import System.Directory import System.Environment import System.IO@@ -93,12 +94,12 @@ -> Maybe Project -> ConfigMonoid -> m Config-configFromConfigMonoid configStackRoot mproject ConfigMonoid{..} = do+configFromConfigMonoid configStackRoot mproject configMonoid@ConfigMonoid{..} = do let configDocker = Docker.dockerOptsFromMonoid mproject configStackRoot configMonoidDockerOpts configConnectionCount = fromMaybe 8 configMonoidConnectionCount configHideTHLoading = fromMaybe True configMonoidHideTHLoading configLatestSnapshotUrl = fromMaybe- "https://www.stackage.org/download/snapshots.json"+ "https://s3.amazonaws.com/haddock.stackage.org/snapshots.json" configMonoidLatestSnapshotUrl configPackageIndices = fromMaybe [PackageIndex@@ -114,6 +115,7 @@ configSystemGHC = fromMaybe True configMonoidSystemGHC configInstallGHC = fromMaybe False configMonoidInstallGHC+ configSkipGHCCheck = fromMaybe False configMonoidSkipGHCCheck configExtraIncludeDirs = configMonoidExtraIncludeDirs configExtraLibDirs = configMonoidExtraLibDirs@@ -129,6 +131,8 @@ configRequireStackVersion = simplifyVersionRange configMonoidRequireStackVersion + configConfigMonoid = configMonoid+ origEnv <- getEnvOverride configPlatform let configEnvOverride _ = return origEnv @@ -155,10 +159,11 @@ -- | Command-line arguments parser for configuration. configOptsParser :: Bool -> Parser ConfigMonoid configOptsParser docker =- (\opts systemGHC installGHC arch os jobs includes libs -> mempty+ (\opts systemGHC installGHC arch os jobs includes libs skipGHCCheck -> mempty { configMonoidDockerOpts = opts , configMonoidSystemGHC = systemGHC , configMonoidInstallGHC = installGHC+ , configMonoidSkipGHCCheck = skipGHCCheck , configMonoidArch = arch , configMonoidOS = os , configMonoidJobs = jobs@@ -200,6 +205,10 @@ <> metavar "DIR" <> help "Extra directories to check for libraries" ))+ <*> maybeBoolFlags+ "skip-ghc-check"+ "skipping the GHC version and architecture check"+ idm -- | Get the directory on Windows where we should install extra programs. For -- more information, see discussion at:@@ -225,14 +234,16 @@ -- | Load the configuration, using current directory, environment variables, -- and defaults as necessary.-loadConfig :: (MonadLogger m,MonadIO m,MonadCatch m,MonadThrow m,MonadBaseControl IO m,MonadReader env m,HasHttpManager env)+loadConfig :: (MonadLogger m,MonadIO m,MonadCatch m,MonadThrow m,MonadBaseControl IO m,MonadReader env m,HasHttpManager env,HasTerminal env) => ConfigMonoid -- ^ Config monoid from parsed command-line arguments+ -> Maybe (Path Abs File)+ -- ^ Override stack.yaml -> m (LoadConfig m)-loadConfig configArgs = do+loadConfig configArgs mstackYaml = do stackRoot <- determineStackRoot extraConfigs <- getExtraConfigs stackRoot >>= mapM loadYaml- mproject <- loadProjectConfig+ mproject <- loadProjectConfig mstackYaml config <- configFromConfigMonoid stackRoot (fmap (\(proj, _, _) -> proj) mproject) $ mconcat $ case mproject of Nothing -> configArgs : extraConfigs@@ -248,7 +259,7 @@ -- | Load the build configuration, adds build-specific values to config loaded by @loadConfig@. -- values.-loadBuildConfig :: (MonadLogger m, MonadIO m, MonadCatch m, MonadReader env m, HasHttpManager env, MonadBaseControl IO m)+loadBuildConfig :: (MonadLogger m, MonadIO m, MonadCatch m, MonadReader env m, HasHttpManager env, MonadBaseControl IO m, HasTerminal env) => EnvOverride -> Maybe (Project, Path Abs File, ConfigMonoid) -> Config@@ -277,9 +288,8 @@ exists <- fileExists dest if exists then do- inTerminal <- liftIO (hIsTerminalDevice stdout) ProjectAndConfigMonoid project _ <- loadYaml dest- when inTerminal $ do+ when (getTerminal env) $ case mresolver of Nothing -> $logInfo ("Using resolver: " <> renderResolver (projectResolver project) <>@@ -342,7 +352,10 @@ case peSubdirs pe of [] -> return [entryRoot] subs -> mapM (resolveDir entryRoot) subs- return $ map (, peValidWanted pe) paths+ case peValidWanted pe of+ Nothing -> return ()+ Just _ -> $logWarn "Warning: you are using the deprecated valid-wanted field. You should instead use extra-dep. See: https://github.com/commercialhaskell/stack/wiki/stack.yaml#packages"+ return $ map (, not $ peExtraDep pe) paths -- | Resolve a PackageLocation into a path, downloading and cloning as -- necessary.@@ -452,8 +465,11 @@ -- | Get the location of the project config file, if it exists. getProjectConfig :: (MonadIO m, MonadThrow m, MonadLogger m)- => m (Maybe (Path Abs File))-getProjectConfig = do+ => Maybe (Path Abs File)+ -- ^ Override stack.yaml+ -> m (Maybe (Path Abs File))+getProjectConfig (Just stackYaml) = return $ Just stackYaml+getProjectConfig Nothing = do env <- liftIO getEnvironment case lookup "STACK_YAML" env of Just fp -> do@@ -485,9 +501,11 @@ -- and otherwise traversing parents. If no config is found, we supply a default -- based on current directory. loadProjectConfig :: (MonadIO m, MonadThrow m, MonadLogger m)- => m (Maybe (Project, Path Abs File, ConfigMonoid))-loadProjectConfig = do- mfp <- getProjectConfig+ => Maybe (Path Abs File)+ -- ^ Override stack.yaml+ -> m (Maybe (Project, Path Abs File, ConfigMonoid))+loadProjectConfig mstackYaml = do+ mfp <- getProjectConfig mstackYaml case mfp of Just fp -> do currDir <- getWorkingDir
src/Stack/Constants.hs view
@@ -23,7 +23,8 @@ ,wiredInPackages ,cabalPackageName ,implicitGlobalDir- )+ ,hpcDirFromDir+ ,dotHpc) where @@ -125,6 +126,14 @@ (</> $(mkRelFile "stack-cabal-mod")) (distDirFromDir dir) +-- | Directory for HPC work.+hpcDirFromDir+ :: (MonadThrow m, MonadReader env m, HasPlatform env, HasEnvConfig env)+ => Path Abs Dir -- ^ Package directory.+ -> m (Path Abs Dir)+hpcDirFromDir dir = do+ liftM (</> $(mkRelDir "hpc")) (distDirFromDir dir)+ -- | Package's build artifacts directory. distDirFromDir :: (MonadThrow m, MonadReader env m, HasPlatform env, HasEnvConfig env) => Path Abs Dir@@ -224,3 +233,7 @@ implicitGlobalDir p = p </> $(mkRelDir "global")++-- | Where .mix files go.+dotHpc :: Path Rel Dir+dotHpc = $(mkRelDir ".hpc")
+ src/Stack/Dot.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+module Stack.Dot where+++import Control.Monad (when)+import Control.Monad.Catch (MonadCatch)+import Control.Monad.IO.Class (MonadIO)+import Control.Monad.Logger (MonadLogger, logInfo)+import Control.Monad.Reader (MonadReader)+import qualified Data.Foldable as F+import Data.Monoid ((<>))+import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Data.Text as T+import Stack.Build.Source+import Stack.Build.Types+import Stack.Package+import Stack.Types++-- | Convert a package name to a graph node name.+nodeName :: PackageName -> T.Text+nodeName name = "\"" <> T.pack (packageNameString name) <> "\""++dot :: (MonadReader env m, HasBuildConfig env, MonadIO m, MonadLogger m, MonadCatch m,HasEnvConfig env)+ => m ()+dot = do+ (locals, _names, _idents) <- loadLocals+ BuildOpts+ { boptsTargets = []+ , boptsLibProfile = False+ , boptsExeProfile = False+ , boptsEnableOptimizations = Nothing+ , boptsHaddock = False+ , boptsHaddockDeps = Nothing+ , boptsFinalAction = DoNothing+ , boptsDryrun = False+ , boptsGhcOptions = []+ , boptsFlags = Map.empty+ , boptsInstallExes = False+ , boptsPreFetch = False+ , boptsTestArgs = []+ , boptsOnlySnapshot = False+ , boptsCoverage = False+ }+ Map.empty+ let localNames = Set.fromList $ map (packageName . lpPackage) locals++ $logInfo "digraph deps {"+ $logInfo "splines=polyline;"++ F.forM_ locals $ \lp -> do+ let deps = Set.intersection localNames $ packageAllDeps $ lpPackage lp+ F.forM_ deps $ \dep ->+ $logInfo $ T.concat+ [ nodeName $ packageName $ lpPackage lp+ , " -> "+ , nodeName dep+ , ";"+ ]+ when (Set.null deps) $+ $logInfo $ T.concat+ [ "{rank=max; "+ , nodeName $ packageName $ lpPackage lp+ , "}"+ ]++ $logInfo "}"
src/Stack/Exec.hs view
@@ -18,17 +18,20 @@ import qualified System.Process as P import System.Process.Read +-- | Default @EnvSettings@ which includes locals and GHC_PACKAGE_PATH+defaultEnvSettings :: EnvSettings+defaultEnvSettings = EnvSettings+ { esIncludeLocals = True+ , esIncludeGhcPackagePath = True+ , esStackExe = True+ } -- | Execute a process within the Stack configured environment. exec :: (HasConfig r, MonadReader r m, MonadIO m, MonadLogger m, MonadThrow m)- => String -> [String] -> m b-exec cmd args = do+ => EnvSettings -> String -> [String] -> m b+exec envSettings cmd args = do config <- asks getConfig- menv <- liftIO (configEnvOverride config- EnvSettings- { esIncludeLocals = True- , esIncludeGhcPackagePath = True- })+ menv <- liftIO (configEnvOverride config envSettings) exists <- liftIO $ doesFileExist cmd cmd' <- if exists
src/Stack/GhcPkg.hs view
@@ -36,8 +36,8 @@ import Stack.Build.Types (StackBuildException (Couldn'tFindPkgId)) import Stack.Constants import Stack.Types-import System.Directory (createDirectoryIfMissing, doesDirectoryExist, canonicalizePath)-import System.FilePath (normalise)+import System.Directory (createDirectoryIfMissing, doesDirectoryExist, canonicalizePath,+ doesDirectoryExist) import System.Process.Read -- | Get the global package database@@ -137,7 +137,13 @@ findGhcPkgHaddockHtml menv pkgDbs pkgId = do mpath <- findGhcPkgField menv pkgDbs (packageIdentifierText pkgId) "haddock-html" case mpath of- Just !path -> return $ parseAbsDir $ normalise $ T.unpack path+ Just !path0 -> do+ let path = T.unpack path0+ exists <- liftIO $ doesDirectoryExist path+ path' <- if exists+ then liftIO $ canonicalizePath path+ else return path+ return (parseAbsDir path') _ -> return Nothing -- | Get the dependencies of the package.
src/Stack/Init.hs view
@@ -88,7 +88,8 @@ } pkgs = map toPkg cabalfps toPkg fp = PackageEntry- { peValidWanted = True+ { peValidWanted = Nothing+ , peExtraDepMaybe = Nothing , peLocation = PLFilePath $ case stripDir currDir $ parent fp of Nothing
src/Stack/Package.hs view
@@ -28,7 +28,8 @@ ,resolvePackageDescription ,packageToolDependencies ,packageDependencies- ,packageIdentifier)+ ,packageIdentifier+ ,CabalFileType(..)) where import Control.Exception hiding (try,catch)@@ -140,7 +141,8 @@ -- Argument is the location of the .cabal file newtype GetPackageFiles = GetPackageFiles { getPackageFiles :: forall m. (MonadIO m, MonadLogger m, MonadThrow m, MonadCatch m)- => Path Abs File+ => CabalFileType+ -> Path Abs File -> m (Set (Path Abs File)) } instance Show GetPackageFiles where@@ -163,6 +165,11 @@ } deriving (Show,Typeable) +-- | Files to get for a cabal package.+data CabalFileType+ = AllFiles+ | Modules+ -- | Compares the package name. instance Ord Package where compare = on compare packageName@@ -233,9 +240,12 @@ { packageName = name , packageVersion = fromCabalVersion (pkgVersion pkgId) , packageDeps = deps- , packageFiles = GetPackageFiles $ \cabalfp -> do- files <- runReaderT (packageDescFiles pkg) cabalfp- return $ S.fromList $ cabalfp : files+ , packageFiles = GetPackageFiles $ \ty cabalfp -> do+ files <- runReaderT (packageDescFiles ty pkg) cabalfp+ return $ S.fromList $+ case ty of+ Modules -> files+ AllFiles -> cabalfp : files , packageTools = packageDescTools pkg , packageFlags = packageConfigFlags packageConfig , packageAllDeps = S.fromList (M.keys deps)@@ -258,62 +268,60 @@ -- | Generate GHC options for the package. generatePkgDescOpts :: (HasEnvConfig env, HasPlatform env, MonadThrow m, MonadReader env m, MonadIO m) => Path Abs File -> PackageDescription -> m [String]-generatePkgDescOpts cabalfp pkg =- do distDir <- distDirFromDir cabalDir- let cabalmacros = autogenDir distDir </> $(mkRelFile "cabal_macros.h")- exists <- fileExists cabalmacros- let mcabalmacros =- if exists- then Just cabalmacros- else Nothing- return (nub- (concatMap- (concatMap (generateBuildInfoOpts mcabalmacros cabalDir distDir))- [ maybe- []- (return . libBuildInfo)- (library pkg)- , map buildInfo (executables pkg)- , map benchmarkBuildInfo (benchmarks pkg)- , map testBuildInfo (testSuites pkg)]))- where cabalDir =- parent cabalfp+generatePkgDescOpts cabalfp pkg = do+ distDir <- distDirFromDir cabalDir+ let cabalmacros = autogenDir distDir </> $(mkRelFile "cabal_macros.h")+ exists <- fileExists cabalmacros+ let mcabalmacros =+ if exists+ then Just cabalmacros+ else Nothing+ return+ (nub+ (["-hide-all-packages"] +++ concatMap+ (concatMap+ (generateBuildInfoOpts mcabalmacros cabalDir distDir))+ [ maybe [] (return . libBuildInfo) (library pkg)+ , map buildInfo (executables pkg)+ , map benchmarkBuildInfo (benchmarks pkg)+ , map testBuildInfo (testSuites pkg)]))+ where+ cabalDir = parent cabalfp -- | Generate GHC options for the target. generateBuildInfoOpts :: Maybe (Path Abs File) -> Path Abs Dir -> Path Abs Dir -> BuildInfo -> [String] generateBuildInfoOpts mcabalmacros cabalDir distDir b =- nub (concat [ghcOpts b, extOpts b, srcOpts, macros])+ nub (concat [ghcOpts b, extOpts b, srcOpts, includeOpts b, macros, deps]) where+ deps =+ concat+ [ ["-package=" <> display name]+ | Dependency name _ <- targetBuildDepends b] macros = case mcabalmacros of- Nothing ->- []+ Nothing -> [] Just cabalmacros -> ["-optP-include", "-optP" <> toFilePath cabalmacros]- ghcOpts =- concatMap snd .- filter (isGhc . fst) .- options+ ghcOpts = concatMap snd . filter (isGhc . fst) . options where- isGhc GHC =- True- isGhc _ =- False- extOpts =- map (("-X" ++) . display) .- allExtensions+ isGhc GHC = True+ isGhc _ = False+ extOpts = map (("-X" ++) . display) . allExtensions srcOpts = map (("-i" <>) . toFilePath) (cabalDir : map (cabalDir </>) (mapMaybe parseRelDir (hsSourceDirs b)) <> [autogenDir distDir])+ includeOpts+ = map (("-I" <>) . toFilePath . (cabalDir </>))+ . mapMaybe parseRelDir+ . includeDirs -- | Make the autogen dir. autogenDir :: Path Abs Dir -> Path Abs Dir-autogenDir distDir =- distDir </>- $(mkRelDir "build/autogen")+autogenDir distDir = distDir </> $(mkRelDir "build/autogen") -- | Get all dependencies of the package (buildable targets only). packageDependencies :: PackageDescription -> Map PackageName VersionRange@@ -355,33 +363,35 @@ , benchmarkEnabled tst ] -- | Get all files referenced by the package.-packageDescFiles :: (MonadLogger m,MonadIO m,MonadThrow m,MonadReader (Path Abs File) m,MonadCatch m)- => PackageDescription -> m [Path Abs File]-packageDescFiles pkg =- do libfiles <-- liftM concat- (mapM libraryFiles- (maybe [] return (library pkg)))- exefiles <-- liftM concat- (mapM executableFiles- (executables pkg))- benchfiles <-- liftM concat- (mapM benchmarkFiles (benchmarks pkg))- testfiles <-- liftM concat- (mapM testFiles (testSuites pkg))- dfiles <-- resolveGlobFiles (map (dataDir pkg FilePath.</>) (dataFiles pkg))- srcfiles <-- resolveGlobFiles (extraSrcFiles pkg)- -- extraTmpFiles purposely not included here, as those are files generated- -- by the build script. Another possible implementation: include them, but- -- don't error out if not present- docfiles <-- resolveGlobFiles (extraDocFiles pkg)- return (concat [libfiles,exefiles,dfiles,srcfiles,docfiles,benchfiles,testfiles])+packageDescFiles+ :: (MonadLogger m, MonadIO m, MonadThrow m, MonadReader (Path Abs File) m, MonadCatch m)+ => CabalFileType -> PackageDescription -> m [Path Abs File]+packageDescFiles ty pkg = do+ libfiles <-+ liftM concat (mapM (libraryFiles ty) (maybe [] return (library pkg)))+ exefiles <- liftM concat (mapM (executableFiles ty) (executables pkg))+ benchfiles <- liftM concat (mapM (benchmarkFiles ty) (benchmarks pkg))+ testfiles <- liftM concat (mapM (testFiles ty) (testSuites pkg))+ dfiles <- resolveGlobFiles (map (dataDir pkg FilePath.</>) (dataFiles pkg))+ srcfiles <- resolveGlobFiles (extraSrcFiles pkg)+ -- extraTmpFiles purposely not included here, as those are files generated+ -- by the build script. Another possible implementation: include them, but+ -- don't error out if not present+ docfiles <- resolveGlobFiles (extraDocFiles pkg)+ case ty of+ Modules ->+ return (nub (concat [libfiles, exefiles, testfiles, benchfiles]))+ AllFiles ->+ return+ (nub+ (concat+ [ libfiles+ , exefiles+ , dfiles+ , srcfiles+ , docfiles+ , benchfiles+ , testfiles])) -- | Resolve globbing of files (e.g. data files) to absolute paths. resolveGlobFiles :: (MonadLogger m,MonadIO m,MonadThrow m,MonadReader (Path Abs File) m,MonadCatch m)@@ -447,8 +457,8 @@ -- | Get all files referenced by the benchmark. benchmarkFiles :: (MonadLogger m, MonadIO m, MonadThrow m, MonadReader (Path Abs File) m)- => Benchmark -> m [Path Abs File]-benchmarkFiles bench = do+ => CabalFileType -> Benchmark -> m [Path Abs File]+benchmarkFiles ty bench = do dirs <- mapMaybeM resolveDirOrWarn (hsSourceDirs build) dir <- asks parent exposed <-@@ -460,15 +470,17 @@ BenchmarkUnsupported _ -> []) haskellFileExts- bfiles <- buildFiles dir build- return (mconcat [bfiles, exposed])+ bfiles <- buildFiles ty dir build+ case ty of+ AllFiles -> return (concat [bfiles,exposed])+ Modules -> return (concat [bfiles]) where build = benchmarkBuildInfo bench -- | Get all files referenced by the test. testFiles :: (MonadLogger m, MonadIO m, MonadThrow m, MonadReader (Path Abs File) m)- => TestSuite -> m [Path Abs File]-testFiles test = do+ => CabalFileType -> TestSuite -> m [Path Abs File]+testFiles ty test = do dirs <- mapMaybeM resolveDirOrWarn (hsSourceDirs build) dir <- asks parent exposed <-@@ -482,15 +494,17 @@ TestSuiteUnsupported _ -> []) haskellFileExts- bfiles <- buildFiles dir build- return (mconcat [bfiles, exposed])+ bfiles <- buildFiles ty dir build+ case ty of+ AllFiles -> return (concat [bfiles,exposed])+ Modules -> return (concat [bfiles]) where build = testBuildInfo test -- | Get all files referenced by the executable. executableFiles :: (MonadLogger m,MonadIO m,MonadThrow m,MonadReader (Path Abs File) m)- => Executable -> m [Path Abs File]-executableFiles exe =+ => CabalFileType -> Executable -> m [Path Abs File]+executableFiles ty exe = do dirs <- mapMaybeM resolveDirOrWarn (hsSourceDirs build) dir <- asks parent exposed <-@@ -498,35 +512,42 @@ (dirs ++ [dir]) [Right (modulePath exe)] haskellFileExts- bfiles <- buildFiles dir build- return (concat [bfiles,exposed])+ bfiles <- buildFiles ty dir build+ case ty of+ AllFiles -> return (concat [bfiles,exposed])+ Modules -> return (concat [bfiles]) where build = buildInfo exe -- | Get all files referenced by the library. libraryFiles :: (MonadLogger m,MonadIO m,MonadThrow m,MonadReader (Path Abs File) m)- => Library -> m [Path Abs File]-libraryFiles lib =+ => CabalFileType -> Library -> m [Path Abs File]+libraryFiles ty lib = do dirs <- mapMaybeM resolveDirOrWarn (hsSourceDirs build) dir <- asks parent exposed <- resolveFiles (dirs ++ [dir]) (map Left (exposedModules lib)) haskellFileExts- bfiles <- buildFiles dir build- return (concat [bfiles,exposed])+ bfiles <- buildFiles ty dir build+ case ty of+ AllFiles -> return (concat [bfiles,exposed])+ Modules -> return (concat [bfiles,exposed]) where build = libBuildInfo lib -- | Get all files in a build. buildFiles :: (MonadLogger m,MonadIO m,MonadThrow m,MonadReader (Path Abs File) m)- => Path Abs Dir -> BuildInfo -> m [Path Abs File]-buildFiles dir build = do+ => CabalFileType -> Path Abs Dir -> BuildInfo -> m [Path Abs File]+buildFiles ty dir build = do dirs <- mapMaybeM resolveDirOrWarn (hsSourceDirs build)- other <- resolveFiles- (dirs ++ [dir])- (map Left (otherModules build))- haskellFileExts+ other <-+ resolveFiles+ (dirs ++ [dir])+ (map Left (otherModules build))+ haskellFileExts cSources' <- mapMaybeM resolveFileOrWarn (cSources build)- return (other ++ cSources')+ case ty of+ Modules -> return other+ AllFiles -> return (other ++ cSources') -- | Get all dependencies of a package, including library, -- executables, tests, benchmarks.@@ -703,40 +724,34 @@ ] return $ stack </> $(mkRelDir "logs") </> fp +-- Internal helper to define resolveFileOrWarn and resolveDirOrWarn+resolveOrWarn :: (MonadLogger m, MonadIO m, MonadReader (Path Abs File) m)+ => Text+ -> (Path Abs Dir -> String -> m (Maybe a))+ -> FilePath.FilePath+ -> m (Maybe a)+resolveOrWarn subject resolver path =+ do cwd <- getWorkingDir+ file <- ask+ dir <- asks parent+ result <- resolver dir path+ when (isNothing result) $+ $logWarn ("Warning: " <> subject <> " listed in " <>+ T.pack (maybe (FL.toFilePath file) FL.toFilePath (stripDir cwd file)) <>+ " file does not exist: " <>+ T.pack path)+ return result+ -- | Resolve the file, if it can't be resolved, warn for the user -- (purely to be helpful). resolveFileOrWarn :: (MonadThrow m,MonadIO m,MonadLogger m,MonadReader (Path Abs File) m) => FilePath.FilePath -> m (Maybe (Path Abs File))-resolveFileOrWarn y =- do cwd <- getWorkingDir- file <- ask- dir <- asks parent- result <- resolveFileMaybe dir y- case result of- Nothing ->- $logWarn ("Warning: File listed in " <>- T.pack (maybe (FL.toFilePath file) FL.toFilePath (stripDir cwd file)) <>- " file does not exist: " <>- T.pack y)- _ -> return ()- return result+resolveFileOrWarn = resolveOrWarn "File" resolveFileMaybe -- | Resolve the directory, if it can't be resolved, warn for the user -- (purely to be helpful). resolveDirOrWarn :: (MonadThrow m,MonadIO m,MonadLogger m,MonadReader (Path Abs File) m) => FilePath.FilePath -> m (Maybe (Path Abs Dir))-resolveDirOrWarn y =- do cwd <- getWorkingDir- file <- ask- dir <- asks parent- result <- resolveDirMaybe dir y- case result of- Nothing ->- $logWarn ("Warning: Directory listed in " <>- T.pack (maybe (FL.toFilePath file) FL.toFilePath (stripDir cwd file)) <>- " file does not exist: " <>- T.pack y)- _ -> return ()- return result+resolveDirOrWarn = resolveOrWarn "Directory" resolveDirMaybe
src/Stack/PackageIndex.hs view
@@ -148,7 +148,7 @@ addJSON ident lbs = case decode lbs of Nothing -> m- Just pd -> Map.insertWith+ Just !pd -> Map.insertWith (\_ pc -> pc { pcDownload = Just pd }) ident PackageCache
src/Stack/Repl.hs view
@@ -14,6 +14,7 @@ import qualified Data.Map.Strict as M import Data.Maybe import Data.Monoid+import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T import Path@@ -26,16 +27,18 @@ -- | Launch a GHCi REPL for the given local project targets with the -- given options and configure it with the load paths and extensions -- of those targets.-repl :: (HasConfig r, HasBuildConfig r, HasEnvConfig r, MonadReader r m, MonadIO m, MonadThrow m, MonadLogger m, MonadCatch m)- => [Text] -- ^ Targets.- -> [String] -- ^ GHC options.- -> FilePath- -> m ()-repl targets opts ghciPath = do+repl+ :: (HasConfig r, HasBuildConfig r, HasEnvConfig r, MonadReader r m, MonadIO m, MonadThrow m, MonadLogger m, MonadCatch m)+ => [Text] -- ^ Targets.+ -> [String] -- ^ GHC options.+ -> FilePath+ -> Bool+ -> m ()+repl targets useropts ghciPath noload = do econfig <- asks getEnvConfig bconfig <- asks getBuildConfig pwd <- getWorkingDir- pkgOpts <-+ pkgs <- liftM catMaybes $ forM (M.toList (bcPackages bconfig)) $ \(dir,validWanted) ->@@ -51,41 +54,29 @@ (getConfig bconfig) } pkg <- readPackage config cabalfp- if validWanted &&- wanted pwd cabalfp pkg+ if validWanted && wanted pwd cabalfp pkg then do- pkgOpts <-- getPackageOpts- (packageOpts pkg)- cabalfp- return (Just (packageName pkg, pkgOpts))+ pkgOpts <- getPackageOpts (packageOpts pkg) cabalfp+ srcfiles <-+ getPackageFiles (packageFiles pkg) Modules cabalfp+ return+ (Just (packageName pkg, pkgOpts, S.toList srcfiles)) else return Nothing+ let pkgopts = filter (not . badForGhci) (concat (map _2 pkgs))+ srcfiles+ | noload = []+ | otherwise = concatMap (map toFilePath . _3) pkgs $logInfo ("Configuring GHCi with the following packages: " <>- T.intercalate- ", "- (map packageNameText (map fst pkgOpts)))- exec- ghciPath- ("--interactive" :- filter- (not . badForGhci)- (concat (map snd pkgOpts)) <>- opts)+ T.intercalate ", " (map packageNameText (map _1 pkgs)))+ exec defaultEnvSettings ghciPath ("--interactive" : pkgopts <> srcfiles <> useropts) where- wanted pwd cabalfp pkg =- isInWantedList || targetsEmptyAndInDir+ wanted pwd cabalfp pkg = isInWantedList || targetsEmptyAndInDir where- isInWantedList =- elem- (packageNameText- (packageName pkg))- targets- targetsEmptyAndInDir =- null targets ||- isParentOf- (parent cabalfp)- pwd+ isInWantedList = elem (packageNameText (packageName pkg)) targets+ targetsEmptyAndInDir = null targets || isParentOf (parent cabalfp) pwd badForGhci x =- isPrefixOf "-O" x ||- elem x (words "-debug -threaded -ticky")+ isPrefixOf "-O" x || elem x (words "-debug -threaded -ticky")+ _1 (x,_,_) = x+ _2 (_,x,_) = x+ _3 (_,_,x) = x
src/Stack/Setup.hs view
@@ -15,6 +15,7 @@ ) where import Control.Applicative+import Control.Exception.Enclosed (catchIO) import Control.Monad (liftM, when, join, void) import Control.Monad.Catch import Control.Monad.IO.Class (MonadIO, liftIO)@@ -54,7 +55,8 @@ import Stack.Solver (getGhcVersion) import Stack.Types import Stack.Types.StackT-import System.Directory (doesDirectoryExist, createDirectoryIfMissing)+import System.Directory (doesDirectoryExist, createDirectoryIfMissing, removeFile)+import System.Environment (getExecutablePath) import System.Exit (ExitCode (ExitSuccess)) import System.FilePath (searchPathSeparator) import qualified System.FilePath as FP@@ -71,6 +73,8 @@ , soptsForceReinstall :: !Bool , soptsSanityCheck :: !Bool -- ^ Run a sanity check on the selected GHC+ , soptsSkipGhcCheck :: !Bool+ -- ^ Don't check for a compatible GHC version/architecture } deriving Show data SetupException = UnsupportedSetupCombo OS Arch@@ -120,6 +124,7 @@ , soptsStackYaml = Just $ bcStackYaml bconfig , soptsForceReinstall = False , soptsSanityCheck = False+ , soptsSkipGhcCheck = configSkipGHCCheck $ bcConfig bconfig } mghcBin <- ensureGHC sopts menv0 <- getMinimalEnvOverride@@ -164,11 +169,13 @@ localdbExists <- liftIO $ doesDirectoryExist $ toFilePath localdb globalDB <- mkEnvOverride platform env1 >>= getGlobalDB let mkGPP locals = T.pack $ intercalate [searchPathSeparator] $ concat- [ [toFilePath localdb | locals && localdbExists]- , [toFilePath deps | depsExists]- , [toFilePath globalDB]+ [ [toFilePathNoTrailingSlash localdb | locals && localdbExists]+ , [toFilePathNoTrailingSlash deps | depsExists]+ , [toFilePathNoTrailingSlash globalDB] ] + executablePath <- liftIO getExecutablePath+ envRef <- liftIO $ newIORef Map.empty let getEnvOverride' es = do m <- readIORef envRef@@ -181,17 +188,21 @@ then Map.insert "GHC_PACKAGE_PATH" (mkGPP (esIncludeLocals es)) else id) + $ (if esStackExe es+ then Map.insert "STACK_EXE" (T.pack executablePath)+ else id)+ -- For reasoning and duplication, see: https://github.com/fpco/stack/issues/70- $ Map.insert "HASKELL_PACKAGE_SANDBOX" (T.pack $ toFilePath deps)+ $ Map.insert "HASKELL_PACKAGE_SANDBOX" (T.pack $ toFilePathNoTrailingSlash deps) $ Map.insert "HASKELL_PACKAGE_SANDBOXES" (T.pack $ if esIncludeLocals es then intercalate [searchPathSeparator]- [ toFilePath localdb- , toFilePath deps+ [ toFilePathNoTrailingSlash localdb+ , toFilePathNoTrailingSlash deps , "" ] else intercalate [searchPathSeparator]- [ toFilePath deps+ [ toFilePathNoTrailingSlash deps , "" ]) $ env1@@ -237,6 +248,7 @@ let needLocal = case msystem of 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 ||@@ -272,7 +284,7 @@ installed <- runReaderT listInstalled config idents <- mapM (ensureTool sopts installed getSetupInfo' msystem) tools paths <- runReaderT (mapM binDirs $ catMaybes idents) config- return $ Just $ map toFilePath $ concat paths+ return $ Just $ map toFilePathNoTrailingSlash $ concat paths else return Nothing when (soptsSanityCheck sopts) $ do@@ -475,6 +487,8 @@ 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 arch os -> throwM $ UnsupportedSetupCombo os arch@@ -580,6 +594,13 @@ run7z (parent archiveFile) archiveFile run7z (parent archiveFile) tarFile+ liftIO (removeFile $ toFilePath tarFile) `catchIO` \e ->+ $logWarn (T.concat+ [ "Exception when removing "+ , T.pack $ toFilePath tarFile+ , ": "+ , T.pack $ show e+ ]) $logInfo $ "GHC installed to " <> T.pack (toFilePath destDir) @@ -712,3 +733,6 @@ case eres of Left e -> throwM $ GHCSanityCheckCompileFailed e ghc Right _ -> return () -- TODO check that the output of running the command is correct++toFilePathNoTrailingSlash :: Path loc Dir -> FilePath+toFilePathNoTrailingSlash = FP.dropTrailingPathSeparator . toFilePath
src/Stack/Types/Config.hs view
@@ -85,6 +85,8 @@ ,configInstallGHC :: !Bool -- ^ Should we automatically install GHC if missing or the wrong -- version is available? Can be overridden by command line options.+ ,configSkipGHCCheck :: !Bool+ -- ^ Don't bother checking the GHC version or architecture. ,configLocalBin :: !(Path Abs Dir) -- ^ Directory we should install executables into ,configRequireStackVersion :: !VersionRange@@ -95,6 +97,8 @@ -- ^ --extra-include-dirs arguments ,configExtraLibDirs :: !(Set Text) -- ^ --extra-lib-dirs arguments+ ,configConfigMonoid :: !ConfigMonoid+ -- ^ @ConfigMonoid@ used to generate this } -- | Information on a single package index@@ -158,6 +162,8 @@ -- ^ include local project bin directory, GHC_PACKAGE_PATH, etc , esIncludeGhcPackagePath :: !Bool -- ^ include the GHC_PACKAGE_PATH variable+ , esStackExe :: !Bool+ -- ^ set the STACK_EXE variable to the current executable name } deriving (Show, Eq, Ord) @@ -173,7 +179,7 @@ -- ^ Version of GHC we expected for this build , bcPackages :: !(Map (Path Abs Dir) Bool) -- ^ Local packages identified by a path, Bool indicates whether it is- -- allowed to be wanted (see 'peValidWanted')+ -- a non-dependency (the opposite of 'peExtraDep') , bcExtraDeps :: !(Map PackageName Version) -- ^ Extra dependencies specified in configuration. --@@ -221,19 +227,37 @@ deriving (Show, Eq, Ord) data PackageEntry = PackageEntry- { peValidWanted :: !Bool- -- ^ Can this package be considered wanted? Useful to disable when simply- -- modifying an upstream package, see:+ { peExtraDepMaybe :: !(Maybe Bool)+ -- ^ Is this package a dependency? This means the local package will be+ -- treated just like an extra-deps: it will only be built as a dependency+ -- for others, and its test suite/benchmarks will not be run.+ --+ -- Useful modifying an upstream package, see: -- https://github.com/commercialhaskell/stack/issues/219+ -- https://github.com/commercialhaskell/stack/issues/386+ , peValidWanted :: !(Maybe Bool)+ -- ^ Deprecated name meaning the opposite of peExtraDep. Only present to+ -- provide deprecation warnings to users. , peLocation :: !PackageLocation , peSubdirs :: ![FilePath] } deriving Show++-- | Once peValidWanted is removed, this should just become the field name in PackageEntry.+peExtraDep :: PackageEntry -> Bool+peExtraDep pe =+ case peExtraDepMaybe pe of+ Just x -> x+ Nothing ->+ case peValidWanted pe of+ Just x -> not x+ Nothing -> False+ instance ToJSON PackageEntry where- toJSON pe | peValidWanted pe && null (peSubdirs pe) =+ toJSON pe | not (peExtraDep pe) && null (peSubdirs pe) = toJSON $ peLocation pe toJSON pe = object- [ "valid-wanted" .= peValidWanted pe+ [ "extra-dep" .= peExtraDep pe , "location" .= peLocation pe , "subdirs" .= peSubdirs pe ]@@ -241,12 +265,14 @@ parseJSON (String t) = do loc <- parseJSON $ String t return PackageEntry- { peValidWanted = True+ { peExtraDepMaybe = Nothing+ , peValidWanted = Nothing , peLocation = loc , peSubdirs = [] } parseJSON v = withObject "PackageEntry" (\o -> PackageEntry- <$> o .:? "valid-wanted" .!= True+ <$> o .:? "extra-dep"+ <*> o .:? "valid-wanted" <*> o .: "location" <*> o .:? "subdirs" .!= []) v @@ -388,6 +414,8 @@ -- ^ See: 'configSystemGHC' ,configMonoidInstallGHC :: !(Maybe Bool) -- ^ See: 'configInstallGHC'+ ,configMonoidSkipGHCCheck :: !(Maybe Bool)+ -- ^ See: 'configSkipGHCCheck' ,configMonoidRequireStackVersion :: !VersionRange -- ^ See: 'configRequireStackVersion' ,configMonoidOS :: !(Maybe String)@@ -412,6 +440,7 @@ , configMonoidPackageIndices = Nothing , configMonoidSystemGHC = Nothing , configMonoidInstallGHC = Nothing+ , configMonoidSkipGHCCheck = Nothing , configMonoidRequireStackVersion = anyVersion , configMonoidOS = Nothing , configMonoidArch = Nothing@@ -425,7 +454,9 @@ , configMonoidHideTHLoading = configMonoidHideTHLoading l <|> configMonoidHideTHLoading r , configMonoidLatestSnapshotUrl = configMonoidLatestSnapshotUrl l <|> configMonoidLatestSnapshotUrl r , configMonoidPackageIndices = configMonoidPackageIndices l <|> configMonoidPackageIndices r- , configMonoidSystemGHC = configMonoidSystemGHC l <|> configMonoidSystemGHC r , configMonoidInstallGHC = configMonoidInstallGHC l <|> configMonoidInstallGHC r+ , configMonoidSystemGHC = configMonoidSystemGHC l <|> configMonoidSystemGHC r+ , configMonoidInstallGHC = configMonoidInstallGHC l <|> configMonoidInstallGHC r+ , configMonoidSkipGHCCheck = configMonoidSkipGHCCheck l <|> configMonoidSkipGHCCheck r , configMonoidRequireStackVersion = intersectVersionRanges (configMonoidRequireStackVersion l) (configMonoidRequireStackVersion r) , configMonoidOS = configMonoidOS l <|> configMonoidOS r@@ -446,6 +477,7 @@ configMonoidPackageIndices <- obj .:? "package-indices" configMonoidSystemGHC <- obj .:? "system-ghc" configMonoidInstallGHC <- obj .:? "install-ghc"+ configMonoidSkipGHCCheck <- obj .:? "skip-ghc-check" configMonoidRequireStackVersion <- unVersionRangeJSON <$> obj .:? "require-stack-version" .!= VersionRangeJSON anyVersion@@ -669,6 +701,7 @@ liftIO $ configEnvOverride config EnvSettings { esIncludeLocals = False , esIncludeGhcPackagePath = False+ , esStackExe = False } data ProjectAndConfigMonoid@@ -714,7 +747,8 @@ -- | A PackageEntry for the current directory, used as a default packageEntryCurrDir :: PackageEntry packageEntryCurrDir = PackageEntry- { peValidWanted = True+ { peValidWanted = Nothing+ , peExtraDepMaybe = Nothing , peLocation = PLFilePath "." , peSubdirs = [] }
src/Stack/Types/FlagName.hs view
@@ -27,6 +27,7 @@ import Data.Attoparsec.ByteString.Char8 import Data.Attoparsec.Combinators import Data.Binary (Binary)+import qualified Data.ByteString as S import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as S8 import Data.Char (isLetter)@@ -36,6 +37,7 @@ import qualified Data.Map as Map import Data.Text (Text) import qualified Data.Text.Encoding as T+import qualified Data.Word8 as Word8 import qualified Distribution.PackageDescription as Cabal import GHC.Generics import Language.Haskell.TH@@ -52,7 +54,12 @@ -- | A flag name. newtype FlagName = FlagName ByteString- deriving (Eq,Ord,Typeable,Data,Generic,Hashable,Binary)+ deriving (Typeable,Data,Generic,Hashable,Binary)+instance Eq FlagName where+ x == y = (compare x y) == EQ+instance Ord FlagName where+ compare (FlagName x) (FlagName y) =+ compare (S.map Word8.toLower x) (S.map Word8.toLower y) instance Lift FlagName where lift (FlagName n) =
src/Stack/Types/StackT.hs view
@@ -93,11 +93,19 @@ -------------------------------------------------------------------------------- -- Logging only StackLoggingT monad transformer +-- | Monadic environment for 'StackLoggingT'.+data LoggingEnv = LoggingEnv+ { lenvLogLevel :: !LogLevel+ , lenvTerminal :: !Bool+ , lenvManager :: !Manager+ , lenvSticky :: !Sticky+ }+ -- | The monad used for logging in the executable @stack@ before -- anything has been initialized.-newtype StackLoggingT m a =- StackLoggingT {unStackLoggingT :: ReaderT (LogLevel,Manager,Sticky) m a}- deriving (Functor,Applicative,Monad,MonadIO,MonadThrow,MonadReader (LogLevel,Manager,Sticky),MonadCatch,MonadMask,MonadTrans)+newtype StackLoggingT m a = StackLoggingT+ { unStackLoggingT :: ReaderT LoggingEnv m a+ } deriving (Functor,Applicative,Monad,MonadIO,MonadThrow,MonadReader LoggingEnv,MonadCatch,MonadMask,MonadTrans) deriving instance (MonadBase b m) => MonadBase b (StackLoggingT m) @@ -107,23 +115,26 @@ restoreM = defaultRestoreM instance MonadTransControl StackLoggingT where- type StT StackLoggingT a = StT (ReaderT (LogLevel,Manager,Sticky)) a+ type StT StackLoggingT a = StT (ReaderT LoggingEnv) a liftWith = defaultLiftWith StackLoggingT unStackLoggingT restoreT = defaultRestoreT StackLoggingT -- | Takes the configured log level into account. instance (MonadIO m) => MonadLogger (StackLoggingT m) where- monadLoggerLog = stickyLoggerFunc+ monadLoggerLog = stickyLoggerFunc -instance HasSticky (LogLevel,Manager,Sticky) where- getSticky (_,_,s) = s+instance HasSticky LoggingEnv where+ getSticky = lenvSticky -instance HasLogLevel (LogLevel,Manager,Sticky) where- getLogLevel (l,_,_) = l+instance HasLogLevel LoggingEnv where+ getLogLevel = lenvLogLevel -instance HasHttpManager (LogLevel,Manager,Sticky) where- getHttpManager (_,m,_) = m+instance HasHttpManager LoggingEnv where+ getHttpManager = lenvManager +instance HasTerminal LoggingEnv where+ getTerminal = lenvTerminal+ -- | Run the logging monad. runStackLoggingT :: MonadIO m => Manager -> LogLevel -> Bool -> StackLoggingT m a -> m a@@ -133,7 +144,12 @@ (\sticky -> runReaderT (unStackLoggingT m)- (logLevel, manager, sticky))+ LoggingEnv+ { lenvLogLevel = logLevel+ , lenvManager = manager+ , lenvSticky = sticky+ , lenvTerminal = terminal+ }) -- | Convenience for getting a 'Manager' newTLSManager :: MonadIO m => m Manager
+ src/Stack/Upgrade.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+module Stack.Upgrade (upgrade) where++import Control.Monad.Catch+import Control.Monad.IO.Class+import Control.Monad.Logger+import Control.Monad.Reader+import Control.Monad.Trans.Control+import qualified Data.Map as Map+import qualified Data.Set as Set+import Network.HTTP.Client.Conduit (HasHttpManager, getHttpManager)+import Path+import Stack.Build+import Stack.Build.Types+import Stack.Config+import Stack.Fetch+import Stack.PackageIndex+import Stack.Setup+import Stack.Types+import Stack.Types.Internal+import Stack.Types.StackT+import System.IO.Temp (withSystemTempDirectory)+import System.Process.Run++upgrade :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, HasTerminal env, HasLogLevel env, MonadBaseControl IO m)+ => Bool -- ^ use Git?+ -> Maybe Resolver+ -> m ()+upgrade fromGit mresolver = withSystemTempDirectory "stack-upgrade" $ \tmp' -> do+ menv <- getMinimalEnvOverride+ tmp <- parseAbsDir tmp'+ dir <-+ if fromGit+ then do+ $logInfo "Cloning stack"+ runIn tmp "git" menv+ [ "clone"+ , "git@github.com:commercialhaskell/stack" -- TODO allow to be configured+ , "stack"+ , "--depth"+ , "1"+ ]+ Nothing+ return $ tmp </> $(mkRelDir "stack")+ else do+ updateAllIndices menv+ caches <- getPackageCaches menv+ let latest = Map.fromListWith max+ $ map toTuple+ $ Map.keys caches+ case Map.lookup $(mkPackageName "stack") latest of+ Nothing -> error "No stack found in package indices"+ 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 path++ manager <- asks getHttpManager+ logLevel <- asks getLogLevel+ terminal <- asks getTerminal+ configMonoid <- asks $ configConfigMonoid . getConfig++ liftIO $ do+ bconfig <- runStackLoggingT manager logLevel terminal $ do+ lc <- loadConfig+ configMonoid+ (Just $ dir </> $(mkRelFile "stack.yaml"))+ lcLoadBuildConfig lc mresolver ThrowException+ envConfig1 <- runStackT manager logLevel bconfig terminal setupEnv+ runStackT manager logLevel envConfig1 terminal $ build BuildOpts+ { boptsTargets = ["stack"]+ , boptsLibProfile = False+ , boptsExeProfile = False+ , boptsEnableOptimizations = Nothing+ , boptsHaddock = False+ , boptsHaddockDeps = Nothing+ , boptsFinalAction = DoNothing+ , boptsDryrun = False+ , boptsGhcOptions = []+ , boptsFlags = Map.empty+ , boptsInstallExes = True+ , boptsPreFetch = False+ , boptsTestArgs = []+ , boptsOnlySnapshot = False+ , boptsCoverage = False+ }
src/Stack/Upload.hs view
@@ -191,9 +191,8 @@ -- | Turn the given settings into an @Uploader@. -- -- Since 0.1.0.0-mkUploader :: FilePath -- ^ runghc- -> Config -> UploadSettings -> IO Uploader-mkUploader runghc config us = do+mkUploader :: Config -> UploadSettings -> IO Uploader+mkUploader config us = do manager <- usGetManager us (creds, fromFile') <- loadCreds $ usCredsSource us config when (not fromFile' && usSaveCreds us) $ saveCreds config creds@@ -203,7 +202,7 @@ , checkStatus = \_ _ _ -> Nothing } return Uploader- { upload_ = \fp0 -> withTarball runghc fp0 $ \fp -> do+ { upload_ = \fp0 -> withTarball fp0 $ \fp -> do let formData = [partFile "package" fp] req2 <- formDataBody formData req1 let req3 = applyBasicAuth@@ -238,9 +237,8 @@ -- | Given either a file, return it. Given a directory, run @cabal sdist@ and -- get the resulting tarball.-withTarball :: FilePath -- ^ runghc- -> FilePath -> (FilePath -> IO a) -> IO a-withTarball _runghc fp0 inner = do+withTarball :: FilePath -> (FilePath -> IO a) -> IO a+withTarball fp0 inner = do isFile <- doesFileExist fp0 if isFile then inner fp0 else withSystemTempDirectory "stackage-upload-tarball" $ \dir -> do isDir <- doesDirectoryExist fp0
src/System/Process/Read.hs view
@@ -294,13 +294,20 @@ Nothing -> do let loop [] = return $ Left $ ExecutableNotFound name (eoPath eo) loop (dir:dirs) = do- let fp = dir FP.</> name ++ eoExeExtension eo- exists <- doesFileExist fp- if exists- then do- fp' <- makeAbsolute fp >>= parseAbsFile- return $ return fp'- else loop dirs+ let fp0 = dir FP.</> name+ fps0+ | null (eoExeExtension eo) = [fp0]+ -- Support `stack exec foo.exe` on Windows+ | otherwise = [fp0 ++ eoExeExtension eo, fp0]+ testFPs [] = loop dirs+ testFPs (fp:fps) = do+ exists <- doesFileExist fp+ if exists+ then do+ fp' <- makeAbsolute fp >>= parseAbsFile+ return $ return fp'+ else testFPs fps+ testFPs fps0 epath <- loop $ eoPath eo !() <- atomicModifyIORef (eoExeCache eo) $ \m' -> (Map.insert name epath m', ())
src/main/Main.hs view
@@ -9,11 +9,14 @@ module Main where +import Blaze.ByteString.Builder (toLazyByteString, copyByteString)+import Blaze.ByteString.Builder.Char.Utf8 (fromShow) import Control.Exception import Control.Monad import Control.Monad.IO.Class import Control.Monad.Logger-import Control.Monad.Reader (ask,asks)+import Control.Monad.Reader (ask)+import qualified Data.ByteString.Lazy as L import Data.Char (toLower) import Data.List import qualified Data.List as List@@ -27,7 +30,6 @@ import qualified Data.Text.IO as T import Data.Traversable import Network.HTTP.Client-import Network.HTTP.Client.Conduit (getHttpManager) import Options.Applicative.Args import Options.Applicative.Builder.Extra import Options.Applicative.Simple@@ -41,6 +43,7 @@ import Stack.Config import Stack.Constants import qualified Stack.Docker as Docker+import Stack.Dot import Stack.Exec import Stack.Fetch import Stack.Init@@ -52,21 +55,29 @@ import Stack.Types import Stack.Types.Internal import Stack.Types.StackT+import Stack.Upgrade import qualified Stack.Upload as Upload+import System.Directory (canonicalizePath) import System.Environment (getArgs, getProgName) import System.Exit import System.FilePath (searchPathSeparator)-import System.IO (stderr)+import System.IO (hIsTerminalDevice, stderr, stdin, stdout, hSetBuffering, BufferMode(..)) import System.Process.Read -- | Commandline dispatcher. main :: IO () main =- do when False $ do -- https://github.com/commercialhaskell/stack/issues/322+ do -- Line buffer the output by default, particularly for non-terminal runs.+ -- See https://github.com/commercialhaskell/stack/pull/360+ hSetBuffering stdout LineBuffering+ hSetBuffering stdin LineBuffering+ hSetBuffering stderr NoBuffering+ when False $ do -- https://github.com/commercialhaskell/stack/issues/322 plugins <- findPlugins (T.pack stackProgName) tryRunPlugin plugins progName <- getProgName args <- getArgs+ isTerminal <- hIsTerminalDevice stdout execExtraHelp args dockerHelpOptName (Docker.dockerOptsParser True)@@ -77,27 +88,28 @@ versionString' "stack - The Haskell Tool Stack" ""- (extraHelpOption progName (Docker.dockerCmdName ++ "*") dockerHelpOptName <*> globalOpts)+ (extraHelpOption progName (Docker.dockerCmdName ++ "*") dockerHelpOptName <*>+ globalOpts isTerminal) (do addCommand "build" "Build the project(s) in this directory/configuration" (buildCmd DoNothing)- (buildOpts False)+ (buildOpts Build) addCommand "install" "Build executables and install to a user path" installCmd- (buildOpts False)+ (buildOpts Build) addCommand "test" "Build and test the project(s) in this directory/configuration" (buildCmd DoTests)- (buildOpts False)+ (buildOpts Test) addCommand "bench" "Build and benchmark the project(s) in this directory/configuration" (buildCmd DoBenchmarks)- (buildOpts False)+ (buildOpts Build) addCommand "haddock" "Generate haddocks for the project(s) in this directory/configuration" (buildCmd DoNothing)- (buildOpts True)+ (buildOpts Haddock) addCommand "new" "Create a brand new project" newCmd@@ -135,43 +147,69 @@ "Update the package index" updateCmd (pure ())+ addCommand "upgrade"+ "Upgrade to the latest stack (experimental)"+ upgradeCmd+ (switch+ ( long "git"+ <> help "Clone from Git instead of downloading from Hackage (more dangerous)"+ )) addCommand "upload" "Upload a package to Hackage" uploadCmd (many $ strArgument $ metavar "TARBALL/DIR")+ addCommand "dot"+ "Visualize your project's dependency graph using Graphviz dot"+ dotCmd+ (pure ()) addCommand "exec" "Execute a command" execCmd- ((,)+ ((,,) <$> strArgument (metavar "CMD")- <*> many (strArgument (metavar "-- ARGS (e.g. stack exec -- ghc --version)")))+ <*> many (strArgument (metavar "-- ARGS (e.g. stack exec -- ghc --version)"))+ <*> (EnvSettings+ <$> pure True+ <*> boolFlags True+ "ghc-package-path"+ "setting the GHC_PACKAGE_PATH variable for the subprocess"+ idm+ <*> boolFlags True+ "stack-exe"+ "setting the STACK_EXE environment variable to the path for the stack executable"+ idm)) addCommand "ghc" "Run ghc" execCmd- ((,)+ ((,,) <$> pure "ghc"- <*> many (strArgument (metavar "-- ARGS (e.g. stack ghc -- X.hs -o x)")))+ <*> many (strArgument (metavar "-- ARGS (e.g. stack ghc -- X.hs -o x)"))+ <*> pure defaultEnvSettings) addCommand "ghci" "Run ghci in the context of project(s)" replCmd- ((,,) <$>+ ((,,,) <$> fmap (map T.pack) (many (strArgument (metavar "TARGET" <> help "If none specified, use all packages defined in current directory"))) <*>- many (strOption (long "ghc-options" <>- metavar "OPTION" <>- help "Additional options passed to GHCi")) <*>+ fmap (fromMaybe [])+ (optional (argsOption (long "ghc-options" <>+ metavar "OPTION" <>+ help "Additional options passed to GHCi"))) <*> fmap (fromMaybe "ghc") (optional (strOption (long "with-ghc" <> metavar "GHC" <>- help "Use this command for the GHC to run"))))+ help "Use this command for the GHC to run"))) <*>+ flag False True (long "no-load" <>+ help "Don't load modules on start-up")) addCommand "runghc" "Run runghc" execCmd- ((,)+ ((,,) <$> pure "runghc"- <*> many (strArgument (metavar "-- ARGS (e.g. stack runghc -- X.hs)")))+ <*> many (strArgument (metavar "-- ARGS (e.g. stack runghc -- X.hs)"))+ <*> pure defaultEnvSettings) addCommand "clean" "Clean the local packages" cleanCmd@@ -206,7 +244,7 @@ case fromException e of Just ec -> exitWith ec Nothing -> do- print e+ L.hPut stderr $ toLazyByteString $ fromShow e <> copyByteString "\n" exitFailure where dockerHelpOptName = Docker.dockerCmdName ++ "-help"@@ -257,7 +295,9 @@ paths) (\(_,key,path) -> $logInfo- (key <> ": " <>+ ((if length keys == 1+ then ""+ else key <> ": ") <> path (PathInfo bc@@ -385,6 +425,7 @@ , soptsStackYaml = mstack , soptsForceReinstall = scoForceReinstall , soptsSanityCheck = True+ , soptsSkipGhcCheck = False } case mpaths of Nothing -> $logInfo "GHC on PATH would be used"@@ -392,6 +433,16 @@ <> T.pack (intercalate [searchPathSeparator] ps) ) +withConfig :: GlobalOpts+ -> StackT Config IO ()+ -> IO ()+withConfig go@GlobalOpts{..} inner = do+ (manager, lc) <- loadConfigWithOpts go+ runStackT manager globalLogLevel (lcConfig lc) globalTerminal $+ Docker.rerunWithOptionalContainer (lcProjectRoot lc) $+ runStackT manager globalLogLevel (lcConfig lc) globalTerminal+ inner+ withBuildConfig :: GlobalOpts -> NoBuildConfigStrategy -> StackT EnvConfig IO ()@@ -425,15 +476,17 @@ Just x -> return x -- | Parser for package:[-]flag-readFlag :: ReadM (Map PackageName (Map FlagName Bool))+readFlag :: ReadM (Map (Maybe PackageName) (Map FlagName Bool)) readFlag = do s <- readerAsk case break (== ':') s of (pn, ':':mflag) -> do pn' <- case parsePackageNameFromString pn of- Nothing -> readerError $ "Invalid package name: " ++ pn- Just x -> return x+ Nothing+ | pn == "*" -> return Nothing+ | otherwise -> readerError $ "Invalid package name: " ++ pn+ Just x -> return $ Just x let (b, flagS) = case mflag of '-':x -> (False, x)@@ -457,49 +510,42 @@ -- | Unpack packages to the filesystem unpackCmd :: [String] -> GlobalOpts -> IO ()-unpackCmd names go@GlobalOpts{..} = do- (manager,lc) <- loadConfigWithOpts go- runStackT manager globalLogLevel (lcConfig lc) globalTerminal $- Docker.rerunWithOptionalContainer (lcProjectRoot lc) $- runStackT manager globalLogLevel (lcConfig lc) globalTerminal $ do- menv <- getMinimalEnvOverride- Stack.Fetch.unpackPackages menv "." names+unpackCmd names go = withConfig go $ do+ menv <- getMinimalEnvOverride+ Stack.Fetch.unpackPackages menv "." names -- | Update the package index updateCmd :: () -> GlobalOpts -> IO ()-updateCmd () go@GlobalOpts{..} = do- (manager,lc) <- loadConfigWithOpts go- runStackT manager globalLogLevel (lcConfig lc) globalTerminal $- Docker.rerunWithOptionalContainer (lcProjectRoot lc) $- runStackT manager globalLogLevel (lcConfig lc) globalTerminal $- getMinimalEnvOverride >>= Stack.PackageIndex.updateAllIndices+updateCmd () go = withConfig go $+ getMinimalEnvOverride >>= Stack.PackageIndex.updateAllIndices +upgradeCmd :: Bool -> GlobalOpts -> IO ()+upgradeCmd fromGit go = withConfig go $+ upgrade fromGit (globalResolver go)+ -- | Upload to Hackage uploadCmd :: [String] -> GlobalOpts -> IO ()-uploadCmd args0 go = withBuildConfig go ExecStrategy $ do- let args = if null args0 then ["."] else args0- config <- asks getConfig- manager <- asks getHttpManager- menv <- getMinimalEnvOverride- runghc <- join $ System.Process.Read.findExecutable menv "runghc"+uploadCmd args0 go = do+ (manager,lc) <- loadConfigWithOpts go+ let config = lcConfig lc+ args = if null args0 then ["."] else args0 liftIO $ do uploader <- Upload.mkUploader- (toFilePath runghc) config $ Upload.setGetManager (return manager) Upload.defaultUploadSettings mapM_ (Upload.upload uploader) args -- | Execute a command.-execCmd :: (String, [String]) -> GlobalOpts -> IO ()-execCmd (cmd,args) go@GlobalOpts{..} =+execCmd :: (String, [String],EnvSettings) -> GlobalOpts -> IO ()+execCmd (cmd,args,envSettings) go@GlobalOpts{..} = withBuildConfig go ExecStrategy $- exec cmd args+ exec envSettings cmd args -- | Run the REPL in the context of a project, with-replCmd :: ([Text], [String], FilePath) -> GlobalOpts -> IO ()-replCmd (targets,args,path) go@GlobalOpts{..} = withBuildConfig go ExecStrategy $ do- repl targets args path+replCmd :: ([Text], [String], FilePath, Bool) -> GlobalOpts -> IO ()+replCmd (targets,args,path,noload) go@GlobalOpts{..} = withBuildConfig go ExecStrategy $ do+ repl targets args path noload -- | Pull the current Docker image. dockerPullCmd :: () -> GlobalOpts -> IO ()@@ -532,13 +578,26 @@ Docker.rerunCmdWithRequiredContainer (lcProjectRoot lc) (return (cmd,args,id)) +-- | Command sum type for conditional arguments.+data Command+ = Build+ | Test+ | Haddock+ deriving (Eq)+ -- | Parser for build arguments.-buildOpts :: Bool -> Parser BuildOpts-buildOpts forHaddock =+buildOpts :: Command -> Parser BuildOpts+buildOpts cmd = fmap process $ BuildOpts <$> target <*> libProfiling <*> exeProfiling <*> optimize <*> haddock <*> haddockDeps <*> finalAction <*> dryRun <*> ghcOpts <*>- flags <*> installExes <*> preFetch <*> testArgs <*> onlySnapshot- where optimize =+ flags <*> installExes <*> preFetch <*> testArgs <*> onlySnapshot <*> coverage+ where process bopts =+ if boptsCoverage bopts+ then bopts { boptsExeProfile = True+ , boptsLibProfile = True+ , boptsGhcOptions = "-fhpc" : boptsGhcOptions bopts}+ else bopts+ optimize = maybeBoolFlags "optimizations" "optimizations for TARGETs and all its dependencies" idm target = fmap (map T.pack)@@ -556,15 +615,17 @@ "library profiling for TARGETs and all its dependencies" idm haddock =- boolFlags forHaddock+ boolFlags (cmd == Haddock) "haddock" "building Haddocks" idm haddockDeps =- maybeBoolFlags- "haddock-deps"- "building Haddocks for dependencies"- idm+ if cmd == Haddock+ then maybeBoolFlags+ "haddock-deps"+ "building Haddocks for dependencies"+ idm+ else pure Nothing finalAction = pure DoNothing installExes = pure False dryRun = flag False True (long "dry-run" <>@@ -592,14 +653,22 @@ help "Fetch packages necessary for the build immediately, useful with --dry-run") testArgs = fmap (fromMaybe [])- (optional- (argsOption- (long "test-arguments" <> metavar "TEST_ARGS" <>- help "Arguments passed in to the test suite program")))+ (if cmd == Test+ then optional+ (argsOption+ (long "test-arguments" <> metavar "TEST_ARGS" <>+ help "Arguments passed in to the test suite program"))+ else pure Nothing) onlySnapshot = flag False True (long "only-snapshot" <> help "Only build packages for the snapshot database, not the local database")+ coverage =+ if cmd == Test+ then flag False True+ (long "coverage" <>+ help "Generate a code coverage report")+ else pure False -- | Parser for docker cleanup arguments. dockerCleanupOpts :: Parser Docker.CleanupOpts@@ -647,17 +716,21 @@ toDescr = map (\c -> if c == '-' then ' ' else c) -- | Parser for global command-line options.-globalOpts :: Parser GlobalOpts-globalOpts =+globalOpts :: Bool -> Parser GlobalOpts+globalOpts defaultTerminal = GlobalOpts <$> logLevelOpt <*> configOptsParser False <*> optional resolverParser <*> flag- True+ defaultTerminal False (long "no-terminal" <> help- "Override terminal detection in the case of running in a false terminal")+ "Override terminal detection in the case of running in a false terminal") <*>+ (optional (strOption+ (long "stack-yaml" <>+ metavar "STACK-YAML" <>+ help "Override project stack.yaml file (overrides any STACK_YAML environment variable)"))) -- | Parse for a logging level. logLevelOpt :: Parser LogLevel@@ -703,6 +776,7 @@ , globalConfigMonoid :: ConfigMonoid -- ^ Config monoid, for passing into 'loadConfig' , globalResolver :: Maybe Resolver -- ^ Resolver override , globalTerminal :: Bool -- ^ We're in a terminal?+ , globalStackYaml :: Maybe FilePath -- ^ Override project stack.yaml } deriving (Show) -- | Load the configuration with a manager. Convenience function used@@ -710,31 +784,28 @@ loadConfigWithOpts :: GlobalOpts -> IO (Manager,LoadConfig (StackLoggingT IO)) loadConfigWithOpts GlobalOpts{..} = do manager <- newTLSManager+ mstackYaml <-+ case globalStackYaml of+ Nothing -> return Nothing+ Just fp -> do+ path <- canonicalizePath fp >>= parseAbsFile+ return $ Just path lc <- runStackLoggingT manager globalLogLevel globalTerminal- (loadConfig globalConfigMonoid)+ (loadConfig globalConfigMonoid mstackYaml) return (manager,lc) -- | Project initialization initCmd :: InitOpts -> GlobalOpts -> IO ()-initCmd initOpts go@GlobalOpts{..} = do- (manager,lc) <- loadConfigWithOpts go- runStackT manager globalLogLevel (lcConfig lc) globalTerminal $- Docker.rerunWithOptionalContainer (lcProjectRoot lc) $- runStackT manager globalLogLevel (lcConfig lc) globalTerminal $- initProject initOpts+initCmd initOpts go = withConfig go $ initProject initOpts -- | Project creation newCmd :: InitOpts -> GlobalOpts -> IO ()-newCmd initOpts go@GlobalOpts{..} = do- (manager,lc) <- loadConfigWithOpts go- runStackT manager globalLogLevel (lcConfig lc) globalTerminal $- Docker.rerunWithOptionalContainer (lcProjectRoot lc) $- runStackT manager globalLogLevel (lcConfig lc) globalTerminal $ do- newProject- initProject initOpts+newCmd initOpts go@GlobalOpts{..} = withConfig go $ do+ newProject+ initProject initOpts -- | Fix up extra-deps for a project solverCmd :: Bool -- ^ modify stack.yaml automatically?@@ -749,3 +820,7 @@ "modify-stack-yaml" "Automatically modify stack.yaml with the solver's recommendations" idm++-- | Visualize dependencies+dotCmd :: () -> GlobalOpts -> IO ()+dotCmd () go = withBuildConfig go ThrowException dot
+ src/test/Stack/Build/ExecuteSpec.hs view
@@ -0,0 +1,24 @@+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++spec :: Spec+spec = describe "compareTestComponents" $ do+ let test comps names expected = it (show (comps, names)) $+ compareTestsComponents+ (T.words $ T.pack comps)+ (T.words $ T.pack names)+ `shouldBe`+ (T.words $ T.pack expected)++ test "" "" ""+ test "" "foo" "foo"+ test "foo" "bar" ""+ test "foo" "foo bar" "foo"+ test "test:foo" "foo bar" "foo"+ test "test:foo exe:bar" "foo bar" "foo"
src/test/Stack/BuildPlanSpec.hs view
@@ -39,7 +39,7 @@ spec :: Spec spec = beforeAll setup $ afterAll teardown $ do let logLevel = LevelDebug- let loadConfig' m = runStackLoggingT m logLevel False (loadConfig mempty)+ let loadConfig' m = runStackLoggingT m logLevel False (loadConfig mempty Nothing) let loadBuildConfigRest m = runStackLoggingT m logLevel False let inTempDir action = do currentDirectory <- getCurrentDirectory
src/test/Stack/ConfigSpec.hs view
@@ -60,7 +60,7 @@ describe "loadConfig" $ do- let loadConfig' m = runStackLoggingT m logLevel False (loadConfig mempty)+ let loadConfig' m = runStackLoggingT m logLevel False (loadConfig mempty Nothing) let loadBuildConfigRest m = runStackLoggingT m logLevel False -- TODO(danburton): make sure parent dirs also don't have config file it "works even if no config file exists" $ \T{..} -> example $ do
stack.cabal view
@@ -1,5 +1,5 @@ name: stack-version: 0.1.0.0+version: 0.1.1.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@@ -30,6 +30,8 @@ new-template/LICENSE new-template/Setup.hs + stack.yaml+ flag integration-tests manual: True default: False@@ -45,6 +47,7 @@ Stack.Constants Stack.Docker Stack.Docker.GlobalDB+ Stack.Dot Stack.Fetch Stack.Exec Stack.GhcPkg@@ -75,6 +78,7 @@ Stack.Build.Installed Stack.Build.Source Stack.Build.Types+ Stack.Upgrade Stack.Upload System.Process.Read System.Process.Log@@ -163,6 +167,7 @@ Plugins.Commands build-depends: base >=4.7 && < 5+ , blaze-builder , bytestring >= 0.10.4.0 , containers , exceptions@@ -194,6 +199,7 @@ main-is: Test.hs other-modules: Spec , Stack.BuildPlanSpec+ , Stack.Build.ExecuteSpec , Stack.ConfigSpec , Stack.PackageDumpSpec , Stack.ArgsSpec@@ -215,6 +221,7 @@ , conduit-extra , resourcet , Cabal+ , text default-language: Haskell2010 test-suite stack-integration-test
+ stack.yaml view
@@ -0,0 +1,7 @@+packages:+- .+extra-deps:+- optparse-simple-0.0.3+- path-0.5.1+- monad-unlift-0.1.1.0+resolver: lts-2.9